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

remove r6rs collection (now in graveyard)

Browse Source 
svn: r6758
This commit is contained in:
Matthew Flatt 2007-06-28 22:51:53 +00:00
parent 675082152e
commit 2bc5b127f7
9 changed files with 0 additions and 1190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/r6rs/doc.txt
View File

@ -1,55 +0,0 @@
The _r6rs_ collection contains support for things that might become
part of the R6RS standard.
To write an R6RS library:
#reader(lib "library.ss" "r6rs")
(library "name" ....)
where "name" matches the containing file name without the file path or
suffix. Note that the #reader line adjusts reader syntax in addition
to converting `library' to `module'.
To evaluate R6RS `library' and `import' forms at the REPL (or with
`load', etc):
> (require (lib "library-repl.ss" "r6rs"))
or start MzScheme as
% mzscheme -L library-repl.ss r6rs
In either mode, to import a collection-based module to to reference
other libraries installed in the collection tree, use
"scheme://<collection>/...<collection>/<file>"
instead of
(lib "<file>" "<collection>" ... "<collection>")
A "scheme://" URI must have at least one <collection> and a <file> to
be translated to a `lib' reference. If the indicated collection does
not exist, a path is invented based on the "mzlib" collection; this
supports absolute URIs that name `library's entered in the REPL.
Limitations:
- doesn't enforce that a for-run import isn't also
a for-expand import in a different import-spec
- reader adjusts only string, character, and quoted-symbol
syntax (as in SRFI-75), for now
To appear:
- a tool to take a sequence of `library' declarations and
copy them into the collection tree (adjusting the
declared library name as necessary, and adding the #reader
line)

3
collects/r6rs/info.ss
View File

@ -1,3 +0,0 @@
(module info (lib "infotab.ss" "setup")
(define name "R6RS"))

311
collects/r6rs/library-module.ss
View File

@ -1,311 +0,0 @@
(module library-module mzscheme
(require-for-syntax "private/helpers.ss"
(lib "kerncase.ss" "syntax")
(lib "context.ss" "syntax")
(lib "boundmap.ss" "syntax")
(lib "stxparam.ss")
(lib "list.ss"))
(require (lib "stxparam.ss"))
(provide (rename library-module-begin #%module-begin)
import)
(define-syntax define-impdef-placeholder
(syntax-rules ()
[(_ id) (begin
(define-syntax (id stx)
(raise-syntax-error
#f
"only allowed at the beginning of a `library' form"
stx))
(provide id))]))
(define-impdef-placeholder export)
(define-impdef-placeholder indirect-export)
(define-syntax (import stx)
(unless (eq? (syntax-local-context) 'top-level)
(raise-syntax-error
#f
"only allowed at the beginning of a `library' form or outside a library at the top level"
stx))
(syntax-case stx ()
[(_ i ...)
#`(begin #,@(map translate-import (syntax->list #'(i ...))))]))
(define-for-syntax (split-bodies bodies)
(let loop ([bodies bodies]
[imports null]
[exports null])
(if (null? bodies)
(values (reverse imports)
(reverse exports)
null)
(syntax-case (car bodies) (import export)
[(import in ...)
(loop (cdr bodies)
(append (syntax->list #'(in ...)) imports)
exports)]
[(import . rest)
(raise-syntax-error #f "bad syntax" (car bodies))]
[(export out ...)
(loop (cdr bodies)
imports
(append (syntax->list #'(out ...)) exports))]
[(export . rest)
(raise-syntax-error #f "bad syntax" (car bodies))]
[else (values (reverse imports)
(reverse exports)
bodies)]))))
(define-for-syntax (make-unboxer id in-src-module-id)
(with-syntax ([id id])
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[(set! _ v) #'(set-box! id v)]
[(_ arg ...) #'((unbox id) arg ...)]
[_ #'(unbox id)])))))
(define-for-syntax (box-rhs stx)
(syntax-case stx ()
[(_ rhs) #'(box rhs)]))
(define-for-syntax (make-protected-unboxer id in-src-module-id)
(with-syntax ([id id])
(make-set!-transformer
(lambda (stx)
(unless (syntax-parameter-value in-src-module-id)
(raise-syntax-error
#f
"reference to non-exported identifier allowed only within its source library"
stx))
(syntax-case stx (set!)
[(set! _ v) #'(set! id v)]
[(_ arg ...) #'(id arg ...)]
[_ #'id])))))
(define-for-syntax (no-box-rhs stx)
(syntax-case stx ()
[(_ rhs) #'rhs]))
(define-for-syntax (check-exported-macro f ok?)
(let ([wrap (lambda (f)
(lambda (stx)
(unless (ok?)
(raise-syntax-error
#f
"reference to non-exported identifier allowed only within its source library"
stx))
(f stx)))])
(cond
[(and (procedure? f) (procedure-arity-includes? f 1))
(wrap f)]
[(set!-transformer? f)
(make-set!-transformer (wrap (set!-transformer-procedure f)))]
[else f])))
(define-syntax (library-module-begin stx)
(syntax-case stx ()
[(_ (__ name lang body ...))
(let ([stx (syntax-case stx () [(_ o) #'o])])
(unless (and (string? (syntax-e #'name))
(uri? (syntax-e #'name)))
(raise-syntax-error
#f
"library name must be a URI"
stx
#'name))
(unless (and (string? (syntax-e #'lang))
(string=? "scheme://r6rs" (syntax-e #'lang)))
(raise-syntax-error
#f
"language position must be \"scheme://r6rs\""
stx
#'lang))
(let ([bodies (syntax->list #'(body ...))])
(let-values ([(imports exports bodies)
(split-bodies bodies)])
(let ([provides (map translate-export exports)])
#`(#%plain-module-begin
(require #,(datum->syntax-object stx '(all-except (lib "r6rs.ss" "r6rs")
#%module-begin)))
(require-for-syntax #,(datum->syntax-object stx '(lib "r6rs.ss" "r6rs")))
(require #,(datum->syntax-object stx '(lib "library-module.ss" "r6rs")))
#,@(map translate-import imports)
#,@provides
(define-syntax-parameter in-src-module #f)
(begin-library-body
in-src-module
#,(apply append (map (lambda (prov)
(map (lambda (p)
(syntax-case p ()
[(_ loc ext) #'loc]
[_else p]))
(cdr (syntax->list prov))))
provides))
()
#,bodies
()
()))))))]
[(_ x)
(raise-syntax-error
#f
"bad syntax"
#'x)]))
(define-for-syntax stops (list*
#'import
#'export
#'indirect-export
(kernel-form-identifier-list #'here)))
(define-syntax (begin-library-body stx)
(syntax-case stx ()
[(_ in-src-module export-info ((macro-id ind-id ...) ...)
() ; no body forms left
((def-macro-id check-id) ...)
((id gen-id boxdef-id) ...))
;; We've processed the whole body, and now we need to
;; create unboxers for the defined names:
(let ([macro-ids (syntax->list #'(macro-id ...))]
[ind-idss (map syntax->list (syntax->list #'((ind-id ...) ...)))])
;; Check that each inidirect-export id was defined
(let ([t (make-bound-identifier-mapping)])
(for-each (lambda (id)
(bound-identifier-mapping-put! t id #t))
(syntax->list #'(def-macro-id ...)))
(for-each (lambda (macro-id)
(unless (bound-identifier-mapping-get t macro-id (lambda () #f))
(raise-syntax-error
#f
"id to trigger indirect exports not defined as syntax in the library"
macro-id)))
macro-ids)
(for-each (lambda (id)
(bound-identifier-mapping-put! t id #t))
(syntax->list #'(id ...)))
(for-each (lambda (id)
(unless (bound-identifier-mapping-get t id (lambda () #f))
(raise-syntax-error
#f
"indirect export not defined in the library"
id)))
(apply append ind-idss)))
;; Add each explicitly exported id to a table
(let ([t (make-bound-identifier-mapping)])
(for-each (lambda (id)
(bound-identifier-mapping-put! t id #t))
(syntax->list #'export-info))
;; Find fixpoint, adding indirect ids when the macro id is
;; exported:
(let loop ([macro-ids macro-ids]
[ind-idss ind-idss]
[next-macro-ids null]
[next-ind-idss null]
[added? #f])
(cond
[(null? macro-ids)
(when added?
(loop next-macro-ids next-ind-idss null null #f))]
[(bound-identifier-mapping-get t (car macro-ids) (lambda () #f))
(for-each (lambda (ind-id)
(bound-identifier-mapping-put! t ind-id #t))
(car ind-idss))
(loop (cdr macro-ids) (cdr ind-idss) next-macro-ids next-ind-idss #t)]
[else
(loop (cdr macro-ids) (cdr ind-idss)
(cons (car macro-ids) next-macro-ids)
(cons (car ind-idss) next-ind-idss)
added?)]))
;; For each defined id, select an unboxer:
(with-syntax ([((make-an-unboxer . box-a-def) ...)
(map (lambda (id)
(if (bound-identifier-mapping-get t id (lambda () #f))
#'(make-unboxer . box-rhs)
#'(make-protected-unboxer . no-box-rhs)))
(syntax->list #'(id ...)))])
;; For each unexported macro id, add compile-time set!:
(with-syntax ([(check-id ...)
(map cdr (filter (lambda (p)
(not (bound-identifier-mapping-get t (car p) (lambda () #f))))
(map cons
(syntax->list #'(def-macro-id ...))
(syntax->list #'(check-id ...)))))])
#'(begin
(begin-for-syntax (set! check-id #f) ...)
(define-syntaxes (boxdef-id) box-a-def) ...
(define-syntaxes (id ...)
(values (make-an-unboxer (quote-syntax gen-id) (quote-syntax in-src-module)) ...)))))))]
[(_ in-src-module export-info indirects (body0 body ...) define-macro-ids defined-ids)
;; Process one body form, body0
(let ([comdef (local-expand #'body0
'module
stops)])
(syntax-case comdef (begin define-syntaxes define-values indirect-export)
[(begin comdef ...)
#`(begin-library-body in-src-module
export-info
indirects
(comdef ... body ...)
define-macro-ids
defined-ids)]
[(define-syntaxes (id ...) rhs)
(with-syntax ([(check-id ...) (generate-temporaries #'(id ...))])
#`(begin (define-for-syntax check-id #t) ...
(define-syntaxes (id ...)
(let-values ([(id ...) rhs])
(values (check-exported-macro id (lambda () check-id)) ...)))
(begin-library-body in-src-module
export-info
indirects
(body ...)
((id check-id) ... . define-macro-ids)
defined-ids)))]
[(define-values (id ...) rhs)
(with-syntax ([(gen-id ...) (generate-temporaries #'(id ...))]
[(boxdef-id ...) (generate-temporaries #'(id ...))])
#`(begin
(define-values (gen-id ...)
(syntax-parameterize ([in-src-module #t])
(let-values ([(id ...) rhs])
(values (boxdef-id id) ...))))
(begin-library-body in-src-module
export-info
indirects
(body ...)
define-macro-ids
((id gen-id boxdef-id) ... . defined-ids))))]
[(indirect-export (macro-id id ...) ...)
(begin
(for-each (lambda (x)
(unless (identifier? x)
(raise-syntax-error
#f
"expected an identifier"
comdef
x)))
(syntax->list #'(macro-id ... id ... ...)))
#`(begin-library-body in-src-module
export-info
((macro-id id ...) ... . indirects)
(body ...)
define-macro-ids
defined-ids))]
[(indirect-export . _)
(raise-syntax-error
#f
"bad syntax"
comdef)]
[expr
;; syntax-parameterize forces an expression (not defn):
#`(begin
(syntax-parameterize ([in-src-module #t])
expr)
(begin-library-body in-src-module
export-info
indirects
(body ...)
define-macro-ids
defined-ids))]))])))

31
collects/r6rs/library-repl.ss
View File

@ -1,31 +0,0 @@
(module library-repl mzscheme
(require (all-except "library-module.ss" #%module-begin)
(prefix r6rs: "reader.ss"))
(require-for-syntax "private/uri.ss")
(provide import export indirect-export library)
(current-readtable r6rs:r6rs-readtable)
(define-syntax (library stx)
(syntax-case stx ()
[(_ name . rest)
(unless (string? (syntax-e #'name))
(raise-syntax-error
#f
"expected a string for the library name"
stx
#'name))
(let ([modname (uri->symbol (syntax-e #'name))])
#`(begin
(module #,modname (lib "library-module.ss" "r6rs")
#,(datum->syntax-object
#f
(list '#%module-begin stx)))
;; Notify module-name resolver that we defined something that
;; might otherwise be loaded.
((current-module-name-resolver) #f '#,modname #f)))])))

40
collects/r6rs/library.ss
View File

@ -1,40 +0,0 @@
(module library mzscheme
(provide (rename lib-read read)
(rename lib-read-syntax read-syntax))
(require (prefix r6rs: "reader.ss"))
(define lib-read
(case-lambda
[() (lib-read (current-input-port))]
[(input) (lib-read-syntax (object-name (current-input-port)) (current-input-port))]))
(define lib-read-syntax
(case-lambda
[() (lib-read-syntax (object-name (current-input-port)) (current-input-port))]
[(src-v) (lib-read-syntax src-v (current-input-port))]
[(src-v input) (let ([r1 (r6rs:read-syntax src-v input)]
[r2 (r6rs:read-syntax src-v input)])
(let ([name-stx (and (syntax? r1)
(eof-object? r2)
(pair? (syntax-e r1))
(eq? 'library (syntax-e (car (syntax-e r1))))
(or (and
(pair? (cdr (syntax-e r1)))
(cadr (syntax-e r1)))
(and
(syntax? (cdr (syntax-e r1)))
(pair? (syntax-e (cdr (syntax-e r1))))
(car (syntax-e (cdr (syntax-e r1)))))))])
(unless (and name-stx (string? (syntax-e name-stx)))
(error 'r6rs-load-handler
"expected a single `library' form with a string name, found something else"))
(datum->syntax-object
#f
`(module ,(string->symbol (syntax-e name-stx)) (lib "library-module.ss" "r6rs")
(#%module-begin ,r1)))))])))

328
collects/r6rs/private/helpers.ss
View File

@ -1,328 +0,0 @@
(module helpers mzscheme
(require (lib "list.ss")
"uri.ss")
(require-for-template mzscheme)
(provide translate-import
translate-export
uri?)
(define (uri? s)
;; Need a proper test here!
#t)
(define ((check-identifier stx) id)
(unless (identifier? id)
(raise-syntax-error
#f
"expected an identifier"
stx
id)))
(define (check-present orig-i what nested !not exceptions names)
(for-each (lambda (en)
(unless (!not (ormap (lambda (i) (bound-identifier=? (car en) i))
names))
(raise-syntax-error
#f
(format "~a in nested ~a" what nested)
orig-i
(car en))))
exceptions))
(define (add-prefix prefix id)
(if prefix
(datum->syntax-object id
(string->symbol
(format "~a~a" (syntax-e prefix) (syntax-e id)))
id)
id))
(define (locate-rename id renames)
(cond
[(null? renames) #f]
[(bound-identifier=? id (caar renames)) (cdar renames)]
[else (locate-rename id (cdr renames))]))
(define (apply-rename new-names old-names name-pairs rcons)
(map (lambda (i)
(or (ormap (lambda (new old)
(and (bound-identifier=? (car i) new)
(rcons old (cdr i))))
new-names old-names)
i))
name-pairs))
(define (remove-all-prefixes orig-i name-pairs form prefix)
(let ([s (symbol->string (syntax-e prefix))])
(map (lambda (i)
(let ([old (symbol->string (syntax-e (car i)))])
(unless (and ((string-length old) . >= . (string-length s))
(string=? s (substring old 0 (string-length s))))
(raise-syntax-error
#f
(format "~a does not have prefix ~s added by nested `prefix' form"
form
s)
orig-i
(car i)))
(cons (datum->syntax-object (car i)
(string->symbol (substring old (string-length s)))
(car i))
(cdr i))))
name-pairs)))
(define (check-unique-names orig-i what names)
(let ([dup (check-duplicate-identifier names)])
(when dup
(raise-syntax-error
#f
(format "duplicate ~a identifier" what)
orig-i
dup))))
(define (localize i stx)
(datum->syntax-object i (syntax-e stx)))
(define (translate-import i)
(define orig-i #`(import #,i))
(syntax-case* i (for run expand) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[(for sub run expand)
(finish-translate-import orig-i #'sub #t #t)]
[(for sub expand run)
(finish-translate-import orig-i #'sub #t #t)]
[(for sub run)
(finish-translate-import orig-i #'sub #t #f)]
[(for sub expand)
(finish-translate-import orig-i #'sub #f #t)]
[(for . _)
(raise-syntax-error
#f
"bad `for' form"
orig-i
i)]
[_else
(finish-translate-import orig-i i #t #f)]))
(define (finish-translate-import orig-i i run? expand?)
(define (mk-require l)
(cond
[(and run? expand?)
#`(begin (require #,@l) (require-for-syntax #,@l))]
[run?
#`(require #,@l)]
[expand?
#`(require-for-syntax #,@l)]))
(translate-impexp
i orig-i
(lambda (i exceptions onlys renames extra-prefix)
;; Found a base URI?
(unless (and (string? (syntax-e i))
(uri? (syntax-e i)))
(raise-syntax-error
#f
"expected a URI string or an `only', `except', `add-prefix', or `rename' form"
orig-i
i))
(let ([name (datum->syntax-object i (uri->module-path (syntax-e i)) i)])
(cond
[onlys
;; Onlys are implemented with `rename':
(mk-require (map (lambda (name-pair)
#`(rename #,name #,(cdr name-pair) #,(car name-pair)))
onlys))]
[(or exceptions (pair? renames))
;; First import non-renamed, then renamed:
(mk-require (cons
(localize i #`(#,(if extra-prefix #'prefix-all-except #'all-except)
#,@(if extra-prefix (list extra-prefix) null)
#,name
#,@(append (map car (or exceptions null))
(map car renames))))
(map (lambda (i)
#`(rename #,name #,(cdr i) #,(car i)))
renames)))]
[extra-prefix
(mk-require (list (localize i #`(prefix #,extra-prefix #,name))))]
[else
(mk-require (list name))])))))
(define (translate-export i)
(define orig-i #`(export #,i))
#`(provide
#,@(syntax-case* i (rename) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[(rename ie ...)
(begin
(for-each (lambda (ie)
(syntax-case ie ()
[(int ext)
(for-each (lambda (i)
(unless (identifier? i)
(raise-syntax-error
#f
"expected an identifier for rename"
orig-i
i)))
(list #'int #'ext))]))
(syntax->list #'(ie ...)))
#`((rename . ie) ...))]
[(rename . x)
(raise-syntax-error
#f
"bad rename clause"
i
orig-i)]
[_
(identifier? i)
(list i)]
[_else
(raise-syntax-error
#f
"expected an identifier or `rename' form"
orig-i
i)])))
(define (translate-impexp i orig-i k)
(let loop ([i i]
[exceptions #f] ; #f if onlys
[onlys #f] ; #f if exceptions
[renames null] ; null if onlys
[extra-prefix #f]) ; #f if onlys, already folded into exceptions & renames
(syntax-case* i (only except rename add-prefix) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[(only sub name ...)
(let ([names (syntax->list #'(name ...))])
(for-each (check-identifier i) names)
(check-unique-names orig-i "`only'" names)
(check-present orig-i "rename not" "`only' list" values renames names)
(cond
[exceptions
(check-present orig-i "except not" "`only' list" values exceptions names)
(loop #'sub
#f
(remove* exceptions (map (lambda (i)
(cons i (or (locate-rename i renames)
(add-prefix extra-prefix i))))
names)
(lambda (a b) (bound-identifier=? (car a) (car b))))
null
#f)]
[onlys
(check-present orig-i "only not" "`only' list" values onlys names)
(loop #'sub #f onlys null #f)]
[else
(loop #'sub
#f
(map (lambda (i)
(cons i (or (locate-rename i renames)
(add-prefix extra-prefix i))))
names)
null
#f)]))]
[(only . _)
(raise-syntax-error
#f
"bad syntax"
i)]
[(except sub name ...)
(let ([names (syntax->list #'(name ...))])
(for-each (check-identifier i) names)
(check-unique-names orig-i "`except'" names)
(check-present orig-i "rename" "`except' list" not renames names)
(let ([remove-exceptions
(lambda ()
(remove* exceptions renames (lambda (a b) (bound-identifier=? (car a) (car b)))))])
(cond
[(pair? exceptions)
(check-present orig-i "except" "`except' list" not exceptions names)
;; union the exceptions
(loop #'sub
(append
(remove* exceptions (map (lambda (i)
(cons i (or (locate-rename i renames)
(add-prefix extra-prefix i))))
names)
(lambda (a b) (bound-identifier=? (car a) (car b))))
exceptions)
#f
(remove-exceptions)
extra-prefix)]
[(pair? onlys)
(check-present orig-i "only" "`except' list" not onlys names)
(loop #'sub #f onlys null #f)]
[else
(loop #'sub
(map (lambda (i)
(cons i (add-prefix extra-prefix i)))
names)
#f
(remove-exceptions)
extra-prefix)])))]
[(except . _)
(raise-syntax-error
#f
"bad syntax"
i)]
[(rename sub (new old) ...)
(let* ([new-names (syntax->list #'(new ...))]
[old-names (syntax->list #'(old ...))]
[name-pairs (map (lambda (old new)
(cons old (add-prefix extra-prefix new)))
old-names new-names)])
(for-each (check-identifier i) (apply append (map list new-names old-names)))
(check-unique-names orig-i "`rename' target" new-names)
(check-unique-names orig-i "`rename' source" old-names)
(let ([combine-renames
(lambda ()
(let ([renames (apply-rename new-names old-names renames cons)])
(append
renames
(remove* renames name-pairs
(lambda (a b)
(bound-identifier=? (car a) (car b)))))))])
(cond
[exceptions
(loop #'sub
(apply-rename new-names old-names exceptions cons)
#f
(combine-renames)
extra-prefix)]
[onlys
(loop #'sub
#f
(apply-rename new-names old-names onlys cons)
null
#f)]
[else
(loop #'sub
#f
#f
(combine-renames)
extra-prefix)])))]
[(rename . _)
(raise-syntax-error
#f
"bad syntax"
i)]
[(add-prefix sub prefix)
(cond
[onlys
(loop #'sub
#f
(remove-all-prefixes orig-i onlys "only" #'prefix)
null
#f)]
[else
(loop #'sub
(and exceptions
(remove-all-prefixes orig-i exceptions "except" #'prefix))
#f
(remove-all-prefixes orig-i renames "rename" #'prefix)
(add-prefix extra-prefix #'prefix))])]
[(add-prefix . _)
(raise-syntax-error
#f
"bad syntax"
i)]
[_else
(k i exceptions onlys renames extra-prefix)]))))

68
collects/r6rs/private/uri.ss
View File

@ -1,68 +0,0 @@
(module uri mzscheme
(require (lib "string.ss")
(lib "list.ss"))
(provide uri->symbol
uri->module-path)
(define rx:scheme-uri #rx"^[sS][cC][hH][eE][mM][eE]://([^/]+/+[^/]+.*)$")
(define (uri->scheme-path s)
(let ([m (regexp-match rx:scheme-uri s)])
(and m
(let ([l (filter (lambda (s)
(not (string=? s "")))
(regexp-split #rx"/" (cadr m)))])
(let loop ([l l][accum null])
(cond
[(null? (cdr l))
(let ([s (car l)])
(cons (if (regexp-match #rx"[.]" s)
s
(string-append s ".scm"))
(reverse accum)))]
[else (loop (cdr l) (cons (car l) accum))]))))))
(define (uri->symbol s)
(let ([p (uri->scheme-path s)])
(cond
[p (string->symbol
(string-append
","
(let ([collpath
;; Try to get real collection; if it doesn't exist,
;; make one up relative to mzlib.
(with-handlers ([exn:fail:filesystem?
(lambda (exn)
(simplify-path
(apply build-path (collection-path "mzlib")
'up
(cdr p))))])
(apply collection-path (cdr p)))])
(path->string (build-path collpath
(path-replace-suffix (car p) #""))))))]
[else (string->symbol
(string-append ","
(path->string
(apply build-path
(simplify-path
(expand-path
;; Don't use (current-load-relative-directory)
(current-directory)))
(filter
(lambda (x)
(not (string=? x "")))
(regexp-split #rx"/" s))))))])))
(define (uri->module-path s)
(let ([p (uri->scheme-path s)])
(cond
[p
;; If the collection exists, build a `lib' path. Otherwise, assume
;; that we're in REPL mode, and make up a symbol using uri->symbol
(if (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
(apply collection-path (cdr p)))
`(lib ,@p)
(uri->symbol s))]
[else s]))))

73
collects/r6rs/r6rs.ss
View File

@ -1,73 +0,0 @@
(module r6rs mzscheme
(require (prefix r5rs: (lib "r5rs.ss" "lang")))
;; R5RS values
(provide car cdr caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
map = < > <= >= max min + - * /
abs gcd lcm exp log sin cos tan not eq?
call-with-current-continuation make-string
symbol->string string->symbol make-rectangular
exact->inexact inexact->exact number->string string->number
rationalize output-port? current-input-port current-output-port current-error-port
open-input-file open-output-file close-input-port close-output-port
with-output-to-file transcript-on transcript-off flush-output
string-length string-ci<=? string-ci>=? string-append
string->list list->string string-fill!
vector-length vector->list list->vector vector-fill!
char-alphabetic? char-numeric? char-whitespace?
char-upper-case? char-lower-case? char->integer integer->char char-downcase
call-with-output-file call-with-input-file with-input-from-file
apply for-each symbol? pair? cons set-car! set-cdr! null? list? list length append reverse
list-tail list-ref memq memv member assq assv assoc procedure?
number? complex? real? rational? integer? exact? inexact? zero?
positive? negative? odd? even?
quotient remainder modulo floor ceiling truncate round
numerator denominator asin acos atan sqrt
expt make-polar real-part imag-part angle magnitude input-port?
read read-char peek-char eof-object?
char-ready? write display newline write-char load
string? string string-ref string-set! string=? substring string-copy
string-ci=? string<? string>? string<=? string>=? string-ci<? string-ci>?
vector? make-vector vector vector-ref vector-set!
char? char=? char<? char>? char<=? char>=?
char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
char-upcase boolean? eqv? equal? force
call-with-values values eval port? scheme-report-environment null-environment
interaction-environment dynamic-wind)
;; Extra values for R6RS:
(provide bound-identifier=?
(rename syntax->list syntax-object->list))
;; R5RS syntax (plus revised #%module-begin)
(provide quasiquote unquote unquote-splicing
if let and or cond case define delay do
(rename r5rs:letrec letrec)
let* begin lambda quote set!
define-syntax let-syntax letrec-syntax
;; We have to include the following MzScheme-isms to do anything,
;; but they're not legal R5RS names, anyway.
#%app #%datum #%top
(rename r6rs-module-begin #%module-begin)
(rename require #%require)
(rename provide #%provide))
;; Extra syntax for R6RS:
(provide syntax-rules syntax-case syntax)
(define-syntax r6rs-module-begin
(lambda (stx)
(datum->syntax-object
(quote-syntax here)
(list* (quote-syntax #%plain-module-begin)
(list 'require-for-syntax
(datum->syntax-object
stx
'(lib "r6rs.ss" "r6rs")))
(cdr (syntax-e stx)))
stx))))

281
collects/r6rs/reader.ss
View File

@ -1,281 +0,0 @@
(module reader mzscheme
(provide r6rs-readtable
(rename r6rs-read read)
(rename r6rs-read-syntax read-syntax))
;; for raise-read-[eof-]error:
(require (lib "readerr.ss" "syntax"))
(define hex-digits (string->list "0123456789abcdefABCDEF"))
(define standard-delimiters (string->list ";',`()[]{}"))
;; hex-value : char -> int
(define (hex-value ch)
(cond
[(char-numeric? ch)
(- (char->integer ch) 48)]
[(memv ch '(#\a #\b #\c #\d #\e #\f))
(- (char->integer ch) 87)]
[else
(- (char->integer ch) 55)]))
;; read-delimited-string : char input-port .... -> string
;; Reads a string or symbol, given the closing character
(define (read-delimited-string closer-ch port
what src line col pos)
;; raise-bad-eof
;; Reports an unexpected EOF in a string/symbol
(define (raise-bad-eof len)
(raise-read-eof-error
(format "unexpected end-of-file in ~a" what)
src line col pos len))
;; to-hex : char int -> int
;; Checks input and gets it's value as a hex digit
(define (to-hex ch len)
(unless (memv ch hex-digits)
(if (eof-object? ch)
(raise-bad-eof len)
(raise-read-error
(format "expected a hex digit for ~a, found: ~e" what ch)
src line col pos len)))
(hex-value ch))
;; loop to read string/symbol characters; track the length for error reporting
(let loop ([chars null][len 1])
(let ([ch (read-char port)])
(cond
;; eof
[(eof-object? ch) (raise-bad-eof len)]
;; closing quote or bar
[(char=? ch closer-ch) (list->string (reverse chars))]
;; escape
[(char=? ch #\\)
(let ([ch (read-char port)])
(cond
;; eof after escape
[(eof-object? ch) (raise-bad-eof (add1 len))]
;; newline escape
[(char=? #\newline ch)
;; Eat whitespace until we find a newline...
(let w-loop ([len (+ len 1)])
(let ([ch (peek-char port)])
(cond
[(eof-object? ch) (raise-bad-eof len)]
[(and (char-whitespace? ch)
(not (char=? #\newline ch)))
(read-char port)
(w-loop (+ len 1))]
[else
(loop chars len)])))]
;; space escape
[(char=? #\space ch)
(loop (cons #\space chars) (+ len 2))]
;; 2-digit hex escape
[(char=? #\x ch)
(let* ([ch1 (to-hex (read-char port) (+ len 2))]
[ch2 (to-hex (read-char port) (+ len 3))])
(loop (cons (integer->char (+ (* ch1 16) ch2))
chars)
(+ len 3)))]
;; 4-digit hex escape
[(char=? #\u ch)
(let* ([ch1 (to-hex (read-char port) (+ len 2))]
[ch2 (to-hex (read-char port) (+ len 3))]
[ch3 (to-hex (read-char port) (+ len 4))]
[ch4 (to-hex (read-char port) (+ len 5))])
(let ([v (+ (* ch1 4096) (* ch2 256) (* ch3 16) ch4)])
(when (<= #xD8FF v #xDFFF)
(raise-read-error
(format "out-of-range character for ~a: \\u~a~a~a~a"
what ch1 ch2 ch3 ch4)
src line col pos (+ len 5)))
(loop (cons (integer->char v) chars)
(+ len 5))))]
;; 8-digit hex escape
[(char=? #\U ch)
(let* ([ch1 (to-hex (read-char port) (+ len 2))]
[ch2 (to-hex (read-char port) (+ len 3))]
[ch3 (to-hex (read-char port) (+ len 4))]
[ch4 (to-hex (read-char port) (+ len 5))]
[ch5 (to-hex (read-char port) (+ len 6))]
[ch6 (to-hex (read-char port) (+ len 7))]
[ch7 (to-hex (read-char port) (+ len 8))]
[ch8 (to-hex (read-char port) (+ len 9))])
(let ([v (+ (* ch1 268435456) (* ch2 16777216) (* ch3 1048576) (* ch4 65536)
(* ch5 4096) (* ch6 256) (* ch7 16) ch8)])
(when (or (> v #x10FFFF)
(<= #xD8FF v #xDFFF))
(raise-read-error
(format "out-of-range character for ~a: \\U~a~a~a~a~a~a~a~a"
what ch1 ch2 ch3 ch4 ch5 ch6 ch7 ch8)
src line col pos (+ len 9)))
(loop (cons (integer->char v) chars)
(+ len 9))))]
;; other escapes
[else (let ([v (case ch
[(#\a) 7]
[(#\b) 8]
[(#\t) 9]
[(#\n) 10]
[(#\v) 11]
[(#\f) 12]
[(#\r) 13]
[(#\") 34]
[(#\\) 92]
[(#\|) 124]
;; not a valid escape!
[else
(raise-read-error
(format "illegal escape for ~a: \\~a" what ch)
src line col pos (+ len 2))])])
(loop (cons (integer->char v) chars) (+ len 2)))]))]
;; other character
[else (loop (cons ch chars) (+ len 1))]))))
;; read-quoted-symbol
;; Reader macro for |
(define (read-quoted-symbol ch port src line col pos)
(string->symbol (read-delimited-string #\| port
"symbol" src line col pos)))
;; read-quoted-string
;; Reader macro for "
(define (read-quoted-string ch port src line col pos)
(read-delimited-string #\" port
"string" src line col pos))
;; read-character
;; Reader macro for characters
(define (read-character ch port src line col pos)
;; make-char-const : list-of-char len -> char
;; Checks whether the character sequence names a char,
;; and either reports and error or returns the character
(define (make-char-const chars len)
(let ([chars (reverse chars)])
(if (null? (cdr chars))
;; simple case: single character
(car chars)
;; multi-character name:
(let ([name (list->string chars)])
;; raise-bad-char
;; When it's not a valid character
(define (raise-bad-char detail)
(raise-read-error
(format "bad character constant~a: #\\~a" detail name)
src line col pos len))
;; hex-char : int -> char
;; Checks whether chars has n hex digits, and
;; produces the character if so
(define (hex-char n)
(unless (= (+ n 1) (length chars))
(raise-bad-char (format " (expected ~a hex digits after #\\~a) "
n
(car chars))))
(for-each (lambda (c)
(unless (memv c hex-digits)
(raise-bad-char (format " (expected hex digit, found ~a) " c))))
(cdr chars))
(let loop ([n 0][chars (cdr chars)])
(if (null? chars)
(begin
(when (or (> n #x10FFFF)
(<= #xD8FF n #xDFFF))
(raise-read-error
(format "out-of-range character: #\\~a" name)
src line col pos (+ len 9)))
(integer->char n))
(loop (+ (* n 16) (hex-value (car chars)))
(cdr chars)))))
;; Check for standard names or hex, and report an error if not
(case (string->symbol name)
[(nul) (integer->char 0)]
[(alarm) (integer->char 7)]
[(backspace) (integer->char 8)]
[(tab) (integer->char 9)]
[(newline linefeed) (integer->char 10)]
[(vtab) (integer->char 11)]
[(page) (integer->char 12)]
[(return) (integer->char 13)]
[(esc) (integer->char 27)]
[(space) (integer->char 32)]
[(delete) (integer->char 127)]
[else
;; Hex?
(case (car chars)
[(#\x)
(hex-char 2)]
[(#\u)
(hex-char 4)]
[(#\U)
(hex-char 8)]
[else
(raise-bad-char "")])])))))
;; read the leading character:
(let ([ch (read-char port)])
(when (eof-object? ch)
(raise-read-eof-error "unexpected end-of-file after #\\"
src line col pos 2))
;; loop until delimiter:
(let loop ([len 3][chars (list ch)])
(let ([ch (peek-char port)])
(if (eof-object? ch)
;; eof is a delimiter
(make-char-const chars len)
;; otherwise, consult the current readtable to find delimiters
;; in case someone extends r6rs-readtable:
(let-values ([(kind proc dispatch-proc)
(readtable-mapping (current-readtable) ch)])
(cond
[(eq? kind 'terminating-macro)
;; a terminating macro is a delimiter by definition
(make-char-const chars len)]
[(or (char-whitespace? ch)
(member ch standard-delimiters))
;; something mapped to one of the standard delimiters is
;; a delimiter
(make-char-const chars len)]
[else
;; otherwise, it's not a delimiter
(read-char port)
(loop (add1 len) (cons ch chars))])))))))
(define (reject-backslash ch port src line col pos)
(raise-read-error
"illegal character in input: \\"
src line col pos 1))
;; r6rs-readtable
;; Extends MzScheme's default reader to handle quoted symbols,
;; strings, and characters:
(define r6rs-readtable
(make-readtable #f
;; New syntax:
#\| 'terminating-macro read-quoted-symbol
#\" 'terminating-macro read-quoted-string
#\\ 'dispatch-macro read-character
;; Disable \ symbol escape:
#\\ 'terminating-macro reject-backslash))
;; r6rs-read
;; Like the normal read, but uses r6rs-readtable
(define r6rs-read
(case-lambda
[() (r6rs-read (current-input-port))]
[(input) (parameterize ([current-readtable r6rs-readtable])
(read input))]))
;; r6rs-read-syntax
;; Like the normal read-syntax, but uses r6rs-readtable
(define r6rs-read-syntax
(case-lambda
[() (r6rs-read-syntax (object-name (current-input-port)) (current-input-port))]
[(src-v) (r6rs-read-syntax src-v (current-input-port))]
[(src-v input) (parameterize ([current-readtable r6rs-readtable])
(read-syntax src-v input))])))