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

change contracts to reflect context via #%variable-reference instead of syntax objects; add id-less #%variable-reference form; drop link to unneeded CPort objects in delayed thunks; streamline some modules that tend to show up in deep phases

Browse Source 
svn: r12231

original commit: 95bedb17fbed95c3288ad8befd94c1c7e26c07e2
This commit is contained in:
Matthew Flatt 2008-11-04 14:24:12 +00:00
parent 9c70829089
commit 65af0d3f3b
1 changed files with 100 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

201
collects/mzlib/private/stxset.ss
View File

@ -1,103 +1,102 @@
#lang scheme/base
(require (for-syntax scheme/base
syntax/kerncase
syntax/context))
(module stxset mzscheme
(provide finish-syntax-set)
(require-for-syntax syntax/kerncase
syntax/context)
(provide finish-syntax-set)
;; Used in the expansion of `define-syntax-set' from "etc.ss"
(define-syntax (finish-syntax-set stx)
(syntax-case stx ()
[(_ stx)
(let ([stx (syntax stx)])
(syntax-case stx ()
[(_ (id ...) defn ...)
;; The ids have already been checked --------------------
(let ([ids (syntax->list (syntax (id ...)))])
(let ([internal-ids (map (lambda (id)
(datum->syntax-object
id
(string->symbol (format "~a/proc" (syntax-e id)))
id))
ids)]
[expand-context (generate-expand-context)])
;; Check defns (requires expand) ---------
(let* ([defns (let loop ([defns (syntax->list (syntax (defn ...)))])
(apply
append
(map
(lambda (defn)
(let ([defn (local-expand
defn
expand-context
(kernel-form-identifier-list))])
(syntax-case defn (define-values define-syntaxes begin)
[(define-values (id ...) expr)
(andmap identifier? (syntax->list (syntax (id ...))))
(list defn)]
[(define-values . _)
(raise-syntax-error
#f
"bad definition"
stx
defn)]
[(define-syntaxes (id ...) expr)
(andmap identifier? (syntax->list (syntax (id ...))))
(list defn)]
[(define-syntaxes . _)
(raise-syntax-error
#f
"bad definition"
stx
defn)]
[(begin defn ...)
(loop (syntax->list (syntax (defn ...))))]
[(begin . _)
(raise-syntax-error
#f
"bad `begin'"
stx
defn)]
[else
(raise-syntax-error
#f
"not a definition"
stx
defn)])))
defns)))]
[def-ids (apply append (map (lambda (defn)
(syntax-case defn ()
[(_ (id ...) expr)
(syntax->list (syntax (id ...)))]))
defns))]
[val-ids (apply append (map (lambda (defn)
(syntax-case defn (define-values)
[(define-values (id ...) expr)
(syntax->list (syntax (id ...)))]
[_else null]))
defns))])
(let ([dup (check-duplicate-identifier def-ids)])
(when dup
(raise-syntax-error
#f
"duplicate defined identifier"
stx
dup)))
;; Check that declared are defined ---------
(for-each (lambda (id)
(unless (check-duplicate-identifier (cons id val-ids))
(raise-syntax-error
#f
"expected identifier is not defined"
stx
id)))
internal-ids)
;; Produce result ------------------------------
(with-syntax ([(defn ...) defns]
[(internal-id ...) internal-ids])
(syntax/loc stx
(let ()
defn ...
(values internal-id ...)))))))]))])))
;; Used in the expansion of `define-syntax-set' from "etc.ss"
(define-syntax (finish-syntax-set stx)
(syntax-case stx ()
[(_ stx)
(let ([stx (syntax stx)])
(syntax-case stx ()
[(_ (id ...) defn ...)
;; The ids have already been checked --------------------
(let ([ids (syntax->list (syntax (id ...)))])
(let ([internal-ids (map (lambda (id)
(datum->syntax
id
(string->symbol (format "~a/proc" (syntax-e id)))
id))
ids)]
[expand-context (generate-expand-context)])
;; Check defns (requires expand) ---------
(let* ([defns (let loop ([defns (syntax->list (syntax (defn ...)))])
(apply
append
(map
(lambda (defn)
(let ([defn (local-expand
defn
expand-context
(kernel-form-identifier-list))])
(syntax-case defn (define-values define-syntaxes begin)
[(define-values (id ...) expr)
(andmap identifier? (syntax->list (syntax (id ...))))
(list defn)]
[(define-values . _)
(raise-syntax-error
#f
"bad definition"
stx
defn)]
[(define-syntaxes (id ...) expr)
(andmap identifier? (syntax->list (syntax (id ...))))
(list defn)]
[(define-syntaxes . _)
(raise-syntax-error
#f
"bad definition"
stx
defn)]
[(begin defn ...)
(loop (syntax->list (syntax (defn ...))))]
[(begin . _)
(raise-syntax-error
#f
"bad `begin'"
stx
defn)]
[else
(raise-syntax-error
#f
"not a definition"
stx
defn)])))
defns)))]
[def-ids (apply append (map (lambda (defn)
(syntax-case defn ()
[(_ (id ...) expr)
(syntax->list (syntax (id ...)))]))
defns))]
[val-ids (apply append (map (lambda (defn)
(syntax-case defn (define-values)
[(define-values (id ...) expr)
(syntax->list (syntax (id ...)))]
[_else null]))
defns))])
(let ([dup (check-duplicate-identifier def-ids)])
(when dup
(raise-syntax-error
#f
"duplicate defined identifier"
stx
dup)))
;; Check that declared are defined ---------
(for-each (lambda (id)
(unless (check-duplicate-identifier (cons id val-ids))
(raise-syntax-error
#f
"expected identifier is not defined"
stx
id)))
internal-ids)
;; Produce result ------------------------------
(with-syntax ([(defn ...) defns]
[(internal-id ...) internal-ids])
(syntax/loc stx
(let ()
defn ...
(values internal-id ...)))))))]))]))