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

fix problem with expansion to lambda in class form; better certficate transparency in splicing-let forms

Browse Source 
svn: r17436
This commit is contained in:
Matthew Flatt 2009-12-30 12:35:21 +00:00
parent c7653ad43b
commit 2200ef17f5
2 changed files with 26 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/scheme/private/class-internal.ss
View File

@ -337,7 +337,7 @@
(local-expand
expr
'expression
(append locals expand-stop-names)
(append locals (list #'lambda #'λ) expand-stop-names)
def-ctx))
;; Checks whether the vars sequence is well-formed
(define (vars-ok? vars)
@ -379,17 +379,19 @@
#f))
;; -- tranform loop starts here --
(let loop ([stx orig-stx][can-expand? #t][name name][locals null])
(syntax-case stx (#%plain-lambda lambda case-lambda letrec-values let-values)
(syntax-case stx (#%plain-lambda lambda λ case-lambda letrec-values let-values)
[(lam vars body1 body ...)
(or (and (free-identifier=? #'lam #'#%plain-lambda)
(vars-ok? (syntax vars)))
(and (free-identifier=? #'lam #'lambda)
(and (or (free-identifier=? #'lam #'lambda)
(free-identifier=? #'lam #'λ))
(kw-vars-ok? (syntax vars))))
(if xform?
(with-syntax ([the-obj the-obj]
[the-finder the-finder]
[name (mk-name name)])
(with-syntax ([vars (if (free-identifier=? #'lam #'lambda)
(with-syntax ([vars (if (or (free-identifier=? #'lam #'lambda)
(free-identifier=? #'lam #'λ))
(let loop ([vars #'vars])
(cond
[(identifier? vars) vars]
@ -425,6 +427,8 @@
(bad "ill-formed lambda expression for method" stx)]
[(lambda . _)
(bad "ill-formed lambda expression for method" stx)]
[(λ . _)
(bad "ill-formed lambda expression for method" stx)]
[(case-lambda [vars body1 body ...] ...)
(andmap vars-ok? (syntax->list (syntax (vars ...))))
(if xform?

25
collects/scheme/splicing.ss
View File

@ -187,9 +187,9 @@
(define-syntax (expand-ssp-body stx)
(syntax-case stx ()
[(_ (sp-id ...) (temp-id ...) body)
(let ([body (local-expand #'(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))]
...)
(force-expand body))
(let ([body (local-expand #'(letrec-syntaxes/trans ([(sp-id) (syntax-local-value (quote-syntax temp-id))]
...)
(force-expand body))
(syntax-local-context)
null ;; `force-expand' actually determines stopping places
#f)])
@ -212,12 +212,23 @@
(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...)
expr))]))]))]))
(define-syntax (letrec-syntaxes/trans stx)
(syntax-case stx ()
[(_ bindings body)
(syntax-property
#'(letrec-syntaxes bindings body)
'certify-mode
'transparent)]))
(define-syntax (force-expand stx)
(syntax-case stx ()
[(_ stx)
;; Expand `stx' to reveal type of form, and then preserve it via
;; `quote':
#`(quote #,(local-expand #'stx
'module
(kernel-form-identifier-list)
#f))]))
(syntax-property
#`(quote #,(local-expand #'stx
'module
(kernel-form-identifier-list)
#f))
'certify-mode
'transparent)]))