r6rs module layer
svn: r8676
This commit is contained in:
Matthew Flatt
parent
f69f0753e3
commit
5dfcc624f8
1
collects/r6rs/info.ss
Normal file
1
collects/r6rs/info.ss
Normal file
|
|
@ -0,0 +1 @@
|
|||
#lang setup/infotab
|
||||
|
|
@ -1,9 +1,381 @@
|
|||
#lang scheme/base
|
||||
|
||||
(provide (rename-out [module-begin #%module-begin])
|
||||
quote)
|
||||
#|
|
||||
FIXME:
|
||||
* (for ... expand) should shift all exports, not just run-time (requires a mzscheme change)
|
||||
* need meta levels other than 0, 1, and -1
|
||||
* Check that each identifier is imported only once across phases.
|
||||
|#
|
||||
|
||||
(define-syntax-rule (module-begin . stuff)
|
||||
(#%module-begin
|
||||
"The R6RS language just supplies a reader, so far."
|
||||
'stuff))
|
||||
(require (for-syntax scheme/base
|
||||
syntax/kerncase
|
||||
"private/find-version.ss"))
|
||||
|
||||
(provide (rename-out [module-begin #%module-begin]))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Library and top-level forms
|
||||
|
||||
(define-for-syntax (syntax-list? stx)
|
||||
(syntax->list stx))
|
||||
|
||||
(define-syntax (module-begin stx)
|
||||
(syntax-case stx (library)
|
||||
[(_ (library . rest))
|
||||
;; A library
|
||||
(with-syntax ([(_ orig) stx])
|
||||
#'(#%plain-module-begin
|
||||
(library-body orig . rest)))]
|
||||
[(_ (library . rest) . _)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"allowed only in as a top-level module by itself"
|
||||
(syntax-case stx ()
|
||||
[(_ lib . _) #'lib]))]
|
||||
[(_ decl . rest)
|
||||
(syntax-list? #'rest)
|
||||
;; A top-level program
|
||||
#'(#%plain-module-begin
|
||||
(top-level-body decl . rest))]
|
||||
[(_)
|
||||
(raise-syntax-error 'r6rs
|
||||
(string-append
|
||||
"must contain a `library' form (for a library)"
|
||||
" or start with `import' (for a top-level program)")
|
||||
stx)]
|
||||
[_
|
||||
(raise-syntax-error #f "ill-formed module (misuse of `.')" stx)]))
|
||||
|
||||
(define-syntax (top-level-body stx)
|
||||
(syntax-case stx (import)
|
||||
[(_ (import . im) . rest)
|
||||
(syntax-list? #'im)
|
||||
(with-syntax ([(_ im . _) stx])
|
||||
#'(begin
|
||||
(r6rs-import im)
|
||||
. rest))]
|
||||
[(_ (import . im) . rest)
|
||||
(raise-syntax-error #f
|
||||
"ill-formed imports (misuse of `.')"
|
||||
(syntax-case stx ()
|
||||
[(_ im . _) #'im]))]
|
||||
[(_ thing . _)
|
||||
(raise-syntax-error 'top-level-program
|
||||
"expected an `import' declaration, found something else"
|
||||
#'thing)]))
|
||||
|
||||
(define-for-syntax (symbolic-identifier=? a b)
|
||||
(eq? (syntax-e a) (syntax-e b)))
|
||||
|
||||
(define-for-syntax (valid-library-name? n)
|
||||
(syntax-case n ()
|
||||
[(id id2 ... (vers ...))
|
||||
(and (identifier? #'id)
|
||||
(andmap identifier? (syntax->list #'(id2 ...)))
|
||||
(andmap (lambda (v)
|
||||
(exact-nonnegative-integer? (syntax-e v)))
|
||||
(syntax->list #'(vers ...))))]
|
||||
[(id id2 ...)
|
||||
(valid-library-name? #'(id id2 ... ()))]
|
||||
[_ #f]))
|
||||
|
||||
(define-syntax (library-body stx)
|
||||
(syntax-case* stx (export import) symbolic-identifier=?
|
||||
[(_ orig name
|
||||
(export . ex)
|
||||
(import . im)
|
||||
. body)
|
||||
(and (valid-library-name? #'name)
|
||||
(syntax-list? #'ex)
|
||||
(syntax-list? #'im)
|
||||
(syntax-list? #'body))
|
||||
(with-syntax ([(_ _ _ ex im . _) stx])
|
||||
#'(begin
|
||||
(r6rs-import im)
|
||||
(r6rs-export ex)
|
||||
(library-body/defns . body)))]
|
||||
[(_ orig name . _)
|
||||
(not (valid-library-name? #'name))
|
||||
(raise-syntax-error #f
|
||||
"invalid library name"
|
||||
#'orig
|
||||
#'name)]
|
||||
[(_ orig name (export . ex) . _)
|
||||
(not (syntax-list? #'ex))
|
||||
(raise-syntax-error #f
|
||||
"ill-formed export sequence (misuse of `.')"
|
||||
#'orig
|
||||
(syntax-case stx ()
|
||||
[(_ _ _ ex . _) #'ex]))]
|
||||
[(_ orig name (export . ex) (import . im) . _)
|
||||
(not (syntax-list? #'im))
|
||||
(raise-syntax-error #f
|
||||
"ill-formed import sequence (misuse of `.')"
|
||||
#'orig
|
||||
(syntax-case stx ()
|
||||
[(_ _ _ _ im . _) #'im]))]
|
||||
[(_ orig name (export . ex) (import . im) . _)
|
||||
(raise-syntax-error #f
|
||||
"ill-formed body (misuse of `.')"
|
||||
#'orig)]
|
||||
[(_ orig name (export . ex))
|
||||
(raise-syntax-error #f
|
||||
"missing `import' clause"
|
||||
#'orig)]
|
||||
[(_ orig name (export . ex) im . _)
|
||||
(raise-syntax-error #f
|
||||
"expected `import' clause, found something else"
|
||||
#'orig
|
||||
#'im)]
|
||||
[(_ orig name)
|
||||
(raise-syntax-error #f
|
||||
"missing `export' and `import' clauses"
|
||||
#'orig)]
|
||||
[(_ orig name ex . _)
|
||||
(raise-syntax-error #f
|
||||
"expected `export' clause, found something else"
|
||||
#'orig
|
||||
#'ex)]
|
||||
[(_ orig)
|
||||
(raise-syntax-error #f
|
||||
"missing name, `export' clauses, and `import' clause"
|
||||
#'orig)]
|
||||
[(_ orig . _)
|
||||
(raise-syntax-error #f
|
||||
"ill-formed library"
|
||||
#'orig)]))
|
||||
|
||||
(define-syntax (library-body/defns stx)
|
||||
(syntax-case stx ()
|
||||
[(_ thing . more)
|
||||
(let ([a (local-expand
|
||||
#'thing
|
||||
'module
|
||||
(kernel-form-identifier-list))])
|
||||
(syntax-case a (begin)
|
||||
[(def . _)
|
||||
(ormap (lambda (id)
|
||||
(free-identifier=? id #'def))
|
||||
(list #'define-values
|
||||
#'define-syntaxes
|
||||
#'define-values-for-syntax))
|
||||
#`(begin #,a (library-body/defns . more))]
|
||||
[(begin sub ...)
|
||||
#`(library-body/defns sub ... . more)]
|
||||
[else
|
||||
#`(begin (let () #,a . more))]))]
|
||||
[(_) #'(begin)]))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Imports and exports
|
||||
|
||||
(define-for-syntax (is-sub-version-reference? stx)
|
||||
(syntax-case* stx (<= >= and or not) symbolic-identifier=?
|
||||
[n (exact-nonnegative-integer? (syntax-e #'n)) #t]
|
||||
[(>= n) (exact-nonnegative-integer? (syntax-e #'n))]
|
||||
[(<= n) (exact-nonnegative-integer? (syntax-e #'n))]
|
||||
[(and sv ...) (andmap is-sub-version-reference? (syntax->list #'(sv ...)))]
|
||||
[(or sv ...) (andmap is-sub-version-reference? (syntax->list #'(sv ...)))]
|
||||
[(not sv) (is-sub-version-reference? #'sv)]
|
||||
[_ #f]))
|
||||
|
||||
(define-for-syntax (is-version-reference? stx)
|
||||
(syntax-case* stx (and or not) symbolic-identifier=?
|
||||
[(and vr ...)
|
||||
(andmap is-version-reference? (syntax->list #'(vr ...)))]
|
||||
[(or vr ...)
|
||||
(andmap is-version-reference? (syntax->list #'(vr ...)))]
|
||||
[(not vr)
|
||||
(is-version-reference? #'vr)]
|
||||
[(sv ...)
|
||||
(andmap is-sub-version-reference? (syntax->list #'(sv ...)))]
|
||||
[_ #f]))
|
||||
|
||||
(define-for-syntax (parse-library-reference orig stx)
|
||||
(syntax-case stx ()
|
||||
[(id1 id2 ... (vers ...))
|
||||
(and (identifier? #'id1)
|
||||
(andmap identifier? (syntax->list #'(id2 ...)))
|
||||
(is-version-reference? #'(vers ...)))
|
||||
(let-values ([(coll file)
|
||||
(let ([strs (map (lambda (id)
|
||||
(symbol->string (syntax-e id)))
|
||||
(syntax->list #'(id1 id2 ...)))])
|
||||
(if (= 1 (length strs))
|
||||
(values (car strs) "main")
|
||||
(values (reverse (cdr (reverse strs)))
|
||||
(car (reverse strs)))))])
|
||||
(let ([base (build-path (with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format
|
||||
"cannot find suitable library installed (exception: ~a)"
|
||||
(if (exn? exn)
|
||||
(exn-message exn)
|
||||
exn))
|
||||
orig
|
||||
stx))])
|
||||
(apply collection-path coll))
|
||||
file)])
|
||||
(let ([vers (find-version (path->bytes base) (syntax->datum #'(vers ...)))])
|
||||
(if vers
|
||||
(datum->syntax
|
||||
stx
|
||||
`(,#'lib ,(apply string-append
|
||||
(car coll)
|
||||
(append
|
||||
(map (lambda (s)
|
||||
(string-append "/" s))
|
||||
(append (cdr coll) (list file)))
|
||||
(map (lambda (v)
|
||||
(format "-~a" v))
|
||||
vers)
|
||||
(list ".ss")))))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"cannot find suitable installed library"
|
||||
orig
|
||||
stx)))))]
|
||||
[(id1 id2 ...)
|
||||
(and (identifier? #'id1)
|
||||
(andmap identifier? (syntax->list #'(id2 ...))))
|
||||
(parse-library-reference orig #'(id1 id2 ... ()))]
|
||||
[_
|
||||
(raise-syntax-error #f
|
||||
"ill-formed library reference"
|
||||
orig
|
||||
stx)]))
|
||||
|
||||
(define-for-syntax (parse-import-set orig stx)
|
||||
(define (bad)
|
||||
(raise-syntax-error #f
|
||||
(format "bad `~a' form"
|
||||
(syntax-e (car (syntax-e stx))))
|
||||
orig
|
||||
stx))
|
||||
(define (check-id id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
(format "not an identifier in `~a' form"
|
||||
(syntax-e (car (syntax-e stx))))
|
||||
orig
|
||||
id)))
|
||||
(syntax-case* stx (library only except prefix rename) symbolic-identifier=?
|
||||
[(library lib)
|
||||
(parse-library-reference orig #'lib)]
|
||||
[(library . _) (bad)]
|
||||
[(only im id ...)
|
||||
(for-each check-id (syntax->list #'(id ...)))
|
||||
#`(only-in #,(parse-import-set orig #'im) id ...)]
|
||||
[(only . _) (bad)]
|
||||
[(except im id ...)
|
||||
(for-each check-id (syntax->list #'(id ...)))
|
||||
#`(except-in #,(parse-import-set orig #'im) id ...)]
|
||||
[(except . _) (bad)]
|
||||
[(prefix im id)
|
||||
(check-id #'id)
|
||||
#`(prefix-in id #,(parse-import-set orig #'im))]
|
||||
[(prefix . _) (bad)]
|
||||
[(rename im (id id2) ...)
|
||||
(for-each check-id
|
||||
(apply
|
||||
append
|
||||
(map syntax->list
|
||||
(syntax->list #'((id id2) ...)))))
|
||||
#`(except-in #,(parse-import-set orig #'im) id ...)]
|
||||
[(rename . _) (bad)]
|
||||
[_ (parse-library-reference orig stx)]))
|
||||
|
||||
(define-syntax (r6rs-import stx)
|
||||
(let ([orig (syntax-case stx ()
|
||||
[(_ orig) #'orig])])
|
||||
(syntax-case stx (import)
|
||||
[(_ (import im ...))
|
||||
(with-syntax ([((im ...) ...)
|
||||
(map (lambda (im)
|
||||
(syntax-case* im (for) symbolic-identifier=?
|
||||
[(for base-im level ...)
|
||||
(let* ([levels
|
||||
(map (lambda (level)
|
||||
(syntax-case* level (run expand meta) symbolic-identifier=?
|
||||
[run #'except-in]
|
||||
[expand #'for-syntax]
|
||||
[(meta 0) #'except-in]
|
||||
[(meta 1) #'for-syntax]
|
||||
[(meta -1) #'for-template]
|
||||
[(meta n)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"meta level not supported"
|
||||
orig
|
||||
level)]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad `for' level"
|
||||
orig
|
||||
level)]))
|
||||
(syntax->list #'(level ...)))])
|
||||
(with-syntax ([is (parse-import-set orig #'im)]
|
||||
[(level ...) (if (null? levels)
|
||||
(list #'only-in)
|
||||
null)])
|
||||
|
||||
#`((level is) ...)))]
|
||||
[(for . _)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad `for' import form"
|
||||
orig
|
||||
im)]
|
||||
[_ (list (parse-import-set orig im))]))
|
||||
(syntax->list #'(im ...)))])
|
||||
#'(require im ... ...))])))
|
||||
|
||||
(define-syntax (r6rs-export stx)
|
||||
(let ([orig (syntax-case stx ()
|
||||
[(_ orig) #'orig])])
|
||||
(syntax-case stx (export)
|
||||
[(_ (export ex ...))
|
||||
(let ([exs (syntax->list #'(ex ...))])
|
||||
(for-each (lambda (ex)
|
||||
(unless (identifier? ex)
|
||||
(syntax-case ex (rename)
|
||||
[(rename thing ...)
|
||||
(for-each (lambda (thing)
|
||||
(syntax-case thing ()
|
||||
[(id1 id2)
|
||||
(unless (and (identifier? #'id1)
|
||||
(identifier? #'id2))
|
||||
(raise-syntax-error #f
|
||||
"not an identifier"
|
||||
orig
|
||||
(if (identifier? #'id1)
|
||||
#'id2
|
||||
#'id1)))]
|
||||
[_ (raise-syntax-error
|
||||
#f
|
||||
"expected `(<id> <id>)' for rename, but found something else"
|
||||
orig
|
||||
thing)]))
|
||||
(syntax->list #'(thing ...)))]
|
||||
[(rename . _)
|
||||
(raise-syntax-error #f
|
||||
"bad syntax (misuse of `.')"
|
||||
orig
|
||||
ex)]
|
||||
[_
|
||||
(raise-syntax-error #f
|
||||
"not an identifier or `rename' clause"
|
||||
orig
|
||||
ex)])))
|
||||
exs)
|
||||
(with-syntax ([(ex ...)
|
||||
(map (lambda (ex)
|
||||
(syntax-case ex ()
|
||||
[(rename . rest)
|
||||
#'(rename-out . rest)]
|
||||
[_ ex]))
|
||||
exs)])
|
||||
#'(provide ex ...)))])))
|
||||
|
|
|
|||
77
collects/r6rs/private/find-version.ss
Normal file
77
collects/r6rs/private/find-version.ss
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
#lang scheme/base
|
||||
|
||||
(provide find-version)
|
||||
|
||||
(define (find-version base-path vers)
|
||||
(let-values ([(dir name _) (split-path (bytes->path base-path))])
|
||||
(let ([files (with-handlers ([exn:fail:filesystem? (lambda (exn) null)])
|
||||
(directory-list dir))])
|
||||
(and files
|
||||
(let* ([p (path-element->bytes name)]
|
||||
[len (bytes-length p)]
|
||||
[candidate-versions
|
||||
(filter
|
||||
values
|
||||
(map
|
||||
(lambda (file)
|
||||
(let ([s (path-element->bytes file)])
|
||||
(and (len . < . (bytes-length s))
|
||||
(regexp-match? #rx#"[.]ss$" s)
|
||||
(bytes=? p (subbytes s 0 len))
|
||||
(or (and (= (bytes-length s) (+ len 3))
|
||||
null)
|
||||
(let ([vers (subbytes s len (- (bytes-length s) 3))])
|
||||
(and (regexp-match #rx#"^(-[0-9]+)+$" vers)
|
||||
(map string->number
|
||||
(cdr
|
||||
(map bytes->string/latin-1
|
||||
(regexp-split #rx#"-" vers))))))))))
|
||||
files))]
|
||||
[versions
|
||||
(sort candidate-versions
|
||||
(lambda (a b)
|
||||
(let loop ([a a][b b])
|
||||
(cond
|
||||
[(null? a) #t]
|
||||
[(null? b) #f]
|
||||
[(> (car a) (car b)) #t]
|
||||
[(< (car a) (car b)) #f]
|
||||
[else (loop (cdr a) (cdr b))]))))])
|
||||
(ormap (lambda (candidate-version)
|
||||
(and (version-match? candidate-version vers)
|
||||
candidate-version))
|
||||
versions))))))
|
||||
|
||||
(define (version-match? cand vers)
|
||||
(cond
|
||||
[(null? vers) #t]
|
||||
[(null? cand) #f]
|
||||
[(eq? (car vers) 'and)
|
||||
(andmap (lambda (v)
|
||||
(version-match? cand v))
|
||||
(cdr vers))]
|
||||
[(eq? (car vers) 'or)
|
||||
(ormap (lambda (v)
|
||||
(version-match? cand v))
|
||||
(cdr vers))]
|
||||
[(eq? (car vers) 'not)
|
||||
(not (version-match? (cadr vers)))]
|
||||
[(sub-version-match? (car cand) (car vers))
|
||||
(version-match? (cdr cand) (cdr vers))]
|
||||
[else #f]))
|
||||
|
||||
(define (sub-version-match? cand subvers)
|
||||
(cond
|
||||
[(number? subvers) (= cand subvers)]
|
||||
[else (case (car subvers)
|
||||
[(>=) (>= cand (cadr subvers))]
|
||||
[(<=) (<= cand (cadr subvers))]
|
||||
[(and) (andmap (lambda (sv)
|
||||
(sub-version-match? cand sv))
|
||||
(cdr subvers))]
|
||||
[(or) (ormap (lambda (sv)
|
||||
(sub-version-match? cand sv))
|
||||
(cdr subvers))]
|
||||
[(not) (not (sub-version-match? cand (cadr subvers)))]
|
||||
[else (error "bad subversion")])]))
|
||||
|
||||
22
collects/rnrs/base-6.ss
Normal file
22
collects/rnrs/base-6.ss
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base)
|
||||
(prefix-in r5rs: r5rs))
|
||||
|
||||
(provide (rename-out [datum #%datum]
|
||||
[r5rs:define define]
|
||||
[r5rs:lambda lambda])
|
||||
#%app)
|
||||
|
||||
;; ----------------------------------------
|
||||
;; 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))]))
|
||||
|
||||
1
collects/rnrs/info.ss
Normal file
1
collects/rnrs/info.ss
Normal file
|
|
@ -0,0 +1 @@
|
|||
#lang setup/infotab
|
||||
Loading…
Reference in New Issue
Block a user