add lib'
svn: r7771
This commit is contained in:
Matthew Flatt
parent
e11974a6c7
commit
0f700b8531
|
|
@ -5,10 +5,31 @@
|
|||
(module misc '#%kernel
|
||||
(#%require '#%utils ; built into mzscheme
|
||||
"more-scheme.ss" "small-scheme.ss" "define.ss"
|
||||
(for-syntax '#%kernel "stx.ss" "stxcase-scheme.ss"))
|
||||
(for-syntax '#%kernel "stx.ss" "stxcase-scheme.ss" "stxcase.ss"))
|
||||
|
||||
;; -------------------------------------------------------------------------
|
||||
|
||||
(define-syntax define-syntax-rule
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(dr (foo . pattern) template)
|
||||
(identifier? #'foo)
|
||||
(syntax/loc stx
|
||||
(define-syntax foo
|
||||
(lambda (x)
|
||||
(syntax-case** dr #t x () free-identifier=?
|
||||
[(_ . pattern) (syntax/loc x template)]))))]
|
||||
[(dr (foo . pattern) template)
|
||||
(raise-syntax-error 'define-rule "expected an identifier" stx #'foo)]
|
||||
[(dr (foo . pattern))
|
||||
(raise-syntax-error 'define-rule "no template provided" stx)]
|
||||
[(dr (foo . pattern) template . etc)
|
||||
(raise-syntax-error 'define-rule "too many templates" stx #'etc)]
|
||||
[(dr head . template)
|
||||
(raise-syntax-error 'define-rule "invalid pattern" stx #'head)])))
|
||||
|
||||
;; -------------------------------------------------------------------------
|
||||
|
||||
(define rationalize
|
||||
(letrec ([check (lambda (x)
|
||||
(unless (real? x) (raise-type-error 'rationalize "real" x)))]
|
||||
|
|
@ -129,7 +150,8 @@
|
|||
|
||||
;; -------------------------------------------------------------------------
|
||||
|
||||
(#%provide rationalize
|
||||
(#%provide define-syntax-rule
|
||||
rationalize
|
||||
path-string? path-replace-suffix path-add-suffix normal-case-path
|
||||
read-eval-print-loop
|
||||
load/cd
|
||||
|
|
|
|||
|
|
@ -36,31 +36,43 @@
|
|||
stx)))
|
||||
|
||||
(define-syntaxes (lib file planet)
|
||||
(let ([t
|
||||
(make-require-transformer
|
||||
(lambda (stx)
|
||||
(check-lib-form stx)
|
||||
(let*-values ([(mod-path) (syntax->datum stx)]
|
||||
[(names et-names lt-names) (syntax-local-module-exports stx)])
|
||||
(values
|
||||
(apply
|
||||
append
|
||||
(map (lambda (names mode)
|
||||
(map (lambda (name)
|
||||
(make-import (datum->syntax
|
||||
stx
|
||||
(let ([t (lambda (stx)
|
||||
(check-lib-form stx)
|
||||
(let*-values ([(mod-path) (syntax->datum stx)]
|
||||
[(names et-names lt-names) (syntax-local-module-exports stx)])
|
||||
(values
|
||||
(apply
|
||||
append
|
||||
(map (lambda (names mode)
|
||||
(map (lambda (name)
|
||||
(make-import (datum->syntax
|
||||
stx
|
||||
name
|
||||
stx)
|
||||
name
|
||||
stx)
|
||||
name
|
||||
mod-path
|
||||
mode
|
||||
'run
|
||||
stx))
|
||||
names))
|
||||
(list names et-names lt-names)
|
||||
(list 'run 'syntax 'label)))
|
||||
(list (make-import-source stx 'run))))))])
|
||||
(values t t t)))
|
||||
mod-path
|
||||
mode
|
||||
'run
|
||||
stx))
|
||||
names))
|
||||
(list names et-names lt-names)
|
||||
(list 'run 'syntax 'label)))
|
||||
(list (make-import-source stx 'run)))))])
|
||||
(let ([t2
|
||||
(let-values ([(s: mk s? s-ref s-set!)
|
||||
(make-struct-type 'req+prov
|
||||
#f
|
||||
0 0 #f
|
||||
(list
|
||||
(cons prop:require-transformer (lambda (a) t)))
|
||||
(current-inspector)
|
||||
(lambda (p stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"misuse of module-path constructor (not within, e.g., `require' or `provide')"
|
||||
stx)))])
|
||||
(mk))])
|
||||
(values t2 t2 t2))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; for-syntax, for-template, for-label
|
||||
|
|
|
|||
|
|
@ -29,21 +29,19 @@
|
|||
(syntax-case** syntax-rules #t stx () free-identifier=?
|
||||
((_ (k ...) ((keyword . pattern) template) ...)
|
||||
(andmap identifier? (syntax->list (syntax (k ...))))
|
||||
(with-syntax (((dummy ...)
|
||||
(map (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"pattern must start with an identifier, found something else"
|
||||
stx
|
||||
id))
|
||||
;; Preserve the name, in case it's printed out
|
||||
(string->uninterned-symbol (symbol->string (syntax-e id))))
|
||||
(syntax->list (syntax (keyword ...))))))
|
||||
(begin
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"pattern must start with an identifier, found something else"
|
||||
stx
|
||||
id)))
|
||||
(syntax->list (syntax (keyword ...))))
|
||||
(syntax/loc stx
|
||||
(lambda (x)
|
||||
(syntax-case** _ #t x (k ...) free-identifier=?
|
||||
((dummy . pattern) (syntax/loc x template))
|
||||
((_ . pattern) (syntax/loc x template))
|
||||
...))))))))
|
||||
|
||||
(-define-syntax syntax-id-rules
|
||||
|
|
|
|||
|
|
@ -361,6 +361,18 @@ Equivalent to
|
|||
]}
|
||||
|
||||
|
||||
@defform[(define-syntax-rule (id . pattern) template)]{
|
||||
|
||||
Equivalent to
|
||||
|
||||
@schemeblock/form[
|
||||
(define-syntax id
|
||||
(syntax-rules ()
|
||||
[(id . pattern) template]))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defidform[...]{
|
||||
|
||||
The @scheme[...] transformer binding prohibits @scheme[...] from
|
||||
|
|
|
|||
|
|
@ -95,7 +95,9 @@ in several significant ways:
|
|||
that `lambda' and `#%app' expand to `#%plain-lambda' and
|
||||
`#%plain-app' (which are also the `lambda' and `#%app' of the
|
||||
`mzscheme' language). The `require' and `provide' forms expand to
|
||||
`#%require' and `#%provide'.
|
||||
`#%require' and `#%provide'. Finally, beware that `#%datum' in
|
||||
`scheme/base' is different than in `mzscheme' (because the former
|
||||
disallows unquoted keywords as expressions).
|
||||
|
||||
- The naming convention for compiled files has changed to preserve
|
||||
the original file suffix. For example, the bytecode version of
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user