suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

r6rs progress

Browse Source 
svn: r8775
This commit is contained in:
Matthew Flatt 2008-02-23 14:11:24 +00:00
parent b1a08edd5a
commit bd97e3e797
24 changed files with 2139 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/r5rs/main.ss
View File

@ -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)

14
collects/r6rs/main.ss
View File

@ -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 ()

18
collects/r6rs/private/inline-rules.ss Normal file
View File

@ -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]))))

22
collects/r6rs/private/prelims.ss Normal file
View File

@ -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))]))

81
collects/r6rs/private/qq-gen.ss Normal file
View File

@ -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))]))))

357
collects/r6rs/private/records-core.ss Normal file
View File

@ -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))))

265
collects/r6rs/private/records-explicit.ss Normal file
View File

@ -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)))))))

93
collects/r6rs/private/vector-types.ss Normal file
View File

@ -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)))

38
collects/rnrs/arithmetic/bitwise-6.ss Normal file
View File

@ -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)))

184
collects/rnrs/arithmetic/fixnums-6.ss Normal file
View File

@ -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<? (a b c ...) nocheck)
(define-fx <= fx<=? (a b c ...) nocheck)
(define-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]" -)

76
collects/rnrs/base-6.ss
View File

@ -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)
(raise
(make-exn:fail:r6rs
(format "~a: ~a" who msg)
(current-continuation-marks)
who
irritants))
irritants)))
(define (assertion-violation who msg . irritants)
(raise
(make-exn:fail:r6rs
(format "~a: ~a" who msg)
(current-continuation-marks)
who
irritants))
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))

45
collects/rnrs/control-6.ss Normal file
View File

@ -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 ...)))))]))

137
collects/rnrs/hashtables-6.ss Normal file
View File

@ -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))

24
collects/rnrs/io/simple-6.ss Normal file
View File

@ -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)

241
collects/rnrs/list-6.ss Normal file
View File

@ -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)))))

13
collects/rnrs/records/inspection-6.ss Normal file
View File

@ -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)))

9
collects/rnrs/records/procedural-6.ss Normal file
View File

@ -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)))

170
collects/rnrs/records/syntactic-6.ss Normal file
View File

@ -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 ...)))))))))

19
collects/rnrs/sorting-6.ss Normal file
View File

@ -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)))

278
collects/rnrs/syntax-case-6.ss Normal file
View File

@ -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 (... <tmpl>) 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)

39
collects/rnrs/unicode-6.ss Normal file
View File

@ -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-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-ci>=?
string-normalize-nfd
string-normalize-nfkd
string-normalize-nfc
string-normalize-nfkc)

2
collects/scribblings/scribble/struct.scrbl
View File

@ -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].

22
collects/srfi/32/vmsort.scm
View File

@ -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,16 +192,14 @@
(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))
(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 pfxlen) (lp j*2) j))))
(tail-len (- len pfxlen)))
(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
@ -213,7 +209,7 @@
(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?))))))))))
temp v (not v=v0?)))))))))
(lambda (ignored-len ignored-ansvec ansvec=v0?)
(if (not ansvec=v0?) (vector-portion-copy! v0 temp0 l r))))))

2
src/mzscheme/src/module.c
View File

@ -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)