From 024ef108642358a52efbbe06f962fa0a98b0c9a9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 17 Jan 2001 23:26:46 +0000 Subject: [PATCH] . original commit: 482b2b2de8e0bbdba7f29d47cedae13b700e36ff --- collects/mzlib/sigutils.ss | 635 +++++++++++++++-------------- collects/mzlib/unit.ss | 13 +- collects/mzlib/unitsig.ss | 287 ++++++------- collects/tests/mzscheme/unit.ss | 1 + collects/tests/mzscheme/unitsig.ss | 204 ++++----- 5 files changed, 564 insertions(+), 576 deletions(-) diff --git a/collects/mzlib/sigutils.ss b/collects/mzlib/sigutils.ss index 29deb90..bf71f82 100644 --- a/collects/mzlib/sigutils.ss +++ b/collects/mzlib/sigutils.ss @@ -1,15 +1,28 @@ (module sigutils mzscheme - ;; Used by signedunit.ss + (import "sigmatch.ss") + (import "exstruct.ss") + (define-struct signature (name ; sym src ; sym elems)) ; list of syms and signatures (define-struct parse-unit (imports renames vars body)) + (define-struct/export sig (content)) + (define inline-sig-name ') + (define-syntax literal? + (lambda (expr) + (syntax-case expr () + [(_ a) + (syntax (eq? (syntax-e (syntax a)) 'a))]))) + + (define (stx->sym s) + (if (syntax? s) (syntax-e s) s)) + (define syntax-error (case-lambda [(who expr msg sub) @@ -20,12 +33,14 @@ (define undef-sig-error (lambda (who expr what) (syntax-error who expr - (format "signature \"~s\" not defined" what)))) + "signature not defined" + what))) (define not-a-sig-error (lambda (who expr what) (syntax-error who expr - (format "\"~s\" is not a signature" what)))) + "not a signature" + what))) (define rename-signature (lambda (sig name) @@ -34,7 +49,7 @@ (signature-elems sig)))) (define intern-signature - (lambda (name desc global-name error) + (lambda (name desc error) (make-signature name name @@ -44,7 +59,7 @@ (cond [(symbol? elem) elem] [(and (pair? elem) (symbol? (car elem))) - (intern-signature (car elem) (cdr elem) #f error)] + (intern-signature (car elem) (cdr elem) error)] [else (error)])) (vector->list desc)) (error))))) @@ -57,20 +72,26 @@ name inline-sig-name) sigid) - (let ([v (syntax-local-value sigid)]) + (let ([v (syntax-local-value sigid (lambda () #f))]) (unless v (undef-sig-error who expr sigid)) - (let ([s (intern-signature sigid v - (and (eq? v gv) sigid) + (unless (sig? v) + (not-a-sig-error who expr sigid)) + (let ([s (intern-signature (syntax-e sigid) (sig-content v) (lambda () (not-a-sig-error who expr sigid)))]) (if name - (rename-signature s name) + (rename-signature s (stx->sym name)) s)))))) (define check-unique (lambda (names error-k) - (let ([dup (check-duplicate-identifier)]) + (let ([dup (check-duplicate-identifier + (map (lambda (n) + (if (syntax? n) + n + (datum->syntax n #f #f))) + names))]) (when dup (error-k dup))))) @@ -107,8 +128,9 @@ [() null] [(something . rest) (append - (syntax-case (syntax something) (struct unit : open) + (syntax-case (syntax something) () [: + (literal? :) (syntax-error who expr "misplaced `:'" (syntax something))] @@ -116,6 +138,7 @@ (identifier? (syntax id)) (list (syntax id))] [(struct name (field ...) omission ...) + (literal? struct) (let ([name (syntax name)] [fields (syntax->list (syntax (field ...)))] [omissions (syntax->list (syntax (omission ...)))]) @@ -171,20 +194,29 @@ names (filter names)))))] [(struct . _) + (literal? struct) (syntax-error who expr "bad `struct' clause form" (syntax something))] [(unit name : sig) - (identifier? name) + (and (literal? unit) + (identifier? (syntax name))) (let ([s (get-sig who expr (syntax name) (syntax sig))]) (list s))] [(unit . _) + (literal? unit) (syntax-error who expr "bad `unit' clause form" (syntax something))] [(open sig) - (let ([s (get-sig who expr #f (syntax open))]) + (literal? open) + (let ([s (get-sig who expr #f (syntax sig))]) (signature-elems s))] + [(open . _) + (literal? open) + (syntax-error who expr + "bad `open' clause form" + (syntax something))] [else (syntax-error who expr "improper signature clause type" (syntax something))]) @@ -192,20 +224,23 @@ [_else (syntax-error who expr "illegal use of `.'")]))]) (check-unique (map (lambda (elem) - (if (identifier? elem) - elem - (signature-name elem))) + (cond + [(symbol? elem) elem] + [(identifier? elem) (syntax-e elem)] + [else (signature-name elem)])) elems) (lambda (name) (syntax-error who expr "duplicate name in signature" name))) - (make-signature name name (sort-signature-elems - (map (lambda (id) - (if (identifier? id) - (syntax-e id) - id)) - elems)))))) + (make-signature (stx->sym name) + (stx->sym name) + (sort-signature-elems + (map (lambda (id) + (if (identifier? id) + (syntax-e id) + id)) + elems)))))) (define explode-sig (lambda (sig) @@ -322,7 +357,7 @@ (define check-signature-unit-body (lambda (sig a-unit renames who expr) - (let ([vars (parse-unit-vars a-unit)]) + (let ([vars (map syntax-e (parse-unit-vars a-unit))]) (for-each (lambda (var) (let ([renamed (do-rename var renames)]) @@ -353,18 +388,19 @@ "bad linkage specification~a") why) rest))]) - (let ([clause (syntax->list clause)]) - (unless clause + (let ([clause (stx->list clause)]) + (unless (stx-list? clause) (bad "")) (map (lambda (item) - (syntax-case item (:) + (syntax-case item () [id (and (identifier? (syntax id)) untagged-legal?) (rename-signature (get-sig who expr #f item) #f)] [(id : sig) - (identifier? (syntax id)) + (and (identifier? (syntax id)) + (eq? (syntax-e (syntax :)) ':)) (get-sig who expr (syntax id) (syntax sig))] [any untagged-legal? @@ -374,8 +410,8 @@ clause))))) (define parse-unit - (lambda (expr body sig) - (let ([body (syntax->list body)]) + (lambda (expr body sig user-stx-forms dv-stx begin-stx inc-stx) + (let ([body (stx->list body)]) (unless body (syntax-error 'unit/sig expr "illegal use of `.'")) (unless (and (pair? body) @@ -391,7 +427,7 @@ (if (and (stx-pair? body) (stx-pair? (car body)) (eq? 'rename (syntax-e (stx-car (car body))))) - (values (cdr (syntax->list (car body))) (cdr body)) + (values (map syntax->datum (cdr (stx->list (car body)))) (cdr body)) (values null body))]) (unless renames (syntax-error 'unit/sig expr "illegal use of `.'" (car body))) @@ -426,7 +462,7 @@ (let loop ([e exported-names]) (if (null? e) e - (if (ormap (lambda (rn) (bound-identifier=? (car rn) (car e))) + (if (ormap (lambda (rn) (eq? (car rn) (car e))) swapped-renames) (loop (cdr e)) (cons (car e) (loop (cdr e)))))))] @@ -443,29 +479,8 @@ [(pair? pre-lines) (car pre-lines)] [port (read-syntax port)] [else (car lines)]) - (list* - ;; Need all kernel syntax - (quote-syntax begin) - (quote-syntax define-values) - (quote-syntax define-syntax) - (quote-syntax set!) - (quote-syntax let) - (quote-syntax let-values) - (quote-syntax let*) - (quote-syntax let*-values) - (quote-syntax letrec) - (quote-syntax letrec-values) - (quote-syntax lambda) - (quote-syntax case-lambda) - (quote-syntax if) - (quote-syntax struct) - (quote-syntax quote) - (quote-syntax letrec-syntax) - (quote-syntax with-continuation-mark) - (quote-syntax #%app) - (quote-syntax #%unbound) - (quote-syntax #%datum) - (quote-syntax include) ;; special to unit/sig + (append + user-stx-forms local-vars))] [(rest-pre-lines) (if (null? pre-lines) @@ -481,21 +496,21 @@ (eof-object? line)) (values lines body vars)] [(and (stx-pair? line) - (module-identifier=? (stx-car line) (quote-syntax define-values))) + (module-identifier=? (stx-car line) dv-stx)) (syntax-case line () [(_ (id ...) expr) (loop rest-pre-lines rest-lines port (cons line body) - (append (syntax (id ...)) vars))] + (append (syntax->list (syntax (id ...))) vars))] [else (syntax-error 'unit/sig expr "improper `define-values' clause form" line)])] [(and (stx-pair? line) - (module-identifier=? (stx-car line) (quote-syntax begin))) - (let ([line-list (syntax->list line)]) + (module-identifier=? (stx-car line) begin-stx)) + (let ([line-list (stx->list line)]) (unless line-list (syntax-error 'unit/sig expr "improper `begin' clause form" @@ -506,7 +521,7 @@ body vars))] [(and (stx-pair? line) - (module-identifier=? (stx-car line) (quote-syntax include))) + (module-identifier=? (stx-car line) inc-stx)) (syntax-case line () [(_ filename) (string? (syntax-e (syntax filename))) @@ -558,10 +573,11 @@ (define parse-compound-unit (lambda (expr body) - (syntax-case body (import link export) + (syntax-case body () [((import . imports) (link . links) (export . exports)) + (and (literal? import) (literal? link) (literal? export)) (let* ([imports (parse-imports 'compound-unit/sig #f #t expr (syntax imports))]) (let ([link-list (syntax->list (syntax links))]) (unless link-list @@ -576,33 +592,39 @@ [links (map (lambda (line) - (syntax-case line (:) + (syntax-case line () [(tag : sig (expr linkage ...)) + (literal? :) (begin (unless (identifier? (syntax tag)) (bad ": link tag is not an identifier" line)) (make-link (syntax-e (syntax tag)) - (get-sig 'compound-unit/sig expr #f (syntax sig)) + (get-sig 'compound-unit/sig (syntax expr) #f (syntax sig)) (syntax expr) (syntax->list (syntax (linkage ...)))))] [(tag . x) (not (identifier? (syntax tag))) (bad ": tag is not an identifier" (syntax tag))] [(tag : sig (expr linkage ...) . rest) + (literal? :) (bad ": extra expressions in sub-clause" line)] [(tag : sig (expr . rest)) + (literal? :) (bad ": illegal use of `.' in linkages" line)] [(tag : sig) + (literal? :) (bad ": expected a unit expression and its linkages" line)] [(tag : sig . e) + (literal? :) (bad ": unit expression and its linkages not parenthesized" line)] [(tag :) + (literal? :) (bad ": expected a signature" line)] [(tag) (bad ": expected `:'" line)] [_else - (bad "")])) - link-lines)] + (bad "" line)])) + link-list)] [in-sigs imports] [find-link (lambda (name links) @@ -626,10 +648,11 @@ (letrec ([check-sig (lambda (sig use-sig) (when use-sig - (with-handlers ([exn:unit? (lambda (exn) - (syntax-error - 'compound-unit/sig expr - (exn-message exn)))]) + (with-handlers ([exn:unit? + (lambda (exn) + (syntax-error + 'compound-unit/sig expr + (exn-message exn)))]) (verify-signature-match 'compound-unit/sig #f (format "signature ~s" (signature-src use-sig)) @@ -647,7 +670,6 @@ [(or (not (stx-pair? p)) (not (identifier? (stx-car p)))) (syntax-error 'compound-unit/sig expr - (format "bad `~a' path" clause) path)] [(memq (syntax-e (stx-car p)) (signature-vars sig)) (if (and (stx-null? (stx-cdr p)) (not use-sig)) @@ -686,21 +708,23 @@ (syntax-e (stx-car p))) path)]))]) (let-values ([(p use-sig) - (syntax-case p (:) + (syntax-case path () [_ (identifier? path) (values (list path) #f)] [(name : sig) - (identifier? (syntax name)) + (and (identifier? (syntax name)) + (literal? :)) (values (list (syntax name)) (get-sig 'compound-unit/sig expr #f (syntax sig)))] [((elem ...) : sig) - (andmap (lambda (s) - (and (identifier? s) - (not (eq? (syntax-e s) ':)))) - (syntax (elem ...))) + (and (andmap (lambda (s) + (and (identifier? s) + (not (eq? (syntax-e s) ':)))) + (syntax->list (syntax (elem ...)))) + (literal? :)) (values (syntax (elem ...)) (get-sig 'compound-unit/sig expr #f @@ -709,7 +733,7 @@ (andmap (lambda (s) (and (identifier? s) (not (eq? (syntax-e s) ':)))) - (syntax (elem ...))) + (syntax->list (syntax (elem ...)))) (values path #f)] [else (syntax-error 'compound-unit/sig expr @@ -742,233 +766,240 @@ clause (syntax-e (stx-car p))) path)]))))]) - (check-unique (map link-name links) - (lambda (name) - (syntax-error 'compound-unit/sig expr - (format "duplicate sub-unit tag \"~s\"" name)))) - (check-unique (map signature-name imports) - (lambda (name) - (syntax-error 'compound-unit/sig expr - (format "duplicate import identifier \"~s\"" name)))) - (check-unique (append (map signature-name imports) - (map link-name links)) - (lambda (name) - (syntax-error 'compound-unit/sig expr - (format - "name \"~s\" is both import and sub-unit identifier" - name)))) - ;; Expand `link' clause using signatures - (for-each - (lambda (link) - (set-link-links! - link - (map - (lambda (link) - (flatten-path 'link link - (lambda (base var var-nopath) - (make-sig-explode-pair - var - (list - (if base - (list base var) - var)))) - (lambda (base last id sig) - (make-sig-explode-pair - (rename-signature sig last) - (if base - (list (cons base (flatten-signature id sig))) - (flatten-signature id sig)))))) - (link-links link)))) - links) - (let ([export-list (syntax->list (syntax exports))]) - (unless export-list - (syntax-error 'compound-unit/sig expr - "improper `export' clause form" - (syntax exports)))) - (let* ([upath? (lambda (p) - (or (identifier? p) - (and (stx-list? p) - (andmap identifietr? (stx->list p)))))] - [spath? (lambda (p) - (syntax-case p (:) - [(name : sig) - (and (upath? (syntax name)) - (or (identifier? (syntax sig)) - (parse-signature 'compound-unit/sig expr #f (syntax sig)))) - #t] - [_else - (upath? p)]))] - [exports - (map - (lambda (export) - (syntax-case export (open var unit) - [(open spath) - (begin - (unless (spath? (syntax spath)) - (syntax-error 'compound-unit/sig expr - "bad `open' sub-clause of `export'" - export)) - (flatten-path 'export - (syntax spath) - (lambda (base var var-nopath) - (syntax-error - 'compound-unit/sig expr - "`open' sub-clause path is a variable" - (car export))) - (lambda (base last name sig) - (if base - (make-sig-explode-pair - (signature-elems sig) - (cons base - (map - list - (flatten-signature name sig) - (flatten-signature #f sig)))) - (syntax-error - 'compound-unit/sig expr - "cannot export imported variables" - export)))))] - [(var upath vname . exname) - (let ([upath (syntax upath)] - [vname (syntax vname)] - [exname (syntax exname)]) - (unless (and (upath? upath) - (identifier? vname) - (or (stx-null? exname) - (and (stx-pair? exname) - (identifier? (stx-car exname)) - (stx-null? (stx-cdr exname))))) - (syntax-error 'compound-unit/sig expr - "bad `var' sub-clause of `export'" - export)) - (flatten-path 'export - (if (identifier? upath) - (list upath vname) - (append (syntax->list upath) (list vname))) - (lambda (base var var-nopath) - (if base - (make-sig-explode-pair - (list (if (stx-null? exname) - var-nopath - (syntax-e (stx-car exname)))) - (list base - (if (stx-null? exname) - (list var var-nopath) - (list var (syntax-e (stx-car exname)))))) - (syntax-error - 'compound-unit/sig expr - "cannot export imported variables" - export))) - (lambda (base last name var) - (syntax-error - 'compound-unit/sig expr - "`var' sub-clause path specifies a unit" - export))))] - [(unit spath . exname) - (let ([spath (syntax spath)] - [exname (syntax exname)]) - (unless (and (spath? spath) - (or (stx-null? exname) - (and (stx-pair? exname) - (identifier? (stx-car exname)) - (stx-null? (stx-cdr exname))))) - (syntax-error 'compound-unit/sig expr - "bad `unit' sub-clause of `export'" - export)) - (flatten-path 'export - spath - (lambda (base var var-nopath) - (syntax-error - 'compound-unit/sig expr - "`unit' sub-clause path is a variable" - export)) - (lambda (base last name sig) - (if base - (make-sig-explode-pair - (list (rename-signature - sig - (if (stx-null? exname) - last - (syntax-e (stx-car exname))))) - (let ([flat (flatten-signature name sig)]) - (cons base - (map - list - flat - (flatten-signature - (symbol->string (if (stx-null? exname) - last - (syntax-e (stx-car exname)))) - sig))))) - (syntax-error - 'compound-unit/sig expr - "cannot export imported variables" - export)))))] - [_else - (syntax-error 'compound-unit/sig expr - (format - "bad `export' sub-clause") - export)])) - export-list)]) - (check-unique (map - (lambda (s) - (if (signature? s) - (signature-name s) - s)) - (apply - append - (map sig-explode-pair-sigpart exports))) - (lambda (name) - (syntax-error 'compound-unit/sig expr - (format - "the name \"~s\" is exported twice" - name)))) - (datum->syntax - `(let ,(map - (lambda (link) - (list (link-name link) - (link-expr link))) - links) - (verify-linkage-signature-match - (quote ,'compound-unit/sig) - (quote ,(map link-name links)) - (list ,@(map link-name links)) - (quote ,(map (lambda (link) (explode-sig (link-sig link))) links)) - (quote ,(map - (lambda (link) - (map (lambda (sep) - (explode-named-sig (sig-explode-pair-sigpart sep))) - (link-links link))) - links))) - ; All checks done. Make the unit: - (make-unit-with-signature - (compound-unit - (import ,@(flatten-signatures - imports)) - (link ,@(map - (lambda (link) - (list (link-name link) - (cons `(unit-with-signature-unit - ,(link-name link)) - (apply - append - (map - sig-explode-pair-exploded - (link-links link)))))) - links)) - (export ,@(map sig-explode-pair-exploded exports))) - (quote ,(explode-named-sigs imports)) - (quote ,(explode-sig - (make-signature - 'dummy - 'dummy - (apply - append - (map sig-explode-pair-sigpart exports))))))) - (quote-syntax here) - expr)))))]))) - + (check-unique (map link-name links) + (lambda (name) + (syntax-error 'compound-unit/sig expr + (format "duplicate sub-unit tag \"~s\"" name)))) + (check-unique (map signature-name imports) + (lambda (name) + (syntax-error 'compound-unit/sig expr + (format "duplicate import identifier \"~s\"" name)))) + (check-unique (append (map signature-name imports) + (map link-name links)) + (lambda (name) + (syntax-error 'compound-unit/sig expr + (format + "name \"~s\" is both import and sub-unit identifier" + name)))) + ;; Expand `link' clause using signatures + (for-each + (lambda (link) + (set-link-links! + link + (map + (lambda (link) + (flatten-path 'link link + (lambda (base var var-nopath) + (make-sig-explode-pair + var + (list + (if base + (list base var) + var)))) + (lambda (base last id sig) + (make-sig-explode-pair + (rename-signature sig last) + (if base + (list (cons base (flatten-signature id sig))) + (flatten-signature id sig)))))) + (link-links link)))) + links) + (let ([export-list (syntax->list (syntax exports))]) + (unless export-list + (syntax-error 'compound-unit/sig expr + "improper `export' clause form" + (syntax exports))) + (let* ([upath? (lambda (p) + (or (identifier? p) + (and (stx-list? p) + (andmap identifier? (stx->list p)))))] + [spath? (lambda (p) + (syntax-case p () + [(name : sig) + (and (literal? :) + (upath? (syntax name)) + (or (identifier? (syntax sig)) + (parse-signature 'compound-unit/sig expr #f (syntax sig)))) + #t] + [_else + (upath? p)]))] + [exports + (map + (lambda (export) + (syntax-case export () + [(open spath) + (literal? open) + (begin + (unless (spath? (syntax spath)) + (syntax-error 'compound-unit/sig expr + "bad `open' sub-clause of `export'" + export)) + (flatten-path 'export + (syntax spath) + (lambda (base var var-nopath) + (syntax-error + 'compound-unit/sig expr + "`open' sub-clause path is a variable" + (car export))) + (lambda (base last name sig) + (if base + (make-sig-explode-pair + (signature-elems sig) + (cons base + (map + list + (flatten-signature name sig) + (flatten-signature #f sig)))) + (syntax-error + 'compound-unit/sig expr + "cannot export imported variables" + export)))))] + [(var (upath vname) . exname) + (literal? var) + (let ([upath (syntax upath)] + [vname (syntax vname)] + [exname (syntax exname)]) + (unless (and (upath? upath) + (identifier? vname) + (or (stx-null? exname) + (and (stx-pair? exname) + (identifier? (stx-car exname)) + (stx-null? (stx-cdr exname))))) + (syntax-error 'compound-unit/sig expr + "bad `var' sub-clause of `export'" + export)) + (flatten-path 'export + (if (identifier? upath) + (list upath vname) + (append (stx->list upath) (list vname))) + (lambda (base var var-nopath) + (if base + (make-sig-explode-pair + (list (if (stx-null? exname) + var-nopath + (syntax-e (stx-car exname)))) + (list base + (if (stx-null? exname) + (list var var-nopath) + (list var (syntax-e (stx-car exname)))))) + (syntax-error + 'compound-unit/sig expr + "cannot export imported variables" + export))) + (lambda (base last name var) + (syntax-error + 'compound-unit/sig expr + "`var' sub-clause path specifies a unit" + export))))] + [(unit spath . exname) + (literal? unit) + (let ([spath (syntax spath)] + [exname (syntax exname)]) + (unless (and (spath? spath) + (or (stx-null? exname) + (and (stx-pair? exname) + (identifier? (stx-car exname)) + (stx-null? (stx-cdr exname))))) + (syntax-error 'compound-unit/sig expr + "bad `unit' sub-clause of `export'" + export)) + (flatten-path 'export + spath + (lambda (base var var-nopath) + (syntax-error + 'compound-unit/sig expr + "`unit' sub-clause path is a variable" + export)) + (lambda (base last name sig) + (if base + (make-sig-explode-pair + (list (rename-signature + sig + (if (stx-null? exname) + last + (syntax-e (stx-car exname))))) + (let ([flat (flatten-signature name sig)]) + (cons base + (map + list + flat + (flatten-signature + (symbol->string (if (stx-null? exname) + last + (syntax-e (stx-car exname)))) + sig))))) + (syntax-error + 'compound-unit/sig expr + "cannot export imported variables" + export)))))] + [_else + (syntax-error 'compound-unit/sig expr + (format + "bad `export' sub-clause") + export)])) + export-list)]) + (check-unique (map + (lambda (s) + (if (signature? s) + (signature-name s) + s)) + (apply + append + (map sig-explode-pair-sigpart exports))) + (lambda (name) + (syntax-error 'compound-unit/sig expr + (format + "the name \"~s\" is exported twice" + name)))) + (values (map link-name links) + (map link-expr links) + (map (lambda (link) (explode-sig (link-sig link))) links) + (map + (lambda (link) + (map (lambda (sep) + (explode-named-sig (sig-explode-pair-sigpart sep))) + (link-links link))) + links) + (flatten-signatures imports) + (map (lambda (link) + (apply + append + (map + sig-explode-pair-exploded + (link-links link)))) + links) + (map sig-explode-pair-exploded exports) + (explode-named-sigs imports) + (explode-sig + (make-signature + 'dummy + 'dummy + (apply + append + (map sig-explode-pair-sigpart exports))))))))))] + [_else (raise-syntax-error + 'compound-unit/sig + "bad syntax" + expr)]))) + (define parse-invoke-vars (lambda (who rest expr) (parse-imports who #t #f expr rest))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (export parse-unit + parse-compound-unit + parse-invoke-vars + + parse-unit-renames + parse-unit-imports + parse-unit-body + + signature-vars + do-rename + get-sig + explode-sig + explode-named-sigs + check-signature-unit-body + flatten-signatures)) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index c7bbec0..1533de0 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -414,6 +414,14 @@ "duplicate import" stx dup))) + ;; Check for duplicate tags + (let ([dup (check-duplicate-identifier tags)]) + (when dup + (raise-syntax-error + 'compound-unit + "duplicate tag" + stx + dup))) ;; Check referenced imports and tags (let ([check-linkage-refs (lambda (v) (syntax-case v () @@ -463,7 +471,7 @@ [id e])) (syntax->list (syntax exs)))])) exports))]) - (let ([dup (check-duplicate-identifier exports)]) + (let ([dup (check-duplicate-identifier export-names)]) (when dup (raise-syntax-error 'compound-unit @@ -543,7 +551,7 @@ ht (syntax-e (syntax-case e () - [(iid eid) (syntax id)] + [(iid eid) (syntax iid)] [id e])))]) (with-syntax ([ex-poss ex-poss] [setup setup] @@ -600,6 +608,7 @@ (let ([unit-setup ((unit-go constituent))] ...) (list (vector . export-mapping) (lambda (ivar ...) + (void) ;; in case there are no units ((list-ref unit-setup 1) . import-mapping) ...))))))))))))))))]))) diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss index c023677..07d7195 100644 --- a/collects/mzlib/unitsig.ss +++ b/collects/mzlib/unitsig.ss @@ -1,17 +1,20 @@ -(module signedunit mzscheme +(module unitsig mzscheme + (import "exstruct.ss") (import "unit.ss") - (import "sigutils.ss") - - ; Transform time: - (define-struct sig (content)) - + (import "sigmatch.ss") + + (import-for-syntax "sigutils.ss") + (import-for-syntax "sigmatch.ss") + + (define-struct/export unit/sig (unit imports exports)) + (define-syntax define-signature (lambda (expr) (syntax-case expr () [(_ name sig) (identifier? (syntax name)) - (let ([sig (get-sig d-s expr (syntax-e (syntax name)) + (let ([sig (get-sig 'define-signature expr (syntax-e (syntax name)) (syntax sig))]) (with-syntax ([content (explode-sig sig)]) (syntax (define-syntax name @@ -33,20 +36,49 @@ (syntax-case expr () [(_ sig . rest) (let ([sig (get-sig 'unit/sig expr #f (syntax sig))]) - (let ([a-unit (parse-unit expr (syntax rest) sig)]) + (let ([a-unit (parse-unit expr (syntax rest) sig + (list + ;; Need all kernel syntax + (quote-syntax begin) + (quote-syntax define-values) + (quote-syntax define-syntax) + (quote-syntax set!) + (quote-syntax let) + (quote-syntax let-values) + (quote-syntax let*) + (quote-syntax let*-values) + (quote-syntax letrec) + (quote-syntax letrec-values) + (quote-syntax lambda) + (quote-syntax case-lambda) + (quote-syntax if) + (quote-syntax struct) + (quote-syntax quote) + (quote-syntax letrec-syntax) + (quote-syntax with-continuation-mark) + (quote-syntax #%app) + (quote-syntax #%unbound) + (quote-syntax #%datum) + (quote-syntax include)) ;; special to unit/sig + (quote-syntax define-values) + (quote-syntax begin) + (quote-syntax include))]) (check-signature-unit-body sig a-unit (parse-unit-renames a-unit) 'unit/sig expr) - (with-syntax ([imports (flatten-signatures - (parse-unit-imports a-unit))] - [exports (map - (lambda (name) - (list (do-rename name (parse-unit-renames a-unit)) - name)) - (signature-vars sig))] + (with-syntax ([imports (datum->syntax + (flatten-signatures (parse-unit-imports a-unit)) + expr expr)] + [exports (datum->syntax + (map + (lambda (name) + (list (do-rename name (parse-unit-renames a-unit)) + name)) + (signature-vars sig)) + expr expr)] [body (reverse! (parse-unit-body a-unit))] [import-sigs (explode-named-sigs (parse-unit-imports a-unit))] [export-sig (explode-sig sig)]) (syntax - (make-unit-with-signature + (make-unit/sig (unit (import . imports) (export . exports) @@ -58,27 +90,67 @@ (lambda (expr) (syntax-case expr () [(_ . body) - (parse-compound-unit expr (syntax body))]))) + (let-values ([(tags + exprs + exploded-link-imports + exploded-link-exports + flat-imports + link-imports + flat-exports + exploded-imports + exploded-exports) + (parse-compound-unit expr (syntax body))] + [(t) (lambda (l) (datum->syntax l expr (quote-syntax here)))]) + (with-syntax ([(tag ...) (t tags)] + [(uexpr ...) (t exprs)] + [(tagx ...) (t (map (lambda (t) (string->symbol (format "u:~a" t))) tags))] + [exploded-link-imports (t exploded-link-imports)] + [exploded-link-exports (t exploded-link-exports)] + [flat-imports (t flat-imports)] + [(link-import ...) (t link-imports)] + [flat-exports (t flat-exports)] + [exploded-imports (t exploded-imports)] + [exploded-exports (t exploded-exports)]) + (syntax/loc + expr + (let ([tagx uexpr] ...) + (verify-linkage-signature-match + 'compound-unit/sig + '(tag ...) + (list tagx ...) + 'exploded-link-imports + 'exploded-link-exports) + ;; All checks done. Make the unit: + (make-unit/sig + (compound-unit + (import . flat-imports) + (link [tag ((unit/sig-unit tagx) + . link-import)] + ...) + (export . flat-exports)) + 'exploded-imports + 'exploded-exports)))))]))) (define-syntax invoke-unit/sig (lambda (expr) (syntax-case expr () [(_ u sig ...) - (let ([u (syntax u)] - [sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)]) - (datum->syntax - `(let ([u ,u]) - (verify-linkage-signature-match - (quote invoke-unit/sig) - (quote (invoke)) - (list u) - (quote (#())) - (quote (,(explode-named-sigs sigs)))) - (invoke-unit (unit-with-signature-unit u) - ,@(flatten-signatures - sigs))) - (quote-syntax here) - expr))]))) + (let ([sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)]) + (with-syntax ([exploded-sigs (datum->syntax (explode-named-sigs sigs) + expr (quote-syntax here))] + [flat-sigs (datum->syntax (flatten-signatures sigs) + expr (quote-syntax here))]) + (syntax/loc + expr + (let ([unt u]) + (verify-linkage-signature-match + (quote invoke-unit/sig) + (quote (invoke)) + (list unt) + (quote (#())) + (quote (exploded-sigs))) + (invoke-unit (unit/sig-unit u) + . flat-sigs)))))]))) (define-syntax unit->unit/sig (lambda (expr) @@ -89,13 +161,15 @@ (get-sig 'unit->unit/sig expr #f sig)) (syntax->list (syntax (im-sig ...))))] [ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig))]) - (datum->syntax - `(make-unit-with-signature - ,e - (quote ,(explode-named-sigs im-sigs)) - (quote ,(explode-sig ex-sig))) - (quote-syntax here) - expr))]))) + (with-syntax ([exploded-imports (datum->syntax (explode-named-sigs im-sigs) + expr (quote-syntax here))] + [exploded-exports (datum->syntax (explode-sig ex-sig) + expr (quote-syntax here))]) + (syntax + (make-unit/sig + e + (quote exploded-imports) + (quote exploded-exports)))))]))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -105,7 +179,7 @@ (lambda (who tags units esigs isigs) (for-each (lambda (u tag) - (unless (unit-with-signature? u) + (unless (unit/sig? u) (raise (make-exn (string->immutable-string @@ -121,11 +195,11 @@ (format "specified export signature for ~a" tag) esig (format "export signature for actual ~a sub-unit" tag) - (unit-with-signature-exports u))) + (unit/sig-exports u))) units tags esigs) (for-each (lambda (u tag isig) - (let ([n (length (unit-with-signature-imports u))] + (let ([n (length (unit/sig-imports u))] [c (length isig)]) (unless (= c n) (raise @@ -138,7 +212,7 @@ units tags isigs) (for-each (lambda (u tag isig) - (let loop ([isig isig][expecteds (unit-with-signature-imports u)][pos 1]) + (let loop ([isig isig][expecteds (unit/sig-imports u)][pos 1]) (unless (null? isig) (let ([expected (car expecteds)] [provided (car isig)]) @@ -156,133 +230,6 @@ (loop (cdr isig) (cdr expecteds) (add1 pos)))))) units tags isigs)))) - (define (hash-sig src-sig table) - (and (vector? src-sig) - (andmap - (lambda (s) - (cond - [(symbol? s) - (if (hash-table-get table s (lambda () #f)) - #f - (begin - (hash-table-put! table s s) - #t))] - [(and (pair? s) (symbol? (car s))) - (let ([name (car s)]) - (if (hash-table-get table name (lambda () #f)) - #f - (let ([t (make-hash-table)]) - (hash-table-put! table name t) - (hash-sig (cdr s) t))))] - [else #f])) - (vector->list src-sig)))) - - (define (sig-path-name name path) - (let loop ([s (symbol->string name)] - [path path]) - (if (null? path) - s - (loop (format "~a:~a" s (car path)) - (cdr path))))) - - (define (check-sig-match table sig path exact? who src-context dest-context) - (and (vector? sig) - (andmap - (lambda (s) - (cond - [(symbol? s) - (let ([v (hash-table-get table s - (lambda () - (raise - (make-exn:unit - (format - "~a: ~a is missing a value name `~a', required by ~a", - who - src-context - (sig-name-path s path) - dest-context) - (current-continuation-marks)))))]) - (and v - (begin - (unless (symbol? v) - (let ([p (sig-name-path s path)]) - (raise - (make-exn:unit - (format - "~a: ~a contains `~a' as a sub-unit name, but ~a contains `~a' as a value name" - who - src-context - p - dest-context - p) - (current-continuation-marks))))) - (hash-table-put! table s #f) - #t)))] - [(and (pair? s) (symbol? (car s))) - (let ([v (hash-table-get table (car s) - (lambda () - (raise - (make-exn:unit - (format - "~a: ~a is missing a sub-unit name `~a', required by ~a", - who - src-context - (sig-name-path s path) - dest-context) - (current-continuation-marks)))))]) - (and v - (begin - (unless (hash-table? v) - (let ([p (sig-name-path (car s) path)]) - (raise - (make-exn:unit - (format - "~a: ~a contains `~a' as a value name, but ~a contains `~a' as a sub-unit name" - who - src-context - p - dest-context - p) - (current-continuation-marks))))) - (hash-table-put! table (car s) #f) - (chec-sig-match v (cdr s) (cons (car s) path) - exact? who src-context dest-context))))] - [else #f])) - (vector->list sig)) - (or (not exact?) - (hash-table-for-each - table - (lambda (k v) - (when v - (let ([p (sig-name-path k path)]) - (raise - (make-exn:unit - (format - "~a: ~a contains an extra ~a name `~a' that is not required by ~a" - who - src-context - (if (symbol? v) 'value 'sub-unit) - p - dest-context) - (current-continuation-marks))))))) - #t))) - - (define (verify-signature-match who exact? dest-context dest-sig src-context src-sig) - (unless (symbol? who) - (raise-type-error 'verify-signature-match "symbol" who)) - (unless (string? dest-context) - (raise-type-error 'verify-signature-match "string" dest-context)) - (unless (string? src-context) - (raise-type-error 'verify-signature-match "string" src-context)) - - (let ([src-table (make-hash-table)]) - (unless (hash_sig src-sig, src-table) - (raise-type-error 'verify-signature-match "signature" src-sig)) - - (unless (check-sig-match src-table dest-sig null - exact? who src-context dest-context) - (raise-type-error 'verify-signature-match "signature" dest-sig)))) - (export-indirect verify-linkage-signature-match) (export define-signature diff --git a/collects/tests/mzscheme/unit.ss b/collects/tests/mzscheme/unit.ss index 6eeb63b..a40d7b6 100644 --- a/collects/tests/mzscheme/unit.ss +++ b/collects/tests/mzscheme/unit.ss @@ -130,6 +130,7 @@ (syntax-test #'(compound-unit (import) (link (a (b))) (export (a (x))))) (syntax-test #'(compound-unit (import) (link (a (b))) (export (1 w)))) +(test unit? (compound-unit (import) (link) (export))) ; Simple: diff --git a/collects/tests/mzscheme/unitsig.ss b/collects/tests/mzscheme/unitsig.ss index b7de5d5..5322ecc 100644 --- a/collects/tests/mzscheme/unitsig.ss +++ b/collects/tests/mzscheme/unitsig.ss @@ -2,60 +2,60 @@ (if (not (defined? 'SECTION)) (load-relative "testing.ss")) +(import (lib "unit.ss")) +(import (lib "unitsig.ss")) + (SECTION 'unit/sig) -(undefine 'a) -(undefine 'b) - -(syntax-test '(define-signature)) -(syntax-test '(define-signature)) -(syntax-test '(define-signature 8)) -(syntax-test '(define-signature . x)) -(syntax-test '(define-signature x)) -(syntax-test '(define-signature 8)) -(syntax-test '(define-signature x (8))) -(syntax-test '(define-signature x (a . 8))) -(syntax-test '(define-signature x (a . y))) -(syntax-test '(define-signature x (y y))) -(syntax-test '(define-signature x ((y)))) -(syntax-test '(define-signature x ((struct)))) -(syntax-test '(define-signature x ((struct y)))) -(syntax-test '(define-signature x ((struct . y)))) -(syntax-test '(define-signature x ((struct y . x)))) -(syntax-test '(define-signature x ((struct y x)))) -(syntax-test '(define-signature x ((struct y (x)) . x))) -(syntax-test '(define-signature x ((unit)))) -(syntax-test '(define-signature x ((unit y)))) -(syntax-test '(define-signature x ((unit . y)))) -(syntax-test '(define-signature x ((unit y : a)))) +(syntax-test #'(define-signature)) +(syntax-test #'(define-signature)) +(syntax-test #'(define-signature 8)) +(syntax-test #'(define-signature . x)) +(syntax-test #'(define-signature x)) +(syntax-test #'(define-signature 8)) +(syntax-test #'(define-signature x (8))) +(syntax-test #'(define-signature x (a . 8))) +(syntax-test #'(define-signature x (a . y))) +(syntax-test #'(define-signature x (y y))) +(syntax-test #'(define-signature x ((y)))) +(syntax-test #'(define-signature x ((struct)))) +(syntax-test #'(define-signature x ((struct y)))) +(syntax-test #'(define-signature x ((struct . y)))) +(syntax-test #'(define-signature x ((struct y . x)))) +(syntax-test #'(define-signature x ((struct y x)))) +(syntax-test #'(define-signature x ((struct y (x)) . x))) +(syntax-test #'(define-signature x ((unit)))) +(syntax-test #'(define-signature x ((unit y)))) +(syntax-test #'(define-signature x ((unit . y)))) +(syntax-test #'(define-signature x ((unit y : a)))) (define-signature a ()) -(syntax-test '(define-signature x ((unit y a)))) -(syntax-test '(define-signature x ((unit y . a)))) -(syntax-test '(define-signature x ((unit y : . a)))) -(syntax-test '(define-signature x ((unit y a) . x))) -(syntax-test '(define-signature x (y (unit y a)))) +(syntax-test #'(define-signature x ((unit y a)))) +(syntax-test #'(define-signature x ((unit y . a)))) +(syntax-test #'(define-signature x ((unit y : . a)))) +(syntax-test #'(define-signature x ((unit y a) . x))) +(syntax-test #'(define-signature x (y (unit y a)))) -(syntax-test '(unit/sig)) -(syntax-test '(unit/sig 8)) -(syntax-test '(unit/sig b)) +(syntax-test #'(unit/sig)) +(syntax-test #'(unit/sig 8)) +(syntax-test #'(unit/sig b)) (define-signature b (x y)) -(syntax-test '(unit/sig (a))) -(syntax-test '(unit/sig a (impLort))) -(syntax-test '(unit/sig a (impLort) 5)) -(syntax-test '(unit/sig a import 5)) -(syntax-test '(unit/sig a (import . x) . 5)) -(syntax-test '(unit/sig a (import (x) 8) 5)) -(syntax-test '(unit/sig a (import (x) . i) 5)) -(syntax-test '(unit/sig a (import (i : a) . b) 5)) -(syntax-test '(unit/sig b (import (i : a)) 5)) -(syntax-test '(unit/sig a (import (i : a x)) 5)) -(syntax-test '(unit/sig a (import (i : a) x) 5)) -(syntax-test '(unit/sig b (import (i : a)) (define x 7))) -(syntax-test '(unit/sig b (import (i : a)) (define x 7) (define i:y 6))) -(syntax-test '(unit/sig blah (import) (define x 7))) +(syntax-test #'(unit/sig (a))) +(syntax-test #'(unit/sig a (impLort))) +(syntax-test #'(unit/sig a (impLort) 5)) +(syntax-test #'(unit/sig a import 5)) +(syntax-test #'(unit/sig a (import . x) . 5)) +(syntax-test #'(unit/sig a (import (x) 8) 5)) +(syntax-test #'(unit/sig a (import (x) . i) 5)) +(syntax-test #'(unit/sig a (import (i : a) . b) 5)) +(syntax-test #'(unit/sig b (import (i : a)) 5)) +(syntax-test #'(unit/sig a (import (i : a x)) 5)) +(syntax-test #'(unit/sig a (import (i : a) x) 5)) +(syntax-test #'(unit/sig b (import (i : a)) (define x 7))) +(syntax-test #'(unit/sig b (import (i : a)) (define x 7) (define i:y 6))) +(syntax-test #'(unit/sig blah (import) (define x 7))) -(syntax-test '(unit/sig () (import) (begin 1 . 2))) -(syntax-test '(unit/sig () (import) (begin (define x 5)) (define x 5))) +(syntax-test #'(unit/sig () (import) (begin 1 . 2))) +(syntax-test #'(unit/sig () (import) (begin (define x 5)) (define x 5))) (define b@ (unit/sig b (import) (define x 9) (define y 9))) (define b2@ (unit/sig b (import (i : a)) (define x 9) (define y 9))) @@ -67,61 +67,61 @@ (define >b@ (compound-unit/sig (import) (link [b@ : b (b@)]) (export (unit b@)))) -(syntax-test '(compound-unit/sig)) -(syntax-test '(compound-unit/sig 8)) -(syntax-test '(compound-unit/sig b)) -(syntax-test '(compound-unit/sig (import) (link) (export (var (U x))))) -(syntax-test '(compound-unit/sig (import a) (link) (export))) -(syntax-test '(compound-unit/sig (import 5) (link) (export))) -(syntax-test '(compound-unit/sig (import . i) (link) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link ()) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@)) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ b)) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b)) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b ())) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ 5))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ . i))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i . a)))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i a a)))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ c@))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (c@ a)))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export . b@))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export b@))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit)))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit c@)))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : c)))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ (b@))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : (b@))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var)))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open)))) -(error-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i : a)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : a)) (link (b@ : b (5 (i : a)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3@ (i : b)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3u@ (i : b)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3u2@ (i : b)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : >b)) (link (b@ : b (b3@ (i : >b)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : ((open a) x))) (link (b@ : b (b3@ (i : ((open a) x))))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : ((unit b@ : ((open b) w))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : a)) (link (b@ : (w) (b@))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : ())) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : ((unit b@ : ())))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : (b@))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : ((unit b@ : (x (unit y : ())))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) -(syntax-test '(compound-unit/sig (import) (link [b@ : b (0 5)]) (export))) -(syntax-test '(compound-unit/sig (import) (link [b@ : b (0 ())]) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : a (5 (i : b)))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var b@)))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x y))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (5 x))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ 5))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ w) 5))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ 7) 5))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x . a))))) +(syntax-test #'(compound-unit/sig)) +(syntax-test #'(compound-unit/sig 8)) +(syntax-test #'(compound-unit/sig b)) +(syntax-test #'(compound-unit/sig (import) (link) (export (var (U x))))) +(syntax-test #'(compound-unit/sig (import a) (link) (export))) +(syntax-test #'(compound-unit/sig (import 5) (link) (export))) +(syntax-test #'(compound-unit/sig (import . i) (link) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link ()) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@)) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ b)) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b)) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b ())) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ 5))) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ . i))) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i . a)))) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i a a)))) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ c@))) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (c@ a)))) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export . b@))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export b@))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit)))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit c@)))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : c)))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ (b@))))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : (b@))))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var)))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open)))) +(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i : a)))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (5 (i : a)))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3@ (i : b)))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3u@ (i : b)))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3u2@ (i : b)))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : >b)) (link (b@ : b (b3@ (i : >b)))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : ((open a) x))) (link (b@ : b (b3@ (i : ((open a) x))))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : ((unit b@ : ((open b) w))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : (w) (b@))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : ())) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : ((unit b@ : ())))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : (b@))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) +(error-test #'(compound-unit/sig (import (i : ((unit b@ : (x (unit y : ())))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) +(syntax-test #'(compound-unit/sig (import) (link [b@ : b (0 5)]) (export))) +(syntax-test #'(compound-unit/sig (import) (link [b@ : b (0 ())]) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : a (5 (i : b)))) (export))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var b@)))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@))))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x y))))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (5 x))))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ 5))))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ w) 5))))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ 7) 5))))) +(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x . a))))) ; Self-import is now allowed -; (syntax-test '(compound-unit/sig (import) (link (A : () (0 A))) (export))) ; self-import -; (syntax-test '(compound-unit/sig (import) (link (A : (x) (0 A))) (export))) ; self-import +; (syntax-test #'(compound-unit/sig (import) (link (A : () (0 A))) (export))) ; self-import +; (syntax-test #'(compound-unit/sig (import) (link (A : (x) (0 A))) (export))) ; self-import (test (list (letrec ([x x]) x) 5) 'self-import (invoke-unit/sig @@ -132,7 +132,7 @@ (export)))) (define-signature not-defined^ (not-defined)) -(error-test '(invoke-unit/sig (unit/sig () (import not-defined^) 10) not-defined^) exn:unit?) +(error-test #'(invoke-unit/sig (unit/sig () (import not-defined^) 10) not-defined^) exn:unit?) (test #t unit/sig? (unit/sig a (import))) (test #t unit/sig? (unit/sig b (import) (define x 1) (define y 2)))