299.107
svn: r259 original commit: 0d4bc2cd9d93b05203f70cccdaf832babee3a4cd
This commit is contained in:
Matthew Flatt
parent
a4bc5b8995
commit
f5ea87030c
|
|
@ -525,8 +525,10 @@
|
|||
;; Body can have mixed exprs and defns. Wrap expressions with
|
||||
;; `(define-values () ... (values))' as needed, and add a (void)
|
||||
;; at the end if needed.
|
||||
(let* ([ctx (generate-expand-context)]
|
||||
[kernel-forms (kernel-form-identifier-list #'here)]
|
||||
(let* ([def-ctx (syntax-local-make-definition-context)]
|
||||
[ctx (list (gensym 'intdef))]
|
||||
[kernel-forms (kernel-form-identifier-list
|
||||
(quote-syntax here))]
|
||||
[init-exprs (let ([v (syntax->list stx)])
|
||||
(unless v
|
||||
(raise-syntax-error #f "bad syntax" stx))
|
||||
|
|
@ -538,36 +540,54 @@
|
|||
(let ([expr (local-expand
|
||||
expr
|
||||
ctx
|
||||
kernel-forms)])
|
||||
(syntax-case expr (begin)
|
||||
kernel-forms
|
||||
def-ctx)])
|
||||
(syntax-case expr (begin define-syntaxes define-values)
|
||||
[(begin . rest)
|
||||
(loop (syntax->list #'rest))]
|
||||
[(define-syntaxes (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(with-syntax ([rhs (local-transformer-expand
|
||||
#'rhs
|
||||
'expression
|
||||
null)])
|
||||
(syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)
|
||||
(list #'(define-syntaxes (id ...) rhs)))]
|
||||
[(define-values (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||
(list expr))]
|
||||
[else
|
||||
(list expr)])))
|
||||
exprs)))])
|
||||
#`(let ()
|
||||
#,@(let loop ([exprs exprs][prev-defns null][prev-exprs null])
|
||||
(cond
|
||||
[(null? exprs) (append
|
||||
(reverse prev-defns)
|
||||
(reverse prev-exprs)
|
||||
(if (null? prev-exprs)
|
||||
(list #'(void))
|
||||
null))]
|
||||
[(and (stx-pair? (car exprs))
|
||||
(identifier? (stx-car (car exprs)))
|
||||
(or (module-identifier=? #'define-values (stx-car (car exprs)))
|
||||
(module-identifier=? #'define-syntaxes (stx-car (car exprs)))))
|
||||
(loop (cdr exprs)
|
||||
(cons (car exprs)
|
||||
(append
|
||||
(map (lambda (expr)
|
||||
#`(define-values () (begin #,expr (values))))
|
||||
prev-exprs)
|
||||
prev-defns))
|
||||
null)]
|
||||
[else
|
||||
(loop (cdr exprs) prev-defns (cons (car exprs) prev-exprs))])))))
|
||||
(let loop ([exprs exprs][prev-stx-defns null][prev-defns null][prev-exprs null])
|
||||
(cond
|
||||
[(null? exprs)
|
||||
#`(letrec-syntaxes+values
|
||||
#,(map stx-cdr (reverse prev-stx-defns))
|
||||
#,(map stx-cdr (reverse prev-defns))
|
||||
#,@(if (null? prev-exprs)
|
||||
(list #'(void))
|
||||
(reverse prev-exprs)))]
|
||||
[(and (stx-pair? (car exprs))
|
||||
(identifier? (stx-car (car exprs)))
|
||||
(module-identifier=? #'define-syntaxes (stx-car (car exprs))))
|
||||
(loop (cdr exprs) (cons (car exprs) prev-stx-defns) prev-defns prev-exprs)]
|
||||
[(and (stx-pair? (car exprs))
|
||||
(identifier? (stx-car (car exprs)))
|
||||
(module-identifier=? #'define-values (stx-car (car exprs))))
|
||||
(loop (cdr exprs)
|
||||
prev-stx-defns
|
||||
(cons (car exprs)
|
||||
(append
|
||||
(map (lambda (expr)
|
||||
#`(define-values () (begin #,expr (values))))
|
||||
prev-exprs)
|
||||
prev-defns))
|
||||
null)]
|
||||
[else
|
||||
(loop (cdr exprs) prev-stx-defns prev-defns (cons (car exprs) prev-exprs))]))))
|
||||
|
||||
(define-syntax (begin-lifted stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
elems ; list of syms and signatures
|
||||
ctxs ; list of stx
|
||||
structs)) ; list of struct-infos
|
||||
(define-struct parsed-unit (imports renames vars stxes body stx-checks))
|
||||
(define-struct parsed-unit (imports renames vars import-vars body stx-checks))
|
||||
|
||||
(define-struct struct-def (name super-name names))
|
||||
|
||||
|
|
@ -528,7 +528,10 @@
|
|||
(let ([vars (map syntax-e (parsed-unit-vars a-unit))])
|
||||
(for-each
|
||||
(lambda (var)
|
||||
(let ([renamed (do-rename var renames)])
|
||||
(let ([renamed (let ([s (do-rename var renames)])
|
||||
(if (syntax? s)
|
||||
(syntax-e s)
|
||||
s))])
|
||||
(unless (memq renamed vars)
|
||||
(syntax-error #f expr
|
||||
(format
|
||||
|
|
@ -578,7 +581,7 @@
|
|||
clause)))))
|
||||
|
||||
(define parse-unit
|
||||
(lambda (expr body sig user-stx-forms dv-stx begin-stx)
|
||||
(lambda (expr body sig user-stx-forms dv-stx ds-stx begin-stx)
|
||||
(let ([body (stx->list body)])
|
||||
(unless body
|
||||
(syntax-error #f expr "illegal use of `.'"))
|
||||
|
|
@ -590,12 +593,22 @@
|
|||
(let* ([imports (parse-imports 'unit/sig #t #t expr (stx-cdr (car body)) #t)]
|
||||
[imported-names (flatten-signatures imports #f)]
|
||||
[exported-names (flatten-signature #f sig #f)]
|
||||
[def-ctx (syntax-local-make-definition-context)]
|
||||
[body (cdr body)])
|
||||
(let-values ([(renames body)
|
||||
(if (and (stx-pair? body)
|
||||
(stx-pair? (car body))
|
||||
(eq? 'rename (syntax-e (stx-car (car body)))))
|
||||
(values (map syntax-object->datum (cdr (stx->list (car body)))) (cdr body))
|
||||
(values (map (lambda (p)
|
||||
(list (stx-car p)
|
||||
(syntax-e (stx-car (stx-cdr p)))))
|
||||
(cdr (stx->list
|
||||
(let ([rn (car body)])
|
||||
(local-expand rn
|
||||
'expression
|
||||
(list (stx-car rn))
|
||||
def-ctx)))))
|
||||
(cdr body))
|
||||
(values null body))])
|
||||
(unless renames
|
||||
(syntax-error #f expr "illegal use of `.'" (car body)))
|
||||
|
|
@ -635,14 +648,29 @@
|
|||
(loop (cdr e))
|
||||
(cons (car e) (loop (cdr e)))))))]
|
||||
[local-vars (append renamed-internals filtered-exported-names imported-names)]
|
||||
[expand-context (generate-expand-context)])
|
||||
(let loop ([pre-lines null][lines body][port #f][port-name #f][body null][vars null])
|
||||
[expand-context (generate-expand-context)]
|
||||
[import-stxes (apply append (map (lambda (i)
|
||||
(map
|
||||
(lambda (d)
|
||||
(datum->syntax-object expr d))
|
||||
(make-struct-stx-decls i #f #t expr #f)))
|
||||
imports))]
|
||||
[import-vars
|
||||
(let ([vars (map (lambda (sym) (datum->syntax-object expr sym expr))
|
||||
(flatten-signatures imports 'must-have-ctx))])
|
||||
;; Treat imported names like internal definitions:
|
||||
(syntax-local-bind-syntaxes vars #f def-ctx)
|
||||
(cdr (syntax->list (local-expand #`(stop #,@vars)
|
||||
'expression
|
||||
(list #'stop)
|
||||
def-ctx))))])
|
||||
(let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null])
|
||||
(cond
|
||||
[(and (null? pre-lines) (not port) (null? lines))
|
||||
(make-parsed-unit imports
|
||||
renames
|
||||
vars
|
||||
(lambda (src-stx) (apply append (map (lambda (i) (make-struct-stx-decls i #f #t src-stx #f)) imports)))
|
||||
import-vars
|
||||
body
|
||||
(lambda (src-stx)
|
||||
;; Disabled until we have a mechanism for declaring precise information in signatures:
|
||||
|
|
@ -656,12 +684,13 @@
|
|||
[port (read-syntax port-name port)]
|
||||
[else (car lines)])])
|
||||
(if (eof-object? s)
|
||||
s
|
||||
(local-expand s
|
||||
expand-context
|
||||
(append
|
||||
user-stx-forms
|
||||
local-vars))))]
|
||||
s
|
||||
(local-expand s
|
||||
expand-context
|
||||
(append
|
||||
user-stx-forms
|
||||
local-vars)
|
||||
def-ctx)))]
|
||||
[(rest-pre-lines)
|
||||
(if (null? pre-lines)
|
||||
null
|
||||
|
|
@ -679,17 +708,48 @@
|
|||
(identifier? (stx-car line))
|
||||
(module-identifier=? (stx-car line) dv-stx))
|
||||
(syntax-case line ()
|
||||
[(_ (id ...) expr)
|
||||
(loop rest-pre-lines
|
||||
rest-lines
|
||||
port
|
||||
port-name
|
||||
(cons line body)
|
||||
(append (syntax->list (syntax (id ...))) vars))]
|
||||
[(_ (id ...) rhs)
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? #'id)
|
||||
(syntax-error #f id "not an identifier" line)))
|
||||
ids)
|
||||
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||
(loop rest-pre-lines
|
||||
rest-lines
|
||||
port
|
||||
port-name
|
||||
(cons line body)
|
||||
(append ids vars)))]
|
||||
[else
|
||||
(syntax-error #f expr
|
||||
"improper `define-values' clause form"
|
||||
line)])]
|
||||
[(and (stx-pair? line)
|
||||
(identifier? (stx-car line))
|
||||
(module-identifier=? (stx-car line) ds-stx))
|
||||
(syntax-case line ()
|
||||
[(_ (id ...) rhs)
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? #'id)
|
||||
(syntax-error #f id "not an identifier" line)))
|
||||
ids)
|
||||
(with-syntax ([rhs (local-transformer-expand
|
||||
#'rhs
|
||||
'expression
|
||||
null)])
|
||||
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
|
||||
(loop rest-pre-lines
|
||||
rest-lines
|
||||
port
|
||||
port-name
|
||||
(cons line body)
|
||||
vars)))]
|
||||
[else
|
||||
(syntax-error #f expr
|
||||
"improper `define-syntaxes' clause form"
|
||||
line)])]
|
||||
[(and (stx-pair? line)
|
||||
(identifier? (stx-car line))
|
||||
(module-identifier=? (stx-car line) begin-stx))
|
||||
|
|
@ -1148,9 +1208,10 @@
|
|||
|
||||
parsed-unit-renames
|
||||
parsed-unit-imports
|
||||
parsed-unit-stxes
|
||||
parsed-unit-import-vars
|
||||
parsed-unit-body
|
||||
parsed-unit-stx-checks
|
||||
parsed-unit-vars
|
||||
|
||||
make-struct-stx-decls
|
||||
verify-struct-shape
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@
|
|||
(build-path d 'up "command.com"))))))])
|
||||
(list cmd
|
||||
'exact
|
||||
(format "~a /c ~a" (path->string cmd) argstr))))
|
||||
(format "~a /c \"~a\"" (path->string cmd) argstr))))
|
||||
(else (raise-mismatch-error
|
||||
who
|
||||
(format "~a: don't know what shell to use for platform: " who)
|
||||
|
|
|
|||
|
|
@ -357,9 +357,7 @@
|
|||
#,(generate-struct-declaration stx
|
||||
id super-id field-ids
|
||||
(syntax-local-context)
|
||||
(make-make-make-struct-type #'(inspector-expr deserializer-id))
|
||||
#'continue-define-serializable-struct
|
||||
#'(inspector-expr deserializer-id))
|
||||
(make-make-make-struct-type #'(inspector-expr deserializer-id)))
|
||||
(define deserializer-id (let ([l (internal-deserialize-info struct-type-id)])
|
||||
(make-deserialize-info
|
||||
((car l))
|
||||
|
|
@ -404,9 +402,6 @@
|
|||
(context-check stx)
|
||||
(main/versions stx)))))
|
||||
|
||||
(define-syntax (continue-define-serializable-struct stx)
|
||||
(generate-delayed-struct-declaration stx make-make-make-struct-type))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; serialize
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -163,13 +163,9 @@
|
|||
(generate-struct-declaration stx
|
||||
id sup-id fields
|
||||
(syntax-local-context)
|
||||
(make-make-make-struct-type props+insp)
|
||||
#'continue-ds/p props+insp)))
|
||||
(make-make-make-struct-type props+insp))))
|
||||
|
||||
(parse-at-main))
|
||||
|
||||
(define-syntax (continue-ds/p stx)
|
||||
(generate-delayed-struct-declaration stx make-make-make-struct-type))
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
;; make->vector
|
||||
|
|
|
|||
|
|
@ -37,295 +37,332 @@
|
|||
;; ----------------------------------------------------------------------
|
||||
;; The `unit' syntactic form
|
||||
|
||||
(define-syntax :unit
|
||||
(lambda (stx)
|
||||
(syntax-case stx (import export)
|
||||
[(_ (import ivar ...)
|
||||
(export evar ...)
|
||||
defn&expr ...)
|
||||
(let ([check-id (lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"import is not an identifier"
|
||||
stx
|
||||
v)))]
|
||||
[check-renamed-id
|
||||
(lambda (v)
|
||||
(syntax-case v ()
|
||||
[id (identifier? (syntax id)) 'ok]
|
||||
[(lid eid) (and (identifier? (syntax lid))
|
||||
(identifier? (syntax eid))) 'ok]
|
||||
[else (raise-syntax-error
|
||||
#f
|
||||
"export is not an identifier or renamed identifier"
|
||||
stx
|
||||
v)]))]
|
||||
[expand-context (generate-expand-context)]
|
||||
[ivars (syntax->list (syntax (ivar ...)))]
|
||||
[evars (syntax->list (syntax (evar ...)))])
|
||||
(for-each check-id ivars)
|
||||
(for-each check-renamed-id evars)
|
||||
|
||||
;; Get import/export declared names:
|
||||
(let* ([exported-names
|
||||
(map (lambda (v)
|
||||
(syntax-case v ()
|
||||
[(lid eid) (syntax lid)]
|
||||
[id (syntax id)]))
|
||||
evars)]
|
||||
[extnames (map (lambda (v)
|
||||
(syntax-case v ()
|
||||
[(lid eid) (syntax eid)]
|
||||
[id (syntax id)]))
|
||||
evars)]
|
||||
[imported-names ivars]
|
||||
[declared-names (append imported-names exported-names)])
|
||||
;; Check that all exports are distinct (as symbols)
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each (lambda (name)
|
||||
(when (hash-table-get ht (syntax-e name) (lambda () #f))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate export"
|
||||
stx
|
||||
name))
|
||||
(hash-table-put! ht (syntax-e name) #t))
|
||||
extnames))
|
||||
|
||||
;; Expand all body expressions
|
||||
;; so that all definitions are exposed.
|
||||
(letrec ([expand-all
|
||||
(lambda (defns&exprs)
|
||||
(let ([expanded
|
||||
(map
|
||||
(lambda (defn-or-expr)
|
||||
(local-expand
|
||||
defn-or-expr
|
||||
expand-context
|
||||
(append
|
||||
(kernel-form-identifier-list (quote-syntax here))
|
||||
declared-names)))
|
||||
defns&exprs)])
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (defn-or-expr)
|
||||
(syntax-case defn-or-expr (begin)
|
||||
[(begin . l)
|
||||
(let ([l (syntax->list (syntax l))])
|
||||
(unless l
|
||||
(define-syntaxes (:unit unit/no-expand)
|
||||
(let ([do-unit
|
||||
(lambda (stx expand?)
|
||||
(syntax-case stx (import export)
|
||||
[(_ (import ivar ...)
|
||||
(export evar ...)
|
||||
defn&expr ...)
|
||||
(let ([check-id (lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"import is not an identifier"
|
||||
stx
|
||||
v)))]
|
||||
[check-renamed-id
|
||||
(lambda (v)
|
||||
(syntax-case v ()
|
||||
[id (identifier? (syntax id)) (list v)]
|
||||
[(lid eid) (and (identifier? (syntax lid))
|
||||
(identifier? (syntax eid)))
|
||||
(list #'lid #'eid)]
|
||||
[else (raise-syntax-error
|
||||
#f
|
||||
"export is not an identifier or renamed identifier"
|
||||
stx
|
||||
v)]))]
|
||||
[expand-context (generate-expand-context)]
|
||||
[def-ctx (and expand?
|
||||
(syntax-local-make-definition-context))]
|
||||
[localify (lambda (ids def-ctx)
|
||||
(if (andmap identifier? ids)
|
||||
;; In expand mode, add internal defn context
|
||||
(if expand?
|
||||
(begin
|
||||
;; Treat imports as internal-defn names:
|
||||
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||
(cdr (syntax->list
|
||||
(local-expand #`(stop #,@ids)
|
||||
'expression
|
||||
(list #'stop)
|
||||
def-ctx))))
|
||||
ids)
|
||||
;; Let later checking report an error:
|
||||
ids))])
|
||||
(let ([ivars (localify (syntax->list (syntax (ivar ...))) def-ctx)]
|
||||
[evars (syntax->list (syntax (evar ...)))])
|
||||
(for-each check-id ivars)
|
||||
(for-each check-renamed-id evars)
|
||||
|
||||
;; Get import/export declared names:
|
||||
(let* ([exported-names
|
||||
(localify
|
||||
(map (lambda (v)
|
||||
(syntax-case v ()
|
||||
[(lid eid) (syntax lid)]
|
||||
[id (syntax id)]))
|
||||
evars)
|
||||
def-ctx)]
|
||||
[extnames (map (lambda (v)
|
||||
(syntax-case v ()
|
||||
[(lid eid) (syntax eid)]
|
||||
[id (syntax id)]))
|
||||
evars)]
|
||||
[imported-names ivars]
|
||||
[declared-names (append imported-names exported-names)])
|
||||
;; Check that all exports are distinct (as symbols)
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each (lambda (name)
|
||||
(when (hash-table-get ht (syntax-e name) (lambda () #f))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (illegal use of `.')"
|
||||
defn-or-expr))
|
||||
(expand-all (map (lambda (s)
|
||||
(syntax-track-origin s defn-or-expr #'begin))
|
||||
l)))]
|
||||
[else (list defn-or-expr)]))
|
||||
expanded))))])
|
||||
(let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))])
|
||||
;; Get all the defined names, sorting out variable definitions
|
||||
;; from syntax definitions.
|
||||
(let* ([definition?
|
||||
(lambda (id)
|
||||
(and (identifier? id)
|
||||
(or (module-identifier=? id (quote-syntax define-values))
|
||||
(module-identifier=? id (quote-syntax define-syntaxes)))))]
|
||||
[all-defined-names/kinds
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (defn-or-expr)
|
||||
(syntax-case defn-or-expr (define-values define-syntaxes)
|
||||
[(dv (id ...) expr)
|
||||
(definition? (syntax dv))
|
||||
(let ([l (syntax->list (syntax (id ...)))])
|
||||
(for-each (lambda (i)
|
||||
(unless (identifier? i)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier in definition"
|
||||
defn-or-expr
|
||||
i)))
|
||||
l)
|
||||
(let ([key (if (module-identifier=? (syntax dv) (quote-syntax define-syntaxes))
|
||||
'stx
|
||||
'val)])
|
||||
(map (lambda (id) (cons key id)) l)))]
|
||||
[(define-values . l)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad definition form"
|
||||
defn-or-expr)]
|
||||
[(define-syntaxes . l)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax definition form"
|
||||
defn-or-expr)]
|
||||
[else null]))
|
||||
all-expanded))]
|
||||
[all-defined-names (map cdr all-defined-names/kinds)]
|
||||
[all-defined-val-names (map cdr
|
||||
(filter (lambda (i) (eq? (car i) 'val))
|
||||
all-defined-names/kinds))])
|
||||
;; Check that all defined names (var + stx) are distinct:
|
||||
(let ([name (check-duplicate-identifier
|
||||
(append imported-names all-defined-names))])
|
||||
(when name
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"variable imported and/or defined twice"
|
||||
stx
|
||||
name)))
|
||||
;; Check that all exported names are defined (as var):
|
||||
(let ([ht (make-hash-table)]
|
||||
[stx-ht (make-hash-table)])
|
||||
(for-each
|
||||
(lambda (kind+name)
|
||||
(let ([name (cdr kind+name)])
|
||||
(let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
|
||||
(hash-table-put! (if (eq? (car kind+name) 'val) ht stx-ht)
|
||||
(syntax-e name)
|
||||
(cons name l)))))
|
||||
all-defined-names/kinds)
|
||||
(for-each
|
||||
(lambda (n)
|
||||
(let ([v (hash-table-get ht (syntax-e n) (lambda () null))])
|
||||
(unless (ormap (lambda (i) (bound-identifier=? i n)) v)
|
||||
;; Either not defined, or defined as syntax:
|
||||
(let ([stx-v (hash-table-get stx-ht (syntax-e n) (lambda () null))])
|
||||
(if (ormap (lambda (i) (bound-identifier=? i n)) stx-v)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"cannot export syntax from a unit"
|
||||
stx
|
||||
n)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"exported variable is not defined"
|
||||
stx
|
||||
n))))))
|
||||
exported-names))
|
||||
"duplicate export"
|
||||
stx
|
||||
name))
|
||||
(hash-table-put! ht (syntax-e name) #t))
|
||||
extnames))
|
||||
|
||||
;; Compute defined but not exported:
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each
|
||||
(lambda (name)
|
||||
(let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
|
||||
(hash-table-put! ht (syntax-e name) (cons name l))))
|
||||
exported-names)
|
||||
(let ([internal-names
|
||||
(let loop ([l all-defined-val-names])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(let ([v (hash-table-get ht (syntax-e (car l)) (lambda () null))])
|
||||
(ormap (lambda (i) (bound-identifier=? i (car l))) v))
|
||||
(loop (cdr l))]
|
||||
[else (cons (car l) (loop (cdr l)))]))])
|
||||
;; Generate names for import/export boxes, etc:
|
||||
(with-syntax ([(iloc ...) (generate-temporaries (syntax (ivar ...)))]
|
||||
[(eloc ...) (generate-temporaries evars)]
|
||||
[(extname ...) extnames]
|
||||
[(expname ...) exported-names]
|
||||
[(intname ...) internal-names])
|
||||
;; Change all definitions to set!s. Convert evars to set-box!,
|
||||
;; because set! on exported variables is not allowed.
|
||||
(with-syntax ([(defn&expr ...)
|
||||
(let ([elocs (syntax->list (syntax (eloc ...)))])
|
||||
(filter
|
||||
values
|
||||
(map (lambda (defn-or-expr)
|
||||
(syntax-case defn-or-expr (define-values define-syntaxes)
|
||||
[(define-values ids expr)
|
||||
(let* ([ids (syntax->list (syntax ids))])
|
||||
(if (null? ids)
|
||||
(syntax/loc defn-or-expr (set!-values ids expr))
|
||||
(let ([do-one
|
||||
(lambda (id tmp name)
|
||||
(let loop ([evars exported-names]
|
||||
[elocs elocs])
|
||||
(cond
|
||||
[(null? evars)
|
||||
;; not an exported id
|
||||
(with-syntax ([id id][tmp tmp])
|
||||
(syntax/loc
|
||||
defn-or-expr
|
||||
(set! id tmp)))]
|
||||
[(bound-identifier=? (car evars) id)
|
||||
;; set! exported id:
|
||||
(with-syntax
|
||||
([loc (car elocs)]
|
||||
[tmp
|
||||
(if name
|
||||
(with-syntax
|
||||
([tmp tmp]
|
||||
[name name])
|
||||
(syntax
|
||||
(let ([name tmp])
|
||||
name)))
|
||||
tmp)])
|
||||
(syntax/loc defn-or-expr
|
||||
(set-box! loc tmp)))]
|
||||
[else (loop (cdr evars)
|
||||
(cdr elocs))])))])
|
||||
(if (null? (cdr ids))
|
||||
(do-one (car ids) (syntax expr) (car ids))
|
||||
(let ([tmps (generate-temporaries ids)])
|
||||
(with-syntax ([(tmp ...) tmps]
|
||||
[(set ...)
|
||||
(map (lambda (id tmp)
|
||||
(do-one id tmp #f))
|
||||
ids tmps)])
|
||||
(syntax/loc defn-or-expr
|
||||
(let-values ([(tmp ...) expr])
|
||||
set ...))))))))]
|
||||
[(define-syntaxes . l) #f]
|
||||
[else defn-or-expr]))
|
||||
all-expanded)))]
|
||||
[(stx-defn ...)
|
||||
(filter
|
||||
values
|
||||
(map (lambda (defn-or-expr)
|
||||
(syntax-case defn-or-expr (define-syntaxes)
|
||||
[(define-syntaxes . l) defn-or-expr]
|
||||
[else #f]))
|
||||
all-expanded))])
|
||||
;; Build up set! redirection chain:
|
||||
(with-syntax ([redirections
|
||||
(let ([varlocs
|
||||
(syntax->list
|
||||
(syntax ((ivar iloc) ... (expname eloc) ...)))])
|
||||
(with-syntax ([vars (map stx-car varlocs)]
|
||||
[rhss
|
||||
(map
|
||||
(lambda (varloc)
|
||||
(with-syntax ([(var loc) varloc])
|
||||
(syntax
|
||||
(make-id-mapper (quote-syntax (unbox loc))
|
||||
(quote-syntax var)))))
|
||||
varlocs)])
|
||||
(syntax
|
||||
([vars (values . rhss)]))))]
|
||||
[num-imports (datum->syntax-object
|
||||
(quote-syntax here)
|
||||
(length (syntax->list (syntax (iloc ...))))
|
||||
#f)]
|
||||
[name (syntax-local-infer-name stx)])
|
||||
(syntax/loc stx
|
||||
(make-a-unit
|
||||
'name
|
||||
num-imports
|
||||
(list (quote extname) ...)
|
||||
(lambda ()
|
||||
(let ([eloc (box undefined)] ...)
|
||||
(list (vector eloc ...)
|
||||
(lambda (iloc ...)
|
||||
(let ([intname undefined] ...)
|
||||
(letrec-syntaxes+values redirections ()
|
||||
stx-defn ...
|
||||
(void) ; in case the body would be empty
|
||||
defn&expr ...))))))))))))))))))])))
|
||||
;; Expand all body expressions
|
||||
;; so that all definitions are exposed.
|
||||
(letrec ([expand-all
|
||||
(if expand?
|
||||
(lambda (defns&exprs)
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (defn-or-expr)
|
||||
(let ([defn-or-expr
|
||||
(local-expand
|
||||
defn-or-expr
|
||||
expand-context
|
||||
(append
|
||||
(kernel-form-identifier-list (quote-syntax here))
|
||||
declared-names)
|
||||
def-ctx)])
|
||||
(syntax-case defn-or-expr (begin define-values define-syntaxes)
|
||||
[(begin . l)
|
||||
(let ([l (syntax->list (syntax l))])
|
||||
(unless l
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (illegal use of `.')"
|
||||
defn-or-expr))
|
||||
(expand-all (map (lambda (s)
|
||||
(syntax-track-origin s defn-or-expr #'begin))
|
||||
l)))]
|
||||
[(define-syntaxes (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(with-syntax ([rhs (local-transformer-expand
|
||||
#'rhs
|
||||
'expression
|
||||
null)])
|
||||
(syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)
|
||||
(list #'(define-syntaxes (id ...) rhs)))]
|
||||
[(define-values (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(begin
|
||||
(syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f def-ctx)
|
||||
(list defn-or-expr))]
|
||||
[else (list defn-or-expr)])))
|
||||
defns&exprs)))
|
||||
values)])
|
||||
(let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))])
|
||||
;; Get all the defined names, sorting out variable definitions
|
||||
;; from syntax definitions.
|
||||
(let* ([definition?
|
||||
(lambda (id)
|
||||
(and (identifier? id)
|
||||
(or (module-identifier=? id (quote-syntax define-values))
|
||||
(module-identifier=? id (quote-syntax define-syntaxes)))))]
|
||||
[all-defined-names/kinds
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (defn-or-expr)
|
||||
(syntax-case defn-or-expr (define-values define-syntaxes)
|
||||
[(dv (id ...) expr)
|
||||
(definition? (syntax dv))
|
||||
(let ([l (syntax->list (syntax (id ...)))])
|
||||
(for-each (lambda (i)
|
||||
(unless (identifier? i)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier in definition"
|
||||
defn-or-expr
|
||||
i)))
|
||||
l)
|
||||
(let ([key (if (module-identifier=? (syntax dv) (quote-syntax define-syntaxes))
|
||||
'stx
|
||||
'val)])
|
||||
(map (lambda (id) (cons key id)) l)))]
|
||||
[(define-values . l)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad definition form"
|
||||
defn-or-expr)]
|
||||
[(define-syntaxes . l)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax definition form"
|
||||
defn-or-expr)]
|
||||
[else null]))
|
||||
all-expanded))]
|
||||
[all-defined-names (map cdr all-defined-names/kinds)]
|
||||
[all-defined-val-names (map cdr
|
||||
(filter (lambda (i) (eq? (car i) 'val))
|
||||
all-defined-names/kinds))])
|
||||
;; Check that all defined names (var + stx) are distinct:
|
||||
(let ([name (check-duplicate-identifier
|
||||
(append imported-names all-defined-names))])
|
||||
(when name
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"variable imported and/or defined twice"
|
||||
stx
|
||||
name)))
|
||||
;; Check that all exported names are defined (as var):
|
||||
(let ([ht (make-hash-table)]
|
||||
[stx-ht (make-hash-table)])
|
||||
(for-each
|
||||
(lambda (kind+name)
|
||||
(let ([name (cdr kind+name)])
|
||||
(let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
|
||||
(hash-table-put! (if (eq? (car kind+name) 'val) ht stx-ht)
|
||||
(syntax-e name)
|
||||
(cons name l)))))
|
||||
all-defined-names/kinds)
|
||||
(for-each
|
||||
(lambda (n)
|
||||
(let ([v (hash-table-get ht (syntax-e n) (lambda () null))])
|
||||
(unless (ormap (lambda (i) (bound-identifier=? i n)) v)
|
||||
;; Either not defined, or defined as syntax:
|
||||
(let ([stx-v (hash-table-get stx-ht (syntax-e n) (lambda () null))])
|
||||
(if (ormap (lambda (i) (bound-identifier=? i n)) stx-v)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"cannot export syntax from a unit"
|
||||
stx
|
||||
n)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"exported variable is not defined"
|
||||
stx
|
||||
n))))))
|
||||
exported-names))
|
||||
|
||||
;; Compute defined but not exported:
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each
|
||||
(lambda (name)
|
||||
(let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
|
||||
(hash-table-put! ht (syntax-e name) (cons name l))))
|
||||
exported-names)
|
||||
(let ([internal-names
|
||||
(let loop ([l all-defined-val-names])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(let ([v (hash-table-get ht (syntax-e (car l)) (lambda () null))])
|
||||
(ormap (lambda (i) (bound-identifier=? i (car l))) v))
|
||||
(loop (cdr l))]
|
||||
[else (cons (car l) (loop (cdr l)))]))])
|
||||
;; Generate names for import/export boxes, etc:
|
||||
(with-syntax ([(ivar ...) ivars]
|
||||
[(iloc ...) (generate-temporaries ivars)]
|
||||
[(eloc ...) (generate-temporaries evars)]
|
||||
[(extname ...) extnames]
|
||||
[(expname ...) exported-names]
|
||||
[(intname ...) internal-names])
|
||||
;; Change all definitions to set!s. Convert evars to set-box!,
|
||||
;; because set! on exported variables is not allowed.
|
||||
(with-syntax ([(defn&expr ...)
|
||||
(let ([elocs (syntax->list (syntax (eloc ...)))])
|
||||
(filter
|
||||
values
|
||||
(map (lambda (defn-or-expr)
|
||||
(syntax-case defn-or-expr (define-values define-syntaxes)
|
||||
[(define-values ids expr)
|
||||
(let* ([ids (syntax->list (syntax ids))])
|
||||
(if (null? ids)
|
||||
(syntax/loc defn-or-expr (set!-values ids expr))
|
||||
(let ([do-one
|
||||
(lambda (id tmp name)
|
||||
(let loop ([evars exported-names]
|
||||
[elocs elocs])
|
||||
(cond
|
||||
[(null? evars)
|
||||
;; not an exported id
|
||||
(with-syntax ([id id][tmp tmp])
|
||||
(syntax/loc
|
||||
defn-or-expr
|
||||
(set! id tmp)))]
|
||||
[(bound-identifier=? (car evars) id)
|
||||
;; set! exported id:
|
||||
(with-syntax
|
||||
([loc (car elocs)]
|
||||
[tmp
|
||||
(if name
|
||||
(with-syntax
|
||||
([tmp tmp]
|
||||
[name name])
|
||||
(syntax
|
||||
(let ([name tmp])
|
||||
name)))
|
||||
tmp)])
|
||||
(syntax/loc defn-or-expr
|
||||
(set-box! loc tmp)))]
|
||||
[else (loop (cdr evars)
|
||||
(cdr elocs))])))])
|
||||
(if (null? (cdr ids))
|
||||
(do-one (car ids) (syntax expr) (car ids))
|
||||
(let ([tmps (generate-temporaries ids)])
|
||||
(with-syntax ([(tmp ...) tmps]
|
||||
[(set ...)
|
||||
(map (lambda (id tmp)
|
||||
(do-one id tmp #f))
|
||||
ids tmps)])
|
||||
(syntax/loc defn-or-expr
|
||||
(let-values ([(tmp ...) expr])
|
||||
set ...))))))))]
|
||||
[(define-syntaxes . l) #f]
|
||||
[else defn-or-expr]))
|
||||
all-expanded)))]
|
||||
[(stx-defn ...)
|
||||
(filter
|
||||
values
|
||||
(map (lambda (defn-or-expr)
|
||||
(syntax-case defn-or-expr (define-syntaxes)
|
||||
[(define-syntaxes . l) #'l]
|
||||
[else #f]))
|
||||
all-expanded))])
|
||||
;; Build up set! redirection chain:
|
||||
(with-syntax ([redirections
|
||||
(let ([varlocs
|
||||
(syntax->list
|
||||
(syntax ((ivar iloc) ... (expname eloc) ...)))])
|
||||
(with-syntax ([vars (map stx-car varlocs)]
|
||||
[rhss
|
||||
(map
|
||||
(lambda (varloc)
|
||||
(with-syntax ([(var loc) varloc])
|
||||
(syntax
|
||||
(make-id-mapper (quote-syntax (unbox loc))
|
||||
(quote-syntax var)))))
|
||||
varlocs)])
|
||||
(syntax
|
||||
([vars (values . rhss)]))))]
|
||||
[num-imports (datum->syntax-object
|
||||
(quote-syntax here)
|
||||
(length (syntax->list (syntax (iloc ...))))
|
||||
#f)]
|
||||
[name (syntax-local-infer-name stx)])
|
||||
(syntax/loc stx
|
||||
(make-a-unit
|
||||
'name
|
||||
num-imports
|
||||
(list (quote extname) ...)
|
||||
(lambda ()
|
||||
(let ([eloc (box undefined)] ...)
|
||||
(list (vector eloc ...)
|
||||
(lambda (iloc ...)
|
||||
(letrec-syntaxes+values
|
||||
(stx-defn ... . redirections)
|
||||
([(intname) undefined] ...)
|
||||
(void) ; in case the body would be empty
|
||||
defn&expr ...))))))))))))))))))]))])
|
||||
(values (lambda (stx) (do-unit stx #t))
|
||||
(lambda (stx) (do-unit stx #f)))))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
;; check-expected-interface: used by the expansion of `compound-unit'
|
||||
|
|
@ -824,7 +861,8 @@
|
|||
(syntax (define-values (tagged-export ...) invoke-unit)))))))])))])
|
||||
(values (mk #f) (mk #t))))
|
||||
|
||||
(provide (rename :unit unit) compound-unit invoke-unit unit?
|
||||
(provide (rename :unit unit) unit/no-expand
|
||||
compound-unit invoke-unit unit?
|
||||
(struct exn:fail:unit ())
|
||||
|
||||
define-values/invoke-unit
|
||||
|
|
|
|||
|
|
@ -44,29 +44,32 @@
|
|||
(let ([a-unit (parse-unit expr (syntax rest) sig
|
||||
(kernel-form-identifier-list (quote-syntax here))
|
||||
(quote-syntax define-values)
|
||||
(quote-syntax define-syntaxes)
|
||||
(quote-syntax begin))])
|
||||
(check-signature-unit-body sig a-unit (parsed-unit-renames a-unit) 'unit/sig expr)
|
||||
(with-syntax ([imports (datum->syntax-object
|
||||
expr
|
||||
(flatten-signatures (parsed-unit-imports a-unit) 'must-have-ctx)
|
||||
expr)]
|
||||
(with-syntax ([imports (parsed-unit-import-vars a-unit)]
|
||||
[exports (datum->syntax-object
|
||||
expr
|
||||
(map
|
||||
(lambda (name)
|
||||
(list (do-rename name (parsed-unit-renames a-unit))
|
||||
name))
|
||||
(signature-vars sig))
|
||||
(let ([vars (make-hash-table)])
|
||||
(for-each (lambda (var)
|
||||
(hash-table-put! vars (syntax-e var) var))
|
||||
(parsed-unit-vars a-unit))
|
||||
(map
|
||||
(lambda (name)
|
||||
(list (hash-table-get vars
|
||||
name
|
||||
(lambda () (do-rename name (parsed-unit-renames a-unit))))
|
||||
name))
|
||||
(signature-vars sig)))
|
||||
expr)]
|
||||
[body (append
|
||||
((parsed-unit-stxes a-unit) expr)
|
||||
(reverse! (parsed-unit-body a-unit))
|
||||
((parsed-unit-stx-checks a-unit) expr))]
|
||||
[import-sigs (explode-named-sigs (parsed-unit-imports a-unit) #f)]
|
||||
[export-sig (explode-sig sig #f)])
|
||||
(syntax/loc expr
|
||||
(make-signed-unit
|
||||
(unit
|
||||
(unit/no-expand
|
||||
(import . imports)
|
||||
(export . exports)
|
||||
. body)
|
||||
|
|
|
|||
53
collects/tests/mzscheme/etc.ss
Normal file
53
collects/tests/mzscheme/etc.ss
Normal file
|
|
@ -0,0 +1,53 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'etc)
|
||||
|
||||
(require (lib "etc.ss"))
|
||||
|
||||
(let ()
|
||||
(begin-with-definitions
|
||||
(define-syntax (goo stx)
|
||||
(syntax-case stx ()
|
||||
[(_ foo) #'(define-syntax (foo stx) (syntax-case stx () [(_ x) #'(define x 12)]))]))
|
||||
(goo foo)
|
||||
(foo x)
|
||||
(test 12 'bwd x)))
|
||||
|
||||
(let-syntax ([goo (lambda (stx) #'(begin (define z 13) (test 13 'bwd z)))])
|
||||
(let-syntax ([y (lambda (stx) #'goo)])
|
||||
(let ()
|
||||
(begin-with-definitions
|
||||
(define-syntax (goo stx)
|
||||
(syntax-case stx ()
|
||||
[(_ foo) #'(define-syntax (foo stx) (syntax-case stx () [(_ x) #'(define x 12)]))]))
|
||||
(goo foo)
|
||||
(foo x)
|
||||
y
|
||||
(test 12 'bwd x)))))
|
||||
|
||||
(let ()
|
||||
(begin-with-definitions
|
||||
(define-struct a (b c))
|
||||
(test 2 'bwd (a-c (make-a 1 2)))))
|
||||
|
||||
(let ()
|
||||
(begin-with-definitions
|
||||
(define-struct a (b c))
|
||||
(let ()
|
||||
(define-struct (d a) (e))
|
||||
(test 3 'bwd (d-e (make-d 1 2 3))))))
|
||||
|
||||
(let ()
|
||||
(begin-with-definitions
|
||||
(define-struct a (b c))
|
||||
(define-struct (d a) (e))
|
||||
(test 3 'bwd (d-e (make-d 1 2 3)))))
|
||||
|
||||
(syntax-test #'(begin-with-definitions
|
||||
(define-syntax goo 10)
|
||||
(define goo 10)
|
||||
12))
|
||||
|
||||
(report-errs)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user