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

fix inverted argument default for editor<%> read-from-file method; better Check Sytax results on packages; added syntax/flatten-begin library

Browse Source 
svn: r14548

original commit: 4b3626c1560658fe3937019e001911c2a44aaff3
This commit is contained in:
Matthew Flatt 2009-04-17 22:50:19 +00:00
parent b14a088754
commit 2b7e5a9642
1 changed files with 11 additions and 4 deletions

15
collects/scheme/package.ss
View File

@ -2,7 +2,8 @@
(require (for-syntax scheme/base (require (for-syntax scheme/base
syntax/kerncase syntax/kerncase
syntax/boundmap syntax/boundmap
syntax/define)) syntax/define
syntax/flatten-begin))
(provide define-package (provide define-package
package-begin package-begin
@ -93,6 +94,12 @@
hidden) hidden)
id))) id)))
(define-for-syntax (move-props orig new)
(datum->syntax new
(syntax-e new)
orig
orig))
(define-for-syntax (do-define-package stx exp-stx) (define-for-syntax (do-define-package stx exp-stx)
(syntax-case exp-stx () (syntax-case exp-stx ()
[(_ pack-id mode exports form ...) [(_ pack-id mode exports form ...)
@ -293,7 +300,7 @@
(car def-ctxes)))]) (car def-ctxes)))])
(syntax-case expr (begin) (syntax-case expr (begin)
[(begin . rest) [(begin . rest)
(loop (append (syntax->list #'rest) (cdr exprs)) (loop (append (flatten-begin expr) (cdr exprs))
rev-forms rev-forms
def-ctxes)] def-ctxes)]
[(def (id ...) rhs) [(def (id ...) rhs)
@ -315,7 +322,7 @@
(syntax-local-bind-syntaxes ids #'rhs def-ctx) (syntax-local-bind-syntaxes ids #'rhs def-ctx)
(register-bindings! ids) (register-bindings! ids)
(loop (cdr exprs) (loop (cdr exprs)
(cons #`(define-syntaxes #,ids rhs) (cons (move-props expr #`(define-syntaxes #,ids rhs))
rev-forms) rev-forms)
(if star? (cons def-ctx def-ctxes) def-ctxes)))))] (if star? (cons def-ctx def-ctxes) def-ctxes)))))]
[(def (id ...) rhs) [(def (id ...) rhs)
@ -333,7 +340,7 @@
(syntax-local-bind-syntaxes ids #f def-ctx) (syntax-local-bind-syntaxes ids #f def-ctx)
(register-bindings! ids) (register-bindings! ids)
(loop (cdr exprs) (loop (cdr exprs)
(cons #`(define-values #,ids rhs) rev-forms) (cons (move-props expr #`(define-values #,ids rhs)) rev-forms)
(if star? (cons def-ctx def-ctxes) def-ctxes))))] (if star? (cons def-ctx def-ctxes) def-ctxes))))]
[else [else
(loop (cdr exprs) (loop (cdr exprs)