From f5ea87030c06a35badf2978f271fed6b57c2e9d0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 28 Jun 2005 17:01:03 +0000 Subject: [PATCH] 299.107 svn: r259 original commit: 0d4bc2cd9d93b05203f70cccdaf832babee3a4cd --- collects/mzlib/etc.ss | 74 ++-- collects/mzlib/private/sigutil.ss | 103 ++++- collects/mzlib/process.ss | 2 +- collects/mzlib/serialize.ss | 7 +- collects/mzlib/struct.ss | 6 +- collects/mzlib/unit.ss | 612 ++++++++++++++++-------------- collects/mzlib/unitsig.ss | 25 +- collects/tests/mzscheme/etc.ss | 53 +++ 8 files changed, 524 insertions(+), 358 deletions(-) create mode 100644 collects/tests/mzscheme/etc.ss diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 27556fc..9948d2d 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -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 () diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index 637dbb9..4b96c01 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -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 diff --git a/collects/mzlib/process.ss b/collects/mzlib/process.ss index cf73edd..6a6de6d 100644 --- a/collects/mzlib/process.ss +++ b/collects/mzlib/process.ss @@ -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) diff --git a/collects/mzlib/serialize.ss b/collects/mzlib/serialize.ss index 12efa78..22c3031 100644 --- a/collects/mzlib/serialize.ss +++ b/collects/mzlib/serialize.ss @@ -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 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/mzlib/struct.ss b/collects/mzlib/struct.ss index a3c0b3b..cf76772 100644 --- a/collects/mzlib/struct.ss +++ b/collects/mzlib/struct.ss @@ -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 diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 8a3698c..da77b87 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -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 diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss index 4fff0b4..368182c 100644 --- a/collects/mzlib/unitsig.ss +++ b/collects/mzlib/unitsig.ss @@ -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) diff --git a/collects/tests/mzscheme/etc.ss b/collects/tests/mzscheme/etc.ss new file mode 100644 index 0000000..76af639 --- /dev/null +++ b/collects/tests/mzscheme/etc.ss @@ -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) +