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

initial reference implementation of library form that might appear in R6RS

Browse Source 
svn: r449
This commit is contained in:
Matthew Flatt 2005-07-26 17:00:09 +00:00
parent 1eda5e3ffd
commit f6531a307f
9 changed files with 1029 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
collects/r6rs/doc.txt Normal file
View File

@ -0,0 +1,51 @@
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.
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
To import a collection-based library, 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
- doesn't enforce that idenfiers in a macro expansion
are only the ones declared by indirect-export
- doesn't check that an identifiers in an indirect-export
declaration are actually defined
- reader adjusts only string, character, and quoted-symbol
syntax, for now

3
collects/r6rs/info.ss Normal file
View File

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

149
collects/r6rs/library-module.ss Normal file
View File

@ -0,0 +1,149 @@
(module library-module mzscheme
(require-for-syntax "private/helpers.ss"
(lib "kerncase.ss" "syntax")
(lib "context.ss" "syntax"))
(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]
[indirect-exports null])
(if (null? bodies)
(values (reverse imports)
(reverse exports)
(reverse indirect-exports)
null)
(syntax-case (car bodies) (import export indirect-export)
[(import in ...)
(loop (cdr bodies)
(append (syntax->list #'(in ...)) imports)
exports
indirect-exports)]
[(import . rest)
(raise-syntax-error #f "bad syntax" (car bodies))]
[(export out ...)
(loop (cdr bodies)
imports
(append (syntax->list #'(out ...)) exports)
indirect-exports)]
[(export . rest)
(raise-syntax-error #f "bad syntax" (car bodies))]
[(indirect-export indirect ...)
(loop (cdr bodies)
imports
exports
(append (syntax->list #'(indirect ...)) indirect-exports))]
[(indirect-export . rest)
(raise-syntax-error #f "bad syntax" (car bodies))]
[else (values (reverse imports)
(reverse exports)
(reverse indirect-exports)
bodies)]))))
(define-for-syntax (make-unboxer 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-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 indirect-exports bodies)
(split-bodies bodies)])
#`(#%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)
#,@(map translate-export exports)
(begin-library-body
#,indirect-exports
#,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 ()
[(_ indirects ())
#'(begin)]
[(_ indirects (body0 body ...))
(let ([comdef (local-expand #'body0
'module
stops)])
(syntax-case comdef (begin define-syntaxes define-values)
[(begin comdef ...)
#`(begin-library-body indirects (comdef ... body ...))]
[(define-syntaxes (id ...) rhs)
#`(begin (define-syntaxes (id ...) rhs)
(begin-library-body indirects (body ...)))]
[(define-values (id ...) rhs)
(with-syntax ([(gen-id ...) (generate-temporaries #'(id ...))])
#`(begin
(define-values (gen-id ...)
(let-values ([(id ...) rhs])
(values (box id) ...)))
(define-syntaxes (id ...)
(values (make-unboxer (quote-syntax gen-id)) ...))
(begin-library-body indirects (body ...))))]
[expr
;; begin0 forces an expression (not defn):
#`(begin
(begin0 expr)
(begin-library-body indirects (body ...)))]))])))

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

@ -0,0 +1,31 @@
(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 Normal file
View File

@ -0,0 +1,40 @@
(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)))))])))

344
collects/r6rs/private/helpers.ss Normal file
View File

@ -0,0 +1,344 @@
(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)
(map (lambda (i)
(or (ormap (lambda (new old)
(and (bound-identifier=? (car i) new)
(cons 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))
(translate-impexp
i orig-i
(lambda (i exceptions onlys renames extra-prefix)
(syntax-case* i (all-defined) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[(all-defined)
(cond
[onlys
#`(provide #,@(map (lambda (name-pair)
#`(rename #,(car name-pair) #,(cdr name-pair)))
onlys))]
[(or exceptions (pair? renames))
;; First import non-renamed, then renamed:
#`(provide (#,(if extra-prefix #'prefix-all-defined-except #'all-defined-except)
#,@(if extra-prefix (list extra-prefix) null)
#,@(append (map car (or exceptions null))
(map car renames)))
#,@(map (lambda (i)
#`(rename #,(car i) #,(cdr i)))
renames))]
[extra-prefix
#`(provide (prefix-all-defined #,extra-prefix))]
[else
#`(provide (all-defined))])]
[(all-defined . _)
(raise-syntax-error #f "bad syntax" i)]
[_else
(begin
(unless (identifier? i)
(raise-syntax-error
#f
"expected an identifier or an `all-defined', `only', `except', `add-prefix', or `rename' form"
orig-i
i))
(when exceptions
(check-present orig-i "except not" "identifier" values exceptions (list i)))
(when onlys
(check-present orig-i "only not" "identifier" values onlys (list i)))
(when renames
(check-present orig-i "rename not" "identifier" values renames (list i)))
(cond
[(pair? exceptions)
;; Must be the only exception, so nothing is exported
#'(provide)]
[(pair? renames)
#`(provide (rename #,(caar renames) #,(cdar renames)))]
[extra-prefix
#`(provide (rename #,i #,(add-prefix extra-prefix i)))]
[else #`(provide #,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)])
(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)
#f
(combine-renames)
extra-prefix)]
[onlys
(loop #'sub
#f
(apply-rename new-names old-names onlys)
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)]))))

57
collects/r6rs/private/uri.ss Normal file
View File

@ -0,0 +1,57 @@
(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 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 (string->symbol s)]))))

73
collects/r6rs/r6rs.ss Normal file
View File

@ -0,0 +1,73 @@
(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 Normal file
View File

@ -0,0 +1,281 @@
(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))])))