From bd97e3e7977e9ccd9cdf357d70f37c553a9fe0eb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 23 Feb 2008 14:11:24 +0000 Subject: [PATCH] r6rs progress svn: r8775 --- collects/r5rs/main.ss | 6 +- collects/r6rs/main.ss | 14 +- collects/r6rs/private/inline-rules.ss | 18 ++ collects/r6rs/private/prelims.ss | 22 ++ collects/r6rs/private/qq-gen.ss | 81 +++++ collects/r6rs/private/records-core.ss | 357 +++++++++++++++++++++ collects/r6rs/private/records-explicit.ss | 265 +++++++++++++++ collects/r6rs/private/vector-types.ss | 93 ++++++ collects/rnrs/arithmetic/bitwise-6.ss | 38 +++ collects/rnrs/arithmetic/fixnums-6.ss | 184 +++++++++++ collects/rnrs/base-6.ss | 92 ++++-- collects/rnrs/control-6.ss | 45 +++ collects/rnrs/hashtables-6.ss | 137 ++++++++ collects/rnrs/io/simple-6.ss | 24 ++ collects/rnrs/list-6.ss | 241 ++++++++++++++ collects/rnrs/records/inspection-6.ss | 13 + collects/rnrs/records/procedural-6.ss | 9 + collects/rnrs/records/syntactic-6.ss | 170 ++++++++++ collects/rnrs/sorting-6.ss | 19 ++ collects/rnrs/syntax-case-6.ss | 278 ++++++++++++++++ collects/rnrs/unicode-6.ss | 39 +++ collects/scribblings/scribble/struct.scrbl | 2 +- collects/srfi/32/vmsort.scm | 52 ++- src/mzscheme/src/module.c | 2 + 24 files changed, 2139 insertions(+), 62 deletions(-) create mode 100644 collects/r6rs/private/inline-rules.ss create mode 100644 collects/r6rs/private/prelims.ss create mode 100644 collects/r6rs/private/qq-gen.ss create mode 100644 collects/r6rs/private/records-core.ss create mode 100644 collects/r6rs/private/records-explicit.ss create mode 100644 collects/r6rs/private/vector-types.ss create mode 100644 collects/rnrs/arithmetic/bitwise-6.ss create mode 100644 collects/rnrs/arithmetic/fixnums-6.ss create mode 100644 collects/rnrs/control-6.ss create mode 100644 collects/rnrs/hashtables-6.ss create mode 100644 collects/rnrs/io/simple-6.ss create mode 100644 collects/rnrs/list-6.ss create mode 100644 collects/rnrs/records/inspection-6.ss create mode 100644 collects/rnrs/records/procedural-6.ss create mode 100644 collects/rnrs/records/syntactic-6.ss create mode 100644 collects/rnrs/sorting-6.ss create mode 100644 collects/rnrs/syntax-case-6.ss create mode 100644 collects/rnrs/unicode-6.ss diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index f2580bcef3..4f0e2c6538 100644 --- a/collects/r5rs/main.ss +++ b/collects/r5rs/main.ss @@ -199,7 +199,8 @@ [unquote (zero? depth) (raise-syntax-error - "invalid content within quasiquote" + #f + "invalid context within quasiquote" stx form)] [((unquote-splicing e) . rest) @@ -212,7 +213,8 @@ [unquote-splicing (zero? depth) (raise-syntax-error - "invalid content within quasiquote" + #f + "invalid context within quasiquote" stx form)] [(r5rs:quasiquote . e) diff --git a/collects/r6rs/main.ss b/collects/r6rs/main.ss index beee32de75..a84637421d 100644 --- a/collects/r6rs/main.ss +++ b/collects/r6rs/main.ss @@ -282,7 +282,7 @@ FIXME: append (map syntax->list (syntax->list #'((id id2) ...))))) - #`(except-in #,(parse-import-set orig #'im) id ...)] + #`(rename-in #,(parse-import-set orig #'im) [id id2] ...)] [(rename . _) (bad)] [_ (parse-library-reference orig stx)])) @@ -312,8 +312,10 @@ FIXME: (with-syntax ([is (parse-import-set orig #'base-im)]) (if (null? levels) #'() - (with-syntax ([(level ...) levels]) - #`((for-meta level is) ...)))))] + (with-syntax ([(level ...) levels] + [prelims (datum->syntax orig + 'r6rs/private/prelims)]) + #`((for-meta level is prelims) ...)))))] [(for . _) (raise-syntax-error #f @@ -321,8 +323,10 @@ FIXME: orig im)] [_ (list (parse-import-set orig im))])) - (syntax->list #'(im ...)))]) - #'(require im ... ...))]))) + (syntax->list #'(im ...)))] + [prelims (datum->syntax orig + 'r6rs/private/prelims)]) + #'(require prelims im ... ...))]))) (define-syntax (r6rs-export stx) (let ([orig (syntax-case stx () diff --git a/collects/r6rs/private/inline-rules.ss b/collects/r6rs/private/inline-rules.ss new file mode 100644 index 0000000000..02cc275d8a --- /dev/null +++ b/collects/r6rs/private/inline-rules.ss @@ -0,0 +1,18 @@ +#lang scheme/base + +(require (for-syntax scheme/base) + (for-template scheme/base)) + +(provide inline-rules) + +(define-syntax-rule (inline-rules orig-id [pat result] ...) + (make-set!-transformer + (lambda (stx) + (syntax-case stx (set!) + [(set! . _) + (raise-syntax-error #f + "cannot mutate" + stx)] + [pat #'result] ... + [(id . args) #'(orig-id . args)] + [id #'orig-id])))) diff --git a/collects/r6rs/private/prelims.ss b/collects/r6rs/private/prelims.ss new file mode 100644 index 0000000000..11d51d5ddb --- /dev/null +++ b/collects/r6rs/private/prelims.ss @@ -0,0 +1,22 @@ +#lang scheme/base + +;; PLT Scheme pre-requisites for any phase + +(require (for-syntax scheme/base)) + +(provide + (rename-out [datum #%datum]) + #%app #%top #%top-interaction) + +;; ---------------------------------------- +;; Datum + +(define-syntax (datum stx) + (syntax-case stx () + [(_ . thing) + (if (vector? (syntax-e #'thing)) + (raise-syntax-error 'r6rs + "a vector is not an expression" + #'thing) + #`(quote thing))])) + diff --git a/collects/r6rs/private/qq-gen.ss b/collects/r6rs/private/qq-gen.ss new file mode 100644 index 0000000000..9a5660942c --- /dev/null +++ b/collects/r6rs/private/qq-gen.ss @@ -0,0 +1,81 @@ +#lang scheme/base + +;; used for quasiquote and quasisyntax + +(require (for-syntax scheme/base)) + +(provide define-generalized-qq) + +(define-syntax-rule (define-generalized-qq r6rs:quasiquote + quasiquote unquote unquote-splicing) + (... + (define-syntax (r6rs:quasiquote stx) + ;; Replace (unquote expr ...) with (unquote expr) ... + (syntax-case stx () + [(_ tmpl) + (let ([new-tmpl + (let loop ([tmpl #'tmpl][level 0]) + (syntax-case tmpl (r6rs:quasiquote) + [((u expr ...) . rest) + (or (free-identifier=? #'u #'unquote) + (free-identifier=? #'u #'unquote-splicing)) + (let ([new-rest (loop #'rest level)]) + (if (zero? level) + (if (and (eq? new-rest #'rest) + (= 1 (length (syntax->list #'(expr ...))))) + tmpl + (datum->syntax + tmpl + (append (let ([a (car (syntax-e tmpl))]) + (map (lambda (expr) + (datum->syntax + a + (list (car (syntax-e a)) + expr) + a a a)) + (syntax->list #'(expr ...)))) + new-rest) + tmpl tmpl tmpl)) + (let* ([first (car (syntax-e tmpl))] + [new-first (loop first (sub1 level))]) + (if (and (eq? new-first first) + (eq? new-rest #'rest)) + tmpl + (datum->syntax + tmpl + (cons new-first new-rest) + tmpl tmpl tmpl)))))] + [(r6rs:quasiquote expr) + (let ([new-expr (loop #'expr (add1 level))]) + (if (eq? new-expr #'expr) + tmpl + (datum->syntax + tmpl + (cons (car (syntax-e tmpl) new-expr)) + tmpl tmpl tmpl)))] + [(a . b) + (let ([new-a (loop #'a level)] + [new-b (loop #'b level)]) + (if (and (eq? new-a #'a) + (eq? new-b #'b)) + tmpl + (datum->syntax + tmpl + (cons new-a new-b) + tmpl tmpl tmpl)))] + [#(a ...) + (let* ([as (syntax->list #'(a ...))] + [new-as (map (lambda (a) + (loop a level)) + as)]) + (if (andmap eq? as new-as) + tmpl + (datum->syntax + tmpl + (list->vector new-as) + tmpl tmpl tmpl)))] + [_ tmpl]))]) + (datum->syntax + stx + (list #'r5rs:quasiquote new-tmpl) + stx stx stx))])))) diff --git a/collects/r6rs/private/records-core.ss b/collects/r6rs/private/records-core.ss new file mode 100644 index 0000000000..777b4edc15 --- /dev/null +++ b/collects/r6rs/private/records-core.ss @@ -0,0 +1,357 @@ +#!r6rs + +;; Implementation of procedural layer for R6RS Records + +;; Based on the SRFI implementation: +; Copyright (C) Michael Sperber (2005). All Rights Reserved. +; +; Permission is hereby granted, free of charge, to any person +; obtaining a copy of this software and associated documentation files +; (the "Software"), to deal in the Software without restriction, +; including without limitation the rights to use, copy, modify, merge, +; publish, distribute, sublicense, and/or sell copies of the Software, +; and to permit persons to whom the Software is furnished to do so, +; subject to the following conditions: +; +; The above copyright notice and this permission notice shall be +; included in all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +; SOFTWARE. + +(library (r6rs private records-core) + (export make-record-type-descriptor + record-type-descriptor? + record-type-name + record-type-parent + record-type-sealed? + record-type-uid + record-type-field-names + record-type-opaque? + make-record-constructor-descriptor record-constructor + record-predicate + record-accessor record-mutator + record-field-mutable? record-type-generative? + record? record-rtd) + (import (rnrs base (6)) + (rnrs list (6)) + (rnrs io simple (6)) ;; REMOVEME + (r6rs private vector-types)) + + (define make-field-spec cons) + + (define field-spec-mutable? car) + (define field-spec-name cdr) + + (define (field-spec=? spec-1 spec-2) + (and (eq? (field-spec-mutable? spec-1) + (field-spec-mutable? spec-2)) + (eq? (field-spec-name spec-1) + (field-spec-name spec-2)))) + + (define :record-type-data (make-vector-type 'record-type-descriptor + #f ; no supertype + #f ; no per-type data + '(#f #f #f #f #f #f) ; all fields immutable + #t)) ; opaque + + (define (make-record-type-data name uid sealed? opaque? field-specs parent) + ((typed-vector-constructor :record-type-data) + name uid sealed? opaque? field-specs parent)) + + (define (record-type-data? thing) + ((vector-type-predicate :record-type-data) thing)) + + (define (typed-vector-ref t v pos) + ((typed-vector-accessor t pos) v)) + + (define (record-type-name rtd) + (typed-vector-ref :record-type-data (vector-type-data rtd) 0)) + (define (record-type-uid rtd) + ;; this is #f in the generative case + (typed-vector-ref :record-type-data (vector-type-data rtd) 1)) + (define (record-type-sealed? rtd) + (typed-vector-ref :record-type-data (vector-type-data rtd) 2)) + (define (record-type-opaque? rtd) + (typed-vector-ref :record-type-data (vector-type-data rtd) 3)) + (define (record-type-field-specs rtd) + (typed-vector-ref :record-type-data (vector-type-data rtd) 4)) + (define (record-type-parent rtd) + (typed-vector-ref :record-type-data (vector-type-data rtd) 5)) + + (define (record-type-descriptor=? rtd-1 rtd-2) + (and (eq? (record-type-parent rtd-1) (record-type-parent rtd-2)) + (eq? (record-type-uid rtd-1) (record-type-uid rtd-2)) + (for-all field-spec=? + (record-type-field-specs rtd-1) + (record-type-field-specs rtd-2)))) + + (define (uid->record-type-descriptor uid) + (find (lambda (rtd) + (eq? (record-type-uid rtd) uid)) + *nongenerative-record-types*)) + + (define (record-type-generative? rtd) + (not (record-type-uid rtd))) + + (define *nongenerative-record-types* '()) + + (define (append-field-mutable-specs parent) + (if parent + (append (append-field-mutable-specs (record-type-parent parent)) + (map field-spec-mutable? (record-type-field-specs parent))) + '())) + + (define (make-record-type-descriptor name parent uid sealed? opaque? field-specs) + (if (not (symbol? name)) + (assertion-violation 'make-record-type-descriptor "not a symbol for record type name" name)) + (if (not (or (not parent) + (record-type-descriptor? parent))) + (assertion-violation 'make-record-type-descriptor "parent not #f or a record type descriptor" parent)) + (if (not (or (not uid) + (symbol? uid))) + (assertion-violation 'make-record-type-descriptor "uid must be #f or a symbol" parent)) + (if (and parent + (record-type-sealed? parent)) + (assertion-violation 'make-record-type-descriptor "can't extend a sealed parent type" parent)) + (if (not (list? field-specs)) + (assertion-violation 'make-record-type-descriptor "field specification must be a list" field-specs)) + (let ((opaque? (if parent + (or (record-type-opaque? parent) + opaque?) + opaque?)) + (field-specs (map parse-field-spec field-specs))) + (let ((rtd + (make-vector-type name + parent + (make-record-type-data name uid (and sealed? #t) (and opaque? #t) field-specs parent) + (append (append-field-mutable-specs parent) + (map field-spec-mutable? field-specs)) + opaque?))) + (if uid + (cond + ((uid->record-type-descriptor uid) + => (lambda (old-rtd) + (if (record-type-descriptor=? rtd old-rtd) + old-rtd + (assertion-violation 'make-record-type + "mismatched nongenerative record types with identical uids" + old-rtd rtd)))) + (else + (set! *nongenerative-record-types* + (cons rtd *nongenerative-record-types*)) + rtd)) + rtd)))) + + (define (record-type-descriptor? thing) + (and (vector-type? thing) + (record-type-data? (vector-type-data thing)))) + + (define (ensure-rtd thing) + (if (not (record-type-descriptor? thing)) + (assertion-violation 'make-record-type "not a record-type descriptor" thing))) + + (define (parse-field-spec spec) + (if (not (and (list? spec) + (= 2 (length spec)))) + (assertion-violation 'make-record-type + "field spec list element is not a list of two elements" + spec)) + (apply (lambda (mutability name) + (if (not (symbol? name)) + (assertion-violation 'make-record-type + "field spec name is not a symbol" + name)) + (make-field-spec + (case mutability + ((mutable) #t) + ((immutable) #f) + (else (assertion-violation 'make-record-type + "field spec with invalid mutability specification" spec))) + name)) + spec)) + + (define (record-type-field-names rtd) + (map field-spec-name (record-type-field-specs rtd))) + + (define (field-count rtd) + (let loop ((rtd rtd) + (count 0)) + (if (not rtd) + count + (loop (record-type-parent rtd) + (+ count (length (record-type-field-specs rtd))))))) + + (define (record? thing) + (and (typed-vector? thing) + (let ((rtd (typed-vector-type thing))) + (and (record-type-descriptor? rtd) + (not (record-type-opaque? rtd)))))) + + (define (record-rtd rec) + (if (record? rec) + (typed-vector-type rec) + (assertion-violation 'record-rtd "cannot extract rtd of a non-record or opaque record" rec))) + + ;; Constructing constructors + + (define :record-constructor-descriptor (make-vector-type 'record-constructor-descriptor #f #f '(#f #f #f #f) #t)) + + (define record-type-constrctor-descriptor? + (vector-type-predicate :record-constructor-descriptor)) + + (define (make-record-constructor-descriptor rtd previous protocol) + (if (not (record-type-descriptor? rtd)) + (assertion-violation 'make-record-constructor-descriptor + "not a record type descriptor" rtd)) + (if (not (or (not previous) + (record-type-constrctor-descriptor? previous))) + (assertion-violation 'make-record-constructor-descriptor + "not #f or a parent record type constructor descriptor" previous)) + (if (not (or (not protocol) + (procedure? protocol))) + (assertion-violation 'make-record-constructor-descriptor + "not #f or procedure for protocol" protocol)) + (let ((parent (record-type-parent rtd))) + (if (and previous (not parent)) + (assertion-violation 'make-record-constructor-descriptor + "mismatch between rtd and constructor descriptor" rtd previous)) + (if (and protocol parent (not previous)) + (assertion-violation 'make-record-constructor-descriptor + "non-default protocol requested, but no parent constrcutor descriptor given" rtd previous)) + (if (and previous + (not protocol) + (record-constructor-descriptor-custom-protocol? previous)) + (assertion-violation 'make-record-constructor-descriptor + "default protocol requested when parent constructor descriptor has custom one" + protocol previous)) + + (let ((custom-protocol? (and protocol #t)) + (protocol (or protocol (default-protocol rtd))) + (previous + (if (or previous + (not parent)) + previous + (make-record-constructor-descriptor parent #f #f)))) + + ((typed-vector-constructor :record-constructor-descriptor) + rtd protocol custom-protocol? previous)))) + + (define (split-at l n) + (if (zero? n) + (values '() l) + (let-values (((a b) (split-at (cdr l) (- n 1)))) + (values (cons (car l) a) b)))) + + (define (default-protocol rtd) + (let ((parent (record-type-parent rtd))) + (if (not parent) + (lambda (p) + (lambda field-values + (apply p field-values))) + (let ((parent-field-count (field-count parent))) + (lambda (p) + (lambda all-field-values + (call-with-values + (lambda () (split-at all-field-values parent-field-count)) + (lambda (parent-field-values this-field-values) + (apply (apply p parent-field-values) this-field-values))))))))) + + (define (record-constructor-descriptor-rtd desc) + (typed-vector-ref :record-constructor-descriptor desc 0)) + (define (record-constructor-descriptor-protocol desc) + (typed-vector-ref :record-constructor-descriptor desc 1)) + ;; this field is for error checking + (define (record-constructor-descriptor-custom-protocol? desc) + (typed-vector-ref :record-constructor-descriptor desc 2)) + (define (record-constructor-descriptor-previous desc) + (typed-vector-ref :record-constructor-descriptor desc 3)) + + ;; A "seeder" is the procedure passed to the cons conser, used to seed + ;; the initial field values. + + (define (make-make-seeder real-rtd wrap for-desc) + (let recur ((for-desc for-desc)) + (let* ((for-rtd (record-constructor-descriptor-rtd for-desc)) + (for-rtd-field-count (length (record-type-field-specs for-rtd)))) + (cond + ((record-constructor-descriptor-previous for-desc) + => (lambda (parent-desc) + (let ((parent-protocol (record-constructor-descriptor-protocol parent-desc)) + (parent-make-seeder (recur parent-desc))) + (lambda extension-field-values + (lambda parent-protocol-args + (lambda for-rtd-field-values + (if (not (= (length for-rtd-field-values) for-rtd-field-count)) + (assertion-violation 'make-record-constructor + "wrong number of arguments to record constructor" + for-rtd for-rtd-field-values)) + (apply (parent-protocol + (apply parent-make-seeder + (append for-rtd-field-values extension-field-values))) + parent-protocol-args))))))) + (else + (lambda extension-field-values + (lambda for-rtd-field-values + (if (not (= (length for-rtd-field-values) for-rtd-field-count)) + (assertion-violation 'make-record-constructor + "wrong number of arguments to record constructor" + for-rtd for-rtd-field-values)) + (wrap + (apply (typed-vector-constructor real-rtd) + (append for-rtd-field-values extension-field-values)))))))))) + + ;; does RTD-1 represent an ancestor of RTD-2? + + ;; This suggests the corresponding procedure in VECTOR-TYPES should be + ;; abstracted out. + + (define (rtd-ancestor? rtd-1 rtd-2) + (let loop ((rtd-2 rtd-2)) + (or (eq? rtd-1 rtd-2) + (and rtd-2 + (loop (record-type-parent rtd-2)))))) + + (define (record-constructor desc) + (let* ((rtd (record-constructor-descriptor-rtd desc))) + ((record-constructor-descriptor-protocol desc) + ((make-make-seeder rtd (lambda (r) r) desc))))) + + (define (record-predicate rtd) + (vector-type-predicate rtd)) + + (define (check-field-id who rtd field-id) + (if (not (record-type-descriptor? rtd)) + (assertion-violation who + "not a record type descriptor" rtd)) + (if (not (and (integer? field-id) + (exact? field-id) + (>= field-id 0) + (< field-id (length (record-type-field-specs rtd))))) + (assertion-violation who + "invalid index (not a non-negative exact integer less than the field count)" field-id))) + + (define (record-accessor rtd field-id) + (check-field-id 'record-accessor rtd field-id) + (typed-vector-accessor rtd (field-id-index rtd field-id))) + + (define (record-mutator rtd field-id) + (check-field-id 'record-mutator rtd field-id) + (if (not (record-field-mutable? rtd field-id)) + (assertion-violation 'record-mutator + "record-mutator called on immutable field" rtd field-id)) + (typed-vector-mutator rtd (field-id-index rtd field-id))) + + ;; A FIELD-ID is an index, which refers to a field in RTD itself. + (define (field-id-index rtd field-id) + (+ (field-count (record-type-parent rtd)) + field-id)) + + (define (record-field-mutable? rtd field-id) + (field-spec-mutable? (list-ref (record-type-field-specs rtd) field-id)))) diff --git a/collects/r6rs/private/records-explicit.ss b/collects/r6rs/private/records-explicit.ss new file mode 100644 index 0000000000..fab09c8c37 --- /dev/null +++ b/collects/r6rs/private/records-explicit.ss @@ -0,0 +1,265 @@ +#!r6rs + +;; Implementation of explicit-naming layer for R6RS Records + +;; Based on the SRFI implementation: +; Copyright (C) Michael Sperber (2005). All Rights Reserved. +; +; Permission is hereby granted, free of charge, to any person +; obtaining a copy of this software and associated documentation files +; (the "Software"), to deal in the Software without restriction, +; including without limitation the rights to use, copy, modify, merge, +; publish, distribute, sublicense, and/or sell copies of the Software, +; and to permit persons to whom the Software is furnished to do so, +; subject to the following conditions: +; +; The above copyright notice and this permission notice shall be +; included in all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +; SOFTWARE. + +(library (r6rs private records-explicit) + (export define-record-type + record-type-descriptor + record-constructor-descriptor + fields mutable immutable parent protocol + sealed opaque nongenerative) + (import (rnrs base) + (rnrs records procedural)) + + (define-syntax define-aux + (syntax-rules () + [(_ id) (define-syntax id (syntax-rules ()))] + [(_ id ...) (begin (define-aux id) ...)])) + + (define-aux + fields mutable immutable parent protocol sealed opaque nongenerative) + + ;; ASSQ at the syntax level + (define-syntax define-alist-extractor + (syntax-rules () + ((define-alist-extractor ?name ?name/cps ?tag ?default) + (begin + + (define-syntax ?name/cps + (syntax-rules (?tag) + ((?name/cps () ?k . ?rands) + (?k ?default . ?rands)) + ((?name/cps ((?tag ?val) . ?rest) ?k . ?rands) + (?k ?val . ?rands)) + ((?name/cps ((?another-tag ?val) . ?rest) ?k . ?rands) + (?name/cps ?rest ?k . ?rands)))) + + (define-syntax ?name + (syntax-rules (?tag) + ((?name ()) + ?default) + ((?name ((?tag ?val) . ?rest)) + ?val) + ((?name ((?another-tag ?val) . ?rest)) + (?name ?rest)))))))) + + (define-alist-extractor extract-parent extract-parent/cps parent no-record-type) + (define-alist-extractor extract-sealed extract-sealed/cps sealed #f) + (define-alist-extractor extract-opaque extract-opaque/cps opaque #f) + (define-alist-extractor extract-protocol extract-protocol/cps + protocol #f) + (define-alist-extractor extract-nongenerative extract-nongenerative/cps nongenerative #f) + + (define-alist-extractor extract-record-name extract-record-name/cps record-name cant-happen) + (define-alist-extractor extract-constructor-name extract-constructor-name/cps + constructor-name cant-happen) + (define-alist-extractor extract-predicate-name extract-predicate-name/cps + predicate-name cant-happen) + + + (define-syntax define-record-type + (syntax-rules () + ((define-record-type (?record-name ?constructor-name ?predicate-name) + ?clause ...) + (define-record-type-1 + ((record-name ?record-name) ; prop alist + (constructor-name ?constructor-name) + (predicate-name ?predicate-name)) + () ; fields + ?clause ...)))) + + (define-syntax define-record-type-1 + (syntax-rules (parent protocol sealed nongenerative opaque fields mutable immutable) + ;; find PARENT clause + ((define-record-type-1 ?props + ?field-specs + (parent ?parent) + ?clause ...) + (define-record-type-1 ((parent ?parent) . ?props) + ?field-specs + ?clause ...)) + + ;; find PROTOCOL clause + ((define-record-type-1 ?props + ?field-specs + (protocol ?protocol) + ?clause ...) + (define-record-type-1 ((protocol ?protocol) . ?props) + ?field-specs + ?clause ...)) + + ;; find SEALED clause + ((define-record-type-1 ?props + ?field-specs + (sealed #t) + ?clause ...) + (define-record-type-1 ((sealed #t) . ?props) + ?field-specs + ?clause ...)) + ((define-record-type-1 ?props + ?field-specs + (sealed #f) + ?clause ...) + (define-record-type-1 ((sealed #f) . ?props) + ?field-specs + ?clause ...)) + + ;; find OPAQUE clause + ((define-record-type-1 ?props + ?field-specs + (opaque #t) + ?clause ...) + (define-record-type-1 ((opaque #t) . ?props) + ?field-specs + ?clause ...)) + ((define-record-type-1 ?props + ?field-specs + (opaque #f) + ?clause ...) + (define-record-type-1 ((opaque #f) . ?props) + ?field-specs + ?clause ...)) + + ;; parse FIELDS clause + + ;; base case + ((define-record-type-1 ?props + (?field-spec ...) + (fields) + ?clause ...) + (define-record-type-1 ?props + (?field-spec ...) + ?clause ...)) + + ;; complete spec + ((define-record-type-1 ?props + (?field-spec ...) + (fields (immutable ?field-name ?accessor) ?rest ...) + ?clause ...) + (define-record-type-1 ?props + (?field-spec ... (immutable ?field-name (?accessor))) + (fields ?rest ...) + ?clause ...)) + + ((define-record-type-1 ?props + (?field-spec ...) + (fields (mutable ?field-name ?accessor ?mutator) ?rest ...) + ?clause ...) + (define-record-type-1 ?props + (?field-spec ... (mutable ?field-name (?accessor ?mutator))) + (fields ?rest ...) + ?clause ...)) + + ;; find NONGENERATIVE clause + ((define-record-type-1 ?props + ?field-specs + (nongenerative ?uid) + ?clause ...) + (define-record-type-1 ((nongenerative '?uid) . ?props) + ?field-specs + ?clause ...)) + + ;; generate code + ((define-record-type-1 ?props + ((?mutability ?field-name ?procs) ...)) + + (begin + ;; where we need LETREC* semantics if this is to work internally + + (define $rtd + (make-record-type-descriptor (extract-record-name/cps ?props quote) + (extract-parent/cps ?props record-type-descriptor) + (extract-nongenerative ?props) + (extract-sealed ?props) + (extract-opaque ?props) + '((?mutability ?field-name) ...))) + + (define $constructor-descriptor + (make-record-constructor-descriptor + $rtd + (extract-parent/cps ?props record-constructor-descriptor) + (extract-protocol ?props))) + + (extract-record-name/cps + ?props + define-record-type-name $rtd $constructor-descriptor) + + (extract-constructor-name/cps + ?props + define + (record-constructor $constructor-descriptor)) + + (extract-predicate-name/cps ?props + define (record-predicate $rtd)) + + (define-record-fields $rtd + 0 (?field-name ?procs) ...))))) + + (define-syntax define-record-type-name + (syntax-rules () + ((define-record-type-name ?name ?rtd ?constructor-descriptor) + (define-syntax ?name + (syntax-rules (descriptor constructor-descriptor) + ((?name descriptor) ?rtd) + ((?name constructor-descriptor) ?constructor-descriptor)))))) + + (define-syntax no-record-type + (syntax-rules (descriptor constructor-descriptor) + ((?name descriptor) #f) + ((?name constructor-descriptor) #f))) + + (define-syntax record-type-descriptor + (syntax-rules () + ((record-type-descriptor ?record-type) + (?record-type descriptor)))) + + (define-syntax record-constructor-descriptor + (syntax-rules () + ((record-constructor-descriptor ?record-type) + (?record-type constructor-descriptor)))) + + (define-syntax define-record-fields + (syntax-rules () + ((define-record-fields ?rtd ?index) + (begin)) + ((define-record-fields ?rtd ?index (?field-name ?procs) . ?rest) + (begin + (define-record-field ?rtd ?field-name ?index ?procs) + (define-record-fields ?rtd (+ 1 ?index) . ?rest))))) + + (define-syntax define-record-field + (syntax-rules () + ((define-record-field ?rtd + ?field-name ?index (?accessor-name)) + (define ?accessor-name + (record-accessor ?rtd ?index))) + ((define-record-field ?rtd + ?field-name ?index (?accessor-name ?mutator-name)) + (begin + (define ?accessor-name + (record-accessor ?rtd ?index)) + (define ?mutator-name + (record-mutator ?rtd ?index))))))) diff --git a/collects/r6rs/private/vector-types.ss b/collects/r6rs/private/vector-types.ss new file mode 100644 index 0000000000..ed2bf8ba5a --- /dev/null +++ b/collects/r6rs/private/vector-types.ss @@ -0,0 +1,93 @@ +#lang scheme/base + +; PLT module definition for vector types for R6RS Records + +; Copyright (C) Matthew Flatt (2006). All Rights Reserved. +; +; Permission is hereby granted, free of charge, to any person +; obtaining a copy of this software and associated documentation files +; (the "Software"), to deal in the Software without restriction, +; including without limitation the rights to use, copy, modify, merge, +; publish, distribute, sublicense, and/or sell copies of the Software, +; and to permit persons to whom the Software is furnished to do so, +; subject to the following conditions: +; +; The above copyright notice and this permission notice shall be +; included in all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +; SOFTWARE. + +(require scheme/mpair) + +(provide (rename-out [make-a-vector-type make-vector-type]) + vector-type? + vector-type-data + vector-type-predicate + typed-vector-constructor + typed-vector-accessor typed-vector-mutator + typed-vector? + typed-vector-type) + +(define-struct vector-type (data field-count supertype + struct-type constructor predicate accessor mutator)) + +(define-values (prop:typed-vector typed-vector? typed-vector-ref) + (make-struct-type-property 'typed-vector)) + +(define (make-a-vector-type name supertype data field-mutability opaque?) + (let* ([super-field-count (if supertype + (vector-type-field-count supertype) + 0)] + [field-mutability (list-tail (mlist->list field-mutability) super-field-count)] + [bx (box #f)]) + (let-values ([(struct: make-s s? s-ref s-set!) + (make-struct-type name + (and supertype + (vector-type-struct-type supertype)) + (length field-mutability) 0 #f + (list (cons prop:typed-vector bx)) + (and opaque? (current-inspector)) + #f ; not a procedure + (let loop ([field-mutability field-mutability] + [index 0]) + (cond + [(null? field-mutability) null] + [(not (car field-mutability)) (cons index + (loop (cdr field-mutability) + (add1 index)))] + [else (loop (cdr field-mutability) (add1 index))])))]) + (let ([vt (make-vector-type data + (+ (length field-mutability) super-field-count) + supertype + struct: make-s s? + s-ref s-set!)]) + (set-box! bx vt) + vt)))) + +(define (vector-type-index t pos) + (let* ([supertype (vector-type-supertype t)] + [super-field-count (if supertype + (vector-type-field-count supertype) + 0)]) + (if (pos . < . super-field-count) + (vector-type-index supertype pos) + (- pos super-field-count)))) + +(define (typed-vector-constructor t) + (vector-type-constructor t)) + +(define (typed-vector-type v) + (unbox (typed-vector-ref v))) + +(define (typed-vector-accessor t pos) + (make-struct-field-accessor (vector-type-accessor t) (vector-type-index t pos))) + +(define (typed-vector-mutator t pos) + (make-struct-field-mutator (vector-type-mutator t) (vector-type-index t pos))) diff --git a/collects/rnrs/arithmetic/bitwise-6.ss b/collects/rnrs/arithmetic/bitwise-6.ss new file mode 100644 index 0000000000..94c8007f9d --- /dev/null +++ b/collects/rnrs/arithmetic/bitwise-6.ss @@ -0,0 +1,38 @@ +#lang scheme/base + +(provide bitwise-and + bitwise-ior + bitwise-xor + bitwise-not + bitwise-if + (rename-out [integer-length bitwise-length]) + bitwise-first-bit-set + (rename-out [arithmetic-shift bitwise-arithmetic-shift]) + bitwise-arithmetic-shift-left + bitwise-arithmetic-shift-right + bitwise-copy-bit) + + +(define (bitwise-if a b c) + (bitwise-ior (bitwise-and a b) + (bitwise-and (bitwise-not a) c))) + +(define (bitwise-first-bit-set b) + (if (zero? b) + -1 + (let loop ([b b][pos 0]) + (if (zero? (bitwise-and b 1)) + (loop (arithmetic-shift b) (add1 pos)) + pos)))) + + +(define (bitwise-arithmetic-shift-left v s) + (arithmetic-shift v s)) +(define (bitwise-arithmetic-shift-right v s) + (arithmetic-shift v (- s))) + +(define (bitwise-copy-bit a b c) + (let ([mask (bitwise-arithmetic-shift-left 1 b)]) + (bitwise-if mask + (bitwise-arithmetic-shift-left c b) + a))) diff --git a/collects/rnrs/arithmetic/fixnums-6.ss b/collects/rnrs/arithmetic/fixnums-6.ss new file mode 100644 index 0000000000..931c216329 --- /dev/null +++ b/collects/rnrs/arithmetic/fixnums-6.ss @@ -0,0 +1,184 @@ +#lang scheme/base + +(require (only-in rnrs/base-6 + div-and-mod div mod + div0-and-mod0 div0 mod0) + (only-in rnrs/arithmetic/bitwise-6 + bitwise-if + bitwise-first-bit-set + bitwise-copy-bit) + (for-syntax r6rs/private/inline-rules)) + +(provide fixnum? + fixnum-width + least-fixnum + greatest-fixnum) + +(define (fixnum-width) 30) +(define (least-fixnum) -1073741824) +(define (greatest-fixnum) +1073741824) + +(define (r6rs:fixnum? v) + (and (exact-integer? v) + (<= -1073741824 v 1073741823))) + +(define-syntax fixnum? + (inline-rules + r6rs:fixnum? + [(_ a) (let ([v a]) + (and (exact-integer? v) + (<= -1073741824 v 1073741823)))])) + +(define (implementation-restriction who what) + (error 'who "implementation restriction: ~e" what)) + +(define-syntax define-an-fx + (syntax-rules () + [(_ orig fx check-result ([(arg ...) (tmp ...)] ...) . rest) + (begin + (provide fx) + (define fx-proc + (let ([fx (case-lambda + [(arg ...) + (unless (fixnum? arg) + (raise-type-error 'fx "fixnum" arg)) + ... + (let ([r (orig arg ...)]) + (unless (fixnum? r) + (implementation-restriction 'fx r)) + r)] + ... + . rest)]) + fx)) + (define-syntax fx + (inline-rules + fx-proc + [(_ arg ...) + (let ([tmp arg] ...) + (if (and (fixnum? tmp) ...) + (let ([v (orig tmp ...)]) + (check-result v (fx-proc tmp ...))) + (fx-proc tmp ...)))] + ...)))])) + +(define-syntax-rule (check v (fx-proc tmp ...)) + (if (fixnum? v) + v + (fx-proc tmp ...))) + +(define-syntax-rule (nocheck v . _) + v) + +(define-syntax define-an-fx+rest + (syntax-rules () + [(_ orig fx check clauses) + (define-an-fx orig fx check clauses + [args (for-each (lambda (arg) + (unless (fixnum? args) + (raise-type-error 'fx "fixnum" arg))) + args) + (let ([r (apply orig args)]) + (unless (fixnum? r) + (implementation-restriction 'fx r)) + r)])])) + + +(define-syntax define-fx + (syntax-rules (...) + [(_ orig fx [(a) (b c)] check) + (define-an-fx orig fx check + ([(a) (t1)] + [(b c) (t1 t2)]))] + [(_ orig fx (a b c (... ...)) check) + (define-an-fx+rest orig fx check + ([(a b) (t1 t2)]))] + [(_ orig fx (a b (... ...)) check) + (define-an-fx+rest orig fx check + ([(a) (t1)] + [(a b) (t1 t2)]))] + [(_ orig fx (a) check) + (define-an-fx+rest orig fx check + ([(a) (t1)]))] + [(_ orig fx (a b) check) + (define-an-fx orig fx check + ([(a b) (t1 t2)]))])) + +(define-fx = fx=? (a b c ...) nocheck) +(define-fx > fx>? (a b c ...) nocheck) +(define-fx < fx= fx>=? (a b c ...) nocheck) + +(define-fx zero? fxzero? (a) nocheck) +(define-fx positive? fxpositive? (a) nocheck) +(define-fx negative? fxnegative? (a) nocheck) +(define-fx odd? fxodd? (a) nocheck) +(define-fx even? fxeven? (a) nocheck) + +(define-fx max fxmax (a b ...) nocheck) +(define-fx max fxmin (a b ...) nocheck) + +(define-fx + fx+ (a b) check) +(define-fx * fx* (a b) check) +(define-fx - fx- [(a) (a b)] check) + +(define-fx div-and-mod fxdiv-and-mod (a b) nocheck) +(define-fx div fxdiv (a b) nocheck) +(define-fx mod fxmod (a b) nocheck) +(define-fx div0-and-mod0 fxdiv0-and-mod0 (a b) nocheck) +(define-fx div0 fxdiv0 (a b) nocheck) +(define-fx mod0 fxmod0 (a b) nocheck) + +(define (fx+/carry a b c) + '...) + +(define (fx-/carry a b c) + '...) + +(define (fx*/carry a b c) + '...) + +(define-fx bitwise-not fxnot (a) nocheck) +(define-fx bitwise-and fxand (a b ...) nocheck) +(define-fx bitwise-ior fxior (a b ...) nocheck) +(define-fx bitwise-xor fxxor (a b ...) nocheck) +(define-fx bitwise-first-bit-set fxfirst-bit-set (a) nocheck) +(define-fx bitwise-copy-bit fxcopy-bit (a) nocheck) + +(define (fxif a b c) + '... + (bitwise-if a b c)) + +(define-syntax-rule (define-shifter fxarithmetic-shift r6rs:fxarithmetic-shift + lower-bound bounds adjust) + (begin + (provide fxarithmetic-shift) + (define-syntax fxarithmetic-shift + (inline-rules + r6rs:fxarithmetic-shift + [(_ a b) + (let ([t1 a] + [t2 b]) + (if (and (fixnum? a) + (and (exact-integer? b) (<= lower-bound b 30))) + (let ([v (arithmetic-shift a (adjust b))]) + (if (fixnum? v) + v + (r6rs:fxarithmetic-shift t1 t2))) + (r6rs:fxarithmetic-shift t1 t2)))])) + (define (r6rs:fxarithmetic-shift a b) + (unless (fixnum? a) + (raise-type-error 'fxarithmetic-shift "fixnum" a)) + (unless (and (exact-integer? b) (<= lower-bound b 30)) + (raise-type-error 'fxarithmetic-shift bounds b)) + (let ([v (arithmetic-shift a (adjust b))]) + (if (fixnum? v) + v + (implementation-restriction 'fxarithmetic-shift v)))))) + +(define-shifter fxarithmetic-shift r6rs:fxarithmetic-shift + -30 "exact integer in [-30, 30]" values) +(define-shifter fxarithmetic-shift-left r6rs:fxarithmetic-shift-left + 0 "exact integer in [0, 30]" values) +(define-shifter fxarithmetic-shift-right r6rs:fxarithmetic-shift-right + 0 "exact integer in [0, 30]" -) diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index 7d0ad88954..a08ed9d599 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -2,21 +2,19 @@ (require (for-syntax scheme/base r6rs/private/identifier-syntax) + r6rs/private/qq-gen (prefix-in r5rs: r5rs) (only-in r6rs/private/readtable rx:number) scheme/bool) (provide - ;; PLT Scheme pre-requisites: - (rename-out [datum #%datum]) - #%app #%top #%top-interaction ;; 11.2 (rename-out [r5rs:define define] - [r5rs:define-syntax define-syntax]) + [r6rs:define-syntax define-syntax]) ;; 11.4.1 - quote + (rename-out [r5rs:quote quote]) ;; 11.4.2 (rename-out [r5rs:lambda lambda]) @@ -154,13 +152,13 @@ assertion-violation assert ;; 11.15 - apply + (rename-out [r5rs:apply apply]) call-with-current-continuation call/cc values call-with-values dynamic-wind ;; 11.17 - (rename-out [r5rs:quasiquote quasiquote]) ;; FIXME: need the R6RS extension + (rename-out [r6rs:quasiquote quasiquote]) unquote unquote-splicing ;; 11.18 @@ -168,7 +166,9 @@ ;; 11.19 (for-syntax syntax-rules - identifier-syntax) + identifier-syntax + ... + _) ) @@ -291,32 +291,72 @@ (define-struct (exn:fail:contract:r6rs exn:fail:contract) (who irritants)) (define (r6rs:error who msg . irritants) - (make-exn:fail:r6rs - (format "~a: ~a" who msg) - (current-continuation-marks) - who - irritants)) + (raise + (make-exn:fail:r6rs + (format "~a: ~a" who msg) + (current-continuation-marks) + who + irritants))) (define (assertion-violation who msg . irritants) - (make-exn:fail:r6rs - (format "~a: ~a" who msg) - (current-continuation-marks) - who - irritants)) + (raise + (make-exn:fail:r6rs + (format "~a: ~a" who msg) + (current-continuation-marks) + who + irritants))) (define-syntax-rule (assert expr) (unless expr (assrtion-violation #f "assertion failed"))) ;; ---------------------------------------- -;; Datum +;; quasiquote generalization -(define-syntax (datum stx) +(define-generalized-qq r6rs:quasiquote + quasiquote unquote unquote-splicing) + +;; ---------------------------------------- +;; define-syntax: wrap a transformer to +;; ensure that the result of an expansion is +;; a wrapped syntax object. + +(define-syntax (r6rs:define-syntax stx) (syntax-case stx () - [(_ . thing) - (if (vector? (syntax-e #'thing)) - (raise-syntax-error 'r6rs - "a vector is not an expression" - #'thing) - #`(quote thing))])) + [(_ id expr) + (identifier? #'id) + (syntax/loc stx + (define-syntax id (wrap-as-needed expr)))])) + +(define-for-syntax (wrap r stx) + (cond + [(syntax? r) r] + [(symbol? r) (error 'macro + "transformer result included a raw symbol: ~e" + r)] + [(mpair? r) (datum->syntax + stx + (cons (wrap (mcar r) stx) + (wrap (mcdr r) stx)) + stx)] + [(vector? r) (datum->syntax + stx + (list->vector + (map (lambda (r) (wrap r stx)) + (vector->list r))) + stx)] + [else (datum->syntax stx r stx)])) + +(define-for-syntax (wrap-as-needed v) + (if (and (procedure? v) + (procedure-arity-includes? v 1)) + (procedure-reduce-arity + (case-lambda + [(stx) (if (syntax? stx) + (let ([r (v stx)]) + (wrap r stx)) + (v stx))] + [args (apply v args)]) + (procedure-arity v)) + v)) diff --git a/collects/rnrs/control-6.ss b/collects/rnrs/control-6.ss new file mode 100644 index 0000000000..8923ae442f --- /dev/null +++ b/collects/rnrs/control-6.ss @@ -0,0 +1,45 @@ +#lang scheme/base + +(require (for-syntax scheme/base) + scheme/mpair) + +(provide when unless do + (rename-out [r6rs:case-lambda case-lambda])) + +(define-syntax (r6rs:case-lambda stx) + (syntax-case stx () + [(_ clause ...) + (quasisyntax/loc stx + (case-lambda + . #,(map (lambda (clause) + (syntax-case clause () + [[formals body1 body ...] + (syntax-case #'formals () + [(id ...) + (andmap identifier? (syntax->list #'(id ...))) + clause] + [(id ... . rest) + (and (identifier? #'rest) + (andmap identifier? (syntax->list #'(id ...)))) + #`[formals + (let ([rest (list->mlist rest)]) + body1 body ...)]] + [rest + (identifier? #'rest) + #`[formals + (let ([rest (list->mlist rest)]) + body1 body ...)]] + [_ + (raise-syntax-error + #f + "ill-formed argument sequence" + stx + #'formals)])] + [else + (raise-syntax-error + #f + "ill-formed clause" + stx + clause)])) + (syntax->list #'(clause ...)))))])) + diff --git a/collects/rnrs/hashtables-6.ss b/collects/rnrs/hashtables-6.ss new file mode 100644 index 0000000000..a958d57734 --- /dev/null +++ b/collects/rnrs/hashtables-6.ss @@ -0,0 +1,137 @@ +#lang scheme/base + +(provide make-eq-hashtable + make-eqv-hashtable + (rename-out [r6rs:make-hashtable make-hashtable]) + hashtable-size + hashtable-ref + hashtable-set! + hashtable-delete! + hashtable-contains? + hashtable-update! + hashtable-copy + hashtable-clear! + hashtable-keys + hashtable-entries + hashtable-equivalence-function + hashtable-hash-function + hashtable-mutable? + (rename-out [equal-hash-code equal-hash]) + string-hash + string-ci-hash + symbol-hash) + +(define-struct hashtable ([ht #:mutable] + wrap + unwrap + mutable? + equivalence-function + hash-function)) + +(define-struct eqv-box (val) + #:property prop:equal+hash (list + (lambda (a b recur) (eqv? (eqv-box-val a) + (eqv-box-val b))) + (lambda (v recur) (equal-hash-code (eqv-box-val v))) + (lambda (v recur) (equal-secondary-hash-code (eqv-box-val v))))) + + +(define (make-eq-hashtable [k 0]) + (unless (exact-nonnegative-integer? k) + (raise-type-error 'make-eq-hashtable "exact, nonnegative integer" k)) + (make-hashtable (make-hash-table) values values #t eq? #f)) + +(define (make-eqv-hashtable [k 0]) + (unless (exact-nonnegative-integer? k) + (raise-type-error 'make-eqv-hashtable "exact, nonnegative integer" k)) + (make-hashtable (make-hash-table 'equal) make-eqv-box eqv-box-val #t eqv? #f)) + +(define r6rs:make-hashtable + (let ([make-hashtable + (lambda (hash =? [k 0]) + (unless (and (procedure? hash) + (procedure-arity-includes? hash 1)) + (raise-type-error 'make-hashtable "procedure (arity 1)" hash)) + (unless (and (procedure? =?) + (procedure-arity-includes? =? 2)) + (raise-type-error 'make-hashtable "procedure (arity 2)" =?)) + (unless (exact-nonnegative-integer? k) + (raise-type-error 'make-hashtable "exact, nonnegative integer" k)) + (let () + (define-struct hash-box (val) + #:property prop:equal+hash (list + (lambda (a b recur) (=? (hash-box-val a) + (hash-box-val b))) + (lambda (v recur) (hash (hash-box-val v))) + (lambda (v recur) 10001))) + (make-hashtable (make-hash-table 'equal) make-hash-box hash-box-val #t =? hash)))]) + make-hashtable)) + +(define (hashtable-size ht) + (hash-table-count (hashtable-ht ht))) + +(define tag (gensym)) + +(define (hashtable-ref ht key default) + (let ([v (hash-table-get (hashtable-ht ht) ((hashtable-wrap ht) key) tag)]) + (if (eq? v tag) + default + v))) + +(define (hashtable-set! ht key val) + (if (hashtable-mutable? ht) + (hash-table-put! (hashtable-ht ht) ((hashtable-wrap ht) key) val) + (raise-type-error 'hashtable-set! "mutable hashtable" ht))) + +(define (hashtable-delete! ht key) + (if (hashtable-mutable? ht) + (hash-table-remove! (hashtable-ht ht) ((hashtable-wrap ht) key)) + (raise-type-error 'hashtable-delete! "mutable hashtable" ht))) + +(define (hashtable-contains? ht key) + (not (eq? (hash-table-get (hashtable-ht ht) ((hashtable-wrap ht) key) tag) + tag))) + +(define (hashtable-update! ht key proc default) + (hashtable-set! ht key (proc (hashtable-ref ht key default)))) + +(define (hashtable-copy ht [mutable? #f]) + (make-hashtable (hash-table-copy (hashtable-ht ht)) + (hashtable-wrap ht) + (hashtable-unwrap ht) + mutable? + (hashtable-equivalence-function ht))) + +(define (hashtable-clear! ht [k 0]) + (unless (exact-nonnegative-integer? k) + (raise-type-error 'hashtable-clear! "exact, nonnegative integer" k)) + (if (hashtable-mutable? ht) + (set-hashtable-ht! (if (eq? values (hashtable-wrap ht)) + (make-hash-table) + (make-hash-table 'equal))) + (raise-type-error 'hashtable-clear! "mutable hashtable" ht))) + +(define (hashtable-keys ht) + (let ([unwrap (hashtable-unwrap ht)]) + (hash-table-map (hashtable-ht ht) (lambda (a b) (unwrap a))))) + +(define (hashtable-entries ht) + (let ([ps (hash-table-map (hashtable-ht ht) cons)] + [unwrap (hashtable-unwrap ht)]) + (values (list->vector (map (lambda (p) (unwrap (car p))) ps)) + (list->vector (map cdr ps))))) + +(define (string-hash s) + (unless (string? s) + (raise-type-error 'string-hash "string" s)) + (equal-hash-code s)) + +(define (string-ci-hash s) + (unless (string? s) + (raise-type-error 'string-ci-hash "string" s)) + (equal-hash-code (string-foldcase s))) + +(define (symbol-hash s) + (unless (symbol? s) + (raise-type-error 'symbol-hash "symbol" s)) + (eq-hash-code s)) diff --git a/collects/rnrs/io/simple-6.ss b/collects/rnrs/io/simple-6.ss new file mode 100644 index 0000000000..a8ec3a44d0 --- /dev/null +++ b/collects/rnrs/io/simple-6.ss @@ -0,0 +1,24 @@ +#lang scheme/base + +(provide (rename-out [eof eof-object]) + eof-object? + call-with-input-file + call-with-output-file + input-port? + output-port? + current-input-port + current-output-port + current-error-port + with-input-from-file + with-output-to-file + open-input-file + open-output-file + close-input-port + close-output-port + read-char + peek-char + read + write-char + newline + display + write) diff --git a/collects/rnrs/list-6.ss b/collects/rnrs/list-6.ss new file mode 100644 index 0000000000..a34da61502 --- /dev/null +++ b/collects/rnrs/list-6.ss @@ -0,0 +1,241 @@ +#!r6rs + +;; implementation mostly from Mike Sperber +; The (rnrs lists (6)) library. + +(library (rnrs lists (6)) + (export find + for-all exists + + filter + partition + fold-left + fold-right + remp remove remv remq + memp member memv memq + assp assoc assv assq + cons*) + (import (rnrs base (6)) + (rnrs control (6))) + + (define (assert-procedure who obj) + (if (not (procedure? obj)) + (assertion-violation who "not a procedure" obj))) + + (define (find proc list) + (assert-procedure 'find proc) + (let loop ((list list)) + (cond + ((null? list) #f) + ((proc (car list)) (car list)) + (else (loop (cdr list)))))) + + (define (check-nulls who the-list the-lists lists) + (for-each (lambda (list) + (if (not (null? list)) + (apply assertion-violation who + "argument lists don't have the same size" + list lists))) + lists)) + + (define for-all + (case-lambda + [(proc list) + (assert-procedure 'for-all proc) + (for-all1 proc list)] + [(proc list . lists) + (assert-procedure 'for-all proc) + (cond + ((null? list) + (check-nulls 'for-all list lists lists) + #t) + (else + (let loop ((list list) (lists lists)) + (let ((next (cdr list))) + (cond + ((null? next) + (apply proc (car list) (map car lists))) + ((apply proc (car list) (map car lists)) + (loop next (map cdr lists))) + (else #f))))))])) + + (define (for-all1 proc list) + (if (null? list) + #t + (let loop ((list list)) + (let ((next (cdr list))) + (cond + ((null? next) (proc (car list))) + ((proc (car list)) (loop next)) + (else #f)))))) + + (define exists + (case-lambda + [(proc list) + (assert-procedure 'exists proc) + (exists1 proc list)] + [(proc list . lists) + (assert-procedure 'exists proc) + (cond + ((null? list) + (check-nulls 'exists list lists lists) + #f) + (else + (let loop ((list list) (lists lists)) + (let ((next (cdr list))) + (if (null? next) + (apply proc (car list) (map car lists)) + (or (apply proc (car list) (map car lists)) + (loop next (map cdr lists))))))))])) + + (define (exists1 proc list) + (if (null? list) + #t + (let loop ((list list)) + (let ((next (cdr list))) + (if (null? next) + (proc (car list)) + (or (proc (car list)) + (loop next))))))) + + (define (filter proc list) + (assert-procedure 'filter proc) + (let loop ((list list)) + (cond ((null? list) '()) + ((proc (car list)) + (let ([r (loop (cdr list))]) + (if (eq? r (cdr list)) + list + (cons (car list) r)))) + (else + (loop (cdr list)))))) + + (define (partition proc list) + (assert-procedure 'partition proc) + (let loop ((list list) (yes '()) (no '())) + (cond ((null? list) + (values (reverse yes) (reverse no))) + ((proc (car list)) + (loop (cdr list) (cons (car list) yes) no)) + (else + (loop (cdr list) yes (cons (car list) no)))))) + + (define (fold-left combine nil the-list . the-lists) + (assert-procedure 'fold-left combine) + (if (null? the-lists) + (fold-left1 combine nil the-list) + (let loop ((accum nil) (list the-list) (lists the-lists)) + (if (null? list) + (begin + (check-nulls 'fold-left the-list the-lists lists) + accum) + (loop (apply combine accum (car list) (map car lists)) + (cdr list) + (map cdr lists)))))) + + (define (fold-left1 combine nil list) + (let loop ((accum nil) (list list)) + (if (null? list) + accum + (loop (combine accum (car list)) + (cdr list))))) + + + (define (fold-right combine nil the-list . the-lists) + (assert-procedure 'fold-right combine) + (if (null? the-lists) + (fold-right1 combine nil the-list) + (let recur ((list the-list) (lists the-lists)) + (if (null? list) + (begin + (check-nulls 'fold-right the-list the-lists lists) + nil) + (apply combine + (car list) + (append (map car lists) + (cons (recur (cdr list) (map cdr lists)) + '()))))))) + + (define (fold-right1 combine nil list) + (let recur ((list list)) + (if (null? list) + nil + (combine (car list) (recur (cdr list)))))) + + (define (remp proc list) + (assert-procedure 'remp proc) + (let recur ((list list)) + (cond ((null? list) '()) + ((proc (car list)) + (recur (cdr list))) + (else + (let ([r (recur (cdr list))]) + (if (eq? r (cdr list)) + list + (cons (car list) r))))))) + + ;; Poor man's inliner + (define-syntax define-remove-like + (syntax-rules () + ((define-remove-like ?name ?equal?) + (define (?name obj list) + (let recur ((list list)) + (cond ((null? list) '()) + ((?equal? obj (car list)) + (recur (cdr list))) + (else + (let ([r (recur (cdr list))]) + (if (eq? r (cdr list)) + list + (cons (car list) r)))))))))) + + (define-remove-like remove equal?) + (define-remove-like remv eqv?) + (define-remove-like remq eq?) + + (define (memp proc list) + (assert-procedure 'member proc) + (let loop ((list list)) + (cond ((null? list) #f) + ((proc (car list)) list) + (else (loop (cdr list)))))) + + (define-syntax define-member-like + (syntax-rules () + ((define-member-like ?name ?equal?) + (define (?name obj list) + (let loop ((list list)) + (cond ((null? list) #f) + ((?equal? obj (car list)) list) + (else (loop (cdr list))))))))) + + (define-member-like member equal?) + (define-member-like memv eqv?) + (define-member-like memq eq?) + + (define (assp proc alist) + (assert-procedure 'assp proc) + (let loop ((alist alist)) + (if (null? alist) + #f + (let ((p (car alist))) + (if (proc (car p)) + p + (loop (cdr alist))))))) + + (define-syntax define-assoc-like + (syntax-rules () + ((define-assoc-like ?name ?equal?) + (define (?name obj alist) + (let loop ((alist alist)) + (if (null? alist) + #f + (let ((p (car alist))) + (if (?equal? obj (car p)) + p + (loop (cdr alist)))))))))) + + (define (cons* obj . objs) + (if (null? objs) + obj + (cons obj (apply cons* objs))))) diff --git a/collects/rnrs/records/inspection-6.ss b/collects/rnrs/records/inspection-6.ss new file mode 100644 index 0000000000..172657c7a6 --- /dev/null +++ b/collects/rnrs/records/inspection-6.ss @@ -0,0 +1,13 @@ +#!r6rs + +(library (rnrs records inspection (6)) + (export record-type-name + record-type-parent + record-type-sealed? + record-type-uid + record-type-generative? + record-type-field-names + record-type-opaque? + record-field-mutable? + record? record-rtd) + (import (r6rs private records-core))) diff --git a/collects/rnrs/records/procedural-6.ss b/collects/rnrs/records/procedural-6.ss new file mode 100644 index 0000000000..b901cdf4fa --- /dev/null +++ b/collects/rnrs/records/procedural-6.ss @@ -0,0 +1,9 @@ +#!r6rs + +(library (rnrs records procedural (6)) + (export make-record-type-descriptor + record-type-descriptor? + make-record-constructor-descriptor record-constructor + record-predicate + record-accessor record-mutator) + (import (r6rs private records-core))) diff --git a/collects/rnrs/records/syntactic-6.ss b/collects/rnrs/records/syntactic-6.ss new file mode 100644 index 0000000000..cbcc022c02 --- /dev/null +++ b/collects/rnrs/records/syntactic-6.ss @@ -0,0 +1,170 @@ +#!r6rs + +;; Implementation of implicit-naming layer for R6RS Records + +;; Based on the SRFI implementation: +; Copyright (C) Michael Sperber (2005). All Rights Reserved. +; +; Permission is hereby granted, free of charge, to any person +; obtaining a copy of this software and associated documentation files +; (the "Software"), to deal in the Software without restriction, +; including without limitation the rights to use, copy, modify, merge, +; publish, distribute, sublicense, and/or sell copies of the Software, +; and to permit persons to whom the Software is furnished to do so, +; subject to the following conditions: +; +; The above copyright notice and this permission notice shall be +; included in all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +; SOFTWARE. + +(library (rnrs records syntactic (6)) + (export define-record-type + record-type-descriptor + record-constructor-descriptor + fields mutable immutable parent protocol + sealed opaque nongenerative) + (import (for (rnrs base (6)) run expand) + (for (rnrs syntax-case (6)) expand) + (rename (r6rs private records-explicit) + (define-record-type define-record-type/explicit))) + + ;; R5RS part of the implementation of DEFINE-RECORD-TYPE for Records SRFI + + (define-syntax define-record-type + (syntax-rules () + ((define-record-type (?record-name ?constructor-name ?predicate-name) + ?clause ...) + (define-record-type-1 ?record-name (?record-name ?constructor-name ?predicate-name) + () + ?clause ...)) + ((define-record-type ?record-name + ?clause ...) + (define-record-type-1 ?record-name ?record-name + () + ?clause ...)))) + + (define-syntax define-record-type-1 + (syntax-rules (fields) + + ;; find FIELDS clause + ((define-record-type-1 ?record-name ?record-name-spec + (?simple-clause ...) + (fields ?field-spec ...) + ?clause ...) + (process-fields-clause (fields ?field-spec ...) + ?record-name ?record-name-spec + (?simple-clause ...) + ?clause ...)) + + ;; collect all other clauses + ((define-record-type-1 ?record-name ?record-name-spec + (?simple-clause ...) + ?clause0 + ?clause ...) + (define-record-type-1 ?record-name ?record-name-spec + (?simple-clause ... ?clause0) + ?clause ...)) + + ;; pass it on + ((define-record-type-1 ?record-name ?record-name-spec + (?simple-clause ...)) + + (define-record-type-2 ?record-name ?record-name-spec + (?simple-clause ...))))) + + ;; syntax-rules part + + (define-syntax define-record-type-2 + (lambda (form) + (syntax-case form () + ((_ ?record-name (?record-name-2 ?constructor-name ?predicate-name) + (?simple-clause ...)) + + (syntax + (begin + (define-record-type/explicit (?record-name ?constructor-name ?predicate-name) + ?simple-clause ...)))) + + ((_ ?record-name ?record-name-2 + (?simple-clause ...)) + + (with-syntax ((?constructor-name + (datum->syntax (syntax ?record-name) + (string->symbol + (string-append "make-" + (symbol->string + (syntax->datum + (syntax ?record-name))))))) + (?predicate-name + (datum->syntax (syntax ?record-name) + (string->symbol + (string-append (symbol->string + (syntax->datum + (syntax ?record-name))) + "?"))))) + + + (syntax + (define-record-type-2 ?record-name (?record-name ?constructor-name ?predicate-name) + (?simple-clause ...)))))))) + + (define-syntax process-fields-clause + (lambda (form) + (syntax-case form (fields mutable immutable) + ((_ (fields ?field-clause ...) + ?record-name ?record-name-spec + (?simple-clause ...) + ?clause ...) + + (let ((record-name (symbol->string (syntax->datum (syntax ?record-name))))) + (with-syntax + (((?simple-field ...) + (map (lambda (clause) + (syntax-case clause (mutable immutable) + ((immutable ?field-name) + (with-syntax ((?accessor-name + (datum->syntax + (syntax ?field-name) + (string->symbol + (string-append record-name "-" + (symbol->string + (syntax->datum + (syntax ?field-name)))))))) + (syntax + (immutable ?field-name ?accessor-name)))) + ((mutable ?field-name) + (with-syntax ((?accessor-name + (datum->syntax + (syntax ?field-name) + (string->symbol + (string-append record-name "-" + (symbol->string + (syntax->datum + (syntax ?field-name))))))) + (?mutator-name + (datum->syntax + (syntax ?field-name) + (string->symbol + (string-append record-name "-" + (symbol->string + (syntax->datum + (syntax ?field-name))) + "-set!"))))) + (syntax + (mutable ?field-name ?accessor-name ?mutator-name)))) + (?clause + clause))) + (syntax (?field-clause ...))))) + (syntax + (define-record-type-1 + ?record-name ?record-name-spec + (?simple-clause ... (fields ?simple-field ...)) + ?clause ...))))))))) diff --git a/collects/rnrs/sorting-6.ss b/collects/rnrs/sorting-6.ss new file mode 100644 index 0000000000..02e5ec6bbc --- /dev/null +++ b/collects/rnrs/sorting-6.ss @@ -0,0 +1,19 @@ +#lang scheme/base + +(require scheme/mpair) + +(provide list-sort + vector-sort + vector-sort!) + +(define (list-sort < l) + ;; FIXME (performance): `sort' internally converts + ;; a list to an mlist! + (list->mlist (sort (mlist->list l) <))) + +(define (vector-sort < v) + (list->vector (sort (vector->list v) <))) + +(define (vector-sort! < v) + (let ([v2 (vector-sort < v)]) + (vector-copy! v 0 v2))) diff --git a/collects/rnrs/syntax-case-6.ss b/collects/rnrs/syntax-case-6.ss new file mode 100644 index 0000000000..09f094eeea --- /dev/null +++ b/collects/rnrs/syntax-case-6.ss @@ -0,0 +1,278 @@ +#lang scheme/base + +(require (for-syntax scheme/base) + r6rs/private/qq-gen + scheme/stxparam + scheme/mpair) + +(provide make-variable-transformer + (rename-out [r6rs:syntax-case syntax-case] + [r6rs:syntax syntax]) + _ ... + identifier? + bound-identifier=? + (rename-out [r6rs:free-identifier=? free-identifier=?] + [r6rs:datum->syntax datum->syntax] + [r6rs:syntax->datum syntax->datum]) + generate-temporaries + (rename-out [r6rs:with-syntax with-syntax] + [r6rs:quasisyntax quasisyntax]) + unsyntax unsyntax-splicing + (rename-out [raise-syntax-error syntax-violation])) + +(define (r6rs:free-identifier=? a b) + (free-identifier=? a a)) + +(define (r6rs:datum->syntax id datum) + (unless (identifier? id) + (raise-type-error 'datum->syntax "identifier?" id)) + (datum->syntax id (convert-mpairs datum))) + +(define (r6rs:syntax->datum stx) + (convert-pairs (syntax->datum stx))) + +(define (make-variable-transformer proc) + (make-set!-transformer proc)) + +(define unwrapped-tag (gensym)) + +(define (wrap expr) + (datum->syntax #f + (convert-mpairs expr) + (list unwrapped-tag #f #f #f #f))) + +(define (convert-mpairs expr) + (cond + [(mpair? expr) + (cons (convert-mpairs (mcar expr)) + (convert-mpairs (mcdr expr)))] + [(vector? expr) + (list->vector (map convert-mpairs (vector->list expr)))] + [else expr])) + +(define (convert-pairs expr) + (cond + [(pair? expr) + (mcons (convert-pairs (car expr)) + (convert-pairs (cdr expr)))] + [(vector? expr) + (list->vector (map convert-pairs (vector->list expr)))] + [else expr])) + +;; R6RS syntax-case has different wrapping rules than PLT Scheme for +;; the result of `syntax'. We have to recognize pattern variables +;; to unwrap appropriately. + +;; Also, R6RS doesn't have (... ) quoting in patterns --- only +;; in templates. <<<< FIXME + +(define-syntax-parameter pattern-vars null) + +(provide pattern-vars) + +(define-for-syntax (add-pattern-vars ids) + (append (syntax->list ids) + (syntax-parameter-value (quote-syntax pattern-vars)))) + +;; ---------------------------------------- + +(define-for-syntax (extract-pattern-ids stx lits) + (syntax-case stx () + [(a . b) (append (extract-pattern-ids #'a lits) + (extract-pattern-ids #'b lits))] + [#(a ...) (apply append + (map (lambda (a) + (extract-pattern-ids a lits)) + (syntax->list #'(a ...))))] + [a + (identifier? #'a) + (if (or (ormap (lambda (lit) + (free-identifier=? lit #'a)) + lits) + (free-identifier=? #'a #'(... ...)) + (free-identifier=? #'a #'_)) + null + (list #'a))] + [_ null])) + +(define-syntax (r6rs:syntax-case stx) + (syntax-case stx () + [(_ expr (lit ...) clause ...) + (let ([lits (syntax->list #'(lit ...))]) + (for-each (lambda (lit) + (unless (identifier? lit) + (raise-syntax-error #f + "bad literal" + stx + lit)) + (when (free-identifier=? lit #'(... ...)) + (raise-syntax-error #f + "ellipses cannot be literal" + stx + lit)) + + (when (free-identifier=? lit #'_) + (raise-syntax-error #f + "underscore cannot be literal" + stx + lit))) + lits) + (quasisyntax/loc stx + (syntax-case (wrap expr) (lit ...) + . #,(map (lambda (clause) + (syntax-case clause () + [(pat val) + (with-syntax ([pat-ids (extract-pattern-ids #'pat lits)]) + #`(pat (syntax-parameterize ([pattern-vars + (add-pattern-vars #'pat-ids)]) + val)))] + [(pat fender val) + (with-syntax ([pat-ids (extract-pattern-ids #'pat lits)]) + #`(pat (syntax-parameterize ([pattern-vars + (add-pattern-vars #'pat-ids)]) + fender) + (syntax-parameterize ([pattern-vars + (add-pattern-vars #'pat-ids)]) + val)))] + [else clause])) + (syntax->list #'(clause ...))))))] + [(_ . rest) (syntax/loc stx (syntax-case . rest))])) + +;; ---------------------------------------- + +(define-for-syntax (make-unwrap-map tmpl pattern-vars) + (let loop ([tmpl tmpl] + [in-ellipses? #f] + [counting? #f]) + (syntax-case tmpl () + [(ellipses expr) + (and (not in-ellipses?) + (identifier? #'ellipses) + (free-identifier=? #'ellipses #'(... ...))) + (loop #'expr #t #f)] + [(expr ellipses . rest) + (and (not in-ellipses?) + (identifier? #'ellipses) + (free-identifier=? #'ellipses #'(... ...))) + (box (cons (loop #'expr #f #f) + (loop #'rest #f #t)))] + [(a . b) (let ([a (loop #'a in-ellipses? #f)] + [b (loop #'b in-ellipses? counting?)]) + (if (or a b counting?) + (cons a b) + #f))] + [#(a ...) (let ([as (map (lambda (a) + (loop a in-ellipses? #f)) + (syntax->list #'(a ...)))]) + (if (ormap values as) + (list->vector as) + #f))] + [a + (identifier? #'a) + (ormap (lambda (pat-var) + (free-identifier=? #'a pat-var)) + pattern-vars)] + [_ #f]))) + +(define (unwrap stx mapping) + (cond + [(not mapping) + ;; In case stx is a pair, explicitly convert + (datum->syntax #f (convert-mpairs stx))] + [(eq? mapping #t) + ;; was a pattern var; unwrap based on srcloc: + (let loop ([v stx]) + (cond + [(syntax? v) + (if (eq? (syntax-source v) unwrapped-tag) + (loop (syntax-e v)) + v)] + [(pair? v) (mcons (loop (car v)) + (loop (cdr v)))] + [(vector? v) (list->vector + (map loop (vector->list v)))] + [else v]))] + [(pair? mapping) + (let ([p (if (syntax? stx) + (syntax-e stx) + stx)]) + (mcons (unwrap (car p) (car mapping)) + (unwrap (cdr p) (cdr mapping))))] + [(vector? mapping) + (list->vector (unwrap (vector->list (syntax-e stx)) (vector->list mapping)))] + [(box? mapping) + ;; ellipses + (let* ([mapping (unbox mapping)] + [rest-mapping (cdr mapping)] + [rest-size + ;; count number of cons cells we need at the end: + (let loop ([m rest-mapping]) + (if (pair? m) + (add1 (loop (cdr m))) + 0))] + [repeat-stx (reverse + (list-tail (let loop ([stx stx][accum null]) + (let ([p (if (syntax? stx) + (syntax-e stx) + stx)]) + (if (pair? p) + (loop (cdr p) (cons (car p) accum)) + accum))) + rest-size))] + [rest-stx (let loop ([stx stx][size (length repeat-stx)]) + (if (zero? size) + stx + (let ([p (if (syntax? stx) + (syntax-e stx) + stx)]) + (loop (cdr p) (sub1 size)))))]) + (let ([repeats (list->mlist + (map (lambda (rep) + (unwrap rep (car mapping))) + repeat-stx))] + [rest-mapping + ;; collapse #fs to single #f: + (if (let loop ([rest-mapping rest-mapping]) + (if (pair? rest-mapping) + (if (not (car rest-mapping)) + (loop (cdr rest-mapping)) + #f) + (not rest-mapping))) + #f + rest-mapping)]) + + (if (and (not rest-mapping) + (or (null? rest-stx) + (and (syntax? rest-stx) + (null? (syntax-e rest-stx))))) + repeats + (mappend repeats + (unwrap rest-stx rest-mapping)))))] + [else (error 'unwrap "srtange unwrap mapping: ~e" mapping)])) + +(define-syntax (r6rs:syntax stx) + (syntax-case stx () + [(_ tmpl) + (quasisyntax/loc stx + (unwrap #,(syntax/loc stx (syntax tmpl)) + '#,(make-unwrap-map #'tmpl + (syntax-parameter-value #'pattern-vars))))] + [(_ . rest) (syntax/loc stx (syntax . rest))])) + +;; ---------------------------------------- + +;; Implementation from R6RS --- which gives the following +;; strange behavior: +;; +;; > (with-syntax ([a 10][... 11]) #'(a ...)) +;; (10 11) + + +(define-syntax r6rs:with-syntax + (syntax-rules () + [(_ [(p e0) ...] e1 e2 ...) + (r6rs:syntax-case (mlist e0 ...) () + [(p ...) (let () e1 e2 ...)])])) + +(define-generalized-qq r6rs:quasisyntax + quasisyntax unsyntax unyntaxquote-splicing) diff --git a/collects/rnrs/unicode-6.ss b/collects/rnrs/unicode-6.ss new file mode 100644 index 0000000000..3bd68c1387 --- /dev/null +++ b/collects/rnrs/unicode-6.ss @@ -0,0 +1,39 @@ +#lang scheme/base + +;; FIXME: there could be all sorts of mismatches between the R6RS +;; definitions and those in `scheme/base'. + +(provide + char-upcase + char-downcase + char-titlecase + char-foldcase + char-ci=? + char-ci? + char-ci<=? + char-ci>=? + char-alphabetic? + char-numeric? + char-whitespace? + char-upper-case? + char-lower-case? + char-title-case? + char-general-category + + string-upcase + string-downcase + string-titlecase + string-foldcase + string-ci=? + string-ci? + string-ci<=? + string-ci>=? + + string-normalize-nfd + string-normalize-nfkd + string-normalize-nfc + string-normalize-nfkc) + + \ No newline at end of file diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index c3e296bb60..35bec8e724 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -399,7 +399,7 @@ label to be shown in the ``on this page'' table for HTML output. } -@defstruct[(link-element element) ([tag any/c])]{ +@defstruct[(link-element element) ([tag tag?])]{ Hyperlinks the content to @scheme[tag]. diff --git a/collects/srfi/32/vmsort.scm b/collects/srfi/32/vmsort.scm index 814ea046e1..168a503007 100644 --- a/collects/srfi/32/vmsort.scm +++ b/collects/srfi/32/vmsort.scm @@ -4,7 +4,8 @@ vector-merge-sort vector-merge-sort!) - (require "vector-util.scm") + (require "vector-util.scm" + (only scheme/base vector-copy!)) ;;; The sort package -- stable vector merge & merge sort -*- Scheme -*- ;;; Copyright (c) 1998 by Olin Shivers. @@ -66,13 +67,10 @@ (define (%vector-merge! elt< v v1 v2 start start1 end1 start2 end2) (letrec ((vblit (lambda (fromv j i end) ; Blit FROMV[J,END) to V[I,?]. - (let lp ((j j) (i i)) - (vector-set! v i (vector-ref fromv j)) - (let ((j (+ j 1))) - (if (< j end) (lp j (+ i 1)))))))) + (vector-copy! v i fromv j end)))) - (cond ((<= end1 start1) (if (< start2 end2) (vblit v2 start2 start))) - ((<= end2 start2) (vblit v1 start1 start)) + (cond ((<= end1 start1) (if (< start2 end2) (vblit v2 start2 start end2))) + ((<= end2 start2) (vblit v1 start1 start end1)) ;; Invariants: I is next index of V to write; X = V1[J]; Y = V2[K]. (else (let lp ((i start) @@ -105,7 +103,7 @@ (pair? (cdr maybe-args)) (pair? (cddr maybe-args))) (caddr maybe-args) - (vector-copy v)))) + (make-vector (vector-length v))))) (%vector-merge-sort! < v start end temp))))) (define (vector-merge-sort < v . maybe-args) @@ -194,26 +192,24 @@ (call-with-values (lambda () (let recur ((l l) (want (- r l))) - (let ((len (- r l))) - (let lp ((pfxlen (getrun v0 l r)) (pfxlen2 1) - (v v0) (temp temp0) - (v=v0? #t)) - (if (or (>= pfxlen want) (= pfxlen len)) - (values pfxlen v v=v0?) - (let ((pfxlen2 (let lp ((j pfxlen2)) - (let ((j*2 (+ j j))) - (if (<= j pfxlen) (lp j*2) j)))) - (tail-len (- len pfxlen))) - ;; PFXLEN2 is now the largest power of 2 <= PFXLEN. - ;; (Just think of it as being roughly PFXLEN.) - (call-with-values - (lambda () - (recur (+ pfxlen l) pfxlen2)) - (lambda (nr-len nr-vec nrvec=v0?) - (merge temp v nr-vec l pfxlen nr-len - (xor nrvec=v0? v=v0?)) - (lp (+ pfxlen nr-len) (+ pfxlen2 pfxlen2) - temp v (not v=v0?)))))))))) + (let lp ((pfxlen (getrun v0 l r)) (pfxlen2 1) + (v v0) (temp temp0) + (v=v0? #t)) + (if (or (>= pfxlen want) (= pfxlen (- r l))) + (values pfxlen v v=v0?) + (let ((pfxlen2 (let lp ((j pfxlen2)) + (let ((j*2 (+ j j))) + (if (<= j*2 pfxlen) (lp j*2) j))))) + ;; PFXLEN2 is now the largest power of 2 <= PFXLEN. + ;; (Just think of it as being roughly PFXLEN.) + (call-with-values + (lambda () + (recur (+ pfxlen l) pfxlen2)) + (lambda (nr-len nr-vec nrvec=v0?) + (merge temp v nr-vec l pfxlen nr-len + (xor nrvec=v0? v=v0?)) + (lp (+ pfxlen nr-len) (+ pfxlen2 pfxlen2) + temp v (not v=v0?))))))))) (lambda (ignored-len ignored-ansvec ansvec=v0?) (if (not ansvec=v0?) (vector-portion-copy! v0 temp0 l r)))))) diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 7dd20678a0..ef19732c2d 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -1781,6 +1781,8 @@ int scheme_is_module_path(Scheme_Object *obj) int i; mzchar *s; obj = SCHEME_CAR(obj); + if (!SCHEME_CHAR_STRINGP(obj)) + return 0; s = SCHEME_CHAR_STR_VAL(obj); i = SCHEME_CHAR_STRLEN_VAL(obj); if (!i)