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

adjust define*-{values,syntaxes} to avoid certificate problems

Browse Source 
svn: r14024

original commit: 13b2bc336337077d603050eab67ae4343beb54cc
This commit is contained in:
Matthew Flatt 2009-03-09 17:19:21 +00:00
parent 0a32e8dd83
commit f5e49e3128
1 changed files with 23 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/scheme/package.ss
View File

@ -34,10 +34,24 @@
(with-syntax ([define-values define-values-id])
(syntax/loc stx
(define-values (id ...) rhs))))]))
(define-syntax (define*-values stx)
(define-syntax (-define*-values stx)
(do-define-* stx #'define-values))
(define-syntax (define*-syntaxes stx)
(define-syntax (-define*-syntaxes stx)
(do-define-* stx #'define-syntaxes))
(define-syntax (define*-values stx)
(syntax-case stx ()
[(_ (id ...) rhs)
(syntax-property
(syntax/loc stx (-define*-values (id ...) rhs))
'certify-mode
'transparent-binding)]))
(define-syntax (define*-syntaxes stx)
(syntax-case stx ()
[(_ (id ...) rhs)
(syntax-property
(syntax/loc stx (-define*-syntaxes (id ...) rhs))
'certify-mode
'transparent-binding)]))
(define-syntax (define* stx)
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
@ -125,8 +139,8 @@
id
def-ctxes))]
[kernel-forms (list*
#'define*-values
#'define*-syntaxes
#'-define*-values
#'-define*-syntaxes
(kernel-form-identifier-list))]
[init-exprs (syntax->list #'(form ...))]
[new-bindings (make-bound-identifier-mapping)]
@ -282,13 +296,13 @@
def-ctxes)]
[(def (id ...) rhs)
(and (or (free-identifier=? #'def #'define-syntaxes)
(free-identifier=? #'def #'define*-syntaxes))
(free-identifier=? #'def #'-define*-syntaxes))
(andmap identifier? (syntax->list #'(id ...))))
(with-syntax ([rhs (local-transformer-expand
#'rhs
'expression
null)])
(let ([star? (free-identifier=? #'def #'define*-syntaxes)]
(let ([star? (free-identifier=? #'def #'-define*-syntaxes)]
[ids (syntax->list #'(id ...))])
(let* ([def-ctx (if star?
(syntax-local-make-definition-context (car def-ctxes))
@ -305,9 +319,9 @@
(if star? (cons def-ctx def-ctxes) def-ctxes)))))]
[(def (id ...) rhs)
(and (or (free-identifier=? #'def #'define-values)
(free-identifier=? #'def #'define*-values))
(free-identifier=? #'def #'-define*-values))
(andmap identifier? (syntax->list #'(id ...))))
(let ([star? (free-identifier=? #'def #'define*-values)]
(let ([star? (free-identifier=? #'def #'-define*-values)]
[ids (syntax->list #'(id ...))])
(let* ([def-ctx (if star?
(syntax-local-make-definition-context)
@ -394,9 +408,7 @@
(define-syntax (open-package stx)
(do-open stx #'define-syntaxes))
(define-syntax (open*-package stx)
(syntax-property (do-open stx #'define*-syntaxes)
'certify-mode
'transparent-binding))
(do-open stx #'define*-syntaxes))
(define-for-syntax (package-exported-identifiers id)
(let ([v (and (identifier? id)