From e19d7a7128bb8b3b5b30aa1009efd4bdc3e47b45 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 8 Jan 2010 21:44:42 +0000 Subject: [PATCH] Moving unit system from mzscheme->scheme/base, reformatting and small changes as necessary. Ran the quiet testsuite, unit tests, and setup-plt, all good. svn: r17582 original commit: 73d68593af6b7c3a389013527f9b2a46618d1642 --- collects/mzlib/private/unitidmap.ss | 63 +- collects/mzlib/unit-exptime.ss | 47 +- collects/mzlib/unit.ss | 3763 +++++++++++++-------------- 3 files changed, 1936 insertions(+), 1937 deletions(-) diff --git a/collects/mzlib/private/unitidmap.ss b/collects/mzlib/private/unitidmap.ss index 718ba07..4eb5907 100644 --- a/collects/mzlib/private/unitidmap.ss +++ b/collects/mzlib/private/unitidmap.ss @@ -1,36 +1,35 @@ +#lang scheme/base -(module unitidmap mzscheme +;; Help Desk binding info: +(define (binding binder bound stx) + stx + ;; This 'bound-in-source is no longer needed + #; + (syntax-property + stx + 'bound-in-source + (cons binder (syntax-local-introduce bound)))) - ;; Help Desk binding info: - (define (binding binder bound stx) - stx - ;; This 'bound-in-source is no longer needed - #; - (syntax-property - stx - 'bound-in-source - (cons binder (syntax-local-introduce bound)))) +(define (make-id-mapper unbox-stx the-binder) + (let ([set!-stx (datum->syntax unbox-stx 'set! #f)]) + (make-set!-transformer + (lambda (sstx) + (cond + [(identifier? sstx) + (binding the-binder sstx + unbox-stx)] + [(free-identifier=? set!-stx (car (syntax-e sstx))) + (raise-syntax-error + 'unit + "cannot set! imported or exported variables" + sstx)] + [else + (binding + the-binder (car (syntax-e sstx)) + (datum->syntax + sstx + (cons unbox-stx (cdr (syntax-e sstx))) + sstx))]))))) - (define (make-id-mapper unbox-stx the-binder) - (let ([set!-stx (datum->syntax-object unbox-stx 'set! #f)]) - (make-set!-transformer - (lambda (sstx) - (cond - [(identifier? sstx) - (binding the-binder sstx - unbox-stx)] - [(module-identifier=? set!-stx (car (syntax-e sstx))) - (raise-syntax-error - 'unit - "cannot set! imported or exported variables" - sstx)] - [else - (binding - the-binder (car (syntax-e sstx)) - (datum->syntax-object - sstx - (cons unbox-stx (cdr (syntax-e sstx))) - sstx))]))))) - - (provide make-id-mapper)) +(provide make-id-mapper) diff --git a/collects/mzlib/unit-exptime.ss b/collects/mzlib/unit-exptime.ss index 9451f60..77f1a88 100644 --- a/collects/mzlib/unit-exptime.ss +++ b/collects/mzlib/unit-exptime.ss @@ -1,26 +1,27 @@ -(module unit-exptime mzscheme - (require "private/unit-syntax.ss" - "private/unit-compiletime.ss") +#lang scheme/base - (provide unit-static-signatures - signature-members) +(require "private/unit-syntax.ss" + "private/unit-compiletime.ss") - (define (unit-static-signatures name err-stx) - (parameterize ((error-syntax err-stx)) - (let ((ui (lookup-def-unit name))) - (values (apply list (unit-info-import-sig-ids ui)) - (apply list (unit-info-export-sig-ids ui)))))) +(provide unit-static-signatures + signature-members) - (define (signature-members name err-stx) - (parameterize ((error-syntax err-stx)) - (let ([s (lookup-signature name)]) - (values - ;; extends: - (and (pair? (cdr (siginfo-names (signature-siginfo s)))) - (cadr (siginfo-names (signature-siginfo s)))) - ;; vars - (apply list (signature-vars s)) - ;; defined vars - (apply list (apply append (map car (signature-val-defs s)))) - ;; defined stxs - (apply list (apply append (map car (signature-stx-defs s))))))))) +(define (unit-static-signatures name err-stx) + (parameterize ((error-syntax err-stx)) + (let ((ui (lookup-def-unit name))) + (values (apply list (unit-info-import-sig-ids ui)) + (apply list (unit-info-export-sig-ids ui)))))) + +(define (signature-members name err-stx) + (parameterize ((error-syntax err-stx)) + (let ([s (lookup-signature name)]) + (values + ;; extends: + (and (pair? (cdr (siginfo-names (signature-siginfo s)))) + (cadr (siginfo-names (signature-siginfo s)))) + ;; vars + (apply list (signature-vars s)) + ;; defined vars + (apply list (apply append (map car (signature-val-defs s)))) + ;; defined stxs + (apply list (apply append (map car (signature-stx-defs s)))))))) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 8375b87..64a77d6 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -1,1937 +1,1936 @@ -(module unit mzscheme - (require-for-syntax mzlib/list - syntax/boundmap - syntax/context - syntax/kerncase - syntax/name - syntax/parse - syntax/struct - syntax/stx - "private/unit-contract-syntax.ss" - "private/unit-compiletime.ss" - "private/unit-syntax.ss") - - (require mzlib/etc - mzlib/contract - mzlib/stxparam - "private/unit-contract.ss" - "private/unit-keywords.ss" - "private/unit-runtime.ss" - "private/unit-utils.ss") - - (provide define-signature-form struct struct/ctc open - define-signature provide-signature-elements - only except rename import export prefix link tag init-depend extends contracted - unit? - (rename :unit unit) define-unit - compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer - invoke-unit define-values/invoke-unit - invoke-unit/infer define-values/invoke-unit/infer - unit-from-context define-unit-from-context - define-unit-binding - unit/new-import-export define-unit/new-import-export - unit/s define-unit/s - unit/c define-unit/contract) - - (define-syntax/err-param (define-signature-form stx) - (syntax-case stx () - ((_ (name arg) . val) - (begin - (check-id #'name) - (check-id #'arg) - #'(define-syntax name - (make-set!-transformer - (make-signature-form (λ (arg) . val)))))) - ((_ . l) - (let ((l (checked-syntax->list stx))) - (unless (>= 3 (length l)) - (raise-stx-err - (format "expected syntax matching (~a (id id) expr ...)" - (syntax-e (stx-car stx))))) - (unless (= 2 (length (checked-syntax->list (car l)))) - (raise-stx-err - "expected syntax matching (identifier identifier)" - (car l))))))) - - (define-signature-form (struct stx) - (parameterize ((error-syntax stx)) - (syntax-case stx () - ((_ name (field ...) . omissions) - (let ([omit-selectors #f] - [omit-setters #f] - [omit-constructor #f] - [omit-type #f]) - (define (remove-ctor&type-name l) - (cond - ((and omit-constructor omit-type) - (cddr l)) - (omit-type - (cdr l)) - (omit-constructor - (cons (car l) (cddr l))) - (else - l))) - (define (remove-ctor&type-info l) - (define new-type - (if omit-type - #f - (cadr l))) - (define new-ctor - (if omit-constructor - #f - (caddr l))) - (cons (car l) - (cons new-type - (cons new-ctor - (cdddr l))))) - (check-id #'name) - (for-each check-id (syntax->list #'(field ...))) - (for-each - (lambda (omission) - (cond - ((and (identifier? omission) - (module-identifier=? omission #'-selectors)) - (set! omit-selectors #t)) - ((and (identifier? omission) - (module-identifier=? omission #'-setters)) - (set! omit-setters #t)) - ((and (identifier? omission) - (module-identifier=? omission #'-constructor)) - (set! omit-constructor #t)) - ((and (identifier? omission) - (module-identifier=? omission #'-type)) - (set! omit-type #t)) - (else - (raise-stx-err - "expected \"-selectors\" or \"-setters\" or \"-constructor\" or \"-type\"" - omission)))) - (checked-syntax->list #'omissions)) - (cons - #`(define-syntaxes (name) - #,(remove-ctor&type-info - (build-struct-expand-info - #'name (syntax->list #'(field ...)) - omit-selectors omit-setters - #f '(#f) '(#f)))) - (remove-ctor&type-name - (build-struct-names #'name (syntax->list #'(field ...)) - omit-selectors omit-setters #f))))) - ((_ name (x . y) . omissions) - ;; Will fail - (checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))) - ((_ name fields . omissions) - (raise-stx-err "expected syntax matching (identifier ...)" #'fields)) - ((_ name) - (raise-stx-err "missing fields")) - ((_) - (raise-stx-err "missing name and fields"))))) - - (define-signature-form (struct/ctc stx) - (parameterize ((error-syntax stx)) - (syntax-case stx () - ((_ name ([field ctc] ...) . omissions) - (let ([omit-selectors #f] - [omit-setters #f] - [omit-constructor #f] - [omit-type #f]) - (define (remove-ctor&type-info l) - (define new-type - (if omit-type - #f - (cadr l))) - (define new-ctor - (if omit-constructor - #f - (caddr l))) - (cons (car l) - (cons new-type - (cons new-ctor - (cdddr l))))) - (define (add-contracts l) - (let* ([pred (caddr l)] - [ctor-ctc #`(-> ctc ... #,pred)] - [pred-ctc #`(-> any/c boolean?)] - [field-ctcs (apply append - (map (λ (c) - (append (if omit-selectors - null - (list #`(-> #,pred #,c))) - (if omit-setters - null - (list #`(-> #,pred #,c void?))))) - (syntax->list #'(ctc ...))))]) - (list* (car l) - (list (cadr l) ctor-ctc) - (list pred pred-ctc) - (map list (cdddr l) field-ctcs)))) - (check-id #'name) - (for-each check-id (syntax->list #'(field ...))) - (for-each - (lambda (omission) - (cond - ((and (identifier? omission) - (module-identifier=? omission #'-selectors)) - (set! omit-selectors #t)) - ((and (identifier? omission) - (module-identifier=? omission #'-setters)) - (set! omit-setters #t)) - ((and (identifier? omission) - (module-identifier=? omission #'-constructor)) - (set! omit-constructor #t)) - ((and (identifier? omission) - (module-identifier=? omission #'-type)) - (set! omit-type #t)) - (else - (raise-stx-err - "expected \"-selectors\" or \"-setters\" or \"-constructor\" or \"-type\"" - omission)))) - (checked-syntax->list #'omissions)) - (cons - #`(define-syntaxes (name) - #,(remove-ctor&type-info - (build-struct-expand-info - #'name (syntax->list #'(field ...)) - omit-selectors omit-setters - #f '(#f) '(#f)))) - (let* ([res (add-contracts - (build-struct-names #'name (syntax->list #'(field ...)) - omit-selectors omit-setters #f))] - [cpairs (cons 'contracted (if omit-constructor (cddr res) (cdr res)))]) - (if omit-type - (list cpairs) - (list (car res) cpairs)))))) - ((_ name (x . y) . omissions) - ;; Will fail - (checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))) - ((_ name fields . omissions) - (raise-stx-err "expected syntax matching (identifier ...)" #'fields)) - ((_ name) - (raise-stx-err "missing fields")) - ((_) - (raise-stx-err "missing name and fields"))))) +#lang scheme/base +(require (for-syntax scheme/base + scheme/list + syntax/boundmap + syntax/context + syntax/kerncase + syntax/name + syntax/parse + syntax/struct + syntax/stx + "private/unit-contract-syntax.ss" + "private/unit-compiletime.ss" + "private/unit-syntax.ss")) - ;; build-val+macro-defs : sig -> (list syntax-object^3) - (define-for-syntax (build-val+macro-defs sig) - (with-syntax ([(((int-ivar . ext-ivar) ...) - ((((int-vid . ext-vid) ...) . vbody) ...) - ((((int-sid . ext-sid) ...) . sbody) ...) - (cbody ...)) - (map-sig (lambda (x) x) - (make-syntax-introducer) - sig)]) - (list - #'((ext-ivar ... ext-vid ... ... ext-sid ... ...) - (values - (make-rename-transformer - (quote-syntax int-ivar)) ... - (make-rename-transformer - (quote-syntax int-vid)) ... ... - (make-rename-transformer - (quote-syntax int-sid)) ... ...)) - #'(((int-sid ...) sbody) ...) - #'(((int-vid ...) vbody) ...)))) - - - (define-signature-form (open stx) - (define (build-sig-elems sig) - (map (λ (p c) - (if c #`(contracted [#,(car p) #,c]) (car p))) - (car sig) - (cadddr sig))) - (parameterize ([error-syntax stx]) - (syntax-case stx () - ((_ export-spec) - (let ([sig (process-spec #'export-spec)]) - (with-syntax (((sig-elem ...) - (build-sig-elems sig)) - ((renames - (((mac-name ...) mac-body) ...) - (((val-name ...) val-body) ...)) - (build-val+macro-defs sig))) - (syntax->list - #'(sig-elem ... - (define-syntaxes . renames) - (define-syntaxes (mac-name ...) mac-body) ... - (define-values (val-name ...) val-body) ...))))) - (_ - (raise-stx-err (format "must match (~a export-spec)" - (syntax-e (stx-car stx)))))))) - - - (define-for-syntax (introduce-def d) - (cons (map syntax-local-introduce (car d)) - (syntax-local-introduce (cdr d)))) - - ;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object - (define-for-syntax (build-define-signature sigid super-sigid sig-exprs) - (unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs)) - (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs)) - (let ([ses (checked-syntax->list sig-exprs)]) - (define-values (super-names super-ctimes super-rtimes super-bindings - super-val-defs super-stx-defs super-ctcs) - (if super-sigid - (let* ([super-sig (lookup-signature super-sigid)] - [super-siginfo (signature-siginfo super-sig)]) - (values (siginfo-names super-siginfo) - (siginfo-ctime-ids super-siginfo) - (map syntax-local-introduce - (siginfo-rtime-ids super-siginfo)) - (map syntax-local-introduce (signature-vars super-sig)) - (map introduce-def (signature-val-defs super-sig)) - (map introduce-def (signature-stx-defs super-sig)) - (map (lambda (ctc) - (if ctc - (syntax-local-introduce ctc) - ctc)) - (signature-ctcs super-sig)))) - (values '() '() '() '() '() '() '()))) - (let loop ((sig-exprs ses) - (bindings null) - (val-defs null) - (stx-defs null) - (ctcs null)) - (cond - ((null? sig-exprs) - (let* ([all-bindings (append super-bindings (reverse bindings))] - [all-val-defs (append super-val-defs (reverse val-defs))] - [all-stx-defs (append super-stx-defs (reverse stx-defs))] - [all-ctcs (append super-ctcs (reverse ctcs))] - [dup - (check-duplicate-identifier - (append all-bindings - (apply append (map car all-val-defs)) - (apply append (map car all-stx-defs))))]) - (when dup - (raise-stx-err "duplicate identifier" dup)) - (with-syntax (((super-rtime ...) super-rtimes) - ((super-name ...) super-names) - ((var ...) all-bindings) - ((ctc ...) all-ctcs) - ((((vid ...) . vbody) ...) all-val-defs) - ((((sid ...) . sbody) ...) all-stx-defs)) - #`(begin - (define signature-tag (gensym)) - (define-syntax #,sigid - (make-set!-transformer - (make-signature - (make-siginfo (list #'#,sigid #'super-name ...) - (list ((syntax-local-certifier) (quote-syntax signature-tag)) - #'super-rtime - ...)) - (list (quote-syntax var) ...) - (list (cons (list (quote-syntax vid) ...) - ((syntax-local-certifier) - (quote-syntax vbody))) - ...) - (list (cons (list (quote-syntax sid) ...) - ((syntax-local-certifier) - (quote-syntax sbody))) - ...) - (list #,@(map (lambda (c) - (if c - #`((syntax-local-certifier) - (quote-syntax #,c)) - #'#f)) - all-ctcs)) - (quote-syntax #,sigid)))) - (define-values () - (begin - (λ (var ...) - (letrec-syntaxes+values - ([(sid ...) sbody] ...) ([(vid ...) vbody] ...) - ctc ... - (void))) - (values))))))) - (else - (syntax-case (car sig-exprs) (define-values define-syntaxes contracted) - (x - (identifier? #'x) - (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs))) - ((x (y z) ...) - (and (identifier? #'x) - (module-identifier=? #'x #'contracted) - (andmap identifier? (syntax->list #'(y ...)))) - (loop (cdr sig-exprs) - (append (syntax->list #'(y ...)) bindings) - val-defs - stx-defs - (append (syntax->list #'(z ...)) ctcs))) - ((x . z) - (and (identifier? #'x) - (module-identifier=? #'x #'contracted)) - (raise-syntax-error - 'define-signature - "expected a list of [id contract] pairs after the contracted keyword" - (car sig-exprs))) - ((x . y) - (and (identifier? #'x) - (or (module-identifier=? #'x #'define-values) - (module-identifier=? #'x #'define-syntaxes))) - (begin - (check-def-syntax (car sig-exprs)) - (syntax-case #'y () - (((name ...) body) - (begin - (for-each (lambda (id) (check-id id)) - (syntax->list #'(name ...))) - (let ((b #'body)) - (loop (cdr sig-exprs) - bindings - (if (module-identifier=? #'x #'define-values) - (cons (cons (syntax->list #'(name ...)) b) - val-defs) - val-defs) - (if (module-identifier=? #'x #'define-syntaxes) - (cons (cons (syntax->list #'(name ...)) b) - stx-defs) - stx-defs) - ctcs))))))) - ((x . y) - (let ((trans - (set!-trans-extract - (syntax-local-value - (syntax-local-introduce #'x) - (lambda () - (raise-stx-err "unknown signature form" #'x)))))) - (unless (signature-form? trans) - (raise-stx-err "not a signature form" #'x)) - (let ((results ((signature-form-f trans) (car sig-exprs)))) - (unless (list? results) - (raise-stx-err - (format "expected list of results from signature form, got ~e" results) - (car sig-exprs))) - (loop (append results (cdr sig-exprs)) - bindings - val-defs - stx-defs - ctcs)))) - (x (raise-stx-err - "expected either an identifier or signature form" - #'x)))))))) +(require mzlib/etc + scheme/contract/base + scheme/stxparam + "private/unit-contract.ss" + "private/unit-keywords.ss" + "private/unit-runtime.ss" + "private/unit-utils.ss") - - (define-syntax/err-param (define-signature stx) - (syntax-case stx (extends) - ((_ sig-name sig-exprs) - (begin - (check-id #'sig-name) - (build-define-signature #'sig-name #f #'sig-exprs))) - ((_ sig-name extends super-name sig-exprs) - (begin - (check-id #'sig-name) - (check-id #'super-name) - (build-define-signature #'sig-name #'super-name #'sig-exprs))) - (_ - (begin - (checked-syntax->list stx) +(provide define-signature-form struct struct/ctc open + define-signature provide-signature-elements + only except rename import export prefix link tag init-depend extends contracted + unit? + (rename-out [:unit unit]) define-unit + compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer + invoke-unit define-values/invoke-unit + invoke-unit/infer define-values/invoke-unit/infer + unit-from-context define-unit-from-context + define-unit-binding + unit/new-import-export define-unit/new-import-export + unit/s define-unit/s + unit/c define-unit/contract) + +(define-syntax/err-param (define-signature-form stx) + (syntax-case stx () + ((_ (name arg) . val) + (begin + (check-id #'name) + (check-id #'arg) + #'(define-syntax name + (make-set!-transformer + (make-signature-form (λ (arg) . val)))))) + ((_ . l) + (let ((l (checked-syntax->list stx))) + (unless (>= 3 (length l)) + (raise-stx-err + (format "expected syntax matching (~a (id id) expr ...)" + (syntax-e (stx-car stx))))) + (unless (= 2 (length (checked-syntax->list (car l)))) (raise-stx-err - (format "expected syntax matching (~a identifier (sig-expr ...)) or (~a identifier extends identifier (sig-expr ...))" - (syntax-e (stx-car stx)) (syntax-e (stx-car stx)))))))) - - (define-for-syntax (signature->identifiers sigids) - (define provide-tagged-sigs (map process-tagged-import sigids)) - (define provide-sigs (map caddr provide-tagged-sigs)) - (map sig-int-names provide-sigs)) - - (define-syntax/err-param (provide-signature-elements stx) - (syntax-case stx () - ((_ . p) - (let* ((sigs (checked-syntax->list #'p)) - (nameses (signature->identifiers sigs)) - ;; Export only the names that would be visible to uses - ;; with the same lexical context as p. Otherwise, we - ;; can end up with collisions with renamings that are - ;; symbolically the same, such as those introduced by - ;; `open'. - (nameses (map (lambda (sig names) - (filter (lambda (name) - (bound-identifier=? - name - (datum->syntax-object sig (syntax-e name)))) - names)) - sigs nameses)) - (names (apply append nameses)) - (dup (check-duplicate-identifier names))) - (when dup - (raise-stx-err (format "duplicate binding for ~e" (syntax-e dup)))) - (quasisyntax/loc stx - (provide #,@names)))))) - - ;; A unit is - ;; - (unit (import import-spec ...) (export export-spec ...) unit-body-expr ...) - - (define-for-syntax (localify exp def-ctx) - (cadr (syntax->list - (local-expand #`(stop #,exp) - 'expression - (list #'stop) - def-ctx)))) - - (define-for-syntax (tagged-sigid->tagged-siginfo x) - (cons (car x) - (signature-siginfo (lookup-signature (cdr x))))) - - (define-for-syntax (make-import-unboxing var renamings loc ctc) - (if ctc - (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)]) - (quasisyntax/loc (error-syntax) - (quote-syntax (let ([v/c (#,loc)]) - (if (pair? v/c) - (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) - (current-contract-region) - #,(id->contract-src-info var)) - (error 'unit "contracted import ~a used before definition" - (quote #,(syntax-object->datum var)))))))) - (quasisyntax/loc (error-syntax) - (quote-syntax (#,loc))))) - - ;; build-unit : syntax-object -> - ;; (values syntax-object (listof identifier) (listof identifier)) - ;; constructs the code for a unit expression. stx must be - ;; such that it passes check-unit-syntax. - ;; The two additional values are the identifiers of the unit's import and export - ;; signatures - (define-for-syntax (build-unit stx) - (syntax-case stx (import export init-depend) - (((import i ...) - (export e ...) - (init-depend id ...) - . body) - - (let* ([d (syntax->list #'(id ...))] - [dep-tagged-sigids (map check-tagged-id d)] - [dep-tagged-siginfos - (map tagged-sigid->tagged-siginfo dep-tagged-sigids)]) - - (define-values (isig tagged-import-sigs import-tagged-infos - import-tagged-sigids import-sigs) - (process-unit-import #'(i ...))) - - (define-values (esig tagged-export-sigs export-tagged-infos - export-tagged-sigids export-sigs) - (process-unit-export #'(e ...))) + "expected syntax matching (identifier identifier)" + (car l))))))) - (check-duplicate-sigs import-tagged-infos isig dep-tagged-siginfos d) +(define-signature-form (struct stx) + (parameterize ((error-syntax stx)) + (syntax-case stx () + ((_ name (field ...) . omissions) + (let ([omit-selectors #f] + [omit-setters #f] + [omit-constructor #f] + [omit-type #f]) + (define (remove-ctor&type-name l) + (cond + ((and omit-constructor omit-type) + (cddr l)) + (omit-type + (cdr l)) + (omit-constructor + (cons (car l) (cddr l))) + (else + l))) + (define (remove-ctor&type-info l) + (define new-type + (if omit-type + #f + (cadr l))) + (define new-ctor + (if omit-constructor + #f + (caddr l))) + (cons (car l) + (cons new-type + (cons new-ctor + (cdddr l))))) + (check-id #'name) + (for-each check-id (syntax->list #'(field ...))) + (for-each + (lambda (omission) + (cond + ((and (identifier? omission) + (free-identifier=? omission #'-selectors)) + (set! omit-selectors #t)) + ((and (identifier? omission) + (free-identifier=? omission #'-setters)) + (set! omit-setters #t)) + ((and (identifier? omission) + (free-identifier=? omission #'-constructor)) + (set! omit-constructor #t)) + ((and (identifier? omission) + (free-identifier=? omission #'-type)) + (set! omit-type #t)) + (else + (raise-stx-err + "expected \"-selectors\" or \"-setters\" or \"-constructor\" or \"-type\"" + omission)))) + (checked-syntax->list #'omissions)) + (cons + #`(define-syntaxes (name) + #,(remove-ctor&type-info + (build-struct-expand-info + #'name (syntax->list #'(field ...)) + omit-selectors omit-setters + #f '(#f) '(#f)))) + (remove-ctor&type-name + (build-struct-names #'name (syntax->list #'(field ...)) + omit-selectors omit-setters #f))))) + ((_ name (x . y) . omissions) + ;; Will fail + (checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))) + ((_ name fields . omissions) + (raise-stx-err "expected syntax matching (identifier ...)" #'fields)) + ((_ name) + (raise-stx-err "missing fields")) + ((_) + (raise-stx-err "missing name and fields"))))) + +(define-signature-form (struct/ctc stx) + (parameterize ((error-syntax stx)) + (syntax-case stx () + ((_ name ([field ctc] ...) . omissions) + (let ([omit-selectors #f] + [omit-setters #f] + [omit-constructor #f] + [omit-type #f]) + (define (remove-ctor&type-info l) + (define new-type + (if omit-type + #f + (cadr l))) + (define new-ctor + (if omit-constructor + #f + (caddr l))) + (cons (car l) + (cons new-type + (cons new-ctor + (cdddr l))))) + (define (add-contracts l) + (let* ([pred (caddr l)] + [ctor-ctc #`(-> ctc ... #,pred)] + [pred-ctc #`(-> any/c boolean?)] + [field-ctcs (apply append + (map (λ (c) + (append (if omit-selectors + null + (list #`(-> #,pred #,c))) + (if omit-setters + null + (list #`(-> #,pred #,c void?))))) + (syntax->list #'(ctc ...))))]) + (list* (car l) + (list (cadr l) ctor-ctc) + (list pred pred-ctc) + (map list (cdddr l) field-ctcs)))) + (check-id #'name) + (for-each check-id (syntax->list #'(field ...))) + (for-each + (lambda (omission) + (cond + ((and (identifier? omission) + (free-identifier=? omission #'-selectors)) + (set! omit-selectors #t)) + ((and (identifier? omission) + (free-identifier=? omission #'-setters)) + (set! omit-setters #t)) + ((and (identifier? omission) + (free-identifier=? omission #'-constructor)) + (set! omit-constructor #t)) + ((and (identifier? omission) + (free-identifier=? omission #'-type)) + (set! omit-type #t)) + (else + (raise-stx-err + "expected \"-selectors\" or \"-setters\" or \"-constructor\" or \"-type\"" + omission)))) + (checked-syntax->list #'omissions)) + (cons + #`(define-syntaxes (name) + #,(remove-ctor&type-info + (build-struct-expand-info + #'name (syntax->list #'(field ...)) + omit-selectors omit-setters + #f '(#f) '(#f)))) + (let* ([res (add-contracts + (build-struct-names #'name (syntax->list #'(field ...)) + omit-selectors omit-setters #f))] + [cpairs (cons 'contracted (if omit-constructor (cddr res) (cdr res)))]) + (if omit-type + (list cpairs) + (list (car res) cpairs)))))) + ((_ name (x . y) . omissions) + ;; Will fail + (checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))) + ((_ name fields . omissions) + (raise-stx-err "expected syntax matching (identifier ...)" #'fields)) + ((_ name) + (raise-stx-err "missing fields")) + ((_) + (raise-stx-err "missing name and fields"))))) + + +;; build-val+macro-defs : sig -> (list syntax-object^3) +(define-for-syntax (build-val+macro-defs sig) + (with-syntax ([(((int-ivar . ext-ivar) ...) + ((((int-vid . ext-vid) ...) . vbody) ...) + ((((int-sid . ext-sid) ...) . sbody) ...) + (cbody ...)) + (map-sig (lambda (x) x) + (make-syntax-introducer) + sig)]) + (list + #'((ext-ivar ... ext-vid ... ... ext-sid ... ...) + (values + (make-rename-transformer + (quote-syntax int-ivar)) ... + (make-rename-transformer + (quote-syntax int-vid)) ... ... + (make-rename-transformer + (quote-syntax int-sid)) ... ...)) + #'(((int-sid ...) sbody) ...) + #'(((int-vid ...) vbody) ...)))) + + +(define-signature-form (open stx) + (define (build-sig-elems sig) + (map (λ (p c) + (if c #`(contracted [#,(car p) #,c]) (car p))) + (car sig) + (cadddr sig))) + (parameterize ([error-syntax stx]) + (syntax-case stx () + ((_ export-spec) + (let ([sig (process-spec #'export-spec)]) + (with-syntax (((sig-elem ...) + (build-sig-elems sig)) + ((renames + (((mac-name ...) mac-body) ...) + (((val-name ...) val-body) ...)) + (build-val+macro-defs sig))) + (syntax->list + #'(sig-elem ... + (define-syntaxes . renames) + (define-syntaxes (mac-name ...) mac-body) ... + (define-values (val-name ...) val-body) ...))))) + (_ + (raise-stx-err (format "must match (~a export-spec)" + (syntax-e (stx-car stx)))))))) + + +(define-for-syntax (introduce-def d) + (cons (map syntax-local-introduce (car d)) + (syntax-local-introduce (cdr d)))) + +;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object +(define-for-syntax (build-define-signature sigid super-sigid sig-exprs) + (unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs)) + (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs)) + (let ([ses (checked-syntax->list sig-exprs)]) + (define-values (super-names super-ctimes super-rtimes super-bindings + super-val-defs super-stx-defs super-ctcs) + (if super-sigid + (let* ([super-sig (lookup-signature super-sigid)] + [super-siginfo (signature-siginfo super-sig)]) + (values (siginfo-names super-siginfo) + (siginfo-ctime-ids super-siginfo) + (map syntax-local-introduce + (siginfo-rtime-ids super-siginfo)) + (map syntax-local-introduce (signature-vars super-sig)) + (map introduce-def (signature-val-defs super-sig)) + (map introduce-def (signature-stx-defs super-sig)) + (map (lambda (ctc) + (if ctc + (syntax-local-introduce ctc) + ctc)) + (signature-ctcs super-sig)))) + (values '() '() '() '() '() '() '()))) + (let loop ((sig-exprs ses) + (bindings null) + (val-defs null) + (stx-defs null) + (ctcs null)) + (cond + ((null? sig-exprs) + (let* ([all-bindings (append super-bindings (reverse bindings))] + [all-val-defs (append super-val-defs (reverse val-defs))] + [all-stx-defs (append super-stx-defs (reverse stx-defs))] + [all-ctcs (append super-ctcs (reverse ctcs))] + [dup + (check-duplicate-identifier + (append all-bindings + (apply append (map car all-val-defs)) + (apply append (map car all-stx-defs))))]) + (when dup + (raise-stx-err "duplicate identifier" dup)) + (with-syntax (((super-rtime ...) super-rtimes) + ((super-name ...) super-names) + ((var ...) all-bindings) + ((ctc ...) all-ctcs) + ((((vid ...) . vbody) ...) all-val-defs) + ((((sid ...) . sbody) ...) all-stx-defs)) + #`(begin + (define signature-tag (gensym)) + (define-syntax #,sigid + (make-set!-transformer + (make-signature + (make-siginfo (list #'#,sigid #'super-name ...) + (list ((syntax-local-certifier) (quote-syntax signature-tag)) + #'super-rtime + ...)) + (list (quote-syntax var) ...) + (list (cons (list (quote-syntax vid) ...) + ((syntax-local-certifier) + (quote-syntax vbody))) + ...) + (list (cons (list (quote-syntax sid) ...) + ((syntax-local-certifier) + (quote-syntax sbody))) + ...) + (list #,@(map (lambda (c) + (if c + #`((syntax-local-certifier) + (quote-syntax #,c)) + #'#f)) + all-ctcs)) + (quote-syntax #,sigid)))) + (define-values () + (begin + (λ (var ...) + (letrec-syntaxes+values + ([(sid ...) sbody] ...) ([(vid ...) vbody] ...) + ctc ... + (void))) + (values))))))) + (else + (syntax-case (car sig-exprs) (define-values define-syntaxes contracted) + (x + (identifier? #'x) + (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs))) + ((x (y z) ...) + (and (identifier? #'x) + (free-identifier=? #'x #'contracted) + (andmap identifier? (syntax->list #'(y ...)))) + (loop (cdr sig-exprs) + (append (syntax->list #'(y ...)) bindings) + val-defs + stx-defs + (append (syntax->list #'(z ...)) ctcs))) + ((x . z) + (and (identifier? #'x) + (free-identifier=? #'x #'contracted)) + (raise-syntax-error + 'define-signature + "expected a list of [id contract] pairs after the contracted keyword" + (car sig-exprs))) + ((x . y) + (and (identifier? #'x) + (or (free-identifier=? #'x #'define-values) + (free-identifier=? #'x #'define-syntaxes))) + (begin + (check-def-syntax (car sig-exprs)) + (syntax-case #'y () + (((name ...) body) + (begin + (for-each (lambda (id) (check-id id)) + (syntax->list #'(name ...))) + (let ((b #'body)) + (loop (cdr sig-exprs) + bindings + (if (free-identifier=? #'x #'define-values) + (cons (cons (syntax->list #'(name ...)) b) + val-defs) + val-defs) + (if (free-identifier=? #'x #'define-syntaxes) + (cons (cons (syntax->list #'(name ...)) b) + stx-defs) + stx-defs) + ctcs))))))) + ((x . y) + (let ((trans + (set!-trans-extract + (syntax-local-value + (syntax-local-introduce #'x) + (lambda () + (raise-stx-err "unknown signature form" #'x)))))) + (unless (signature-form? trans) + (raise-stx-err "not a signature form" #'x)) + (let ((results ((signature-form-f trans) (car sig-exprs)))) + (unless (list? results) + (raise-stx-err + (format "expected list of results from signature form, got ~e" results) + (car sig-exprs))) + (loop (append results (cdr sig-exprs)) + bindings + val-defs + stx-defs + ctcs)))) + (x (raise-stx-err + "expected either an identifier or signature form" + #'x)))))))) + + +(define-syntax/err-param (define-signature stx) + (syntax-case stx (extends) + ((_ sig-name sig-exprs) + (begin + (check-id #'sig-name) + (build-define-signature #'sig-name #f #'sig-exprs))) + ((_ sig-name extends super-name sig-exprs) + (begin + (check-id #'sig-name) + (check-id #'super-name) + (build-define-signature #'sig-name #'super-name #'sig-exprs))) + (_ + (begin + (checked-syntax->list stx) + (raise-stx-err + (format "expected syntax matching (~a identifier (sig-expr ...)) or (~a identifier extends identifier (sig-expr ...))" + (syntax-e (stx-car stx)) (syntax-e (stx-car stx)))))))) + +(define-for-syntax (signature->identifiers sigids) + (define provide-tagged-sigs (map process-tagged-import sigids)) + (define provide-sigs (map caddr provide-tagged-sigs)) + (map sig-int-names provide-sigs)) + +(define-syntax/err-param (provide-signature-elements stx) + (syntax-case stx () + ((_ . p) + (let* ((sigs (checked-syntax->list #'p)) + (nameses (signature->identifiers sigs)) + ;; Export only the names that would be visible to uses + ;; with the same lexical context as p. Otherwise, we + ;; can end up with collisions with renamings that are + ;; symbolically the same, such as those introduced by + ;; `open'. + (nameses (map (lambda (sig names) + (filter (lambda (name) + (bound-identifier=? + name + (datum->syntax sig (syntax-e name)))) + names)) + sigs nameses)) + (names (apply append nameses)) + (dup (check-duplicate-identifier names))) + (when dup + (raise-stx-err (format "duplicate binding for ~e" (syntax-e dup)))) + (quasisyntax/loc stx + (provide #,@names)))))) + +;; A unit is +;; - (unit (import import-spec ...) (export export-spec ...) unit-body-expr ...) + +(define-for-syntax (localify exp def-ctx) + (cadr (syntax->list + (local-expand #`(stop #,exp) + 'expression + (list #'stop) + def-ctx)))) + +(define-for-syntax (tagged-sigid->tagged-siginfo x) + (cons (car x) + (signature-siginfo (lookup-signature (cdr x))))) + +(define-for-syntax (make-import-unboxing var renamings loc ctc) + (if ctc + (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)]) + (quasisyntax/loc (error-syntax) + (quote-syntax (let ([v/c (#,loc)]) + (if (pair? v/c) + (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) + (current-contract-region) + #,(id->contract-src-info var)) + (error 'unit "contracted import ~a used before definition" + (quote #,(syntax->datum var)))))))) + (quasisyntax/loc (error-syntax) + (quote-syntax (#,loc))))) + +;; build-unit : syntax-object -> +;; (values syntax-object (listof identifier) (listof identifier)) +;; constructs the code for a unit expression. stx must be +;; such that it passes check-unit-syntax. +;; The two additional values are the identifiers of the unit's import and export +;; signatures +(define-for-syntax (build-unit stx) + (syntax-case stx (import export init-depend) + (((import i ...) + (export e ...) + (init-depend id ...) + . body) + + (let* ([d (syntax->list #'(id ...))] + [dep-tagged-sigids (map check-tagged-id d)] + [dep-tagged-siginfos + (map tagged-sigid->tagged-siginfo dep-tagged-sigids)]) + + (define-values (isig tagged-import-sigs import-tagged-infos + import-tagged-sigids import-sigs) + (process-unit-import #'(i ...))) + + (define-values (esig tagged-export-sigs export-tagged-infos + export-tagged-sigids export-sigs) + (process-unit-export #'(e ...))) + + (check-duplicate-sigs import-tagged-infos isig dep-tagged-siginfos d) + + (check-duplicate-subs export-tagged-infos esig) + + (check-unit-ie-sigs import-sigs export-sigs) + + (with-syntax ((((dept . depr) ...) + (map + (lambda (tinfo) + (cons (car tinfo) + (syntax-local-introduce (car (siginfo-rtime-ids (cdr tinfo)))))) + dep-tagged-siginfos)) + [((renames (mac ...) (val ...)) ...) + (map build-val+macro-defs import-sigs)] + [(((int-ivar . ext-ivar) ...) ...) (map car import-sigs)] + [(((int-evar . ext-evar) ...) ...) (map car export-sigs)] + [((iloc ...) ...) + (map (lambda (x) (generate-temporaries (car x))) import-sigs)] + [((eloc ...) ...) + (map (lambda (x) (generate-temporaries (car x))) export-sigs)] + [((ectc ...) ...) + (map (λ (sig) + (map (λ (ctc) + (if ctc + (cons 'contract ctc) + #f)) + (cadddr sig))) export-sigs)] + [((import-key import-super-keys ...) ...) + (map tagged-info->keys import-tagged-infos)] + [((export-key ...) ...) + (map tagged-info->keys export-tagged-infos)] + [(import-name ...) + (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) + import-tagged-infos)] + [(export-name ...) + (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) + export-tagged-infos)] + [name (syntax-local-infer-name (error-syntax))] + [(icount ...) (map + (lambda (import) (length (car import))) + import-sigs)]) + (values + (quasisyntax/loc (error-syntax) + (make-unit + 'name + (vector-immutable (cons 'import-name + (vector-immutable import-key import-super-keys ...)) ...) + (vector-immutable (cons 'export-name + (vector-immutable export-key ...)) ...) + (list (cons 'dept depr) ...) + (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) + (lambda () + (let ([eloc (box undefined)] ... ...) + (values + (lambda (import-table) + (let-values ([(iloc ...) + (vector->values (hash-ref import-table import-key) 0 icount)] + ...) + (letrec-syntaxes (#,@(map (lambda (ivs e-ivs ils ics) + (with-syntax ([renamings + (map (λ (ev iv) + #`(#,ev + (make-rename-transformer + (quote-syntax #,iv)))) + (syntax->list e-ivs) + (syntax->list ivs))]) + (quasisyntax/loc (error-syntax) + [#,ivs + (make-id-mappers + #,@(map (lambda (iv l c) + (make-import-unboxing iv #'renamings l c)) + (syntax->list ivs) + (syntax->list ils) + ics))]))) + (syntax->list #'((int-ivar ...) ...)) + (syntax->list #'((ext-ivar ...) ...)) + (syntax->list #'((iloc ...) ...)) + (map cadddr import-sigs))) + (letrec-syntaxes+values (renames ... + mac ... ...) + (val ... ...) + (unit-body #,(error-syntax) + (int-ivar ... ...) + (int-evar ... ...) + (eloc ... ...) + (ectc ... ...) + . body))))) + (unit-export ((export-key ...) (vector-immutable (λ () (unbox eloc)) ...)) ...))))))) + import-tagged-sigids + export-tagged-sigids + dep-tagged-sigids)))))) + +(define-syntax/err-param (:unit stx) + (syntax-case stx () + ((_ . x) + (begin + (let-values (((u x y z) (build-unit (check-unit-syntax #'x)))) + u))))) + +(define-syntax (unit-body stx) + (syntax-case stx () + ((_ err-stx ivars evars elocs ectcs body ...) + (parameterize ((error-syntax #'err-stx)) + (let* ([expand-context (generate-expand-context)] + [def-ctx (syntax-local-make-definition-context)] + [stop-list + (append + (kernel-form-identifier-list) + (syntax->list #'ivars))] + [definition? + (lambda (id) + (and (identifier? id) + (or (free-identifier=? id (quote-syntax define-values)) + (free-identifier=? id (quote-syntax define-syntaxes)))))] + [expanded-body + (let expand-all ((defns&exprs (syntax->list #'(body ...)))) + ;; Also lifted from Matthew, to expand the body enough + (apply + append + (map + (lambda (defn-or-expr) + (let ([defn-or-expr + (local-expand + defn-or-expr + expand-context + stop-list + def-ctx)]) + (syntax-case defn-or-expr (begin define-values define-syntaxes) + [(begin . l) + (let ([l (parameterize ((error-syntax defn-or-expr)) + (checked-syntax->list #'l))]) + (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)))] + ;; Get all the defined names, sorting out variable definitions + ;; from syntax definitions. + [defined-names-table + (let ((table (make-bound-identifier-mapping))) + (for-each + (lambda (defn-or-expr) + (syntax-case defn-or-expr () + ((dv . rest) + (definition? #'dv) + (begin + (check-def-syntax defn-or-expr) + (syntax-case #'rest () + [((id ...) expr) + (for-each + (lambda (id) + (when (bound-identifier-mapping-get table id (lambda () #f)) + (raise-stx-err "variable defined twice" id)) + (bound-identifier-mapping-put! + table id + (make-var-info (free-identifier=? #'dv (quote-syntax define-syntaxes)) + #f + id + #f))) + (syntax->list #'(id ...)))] + [_ (void)]))) + [_ (void)])) + expanded-body) + table)]) + (internal-definition-context-seal def-ctx) - (check-duplicate-subs export-tagged-infos esig) + ;; Mark exported names and + ;; check that all exported names are defined (as var): + (for-each + (lambda (name loc ctc) + (let ([v (bound-identifier-mapping-get defined-names-table + name + (lambda () #f))]) + (unless v + (raise-stx-err (format "undefined export ~a" (syntax-e name)))) + (when (var-info-syntax? v) + (raise-stx-err "cannot export syntax from a unit" name)) + (set-var-info-exported?! v loc) + (when (pair? (syntax-e ctc)) + (set-var-info-ctc! v (localify (cdr (syntax-e ctc)) def-ctx))))) + (syntax->list (localify #'evars def-ctx)) + (syntax->list #'elocs) + (syntax->list #'ectcs)) - (check-unit-ie-sigs import-sigs export-sigs) + ;; Check that none of the imports are defined + (for-each + (lambda (i) + (let ((defid (bound-identifier-mapping-get defined-names-table + i + (lambda () #f)))) + (when defid + (raise-stx-err + "definition for imported identifier" + (var-info-id defid))))) + (syntax->list (localify #'ivars def-ctx))) + (let ([marker (make-syntax-introducer)]) + (with-syntax ([(defn-or-expr ...) + (apply append + (map (λ (defn-or-expr) + (syntax-case defn-or-expr (define-values) + [(define-values (id ...) body) + (let* ([ids (syntax->list #'(id ...))] + [tmps (map marker ids)] + [do-one + (λ (id tmp) + (let ([var-info (bound-identifier-mapping-get + defined-names-table + id)]) + (cond + [(var-info-exported? var-info) + => + (λ (export-loc) + (let ([ctc (var-info-ctc var-info)]) + (list (if ctc + (quasisyntax/loc defn-or-expr + (begin + (contract #,ctc #,tmp + (current-contract-region) + 'cant-happen + #,(id->contract-src-info id)) + (set-box! #,export-loc + (cons #,tmp (current-contract-region))))) + (quasisyntax/loc defn-or-expr + (set-box! #,export-loc #,tmp))) + (quasisyntax/loc defn-or-expr + (define-syntax #,id + (make-id-mapper (quote-syntax #,tmp)))))))] + [else (list (quasisyntax/loc defn-or-expr + (define-syntax #,id + (make-rename-transformer (quote-syntax #,tmp)))))])))]) + (cons (quasisyntax/loc defn-or-expr + (define-values #,tmps body)) + (apply append (map do-one ids tmps))))] + [else (list defn-or-expr)])) + expanded-body))]) + #'(begin-with-definitions defn-or-expr ...)))))))) + +(define-for-syntax (redirect-imports/exports import?) + (lambda (table-stx + import-tagged-infos + import-sigs + target-import-tagged-infos + target-import-sigs) + (define def-table (make-bound-identifier-mapping)) + (define ctc-table (make-bound-identifier-mapping)) + (define sig-table (make-bound-identifier-mapping)) + (for-each + (lambda (tagged-info sig) + (define v + #`(hash-ref #,table-stx #,(car (tagged-info->keys tagged-info)))) + (for-each + (lambda (int/ext-name index ctc) + (bound-identifier-mapping-put! def-table + (car int/ext-name) + #`(vector-ref #,v #,index)) + (bound-identifier-mapping-put! ctc-table + (car int/ext-name) + ctc) + (bound-identifier-mapping-put! sig-table + (car int/ext-name) + sig)) + (car sig) + (iota (length (car sig))) + (cadddr sig))) + import-tagged-infos + import-sigs) + (with-syntax ((((eloc ...) ...) + (map + (lambda (target-sig) + (map + (lambda (target-int/ext-name target-ctc) + (let* ([var (car target-int/ext-name)] + [vref + (bound-identifier-mapping-get + def-table + var + (lambda () + (raise-stx-err + (format (if import? + "identifier ~a is not present in new imports" + "identifier ~a is not present in old exports") + (syntax-e (car target-int/ext-name))))))] + [ctc (bound-identifier-mapping-get ctc-table var)] + [rename-bindings (get-member-bindings def-table + (bound-identifier-mapping-get sig-table var) + #'(current-contract-region))]) + (with-syntax ([ctc-stx (if ctc (syntax-property + #`(letrec-syntax #,rename-bindings #,ctc) + 'inferred-name var) + ctc)]) + (if target-ctc + #`(λ () + (cons #,(if ctc + #`(let ([old-v/c (#,vref)]) + (contract ctc-stx (car old-v/c) + (cdr old-v/c) (current-contract-region) + #,(id->contract-src-info var))) + #`(#,vref)) + (current-contract-region))) + (if ctc + #`(λ () + (let ([old-v/c (#,vref)]) + (contract ctc-stx (car old-v/c) + (cdr old-v/c) (current-contract-region) + #,(id->contract-src-info var)))) + vref))))) + (car target-sig) + (cadddr target-sig))) + target-import-sigs)) + (((export-keys ...) ...) + (map tagged-info->keys target-import-tagged-infos))) + #`(unit-export ((export-keys ...) + (vector-immutable eloc ...)) ...)))) + +(define-for-syntax redirect-imports (redirect-imports/exports #t)) +(define-for-syntax redirect-exports (redirect-imports/exports #f)) + + +;; build-unit/new-import-export : syntax-object -> +;; (values syntax-object (listof identifier) (listof identifier)) +;; constructs the code for a unit expression that changes the import and export signatures +;; of another. stx must be such that it passes check-unit-syntax. +;; The two additional values are the identifiers of the unit's import and export +;; signatures +(define-for-syntax (build-unit/new-import-export stx) + (syntax-case stx (import export init-depend) + (((import i ...) + (export e ...) + (init-depend id ...) + . body) + + (let* ([d (syntax->list #'(id ...))] + [dep-tagged-sigids (map check-tagged-id d)] + [dep-tagged-siginfos + (map tagged-sigid->tagged-siginfo dep-tagged-sigids)]) + (define-values (isig tagged-import-sigs import-tagged-infos + import-tagged-sigids import-sigs) + (process-unit-import #'(i ...))) + + (define-values (esig tagged-export-sigs export-tagged-infos + export-tagged-sigids export-sigs) + (process-unit-export #'(e ...))) + + (check-duplicate-sigs import-tagged-infos isig dep-tagged-siginfos d) + + (check-duplicate-subs export-tagged-infos esig) + + (check-unit-ie-sigs import-sigs export-sigs) + + (syntax-case #'body () + ((b) (check-link-line-syntax #'b)) + (() (raise-stx-err "missing unit specification")) + (_ (raise-stx-err "expects a single unit specification"))) + + (with-syntax (((((orig-e ...) unit-exp orig-i ...)) #'body)) + (define-values (orig-isig orig-tagged-import-sigs orig-import-tagged-infos + orig-import-tagged-sigids orig-import-sigs) + (process-unit-export #'(orig-i ...))) + + (define-values (orig-esig orig-tagged-export-sigs orig-export-tagged-infos + orig-export-tagged-sigids orig-export-sigs) + (process-unit-import #'(orig-e ...))) (with-syntax ((((dept . depr) ...) (map (lambda (tinfo) (cons (car tinfo) (syntax-local-introduce (car (siginfo-rtime-ids (cdr tinfo)))))) dep-tagged-siginfos)) - [((renames (mac ...) (val ...)) ...) - (map build-val+macro-defs import-sigs)] - [(((int-ivar . ext-ivar) ...) ...) (map car import-sigs)] - [(((int-evar . ext-evar) ...) ...) (map car export-sigs)] - [((iloc ...) ...) - (map (lambda (x) (generate-temporaries (car x))) import-sigs)] - [((eloc ...) ...) - (map (lambda (x) (generate-temporaries (car x))) export-sigs)] - [((ectc ...) ...) - (map (λ (sig) - (map (λ (ctc) - (if ctc - (cons 'contract ctc) - #f)) - (cadddr sig))) export-sigs)] - [((import-key import-super-keys ...) ...) + [((import-key ...) ...) (map tagged-info->keys import-tagged-infos)] [((export-key ...) ...) (map tagged-info->keys export-tagged-infos)] + [((orig-import-key ...) ...) + (map tagged-info->keys orig-import-tagged-infos)] + [((orig-export-key ...) ...) + (map tagged-info->keys orig-export-tagged-infos)] [(import-name ...) (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) import-tagged-infos)] [(export-name ...) (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) export-tagged-infos)] + [(orig-import-name ...) + (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) + orig-import-tagged-infos)] + [(orig-export-name ...) + (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) + orig-export-tagged-infos)] [name (syntax-local-infer-name (error-syntax))] - [(icount ...) (map - (lambda (import) (length (car import))) - import-sigs)]) + [form (syntax-e (stx-car (error-syntax)))]) (values (quasisyntax/loc (error-syntax) - (make-unit - 'name - (vector-immutable (cons 'import-name - (vector-immutable import-key import-super-keys ...)) ...) - (vector-immutable (cons 'export-name - (vector-immutable export-key ...)) ...) - (list (cons 'dept depr) ...) - (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) - (lambda () - (let ([eloc (box undefined)] ... ...) - (values - (lambda (import-table) - (let-values ([(iloc ...) - (vector->values (hash-table-get import-table import-key) 0 icount)] - ...) - (letrec-syntaxes (#,@(map (lambda (ivs e-ivs ils ics) - (with-syntax ([renamings - (map (λ (ev iv) - #`(#,ev - (make-rename-transformer - (quote-syntax #,iv)))) - (syntax->list e-ivs) - (syntax->list ivs))]) - (quasisyntax/loc (error-syntax) - [#,ivs - (make-id-mappers - #,@(map (lambda (iv l c) - (make-import-unboxing iv #'renamings l c)) - (syntax->list ivs) - (syntax->list ils) - ics))]))) - (syntax->list #'((int-ivar ...) ...)) - (syntax->list #'((ext-ivar ...) ...)) - (syntax->list #'((iloc ...) ...)) - (map cadddr import-sigs))) - (letrec-syntaxes+values (renames ... - mac ... ...) - (val ... ...) - (unit-body #,(error-syntax) - (int-ivar ... ...) - (int-evar ... ...) - (eloc ... ...) - (ectc ... ...) - . body))))) - (unit-export ((export-key ...) (vector-immutable (λ () (unbox eloc)) ...)) ...))))))) + (let ([unit-tmp unit-exp]) + (check-unit unit-tmp 'form) + (check-sigs unit-tmp + (vector-immutable + (cons 'orig-import-name + (vector-immutable orig-import-key ...)) ...) + (vector-immutable + (cons 'orig-export-name + (vector-immutable orig-export-key ...)) ...) + 'form) + (make-unit + 'name + (vector-immutable (cons 'import-name + (vector-immutable import-key ...)) ...) + (vector-immutable (cons 'export-name + (vector-immutable export-key ...)) ...) + (list (cons 'dept depr) ...) + (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) + (lambda () + (let-values ([(unit-fn export-table) ((unit-go unit-tmp))]) + (values (lambda (import-table) + (unit-fn #,(redirect-imports #'import-table + import-tagged-infos + import-sigs + orig-import-tagged-infos + orig-import-sigs))) + #,(redirect-exports #'export-table + orig-export-tagged-infos + orig-export-sigs + export-tagged-infos + export-sigs)))))))) import-tagged-sigids export-tagged-sigids - dep-tagged-sigids)))))) + dep-tagged-sigids))))))) - (define-syntax/err-param (:unit stx) - (syntax-case stx () - ((_ . x) - (begin - (let-values (((u x y z) (build-unit (check-unit-syntax #'x)))) - u))))) - - (define-syntax (unit-body stx) - (syntax-case stx () - ((_ err-stx ivars evars elocs ectcs body ...) - (parameterize ((error-syntax #'err-stx)) - (let* ([expand-context (generate-expand-context)] - [def-ctx (syntax-local-make-definition-context)] - [stop-list - (append - (kernel-form-identifier-list) - (syntax->list #'ivars))] - [definition? - (lambda (id) - (and (identifier? id) - (or (module-identifier=? id (quote-syntax define-values)) - (module-identifier=? id (quote-syntax define-syntaxes)))))] - [expanded-body - (let expand-all ((defns&exprs (syntax->list #'(body ...)))) - ;; Also lifted from Matthew, to expand the body enough - (apply - append - (map - (lambda (defn-or-expr) - (let ([defn-or-expr - (local-expand - defn-or-expr - expand-context - stop-list - def-ctx)]) - (syntax-case defn-or-expr (begin define-values define-syntaxes) - [(begin . l) - (let ([l (parameterize ((error-syntax defn-or-expr)) - (checked-syntax->list #'l))]) - (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)))] - ;; Get all the defined names, sorting out variable definitions - ;; from syntax definitions. - [defined-names-table - (let ((table (make-bound-identifier-mapping))) - (for-each - (lambda (defn-or-expr) - (syntax-case defn-or-expr () - ((dv . rest) - (definition? #'dv) - (begin - (check-def-syntax defn-or-expr) - (syntax-case #'rest () - [((id ...) expr) - (for-each - (lambda (id) - (when (bound-identifier-mapping-get table id (lambda () #f)) - (raise-stx-err "variable defined twice" id)) - (bound-identifier-mapping-put! - table id - (make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes)) - #f - id - #f))) - (syntax->list #'(id ...)))] - [_ (void)]))) - [_ (void)])) - expanded-body) - table)]) - (internal-definition-context-seal def-ctx) - - ;; Mark exported names and - ;; check that all exported names are defined (as var): - (for-each - (lambda (name loc ctc) - (let ([v (bound-identifier-mapping-get defined-names-table - name - (lambda () #f))]) - (unless v - (raise-stx-err (format "undefined export ~a" (syntax-e name)))) - (when (var-info-syntax? v) - (raise-stx-err "cannot export syntax from a unit" name)) - (set-var-info-exported?! v loc) - (when (pair? (syntax-e ctc)) - (set-var-info-ctc! v (localify (cdr (syntax-e ctc)) def-ctx))))) - (syntax->list (localify #'evars def-ctx)) - (syntax->list #'elocs) - (syntax->list #'ectcs)) - - ;; Check that none of the imports are defined - (for-each - (lambda (i) - (let ((defid (bound-identifier-mapping-get defined-names-table - i - (lambda () #f)))) - (when defid - (raise-stx-err - "definition for imported identifier" - (var-info-id defid))))) - (syntax->list (localify #'ivars def-ctx))) - - (let ([marker (make-syntax-introducer)]) - (with-syntax ([(defn-or-expr ...) - (apply append - (map (λ (defn-or-expr) - (syntax-case defn-or-expr (define-values) - [(define-values (id ...) body) - (let* ([ids (syntax->list #'(id ...))] - [tmps (map marker ids)] - [do-one - (λ (id tmp) - (let ([var-info (bound-identifier-mapping-get - defined-names-table - id)]) - (cond - [(var-info-exported? var-info) - => - (λ (export-loc) - (let ([ctc (var-info-ctc var-info)]) - (list (if ctc - (quasisyntax/loc defn-or-expr - (begin - (contract #,ctc #,tmp - (current-contract-region) - 'cant-happen - #,(id->contract-src-info id)) - (set-box! #,export-loc - (cons #,tmp (current-contract-region))))) - (quasisyntax/loc defn-or-expr - (set-box! #,export-loc #,tmp))) - (quasisyntax/loc defn-or-expr - (define-syntax #,id - (make-id-mapper (quote-syntax #,tmp)))))))] - [else (list (quasisyntax/loc defn-or-expr - (define-syntax #,id - (make-rename-transformer (quote-syntax #,tmp)))))])))]) - (cons (quasisyntax/loc defn-or-expr - (define-values #,tmps body)) - (apply append (map do-one ids tmps))))] - [else (list defn-or-expr)])) - expanded-body))]) - #'(begin-with-definitions defn-or-expr ...)))))))) - (define-for-syntax (redirect-imports/exports import?) - (lambda (table-stx - import-tagged-infos - import-sigs - target-import-tagged-infos - target-import-sigs) - (define def-table (make-bound-identifier-mapping)) - (define ctc-table (make-bound-identifier-mapping)) - (define sig-table (make-bound-identifier-mapping)) - (for-each - (lambda (tagged-info sig) - (define v - #`(hash-table-get #,table-stx #,(car (tagged-info->keys tagged-info)))) - (for-each - (lambda (int/ext-name index ctc) - (bound-identifier-mapping-put! def-table - (car int/ext-name) - #`(vector-ref #,v #,index)) - (bound-identifier-mapping-put! ctc-table - (car int/ext-name) - ctc) - (bound-identifier-mapping-put! sig-table - (car int/ext-name) - sig)) - (car sig) - (iota (length (car sig))) - (cadddr sig))) - import-tagged-infos - import-sigs) - (with-syntax ((((eloc ...) ...) - (map - (lambda (target-sig) - (map - (lambda (target-int/ext-name target-ctc) - (let* ([var (car target-int/ext-name)] - [vref - (bound-identifier-mapping-get - def-table - var - (lambda () - (raise-stx-err - (format (if import? - "identifier ~a is not present in new imports" - "identifier ~a is not present in old exports") - (syntax-e (car target-int/ext-name))))))] - [ctc (bound-identifier-mapping-get ctc-table var)] - [rename-bindings (get-member-bindings def-table - (bound-identifier-mapping-get sig-table var) - #'(current-contract-region))]) - (with-syntax ([ctc-stx (if ctc (syntax-property - #`(letrec-syntax #,rename-bindings #,ctc) - 'inferred-name var) - ctc)]) - (if target-ctc - #`(λ () - (cons #,(if ctc - #`(let ([old-v/c (#,vref)]) - (contract ctc-stx (car old-v/c) - (cdr old-v/c) (current-contract-region) - #,(id->contract-src-info var))) - #`(#,vref)) - (current-contract-region))) - (if ctc - #`(λ () - (let ([old-v/c (#,vref)]) - (contract ctc-stx (car old-v/c) - (cdr old-v/c) (current-contract-region) - #,(id->contract-src-info var)))) - vref))))) - (car target-sig) - (cadddr target-sig))) - target-import-sigs)) - (((export-keys ...) ...) - (map tagged-info->keys target-import-tagged-infos))) - #`(unit-export ((export-keys ...) - (vector-immutable eloc ...)) ...)))) - - (define-for-syntax redirect-imports (redirect-imports/exports #t)) - (define-for-syntax redirect-exports (redirect-imports/exports #f)) - - - ;; build-unit/new-import-export : syntax-object -> - ;; (values syntax-object (listof identifier) (listof identifier)) - ;; constructs the code for a unit expression that changes the import and export signatures - ;; of another. stx must be such that it passes check-unit-syntax. - ;; The two additional values are the identifiers of the unit's import and export - ;; signatures - (define-for-syntax (build-unit/new-import-export stx) - (syntax-case stx (import export init-depend) - (((import i ...) - (export e ...) - (init-depend id ...) - . body) +(define-syntax/err-param (unit/new-import-export stx) + (syntax-case stx () + ((_ . x) + (begin + (let-values (((u x y z) (build-unit/new-import-export (check-unit-syntax #'x)))) + u))))) + +;; build-compound-unit : syntax-object -> +;; (values syntax-object (listof identifier) (listof identifier)) +;; constructs the code for a compound-unit expression. stx match the return of +;; check-compound-syntax +;; The two additional values are the identifiers of the compound-unit's import and export +;; signatures +(define-for-syntax (build-compound-unit stx) + (define-struct lnkid-record (access-code names ctime-ids rtime-ids source-idx sigid siginfo)) + (define (lnkid-rec->keys t rec) + (map (lambda (rid) (build-key t rid)) + (lnkid-record-rtime-ids rec))) + (syntax-case stx () + (((import ...) + (export-lnktag ...) + (((sub-out ...) sub-exp sub-in-lnktag ...) ...)) + (with-syntax ((((import-tag import-lnkid . import-sigid) ...) + (map check-tagged-:-clause (syntax->list #'(import ...)))) + (((export-tag . export-lnkid) ...) + (map check-tagged-id + (syntax->list #'(export-lnktag ...)))) + ((((sub-out-tag sub-out-lnkid . sub-out-sigid) ...) ...) + (map (lambda (e) (map check-tagged-:-clause (syntax->list e))) + (syntax->list #'((sub-out ...) ...)))) + ((((sub-in-tag . sub-in-lnkid) ...) ...) + (map (lambda (t) (map check-tagged-id (syntax->list t))) + (syntax->list #'((sub-in-lnktag ...) ...))))) - (let* ([d (syntax->list #'(id ...))] - [dep-tagged-sigids (map check-tagged-id d)] - [dep-tagged-siginfos - (map tagged-sigid->tagged-siginfo dep-tagged-sigids)]) - (define-values (isig tagged-import-sigs import-tagged-infos - import-tagged-sigids import-sigs) - (process-unit-import #'(i ...))) - - (define-values (esig tagged-export-sigs export-tagged-infos - export-tagged-sigids export-sigs) - (process-unit-export #'(e ...))) - - (check-duplicate-sigs import-tagged-infos isig dep-tagged-siginfos d) - - (check-duplicate-subs export-tagged-infos esig) - - (check-unit-ie-sigs import-sigs export-sigs) - - (syntax-case #'body () - ((b) (check-link-line-syntax #'b)) - (() (raise-stx-err "missing unit specification")) - (_ (raise-stx-err "expects a single unit specification"))) - - (with-syntax (((((orig-e ...) unit-exp orig-i ...)) #'body)) - (define-values (orig-isig orig-tagged-import-sigs orig-import-tagged-infos - orig-import-tagged-sigids orig-import-sigs) - (process-unit-export #'(orig-i ...))) - - (define-values (orig-esig orig-tagged-export-sigs orig-export-tagged-infos - orig-export-tagged-sigids orig-export-sigs) - (process-unit-import #'(orig-e ...))) - (with-syntax ((((dept . depr) ...) - (map - (lambda (tinfo) - (cons (car tinfo) - (syntax-local-introduce (car (siginfo-rtime-ids (cdr tinfo)))))) - dep-tagged-siginfos)) - [((import-key ...) ...) - (map tagged-info->keys import-tagged-infos)] - [((export-key ...) ...) - (map tagged-info->keys export-tagged-infos)] - [((orig-import-key ...) ...) - (map tagged-info->keys orig-import-tagged-infos)] - [((orig-export-key ...) ...) - (map tagged-info->keys orig-export-tagged-infos)] - [(import-name ...) - (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) - import-tagged-infos)] - [(export-name ...) - (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) - export-tagged-infos)] - [(orig-import-name ...) - (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) - orig-import-tagged-infos)] - [(orig-export-name ...) - (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) - orig-export-tagged-infos)] - [name (syntax-local-infer-name (error-syntax))] - [form (syntax-e (stx-car (error-syntax)))]) - (values - (quasisyntax/loc (error-syntax) - (let ([unit-tmp unit-exp]) - (check-unit unit-tmp 'form) - (check-sigs unit-tmp - (vector-immutable - (cons 'orig-import-name - (vector-immutable orig-import-key ...)) ...) - (vector-immutable - (cons 'orig-export-name - (vector-immutable orig-export-key ...)) ...) - 'form) - (make-unit - 'name - (vector-immutable (cons 'import-name - (vector-immutable import-key ...)) ...) - (vector-immutable (cons 'export-name - (vector-immutable export-key ...)) ...) - (list (cons 'dept depr) ...) - (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) - (lambda () - (let-values ([(unit-fn export-table) ((unit-go unit-tmp))]) - (values (lambda (import-table) - (unit-fn #,(redirect-imports #'import-table - import-tagged-infos - import-sigs - orig-import-tagged-infos - orig-import-sigs))) - #,(redirect-exports #'export-table - orig-export-tagged-infos - orig-export-sigs - export-tagged-infos - export-sigs)))))))) - import-tagged-sigids - export-tagged-sigids - dep-tagged-sigids))))))) - - - (define-syntax/err-param (unit/new-import-export stx) - (syntax-case stx () - ((_ . x) - (begin - (let-values (((u x y z) (build-unit/new-import-export (check-unit-syntax #'x)))) - u))))) - - ;; build-compound-unit : syntax-object -> - ;; (values syntax-object (listof identifier) (listof identifier)) - ;; constructs the code for a compound-unit expression. stx match the return of - ;; check-compound-syntax - ;; The two additional values are the identifiers of the compound-unit's import and export - ;; signatures - (define-for-syntax (build-compound-unit stx) - (define-struct lnkid-record (access-code names ctime-ids rtime-ids source-idx sigid siginfo)) - (define (lnkid-rec->keys t rec) - (map (lambda (rid) (build-key t rid)) - (lnkid-record-rtime-ids rec))) - (syntax-case stx () - (((import ...) - (export-lnktag ...) - (((sub-out ...) sub-exp sub-in-lnktag ...) ...)) - (with-syntax ((((import-tag import-lnkid . import-sigid) ...) - (map check-tagged-:-clause (syntax->list #'(import ...)))) - (((export-tag . export-lnkid) ...) - (map check-tagged-id - (syntax->list #'(export-lnktag ...)))) - ((((sub-out-tag sub-out-lnkid . sub-out-sigid) ...) ...) - (map (lambda (e) (map check-tagged-:-clause (syntax->list e))) - (syntax->list #'((sub-out ...) ...)))) - ((((sub-in-tag . sub-in-lnkid) ...) ...) - (map (lambda (t) (map check-tagged-id (syntax->list t))) - (syntax->list #'((sub-in-lnktag ...) ...))))) - - (let ([dup (check-duplicate-identifier - (syntax->list #'(import-lnkid ... sub-out-lnkid ... ...)))]) - (when dup - (raise-stx-err "duplicate linking identifier definition" dup))) - - - (let ([bt (make-bound-identifier-mapping)]) - (for-each - (lambda (lnkid) - (bound-identifier-mapping-put! bt lnkid #t)) - (syntax->list #'(import-lnkid ...))) - (for-each - (lambda (lnkid) - (when (bound-identifier-mapping-get bt lnkid (lambda () #f)) - (raise-stx-err "cannot directly export an import" lnkid))) - (syntax->list #'(export-lnkid ...)))) - - - (let* ([idxs (iota (add1 (length (syntax->list #'(sub-exp ...)))))] - [sub-export-table-tmps (generate-temporaries #'(sub-exp ...))] - [link-map - (let ((bt (make-bound-identifier-mapping))) - (for-each - (lambda (tags lnkids sigids tableid i) - (for-each - (lambda (tag lnkid sigid) - (define siginfo (signature-siginfo (lookup-signature sigid))) - (define rtime-ids (map syntax-local-introduce - (siginfo-rtime-ids siginfo))) - (bound-identifier-mapping-put! - bt - lnkid - (make-lnkid-record - #`(hash-table-get - #,tableid - #,(build-key (syntax-e tag) (car rtime-ids))) - (siginfo-names siginfo) - (siginfo-ctime-ids siginfo) - rtime-ids - i - sigid - siginfo))) - (syntax->list tags) - (syntax->list lnkids) - (syntax->list sigids))) - (syntax->list #'((import-tag ...) (sub-out-tag ...) ...)) - (syntax->list #'((import-lnkid ...) (sub-out-lnkid ...) ...)) - (syntax->list #'((import-sigid ...) (sub-out-sigid ...) ...)) - (cons #'import-table-id sub-export-table-tmps) - idxs) - (lambda (id) - (bound-identifier-mapping-get - bt - id - (lambda () - (raise-stx-err "unknown linking identifier" id)))))] - [link-deps - (map - (lambda (tags lnkids i) - (define ht (make-hash-table 'equal)) + (let ([dup (check-duplicate-identifier + (syntax->list #'(import-lnkid ... sub-out-lnkid ... ...)))]) + (when dup + (raise-stx-err "duplicate linking identifier definition" dup))) + + + (let ([bt (make-bound-identifier-mapping)]) + (for-each + (lambda (lnkid) + (bound-identifier-mapping-put! bt lnkid #t)) + (syntax->list #'(import-lnkid ...))) + (for-each + (lambda (lnkid) + (when (bound-identifier-mapping-get bt lnkid (lambda () #f)) + (raise-stx-err "cannot directly export an import" lnkid))) + (syntax->list #'(export-lnkid ...)))) + + + (let* ([idxs (iota (add1 (length (syntax->list #'(sub-exp ...)))))] + [sub-export-table-tmps (generate-temporaries #'(sub-exp ...))] + [link-map + (let ((bt (make-bound-identifier-mapping))) + (for-each + (lambda (tags lnkids sigids tableid i) (for-each - (lambda (t l) - (define et (syntax-e t)) - (define el (syntax-e l)) - (define rec (link-map l)) - (define forward-dep (>= (lnkid-record-source-idx rec) i)) - (define import-dep (= 0 (lnkid-record-source-idx rec))) - (for-each - (lambda (ctime-id rtime-id name) - (hash-table-put! ht - (build-key et ctime-id) - (list forward-dep import-dep et rtime-id name el))) - (lnkid-record-ctime-ids rec) - (lnkid-record-rtime-ids rec) - (lnkid-record-names rec))) + (lambda (tag lnkid sigid) + (define siginfo (signature-siginfo (lookup-signature sigid))) + (define rtime-ids (map syntax-local-introduce + (siginfo-rtime-ids siginfo))) + (bound-identifier-mapping-put! + bt + lnkid + (make-lnkid-record + #`(hash-ref + #,tableid + #,(build-key (syntax-e tag) (car rtime-ids))) + (siginfo-names siginfo) + (siginfo-ctime-ids siginfo) + rtime-ids + i + sigid + siginfo))) (syntax->list tags) - (syntax->list lnkids)) - (hash-table-map ht (lambda (x y) y))) - (syntax->list #'((sub-in-tag ...) ...)) - (syntax->list #'((sub-in-lnkid ...) ...)) - (cdr idxs))]) - - (check-duplicate-subs - (map (lambda (t lid) (cons (syntax-e t) - (lnkid-record-siginfo (link-map lid)))) - (syntax->list #'(export-tag ...)) - (syntax->list #'(export-lnkid ...))) - (syntax->list #'(export-lnktag ...))) - - (with-syntax (((sub-tmp ...) (generate-temporaries #'(sub-exp ...))) - ((sub-export-table-tmp ...) sub-export-table-tmps) - (name (syntax-local-infer-name (error-syntax))) - (((import-key ...) ...) - (map - (lambda (t l) - (lnkid-rec->keys (syntax-e t) (link-map l))) - (syntax->list #'(import-tag ...)) - (syntax->list #'(import-lnkid ...)))) - (((export-key ...) ...) - (map - (lambda (t l) - (lnkid-rec->keys (syntax-e t) (link-map l))) - (syntax->list #'(export-tag ...)) - (syntax->list #'(export-lnkid ...)))) - ((import-name ...) - (map (lambda (l) (car (lnkid-record-names (link-map l)))) - (syntax->list #'(import-lnkid ...)))) - ((export-name ...) - (map (lambda (l) (car (lnkid-record-names (link-map l)))) - (syntax->list #'(export-lnkid ...)))) - (((((sub-in-key sub-in-code) ...) ...) ...) - (map - (lambda (stxed-tags lnkids) - (define lnkid-recs (map link-map (syntax->list lnkids))) - (define tags (map syntax-e (syntax->list stxed-tags))) - (define tagged-siginfos - (map - (lambda (t l) (cons t (lnkid-record-siginfo l))) - tags - lnkid-recs)) - (check-duplicate-subs tagged-siginfos (syntax->list lnkids)) + (syntax->list lnkids) + (syntax->list sigids))) + (syntax->list #'((import-tag ...) (sub-out-tag ...) ...)) + (syntax->list #'((import-lnkid ...) (sub-out-lnkid ...) ...)) + (syntax->list #'((import-sigid ...) (sub-out-sigid ...) ...)) + (cons #'import-table-id sub-export-table-tmps) + idxs) + (lambda (id) + (bound-identifier-mapping-get + bt + id + (lambda () + (raise-stx-err "unknown linking identifier" id)))))] + [link-deps + (map + (lambda (tags lnkids i) + (define ht (make-hash)) + (for-each + (lambda (t l) + (define et (syntax-e t)) + (define el (syntax-e l)) + (define rec (link-map l)) + (define forward-dep (>= (lnkid-record-source-idx rec) i)) + (define import-dep (= 0 (lnkid-record-source-idx rec))) + (for-each + (lambda (ctime-id rtime-id name) + (hash-set! ht + (build-key et ctime-id) + (list forward-dep import-dep et rtime-id name el))) + (lnkid-record-ctime-ids rec) + (lnkid-record-rtime-ids rec) + (lnkid-record-names rec))) + (syntax->list tags) + (syntax->list lnkids)) + (hash-map ht (lambda (x y) y))) + (syntax->list #'((sub-in-tag ...) ...)) + (syntax->list #'((sub-in-lnkid ...) ...)) + (cdr idxs))]) + + (check-duplicate-subs + (map (lambda (t lid) (cons (syntax-e t) + (lnkid-record-siginfo (link-map lid)))) + (syntax->list #'(export-tag ...)) + (syntax->list #'(export-lnkid ...))) + (syntax->list #'(export-lnktag ...))) + + (with-syntax (((sub-tmp ...) (generate-temporaries #'(sub-exp ...))) + ((sub-export-table-tmp ...) sub-export-table-tmps) + (name (syntax-local-infer-name (error-syntax))) + (((import-key ...) ...) + (map + (lambda (t l) + (lnkid-rec->keys (syntax-e t) (link-map l))) + (syntax->list #'(import-tag ...)) + (syntax->list #'(import-lnkid ...)))) + (((export-key ...) ...) + (map + (lambda (t l) + (lnkid-rec->keys (syntax-e t) (link-map l))) + (syntax->list #'(export-tag ...)) + (syntax->list #'(export-lnkid ...)))) + ((import-name ...) + (map (lambda (l) (car (lnkid-record-names (link-map l)))) + (syntax->list #'(import-lnkid ...)))) + ((export-name ...) + (map (lambda (l) (car (lnkid-record-names (link-map l)))) + (syntax->list #'(export-lnkid ...)))) + (((((sub-in-key sub-in-code) ...) ...) ...) + (map + (lambda (stxed-tags lnkids) + (define lnkid-recs (map link-map (syntax->list lnkids))) + (define tags (map syntax-e (syntax->list stxed-tags))) + (define tagged-siginfos (map - (lambda (t lr) - (with-syntax (((key ...) - (lnkid-rec->keys t lr))) - #`((key #,(lnkid-record-access-code lr)) ...))) + (lambda (t l) (cons t (lnkid-record-siginfo l))) tags lnkid-recs)) - (syntax->list #'((sub-in-tag ...) ...)) - (syntax->list #'((sub-in-lnkid ...) ...)))) - ((((sub-out-key ...) ...) ...) + (check-duplicate-subs tagged-siginfos (syntax->list lnkids)) + (map + (lambda (t lr) + (with-syntax (((key ...) + (lnkid-rec->keys t lr))) + #`((key #,(lnkid-record-access-code lr)) ...))) + tags + lnkid-recs)) + (syntax->list #'((sub-in-tag ...) ...)) + (syntax->list #'((sub-in-lnkid ...) ...)))) + ((((sub-out-key ...) ...) ...) + (map + (lambda (lnkids tags) + (map + (lambda (l t) + (lnkid-rec->keys (syntax-e t) (link-map l))) + (syntax->list lnkids) + (syntax->list tags))) + (syntax->list #'((sub-out-lnkid ...) ...)) + (syntax->list #'((sub-out-tag ...) ...)))) + (((export-sigid . export-code) ...) + (map (lambda (lnkid) + (define s (link-map lnkid)) + (cons (lnkid-record-sigid s) + (lnkid-record-access-code s))) + (syntax->list #'(export-lnkid ...)))) + (form (syntax-e (stx-car (error-syntax)))) + ) + + (with-syntax (((check-sub-exp ...) (map - (lambda (lnkids tags) - (map - (lambda (l t) - (lnkid-rec->keys (syntax-e t) (link-map l))) - (syntax->list lnkids) - (syntax->list tags))) - (syntax->list #'((sub-out-lnkid ...) ...)) - (syntax->list #'((sub-out-tag ...) ...)))) - (((export-sigid . export-code) ...) - (map (lambda (lnkid) - (define s (link-map lnkid)) - (cons (lnkid-record-sigid s) - (lnkid-record-access-code s))) - (syntax->list #'(export-lnkid ...)))) - (form (syntax-e (stx-car (error-syntax)))) + (lambda (stx link-deps) + (with-syntax (((sub-exp + sub-tmp + ((sub-in-key ...) ...) + ((sub-out-key ...) ...) + sub-in-lnkid + sub-out-lnkid) + stx)) + (with-syntax (((sub-in-signame ...) + (map (lambda (l) (car (lnkid-record-names (link-map l)))) + (syntax->list #'sub-in-lnkid))) + ((sub-out-signame ...) + (map (lambda (l) (car (lnkid-record-names (link-map l)))) + (syntax->list #'sub-out-lnkid))) + (((fdep-tag fdep-rtime fsig-name flnk-name) ...) + (map cddr (filter car link-deps))) + (((rdep-tag rdep-rtime . _) ...) + (map cddr (filter cadr link-deps)))) + #`(begin + #,(syntax/loc #'sub-exp + (check-unit sub-tmp 'form)) + #,(syntax/loc #'sub-exp + (check-sigs sub-tmp + (vector-immutable + (cons 'sub-in-signame + (vector-immutable sub-in-key ...)) + ...) + (vector-immutable + (cons 'sub-out-signame + (vector-immutable sub-out-key ...)) + ...) + 'form)) + (let ([fht (equal-hash-table + ((cons 'fdep-tag fdep-rtime) + (cons 'fsig-name 'flnk-name)) + ...)] + [rht (equal-hash-table + ((cons 'rdep-tag rdep-rtime) + #t) + ...)]) + #,(syntax/loc #'sub-exp (check-deps fht sub-tmp 'form)) + (for-each + (lambda (dep) + (when (hash-ref rht dep #f) + (set! deps (cons dep deps)))) + (unit-deps sub-tmp))))))) + (syntax->list #'((sub-exp + sub-tmp + ((sub-in-key ...) ...) + ((sub-out-key ...) ...) + (sub-in-lnkid ...) + (sub-out-lnkid ...)) + ...)) + link-deps)) + (((sub-in-key-code-workaround ...) ...) + (map + (lambda (x) + (with-syntax ((((a ...) ...) x)) + #'(a ... ...))) + (syntax->list #'((((sub-in-key sub-in-code) ...) ...) ...)))) ) - - (with-syntax (((check-sub-exp ...) - (map - (lambda (stx link-deps) - (with-syntax (((sub-exp - sub-tmp - ((sub-in-key ...) ...) - ((sub-out-key ...) ...) - sub-in-lnkid - sub-out-lnkid) - stx)) - (with-syntax (((sub-in-signame ...) - (map (lambda (l) (car (lnkid-record-names (link-map l)))) - (syntax->list #'sub-in-lnkid))) - ((sub-out-signame ...) - (map (lambda (l) (car (lnkid-record-names (link-map l)))) - (syntax->list #'sub-out-lnkid))) - (((fdep-tag fdep-rtime fsig-name flnk-name) ...) - (map cddr (filter car link-deps))) - (((rdep-tag rdep-rtime . _) ...) - (map cddr (filter cadr link-deps)))) - #`(begin - #,(syntax/loc #'sub-exp - (check-unit sub-tmp 'form)) - #,(syntax/loc #'sub-exp - (check-sigs sub-tmp - (vector-immutable - (cons 'sub-in-signame - (vector-immutable sub-in-key ...)) - ...) - (vector-immutable - (cons 'sub-out-signame - (vector-immutable sub-out-key ...)) - ...) - 'form)) - (let ([fht (equal-hash-table - ((cons 'fdep-tag fdep-rtime) - (cons 'fsig-name 'flnk-name)) - ...)] - [rht (equal-hash-table - ((cons 'rdep-tag rdep-rtime) - #t) - ...)]) - #,(syntax/loc #'sub-exp (check-deps fht sub-tmp 'form)) - (for-each - (lambda (dep) - (when (hash-table-get rht dep #f) - (set! deps (cons dep deps)))) - (unit-deps sub-tmp))))))) - (syntax->list #'((sub-exp - sub-tmp - ((sub-in-key ...) ...) - ((sub-out-key ...) ...) - (sub-in-lnkid ...) - (sub-out-lnkid ...)) - ...)) - link-deps)) - (((sub-in-key-code-workaround ...) ...) - (map - (lambda (x) - (with-syntax ((((a ...) ...) x)) - #'(a ... ...))) - (syntax->list #'((((sub-in-key sub-in-code) ...) ...) ...)))) - ) - (values - (quasisyntax/loc (error-syntax) - (let ([deps '()] - [sub-tmp sub-exp] ...) - check-sub-exp ... - (make-unit - 'name - (vector-immutable - (cons 'import-name - (vector-immutable import-key ...)) - ...) - (vector-immutable - (cons 'export-name - (vector-immutable export-key ...)) - ...) - deps - (lambda () - (let-values ([(sub-tmp sub-export-table-tmp) ((unit-go sub-tmp))] - ...) - (values (lambda (import-table-id) - (void) - (sub-tmp (equal-hash-table sub-in-key-code-workaround ...)) - ...) - (unit-export ((export-key ...) export-code) ...))))))) - (map syntax-e (syntax->list #'((import-tag . import-sigid) ...))) - (map syntax-e (syntax->list #'((export-tag . export-sigid) ...))) - '())))))) - (((i ...) (e ...) (l ...)) - (for-each check-link-line-syntax (syntax->list #'(l ...)))))) - - - (define-syntax/err-param (compound-unit stx) - (let-values (((u x y z) - (build-compound-unit - (check-compound-syntax (syntax-case stx () ((_ . x) #'x)))))) - u)) - - - (define (invoke-unit/core unit) - (check-unit unit 'invoke-unit) - (check-no-imports unit 'invoke-unit) - (let-values ([(f exports) ((unit-go unit))]) - (f #f))) - - (define-syntax/err-param (define-values/invoke-unit/core stx) - (syntax-case stx () - ((_ unit-expr . unit-out) - (let* ((unit-out (checked-syntax->list #'unit-out)) - (tagged-out (map process-tagged-import unit-out)) - (out-tags (map car tagged-out)) - (out-sigs (map caddr tagged-out)) - (dup (check-duplicate-identifier (apply append (map sig-int-names out-sigs)))) - (out-vec (generate-temporaries out-sigs)) - (tmarker (make-syntax-introducer)) - (tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs)) - (def-table (make-bound-identifier-mapping))) - (when dup - (raise-stx-err (format "duplicate binding for ~e" (syntax-e dup)))) - (for-each - (λ (sig new-xs) - (for-each - (λ (old new) - (bound-identifier-mapping-put! def-table old new)) - (map car (car sig)) - new-xs)) - out-sigs - tmp-bindings) - (with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags)) - ((((int-binding . ext-binding) ...) ...) (map car out-sigs)) - ((out-vec ...) out-vec) - (((renames - (((mac-name ...) mac-body) ...) - (((val-name ...) val-body) ...)) - ...) - (map build-val+macro-defs out-sigs)) - ((out-names ...) - (map (lambda (info) (car (siginfo-names (cdr info)))) - out-tags)) - (((tmp-binding ...) ...) tmp-bindings) - (((out-code ...) ...) - (map - (lambda (os ov) - (map - (lambda (i) - #`(vector-ref #,ov #,i)) - (iota (length (car os))))) - out-sigs - out-vec)) - (((wrap-code ...) ...) - (map (λ (os ov tbs) - (define rename-bindings - (get-member-bindings def-table os #'(#%variable-reference))) - (map (λ (tb i v c) - (if c - (with-syntax ([ctc-stx - (syntax-property - #`(letrec-syntax #,rename-bindings #,c) - 'inferred-name v)]) - #`(let ([v/c (#,tb)]) - (contract ctc-stx (car v/c) (cdr v/c) - (current-contract-region) - #,(id->contract-src-info v)))) - #`(#,tb))) - tbs - (iota (length (car os))) - (map car (car os)) - (cadddr os))) - out-sigs - out-vec - tmp-bindings))) - (quasisyntax/loc stx - (begin - (define-values (tmp-binding ... ...) - #,(syntax/loc #'unit-expr - (let ((unit-tmp unit-expr)) - (check-unit unit-tmp 'define-values/invoke-unit) - (check-sigs unit-tmp - (vector-immutable) - (vector-immutable (cons 'out-names - (vector-immutable key1 key ...)) ...) - 'define-values/invoke-unit) - (let-values (((unit-fn export-table) - ((unit-go unit-tmp)))) - (let ([out-vec (hash-table-get export-table key1)] ...) - (unit-fn #f) - (values out-code ... ...)))))) - (define-values (int-binding ... ...) - (values wrap-code ... ...)) - (define-syntaxes . renames) ... - (define-syntaxes (mac-name ...) mac-body) ... ... - (define-values (val-name ...) val-body) ... ...))))) - ((_) - (raise-stx-err "missing unit expression")))) - - ;; build-unit-from-context : syntax-object -> - ;; (values syntax-object (listof identifier) (listof identifier)) - ;; constructs the code for a unit-from-context expression. stx must be - ;; such that it passes check-ufc-syntax. - ;; The two additional values are the identifiers of the unit's import and export - ;; signatures - (define-for-syntax (build-unit-from-context stx) - (syntax-case stx () - ((export-spec) - (let* ((tagged-export-sig (process-tagged-export #'export-spec)) - (export-sig (caddr tagged-export-sig))) - (with-syntax ((((int-id . ext-id) ...) (car export-sig)) - ((def-name ...) (generate-temporaries (map car (car export-sig))))) - (values - #'(:unit (import) (export (rename export-spec (def-name int-id) ...)) - (define def-name int-id) - ...) - null - (list (cadr tagged-export-sig)) - '())))))) - - (define-for-syntax (check-ufc-syntax stx) - (syntax-case stx () - ((export-spec) (void)) - (() - (raise-stx-err "missing export-spec")) - (_ - (raise-stx-err "nothing is permitted after export-spec")))) - - (define-syntax/err-param (unit-from-context stx) - (syntax-case stx () - ((_ . x) - (begin - (check-ufc-syntax #'x) - (let-values (((u x y z) (build-unit-from-context #'x))) - u))))) - - - - (define-for-syntax (build-define-unit-helper contracted?) - (lambda (stx build err-msg) - (syntax-case stx () - ((_ name . rest) - (begin - (check-id #'name) - (let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))]) - (build #'rest )))) - (with-syntax ((((itag . isig) ...) i) - (((etag . esig) ...) e) - (((deptag . depsig) ...) d) - (contracted? contracted?)) - (quasisyntax/loc (error-syntax) - (begin - (define u #,exp) - (define-syntax name - (make-set!-transformer - (make-unit-info ((syntax-local-certifier) (quote-syntax u)) - (list (cons 'itag (quote-syntax isig)) ...) - (list (cons 'etag (quote-syntax esig)) ...) - (list (cons 'deptag (quote-syntax deptag)) ...) - (quote-syntax name) - contracted?))))))))) - ((_) - (raise-stx-err err-msg))))) - - ;; build-define-unit : syntax-object - ;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier)) - ;; string -> - ;; syntax-object - (define-for-syntax build-define-unit (build-define-unit-helper #f)) - (define-for-syntax build-define-unit/contracted (build-define-unit-helper #t)) - - (define-for-syntax (build-define-unit-binding stx) - - (define (check-helper tagged-info) - (cons (car (siginfo-names (cdr tagged-info))) - (tagged-info->keys tagged-info))) - - (syntax-case stx (import export init-depend) - ((unit-exp (import i ...) (export e ...) (init-depend idep ...)) - (let* ([ti (syntax->list #'(i ...))] - [te (syntax->list #'(e ...))] - [tidep (syntax->list #'(idep ...))] - [tagged-import-sigids (map check-tagged-id ti)] - [tagged-export-sigids (map check-tagged-id te)] - [tagged-dep-sigids (map check-tagged-id tidep)] - [tagged-import-infos (map tagged-sigid->tagged-siginfo tagged-import-sigids)] - [tagged-export-infos (map tagged-sigid->tagged-siginfo tagged-export-sigids)] - [tagged-dep-siginfos (map tagged-sigid->tagged-siginfo tagged-dep-sigids)]) - (check-duplicate-sigs tagged-import-infos ti tagged-dep-siginfos tidep) - (check-duplicate-subs tagged-export-infos te) - (with-syntax ((((import-name . (import-keys ...)) ...) - (map check-helper tagged-import-infos)) - (((export-name . (export-keys ...)) ...) - (map check-helper tagged-export-infos)) - (form (stx-car (error-syntax)))) - (values - #`(let ([unit-tmp unit-exp]) - #,(syntax/loc #'unit-exp - (check-unit unit-tmp 'form)) - #,(syntax/loc #'unit-exp - (check-sigs unit-tmp - (vector-immutable - (cons 'import-name - (vector-immutable import-keys ...)) + (values + (quasisyntax/loc (error-syntax) + (let ([deps '()] + [sub-tmp sub-exp] ...) + check-sub-exp ... + (make-unit + 'name + (vector-immutable + (cons 'import-name + (vector-immutable import-key ...)) + ...) + (vector-immutable + (cons 'export-name + (vector-immutable export-key ...)) + ...) + deps + (lambda () + (let-values ([(sub-tmp sub-export-table-tmp) ((unit-go sub-tmp))] + ...) + (values (lambda (import-table-id) + (void) + (sub-tmp (equal-hash-table sub-in-key-code-workaround ...)) ...) - (vector-immutable - (cons 'export-name - (vector-immutable export-keys ...)) - ...) - 'form)) - unit-tmp) - tagged-import-sigids - tagged-export-sigids - tagged-dep-sigids)))))) - - (define-syntax/err-param (define-unit-binding stx) - (build-define-unit stx (lambda (unit) - (build-define-unit-binding (check-unit-body-syntax unit))) - "missing unit name, unit expression, import clause, and export clause")) - - (define-syntax/err-param (define-unit stx) - (build-define-unit stx (lambda (unit) - (build-unit (check-unit-syntax unit))) - "missing unit name, import clause, and export clause")) - - (define-syntax/err-param (define-unit/new-import-export stx) - (build-define-unit stx (lambda (unit) - (build-unit/new-import-export (check-unit-syntax unit))) - "missing unit name, import clause, and export clause")) - - (define-syntax/err-param (define-compound-unit stx) - (build-define-unit stx (lambda (clauses) - (build-compound-unit (check-compound-syntax clauses))) - "missing unit name")) - - (define-syntax/err-param (define-unit-from-context stx) - (build-define-unit stx (lambda (sig) - (check-ufc-syntax sig) - (build-unit-from-context sig)) - "missing unit name and signature")) - - (define-for-syntax (build-unit/contract stx) - (syntax-parse stx - [(:import-clause/contract :export-clause/contract dep:dep-clause . body) - (let-values ([(exp isigs esigs deps) - (build-unit - (check-unit-syntax - (syntax/loc stx - ((import i.s ...) (export e.s ...) dep . body))))]) - (with-syntax ([name (syntax-local-infer-name (error-syntax))] - [(import-tagged-sig-id ...) - (map (λ (i s) - (if (identifier? i) #`(tag #,i #,s) s)) - (syntax->list #'(i.s.i ...)) - (syntax->list #'(i.s.s.name ...)))] - [(export-tagged-sig-id ...) - (map (λ (i s) - (if (identifier? i) #`(tag #,i #,s) s)) - (syntax->list #'(e.s.i ...)) - (syntax->list #'(e.s.s.name ...)))]) - (with-syntax ([new-unit exp] - [unit-contract - (unit/c/core - #'name - (syntax/loc stx - ((import (import-tagged-sig-id [i.x i.c] ...) ...) - (export (export-tagged-sig-id [e.x e.c] ...) ...))))] - [src-info (id->contract-src-info #'name)]) - (values - (syntax/loc stx - (contract unit-contract new-unit '(unit name) (current-contract-region) src-info)) - isigs esigs deps))))] - [(ic:import-clause/contract ec:export-clause/contract . body) - (build-unit/contract - (syntax/loc stx - (ic ec (init-depend) . body)))])) - - (define-syntax/err-param (define-unit/contract stx) - (build-define-unit/contracted stx (λ (stx) - (build-unit/contract stx)) - "missing unit name")) + (unit-export ((export-key ...) export-code) ...))))))) + (map syntax-e (syntax->list #'((import-tag . import-sigid) ...))) + (map syntax-e (syntax->list #'((export-tag . export-sigid) ...))) + '())))))) + (((i ...) (e ...) (l ...)) + (for-each check-link-line-syntax (syntax->list #'(l ...)))))) - (define-for-syntax (unprocess-tagged-id ti) - (if (car ti) - #`(tag #,(car ti) #,(cdr ti)) - (cdr ti))) - - (define-for-syntax (temp-id-with-tags id i) - (syntax-case i (tag) - [(tag t sig) - (list id #`(tag t #,id) #'sig)] - [_else - (list id id i)])) - (define-syntax/err-param (define-values/invoke-unit stx) - (syntax-case stx (import export) - ((_ u (import) (export e ...)) - (quasisyntax/loc stx - (define-values/invoke-unit/core u e ...))) - ((_ u (import i ...) (export e ...)) - (with-syntax (((EU ...) (generate-temporaries #'(e ...))) - (((IU IUl i) ...) (map temp-id-with-tags - (generate-temporaries #'(i ...)) - (syntax->list #'(i ...)))) - ((iu ...) (generate-temporaries #'(i ...))) - ((i-id ...) (map cdadr - (map process-tagged-import - (syntax->list #'(i ...))))) - ((e-id ...) (map cdadr - (map process-tagged-export - (syntax->list #'(e ...)))))) +(define-syntax/err-param (compound-unit stx) + (let-values (((u x y z) + (build-compound-unit + (check-compound-syntax (syntax-case stx () ((_ . x) #'x)))))) + u)) + + +(define (invoke-unit/core unit) + (check-unit unit 'invoke-unit) + (check-no-imports unit 'invoke-unit) + (let-values ([(f exports) ((unit-go unit))]) + (f #f))) + +(define-syntax/err-param (define-values/invoke-unit/core stx) + (syntax-case stx () + ((_ unit-expr . unit-out) + (let* ((unit-out (checked-syntax->list #'unit-out)) + (tagged-out (map process-tagged-import unit-out)) + (out-tags (map car tagged-out)) + (out-sigs (map caddr tagged-out)) + (dup (check-duplicate-identifier (apply append (map sig-int-names out-sigs)))) + (out-vec (generate-temporaries out-sigs)) + (tmarker (make-syntax-introducer)) + (tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs)) + (def-table (make-bound-identifier-mapping))) + (when dup + (raise-stx-err (format "duplicate binding for ~e" (syntax-e dup)))) + (for-each + (λ (sig new-xs) + (for-each + (λ (old new) + (bound-identifier-mapping-put! def-table old new)) + (map car (car sig)) + new-xs)) + out-sigs + tmp-bindings) + (with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags)) + ((((int-binding . ext-binding) ...) ...) (map car out-sigs)) + ((out-vec ...) out-vec) + (((renames + (((mac-name ...) mac-body) ...) + (((val-name ...) val-body) ...)) + ...) + (map build-val+macro-defs out-sigs)) + ((out-names ...) + (map (lambda (info) (car (siginfo-names (cdr info)))) + out-tags)) + (((tmp-binding ...) ...) tmp-bindings) + (((out-code ...) ...) + (map + (lambda (os ov) + (map + (lambda (i) + #`(vector-ref #,ov #,i)) + (iota (length (car os))))) + out-sigs + out-vec)) + (((wrap-code ...) ...) + (map (λ (os ov tbs) + (define rename-bindings + (get-member-bindings def-table os #'(#%variable-reference))) + (map (λ (tb i v c) + (if c + (with-syntax ([ctc-stx + (syntax-property + #`(letrec-syntax #,rename-bindings #,c) + 'inferred-name v)]) + #`(let ([v/c (#,tb)]) + (contract ctc-stx (car v/c) (cdr v/c) + (current-contract-region) + #,(id->contract-src-info v)))) + #`(#,tb))) + tbs + (iota (length (car os))) + (map car (car os)) + (cadddr os))) + out-sigs + out-vec + tmp-bindings))) (quasisyntax/loc stx (begin - (define-unit-from-context iu i) - ... - (define-compound-unit u2 (import) - (export EU ...) - (link [((IU : i-id)) iu] ... [((EU : e-id) ...) u IUl ...])) - (define-values/invoke-unit/core u2 e ...))))) + (define-values (tmp-binding ... ...) + #,(syntax/loc #'unit-expr + (let ((unit-tmp unit-expr)) + (check-unit unit-tmp 'define-values/invoke-unit) + (check-sigs unit-tmp + (vector-immutable) + (vector-immutable (cons 'out-names + (vector-immutable key1 key ...)) ...) + 'define-values/invoke-unit) + (let-values (((unit-fn export-table) + ((unit-go unit-tmp)))) + (let ([out-vec (hash-ref export-table key1)] ...) + (unit-fn #f) + (values out-code ... ...)))))) + (define-values (int-binding ... ...) + (values wrap-code ... ...)) + (define-syntaxes . renames) ... + (define-syntaxes (mac-name ...) mac-body) ... ... + (define-values (val-name ...) val-body) ... ...))))) + ((_) + (raise-stx-err "missing unit expression")))) + +;; build-unit-from-context : syntax-object -> +;; (values syntax-object (listof identifier) (listof identifier)) +;; constructs the code for a unit-from-context expression. stx must be +;; such that it passes check-ufc-syntax. +;; The two additional values are the identifiers of the unit's import and export +;; signatures +(define-for-syntax (build-unit-from-context stx) + (syntax-case stx () + ((export-spec) + (let* ((tagged-export-sig (process-tagged-export #'export-spec)) + (export-sig (caddr tagged-export-sig))) + (with-syntax ((((int-id . ext-id) ...) (car export-sig)) + ((def-name ...) (generate-temporaries (map car (car export-sig))))) + (values + #'(:unit (import) (export (rename export-spec (def-name int-id) ...)) + (define def-name int-id) + ...) + null + (list (cadr tagged-export-sig)) + '())))))) + +(define-for-syntax (check-ufc-syntax stx) + (syntax-case stx () + ((export-spec) (void)) + (() + (raise-stx-err "missing export-spec")) + (_ + (raise-stx-err "nothing is permitted after export-spec")))) + +(define-syntax/err-param (unit-from-context stx) + (syntax-case stx () + ((_ . x) + (begin + (check-ufc-syntax #'x) + (let-values (((u x y z) (build-unit-from-context #'x))) + u))))) + + + +(define-for-syntax (build-define-unit-helper contracted?) + (lambda (stx build err-msg) + (syntax-case stx () + ((_ name . rest) + (begin + (check-id #'name) + (let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))]) + (build #'rest )))) + (with-syntax ((((itag . isig) ...) i) + (((etag . esig) ...) e) + (((deptag . depsig) ...) d) + (contracted? contracted?)) + (quasisyntax/loc (error-syntax) + (begin + (define u #,exp) + (define-syntax name + (make-set!-transformer + (make-unit-info ((syntax-local-certifier) (quote-syntax u)) + (list (cons 'itag (quote-syntax isig)) ...) + (list (cons 'etag (quote-syntax esig)) ...) + (list (cons 'deptag (quote-syntax deptag)) ...) + (quote-syntax name) + contracted?))))))))) ((_) - (raise-stx-err "missing unit" stx)) - ((_ . b) - (raise-stx-err - (format "expected syntax matching (~a (import ...) (export ...))" - (syntax-e (stx-car stx))))))) + (raise-stx-err err-msg))))) + +;; build-define-unit : syntax-object +;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier)) +;; string -> +;; syntax-object +(define-for-syntax build-define-unit (build-define-unit-helper #f)) +(define-for-syntax build-define-unit/contracted (build-define-unit-helper #t)) + +(define-for-syntax (build-define-unit-binding stx) - ;; build-compound-unit/infer : syntax-object -> - ;; (values syntax-object (listof identifier) (listof identifier)) - ;; constructs the code for a compound-unit/infer expression. stx match the return of - ;; check-compound-syntax - ;; The two additional values are the identifiers of the compound-unit's import and export - ;; signatures - (define-for-syntax (build-compound-unit/infer stx) - - (define (lookup-tagged tid) - (cons (car tid) (lookup-signature (cdr tid)))) - - (define (process-signature s) - (define l - ((check-tagged - (lambda (b) - (syntax-case* b (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y))) - ((x : y) - (and (identifier? #'x) (identifier? #'y)) - (list #'x #'y (signature-siginfo (lookup-signature #'y)))) - (x - (identifier? #'x) - (list (car (generate-temporaries (list #'x))) - #'x - (signature-siginfo (lookup-signature #'x)))) - (_ - (raise-stx-err "expected syntax matching or ( : )" - b))))) - s)) - (apply make-link-record l)) - - (define ((process-tagged-sigid introducer) sid) - (make-link-record (car sid) #f (introducer (cdr sid)) (signature-siginfo (lookup-signature (cdr sid))))) - - (syntax-case stx () - (((import ...) - (export ...) - (((out ...) u l ...) ...)) - (let* ([us (syntax->list #'(u ...))] - [units (map lookup-def-unit us)] - [import-sigs (map process-signature - (syntax->list #'(import ...)))] - [sig-introducers (map (lambda (unit u) - (make-syntax-delta-introducer u (unit-info-orig-binder unit))) - units us)] - [sub-outs - (map - (lambda (outs unit sig-introducer) - (define o + (define (check-helper tagged-info) + (cons (car (siginfo-names (cdr tagged-info))) + (tagged-info->keys tagged-info))) + + (syntax-case stx (import export init-depend) + ((unit-exp (import i ...) (export e ...) (init-depend idep ...)) + (let* ([ti (syntax->list #'(i ...))] + [te (syntax->list #'(e ...))] + [tidep (syntax->list #'(idep ...))] + [tagged-import-sigids (map check-tagged-id ti)] + [tagged-export-sigids (map check-tagged-id te)] + [tagged-dep-sigids (map check-tagged-id tidep)] + [tagged-import-infos (map tagged-sigid->tagged-siginfo tagged-import-sigids)] + [tagged-export-infos (map tagged-sigid->tagged-siginfo tagged-export-sigids)] + [tagged-dep-siginfos (map tagged-sigid->tagged-siginfo tagged-dep-sigids)]) + (check-duplicate-sigs tagged-import-infos ti tagged-dep-siginfos tidep) + (check-duplicate-subs tagged-export-infos te) + (with-syntax ((((import-name . (import-keys ...)) ...) + (map check-helper tagged-import-infos)) + (((export-name . (export-keys ...)) ...) + (map check-helper tagged-export-infos)) + (form (stx-car (error-syntax)))) + (values + #`(let ([unit-tmp unit-exp]) + #,(syntax/loc #'unit-exp + (check-unit unit-tmp 'form)) + #,(syntax/loc #'unit-exp + (check-sigs unit-tmp + (vector-immutable + (cons 'import-name + (vector-immutable import-keys ...)) + ...) + (vector-immutable + (cons 'export-name + (vector-immutable export-keys ...)) + ...) + 'form)) + unit-tmp) + tagged-import-sigids + tagged-export-sigids + tagged-dep-sigids)))))) + +(define-syntax/err-param (define-unit-binding stx) + (build-define-unit stx (lambda (unit) + (build-define-unit-binding (check-unit-body-syntax unit))) + "missing unit name, unit expression, import clause, and export clause")) + +(define-syntax/err-param (define-unit stx) + (build-define-unit stx (lambda (unit) + (build-unit (check-unit-syntax unit))) + "missing unit name, import clause, and export clause")) + +(define-syntax/err-param (define-unit/new-import-export stx) + (build-define-unit stx (lambda (unit) + (build-unit/new-import-export (check-unit-syntax unit))) + "missing unit name, import clause, and export clause")) + +(define-syntax/err-param (define-compound-unit stx) + (build-define-unit stx (lambda (clauses) + (build-compound-unit (check-compound-syntax clauses))) + "missing unit name")) + +(define-syntax/err-param (define-unit-from-context stx) + (build-define-unit stx (lambda (sig) + (check-ufc-syntax sig) + (build-unit-from-context sig)) + "missing unit name and signature")) + +(define-for-syntax (build-unit/contract stx) + (syntax-parse stx + [(:import-clause/contract :export-clause/contract dep:dep-clause . body) + (let-values ([(exp isigs esigs deps) + (build-unit + (check-unit-syntax + (syntax/loc stx + ((import i.s ...) (export e.s ...) dep . body))))]) + (with-syntax ([name (syntax-local-infer-name (error-syntax))] + [(import-tagged-sig-id ...) + (map (λ (i s) + (if (identifier? i) #`(tag #,i #,s) s)) + (syntax->list #'(i.s.i ...)) + (syntax->list #'(i.s.s.name ...)))] + [(export-tagged-sig-id ...) + (map (λ (i s) + (if (identifier? i) #`(tag #,i #,s) s)) + (syntax->list #'(e.s.i ...)) + (syntax->list #'(e.s.s.name ...)))]) + (with-syntax ([new-unit exp] + [unit-contract + (unit/c/core + #'name + (syntax/loc stx + ((import (import-tagged-sig-id [i.x i.c] ...) ...) + (export (export-tagged-sig-id [e.x e.c] ...) ...))))] + [src-info (id->contract-src-info #'name)]) + (values + (syntax/loc stx + (contract unit-contract new-unit '(unit name) (current-contract-region) src-info)) + isigs esigs deps))))] + [(ic:import-clause/contract ec:export-clause/contract . body) + (build-unit/contract + (syntax/loc stx + (ic ec (init-depend) . body)))])) + +(define-syntax/err-param (define-unit/contract stx) + (build-define-unit/contracted stx (λ (stx) + (build-unit/contract stx)) + "missing unit name")) + +(define-for-syntax (unprocess-tagged-id ti) + (if (car ti) + #`(tag #,(car ti) #,(cdr ti)) + (cdr ti))) + +(define-for-syntax (temp-id-with-tags id i) + (syntax-case i (tag) + [(tag t sig) + (list id #`(tag t #,id) #'sig)] + [_else + (list id id i)])) + +(define-syntax/err-param (define-values/invoke-unit stx) + (syntax-case stx (import export) + ((_ u (import) (export e ...)) + (quasisyntax/loc stx + (define-values/invoke-unit/core u e ...))) + ((_ u (import i ...) (export e ...)) + (with-syntax (((EU ...) (generate-temporaries #'(e ...))) + (((IU IUl i) ...) (map temp-id-with-tags + (generate-temporaries #'(i ...)) + (syntax->list #'(i ...)))) + ((iu ...) (generate-temporaries #'(i ...))) + ((i-id ...) (map cdadr + (map process-tagged-import + (syntax->list #'(i ...))))) + ((e-id ...) (map cdadr + (map process-tagged-export + (syntax->list #'(e ...)))))) + (quasisyntax/loc stx + (begin + (define-unit-from-context iu i) + ... + (define-compound-unit u2 (import) + (export EU ...) + (link [((IU : i-id)) iu] ... [((EU : e-id) ...) u IUl ...])) + (define-values/invoke-unit/core u2 e ...))))) + ((_) + (raise-stx-err "missing unit" stx)) + ((_ . b) + (raise-stx-err + (format "expected syntax matching (~a (import ...) (export ...))" + (syntax-e (stx-car stx))))))) + +;; build-compound-unit/infer : syntax-object -> +;; (values syntax-object (listof identifier) (listof identifier)) +;; constructs the code for a compound-unit/infer expression. stx match the return of +;; check-compound-syntax +;; The two additional values are the identifiers of the compound-unit's import and export +;; signatures +(define-for-syntax (build-compound-unit/infer stx) + + (define (lookup-tagged tid) + (cons (car tid) (lookup-signature (cdr tid)))) + + (define (process-signature s) + (define l + ((check-tagged + (lambda (b) + (syntax-case* b (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y))) + ((x : y) + (and (identifier? #'x) (identifier? #'y)) + (list #'x #'y (signature-siginfo (lookup-signature #'y)))) + (x + (identifier? #'x) + (list (car (generate-temporaries (list #'x))) + #'x + (signature-siginfo (lookup-signature #'x)))) + (_ + (raise-stx-err "expected syntax matching or ( : )" + b))))) + s)) + (apply make-link-record l)) + + (define ((process-tagged-sigid introducer) sid) + (make-link-record (car sid) #f (introducer (cdr sid)) (signature-siginfo (lookup-signature (cdr sid))))) + + (syntax-case stx () + (((import ...) + (export ...) + (((out ...) u l ...) ...)) + (let* ([us (syntax->list #'(u ...))] + [units (map lookup-def-unit us)] + [import-sigs (map process-signature + (syntax->list #'(import ...)))] + [sig-introducers (map (lambda (unit u) + (make-syntax-delta-introducer u (unit-info-orig-binder unit))) + units us)] + [sub-outs + (map + (lambda (outs unit sig-introducer) + (define o + (map + (lambda (clause) + (define c (check-tagged-:-clause clause)) + (make-link-record (car c) (cadr c) (cddr c) + (signature-siginfo (lookup-signature (cddr c))))) + (syntax->list outs))) + (complete-exports (map (process-tagged-sigid sig-introducer) (unit-info-export-sig-ids unit)) + o)) + (syntax->list #'((out ...) ...)) + units + sig-introducers)] + [link-defs (append import-sigs (apply append sub-outs))]) + + (define lnk-table (make-bound-identifier-mapping)) + (define sig-table (make-hasheq)) + + (let ([dup (check-duplicate-identifier (map link-record-linkid link-defs))]) + (when dup + (raise-stx-err "duplicate identifier" dup))) + + (for-each + (lambda (b) + (bound-identifier-mapping-put! lnk-table (link-record-linkid b) b)) + link-defs) + + (for-each + (lambda (b) + (for-each + (lambda (cid) + (define there? (hash-ref sig-table cid #f)) + (hash-set! sig-table cid (if there? 'duplicate (link-record-linkid b)))) + (siginfo-ctime-ids (link-record-siginfo b)))) + link-defs) + + (let ([sub-ins + (map + (lambda (ins unit sig-introducer unit-stx) + (define is (syntax->list ins)) + (define lrs + (map + (lambda (i) + (define tagged-lnkid (check-tagged-id i)) + (define sig + (bound-identifier-mapping-get lnk-table + (cdr tagged-lnkid) + (lambda () #f))) + (unless sig + (raise-stx-err "unknown linking identifier" i)) + (make-link-record (car tagged-lnkid) + (cdr tagged-lnkid) + (link-record-sigid sig) + (link-record-siginfo sig))) + is)) + (check-duplicate-subs + (map + (lambda (lr) (cons (link-record-tag lr) (link-record-siginfo lr))) + lrs) + is) + (complete-imports sig-table + lrs + (map (process-tagged-sigid sig-introducer) + (unit-info-import-sig-ids unit)) + unit-stx)) + (syntax->list #'((l ...) ...)) + units + sig-introducers + us)] + [exports + (map + (lambda (e) + (define tid (check-tagged-id e)) + (define lookup (bound-identifier-mapping-get + lnk-table + (cdr tid) + (lambda () #f))) + (cond + [lookup (unprocess-tagged-id tid)] + [else + (let ([lnkid (hash-ref + sig-table + (car (siginfo-ctime-ids (signature-siginfo (lookup-signature (cdr tid))))) + #f)]) + (cond + [(not lnkid) + (raise-stx-err "no sub unit exports this signature" (cdr tid))] + [(eq? lnkid 'duplicate) + (raise-stx-err "multiple sub units export this signature" (cdr tid))] + [else + (unprocess-tagged-id + (cons (car tid) lnkid))]))])) + (syntax->list #'(export ...)))]) + (with-syntax (((import ...) + (map unprocess-link-record-bind import-sigs)) + (((out ...) ...) + (map + (lambda (out) + (map unprocess-link-record-bind out)) + sub-outs)) + (((in ...) ...) + (map + (lambda (ins) + (map unprocess-link-record-use ins)) + sub-ins)) + ((unit-id ...) (map + (lambda (u stx) + (quasisyntax/loc stx #,(unit-info-unit-id u))) + units (syntax->list #'(u ...))))) + (build-compound-unit #`((import ...) + #,exports + (((out ...) unit-id in ...) ...))))))) + (((i ...) (e ...) (l ...)) + (for-each check-link-line-syntax (syntax->list #'(l ...)))))) + + +(define-for-syntax (check-compound/infer-syntax stx) + (syntax-case (check-compound-syntax stx) () + ((i e (b ...)) + (with-syntax (((b ...) (map + (lambda (b) + (if (identifier? b) + #`(() #,b) + b)) + (syntax->list #'(b ...))))) + #'(i e (b ...)))))) + +(define-syntax/err-param (compound-unit/infer stx) + (let-values (((u i e d) + (build-compound-unit/infer + (check-compound/infer-syntax + (syntax-case stx () ((_ . x) #'x)))))) + u)) + +(define-for-syntax (do-define-compound-unit/infer stx) + (build-define-unit stx (lambda (clause) - (define c (check-tagged-:-clause clause)) - (make-link-record (car c) (cadr c) (cddr c) - (signature-siginfo (lookup-signature (cddr c))))) - (syntax->list outs))) - (complete-exports (map (process-tagged-sigid sig-introducer) (unit-info-export-sig-ids unit)) - o)) - (syntax->list #'((out ...) ...)) - units - sig-introducers)] - [link-defs (append import-sigs (apply append sub-outs))]) + (build-compound-unit/infer (check-compound/infer-syntax clause))) + "missing unit name")) - (define lnk-table (make-bound-identifier-mapping)) - (define sig-table (make-hash-table)) +(define-syntax/err-param (define-compound-unit/infer stx) + (do-define-compound-unit/infer stx)) - (let ([dup (check-duplicate-identifier (map link-record-linkid link-defs))]) - (when dup - (raise-stx-err "duplicate identifier" dup))) - - (for-each - (lambda (b) - (bound-identifier-mapping-put! lnk-table (link-record-linkid b) b)) - link-defs) - - (for-each - (lambda (b) - (for-each - (lambda (cid) - (define there? (hash-table-get sig-table cid #f)) - (hash-table-put! sig-table cid (if there? 'duplicate (link-record-linkid b)))) - (siginfo-ctime-ids (link-record-siginfo b)))) - link-defs) - - (let ([sub-ins - (map - (lambda (ins unit sig-introducer unit-stx) - (define is (syntax->list ins)) - (define lrs - (map - (lambda (i) - (define tagged-lnkid (check-tagged-id i)) - (define sig - (bound-identifier-mapping-get lnk-table - (cdr tagged-lnkid) - (lambda () #f))) - (unless sig - (raise-stx-err "unknown linking identifier" i)) - (make-link-record (car tagged-lnkid) - (cdr tagged-lnkid) - (link-record-sigid sig) - (link-record-siginfo sig))) - is)) - (check-duplicate-subs - (map - (lambda (lr) (cons (link-record-tag lr) (link-record-siginfo lr))) - lrs) - is) - (complete-imports sig-table - lrs - (map (process-tagged-sigid sig-introducer) - (unit-info-import-sig-ids unit)) - unit-stx)) - (syntax->list #'((l ...) ...)) - units - sig-introducers - us)] - [exports - (map - (lambda (e) - (define tid (check-tagged-id e)) - (define lookup (bound-identifier-mapping-get - lnk-table - (cdr tid) - (lambda () #f))) - (cond - [lookup (unprocess-tagged-id tid)] - [else - (let ([lnkid (hash-table-get - sig-table - (car (siginfo-ctime-ids (signature-siginfo (lookup-signature (cdr tid))))) - #f)]) - (cond - [(not lnkid) - (raise-stx-err "no sub unit exports this signature" (cdr tid))] - [(eq? lnkid 'duplicate) - (raise-stx-err "multiple sub units export this signature" (cdr tid))] - [else - (unprocess-tagged-id - (cons (car tid) lnkid))]))])) - (syntax->list #'(export ...)))]) - (with-syntax (((import ...) - (map unprocess-link-record-bind import-sigs)) - (((out ...) ...) - (map - (lambda (out) - (map unprocess-link-record-bind out)) - sub-outs)) - (((in ...) ...) - (map - (lambda (ins) - (map unprocess-link-record-use ins)) - sub-ins)) - ((unit-id ...) (map - (lambda (u stx) - (quasisyntax/loc stx #,(unit-info-unit-id u))) - units (syntax->list #'(u ...))))) - (build-compound-unit #`((import ...) - #,exports - (((out ...) unit-id in ...) ...))))))) - (((i ...) (e ...) (l ...)) - (for-each check-link-line-syntax (syntax->list #'(l ...)))))) - - - (define-for-syntax (check-compound/infer-syntax stx) - (syntax-case (check-compound-syntax stx) () - ((i e (b ...)) - (with-syntax (((b ...) - (map - (lambda (b) - (if (identifier? b) - #`(() #,b) - b)) - (syntax->list #'(b ...))))) - #'(i e (b ...)))))) +;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax +(define-for-syntax (build-invoke-unit/infer units define? exports) + (define (imps/exps-from-unit u) + (let* ([ui (lookup-def-unit u)] + [unprocess (let ([i (make-syntax-delta-introducer u (unit-info-orig-binder ui))]) + (lambda (p) + (unprocess-tagged-id (cons (car p) (i (cdr p))))))] + [isigs (map unprocess (unit-info-import-sig-ids ui))] + [esigs (map unprocess (unit-info-export-sig-ids ui))]) + (values isigs esigs))) + (define (drop-from-other-list exp-tagged imp-tagged imp-sources) + (let loop ([ts imp-tagged] [ss imp-sources]) + (cond + [(null? ts) null] + [(ormap (lambda (tinfo2) + (and (eq? (car (car ts)) (car tinfo2)) + (siginfo-subtype (cdr tinfo2) (cdr (car ts))))) + exp-tagged) + (loop (cdr ts) (cdr ss))] + [else (cons (car ss) (loop (cdr ts) (cdr ss)))]))) - (define-syntax/err-param (compound-unit/infer stx) - (let-values (((u i e d) - (build-compound-unit/infer - (check-compound/infer-syntax - (syntax-case stx () ((_ . x) #'x)))))) - u)) - - (define-for-syntax (do-define-compound-unit/infer stx) - (build-define-unit stx - (lambda (clause) - (build-compound-unit/infer (check-compound/infer-syntax clause))) - "missing unit name")) - - (define-syntax/err-param (define-compound-unit/infer stx) - (do-define-compound-unit/infer stx)) - - ;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax - (define-for-syntax (build-invoke-unit/infer units define? exports) - (define (imps/exps-from-unit u) - (let* ([ui (lookup-def-unit u)] - [unprocess (let ([i (make-syntax-delta-introducer u (unit-info-orig-binder ui))]) - (lambda (p) - (unprocess-tagged-id (cons (car p) (i (cdr p))))))] - [isigs (map unprocess (unit-info-import-sig-ids ui))] - [esigs (map unprocess (unit-info-export-sig-ids ui))]) - (values isigs esigs))) - (define (drop-from-other-list exp-tagged imp-tagged imp-sources) - (let loop ([ts imp-tagged] [ss imp-sources]) - (cond - [(null? ts) null] - [(ormap (lambda (tinfo2) - (and (eq? (car (car ts)) (car tinfo2)) - (siginfo-subtype (cdr tinfo2) (cdr (car ts))))) - exp-tagged) - (loop (cdr ts) (cdr ss))] - [else (cons (car ss) (loop (cdr ts) (cdr ss)))]))) + (define (drop-duplicates tagged-siginfos sources) + (let loop ([ts tagged-siginfos] [ss sources] [res-t null] [res-s null]) + (cond + [(null? ts) (values res-t res-s)] + [(ormap (lambda (tinfo2) + (and (eq? (car (car ts)) (car tinfo2)) + (siginfo-subtype (cdr tinfo2) (cdr (car ts))))) + (cdr ts)) + (loop (cdr ts) (cdr ss) res-t res-s)] + [else (loop (cdr ts) (cdr ss) (cons (car ts) res-t) (cons (car ss) res-s))]))) + + (define (imps/exps-from-units units exports) + (define-values (isigs esigs) + (let loop ([units units] [imps null] [exps null]) + (if (null? units) + (values imps exps) + (let-values ([(i e) (imps/exps-from-unit (car units))]) + (loop (cdr units) (append i imps) (append e exps)))))) + (define-values (isig tagged-import-sigs import-tagged-infos + import-tagged-sigids import-sigs) + (process-unit-import (datum->syntax #f isigs))) - (define (drop-duplicates tagged-siginfos sources) - (let loop ([ts tagged-siginfos] [ss sources] [res-t null] [res-s null]) - (cond - [(null? ts) (values res-t res-s)] - [(ormap (lambda (tinfo2) - (and (eq? (car (car ts)) (car tinfo2)) - (siginfo-subtype (cdr tinfo2) (cdr (car ts))))) - (cdr ts)) - (loop (cdr ts) (cdr ss) res-t res-s)] - [else (loop (cdr ts) (cdr ss) (cons (car ts) res-t) (cons (car ss) res-s))]))) - - (define (imps/exps-from-units units exports) - (define-values (isigs esigs) - (let loop ([units units] [imps null] [exps null]) - (if (null? units) - (values imps exps) - (let-values ([(i e) (imps/exps-from-unit (car units))]) - (loop (cdr units) (append i imps) (append e exps)))))) - (define-values (isig tagged-import-sigs import-tagged-infos - import-tagged-sigids import-sigs) - (process-unit-import (datum->syntax-object #f isigs))) - - (define-values (esig tagged-export-sigs export-tagged-infos - export-tagged-sigids export-sigs) - (process-unit-export (datum->syntax-object #f esigs))) - (check-duplicate-subs export-tagged-infos esig) - (let-values ([(itagged isources) (drop-duplicates import-tagged-infos isig)]) - (values (drop-from-other-list export-tagged-infos itagged isources) - (cond - [(list? exports) - (let-values ([(spec-esig spec-tagged-export-sigs spec-export-tagged-infos - spec-export-tagged-sigids spec-export-sigs) - (process-unit-export (datum->syntax-object #f exports))]) - (restrict-exports export-tagged-infos - spec-esig spec-export-tagged-infos))] - [else esig])))) - - (define (restrict-exports unit-tagged-exports spec-exports spec-tagged-exports) - (for-each (lambda (se ste) - (unless (ormap (lambda (ute) - (and (eq? (car ute) (car ste)) - (siginfo-subtype (cdr ute) (cdr ste)))) - unit-tagged-exports) - (raise-stx-err (format "no subunit exports signature ~a" - (syntax-object->datum se)) - se))) - spec-exports - spec-tagged-exports) - spec-exports) - (when (and (not define?) exports) - (error 'build-invoke-unit/infer - "internal error: exports for invoke-unit/infer")) - (when (null? units) - (raise-stx-err "no units in link clause")) - (cond [(identifier? units) - (let-values ([(isig esig) (imps/exps-from-units (list units) exports)]) - (with-syntax ([u units] - [(esig ...) esig] - [(isig ...) isig]) + (define-values (esig tagged-export-sigs export-tagged-infos + export-tagged-sigids export-sigs) + (process-unit-export (datum->syntax #f esigs))) + (check-duplicate-subs export-tagged-infos esig) + (let-values ([(itagged isources) (drop-duplicates import-tagged-infos isig)]) + (values (drop-from-other-list export-tagged-infos itagged isources) + (cond + [(list? exports) + (let-values ([(spec-esig spec-tagged-export-sigs spec-export-tagged-infos + spec-export-tagged-sigids spec-export-sigs) + (process-unit-export (datum->syntax #f exports))]) + (restrict-exports export-tagged-infos + spec-esig spec-export-tagged-infos))] + [else esig])))) + + (define (restrict-exports unit-tagged-exports spec-exports spec-tagged-exports) + (for-each (lambda (se ste) + (unless (ormap (lambda (ute) + (and (eq? (car ute) (car ste)) + (siginfo-subtype (cdr ute) (cdr ste)))) + unit-tagged-exports) + (raise-stx-err (format "no subunit exports signature ~a" + (syntax->datum se)) + se))) + spec-exports + spec-tagged-exports) + spec-exports) + (when (and (not define?) exports) + (error 'build-invoke-unit/infer + "internal error: exports for invoke-unit/infer")) + (when (null? units) + (raise-stx-err "no units in link clause")) + (cond [(identifier? units) + (let-values ([(isig esig) (imps/exps-from-units (list units) exports)]) + (with-syntax ([u units] + [(esig ...) esig] + [(isig ...) isig]) + (if define? + (syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...))) + (syntax/loc (error-syntax) (invoke-unit u (import isig ...))))))] + [(list? units) + (let-values ([(isig esig) (imps/exps-from-units units exports)]) + (with-syntax ([(new-unit) (generate-temporaries '(new-unit))] + [(unit ...) units] + [(esig ...) esig] + [(isig ...) isig]) + (with-syntax ([u (let-values ([(u i e d) + (build-compound-unit/infer + (check-compound/infer-syntax + #'((import isig ...) + (export esig ...) + (link unit ...))))]) u)]) (if define? - (syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...))) - (syntax/loc (error-syntax) (invoke-unit u (import isig ...))))))] - [(list? units) - (let-values ([(isig esig) (imps/exps-from-units units exports)]) - (with-syntax ([(new-unit) (generate-temporaries '(new-unit))] - [(unit ...) units] - [(esig ...) esig] - [(isig ...) isig]) - (with-syntax ([u (let-values ([(u i e d) - (build-compound-unit/infer - (check-compound/infer-syntax - #'((import isig ...) - (export esig ...) - (link unit ...))))]) u)]) - (if define? - (syntax/loc (error-syntax) - (define-values/invoke-unit u - (import isig ...) (export esig ...))) - (syntax/loc (error-syntax) - (invoke-unit u - (import isig ...)))))))] - ;; just for error handling - [else (lookup-def-unit units)])) + (syntax/loc (error-syntax) + (define-values/invoke-unit u + (import isig ...) (export esig ...))) + (syntax/loc (error-syntax) + (invoke-unit u + (import isig ...)))))))] + ;; just for error handling + [else (lookup-def-unit units)])) - (define-syntax/err-param (define-values/invoke-unit/infer stx) - (syntax-case stx (export link) - [(_ (link unit ...)) - (build-invoke-unit/infer (syntax->list #'(unit ...)) #t #f)] - [(_ (export e ...) (link unit ...)) - (build-invoke-unit/infer (syntax->list #'(unit ...)) #t (syntax->list #'(e ...)))] - [(_ (export e ...) u) - (build-invoke-unit/infer #'u #t (syntax->list #'(e ...)))] - [(_ u) - (build-invoke-unit/infer #'u #t #f)] - [(_) - (raise-stx-err "missing unit" stx)] - [(_ . b) - (raise-stx-err - (format "expected syntax matching (~a [(export )] ) or (~a [(export )] (link ...))" - (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))])) - - (define-syntax/err-param (invoke-unit stx) - (syntax-case stx (import) - ((_ unit) +(define-syntax/err-param (define-values/invoke-unit/infer stx) + (syntax-case stx (export link) + [(_ (link unit ...)) + (build-invoke-unit/infer (syntax->list #'(unit ...)) #t #f)] + [(_ (export e ...) (link unit ...)) + (build-invoke-unit/infer (syntax->list #'(unit ...)) #t (syntax->list #'(e ...)))] + [(_ (export e ...) u) + (build-invoke-unit/infer #'u #t (syntax->list #'(e ...)))] + [(_ u) + (build-invoke-unit/infer #'u #t #f)] + [(_) + (raise-stx-err "missing unit" stx)] + [(_ . b) + (raise-stx-err + (format "expected syntax matching (~a [(export )] ) or (~a [(export )] (link ...))" + (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))])) + +(define-syntax/err-param (invoke-unit stx) + (syntax-case stx (import) + ((_ unit) + (syntax/loc stx + (invoke-unit/core unit))) + ((_ unit (import isig ...)) + (with-syntax (((u ...) (generate-temporaries (syntax->list #'(isig ...)))) + (((U Ul isig) ...) (map temp-id-with-tags + (generate-temporaries #'(isig ...)) + (syntax->list #'(isig ...)))) + ((isig-id ...) (map cdadr + (map process-tagged-import + (syntax->list #'(isig ...)))))) (syntax/loc stx - (invoke-unit/core unit))) - ((_ unit (import isig ...)) - (with-syntax (((u ...) (generate-temporaries (syntax->list #'(isig ...)))) - (((U Ul isig) ...) (map temp-id-with-tags - (generate-temporaries #'(isig ...)) - (syntax->list #'(isig ...)))) - ((isig-id ...) (map cdadr - (map process-tagged-import - (syntax->list #'(isig ...)))))) - (syntax/loc stx - (let () - (define-unit-from-context u isig) - ... - (define-compound-unit u2 (import) (export) - (link [((U : isig-id)) u] ... [() unit Ul ...])) - (invoke-unit/core u2))))) - (_ (raise-stx-err (format - "expected (~a ) or (~a (import ...))" - (syntax-e (stx-car stx)) - (syntax-e (stx-car stx))))))) - - (define-syntax/err-param (invoke-unit/infer stx) - (syntax-case stx () - [(_ (link unit ...)) - (build-invoke-unit/infer (syntax->list #'(unit ...)) #f #f)] - [(_ u) (build-invoke-unit/infer #'u #f #f)] - [(_) - (raise-stx-err "missing unit" stx)] - [(_ . b) - (raise-stx-err - (format "expected syntax matching (~a ) or (~a (link ...))" - (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))])) - - (define-for-syntax (build-unit/s stx) - (syntax-case stx (import export init-depend) - [((import i ...) (export e ...) (init-depend d ...) u) - (let* ([ui (lookup-def-unit #'u)] - [unprocess (let ([i (make-syntax-delta-introducer #'u (unit-info-orig-binder ui))]) - (lambda (p) - (unprocess-tagged-id (cons (car p) (i (cdr p))))))]) - (with-syntax ([(isig ...) (map unprocess (unit-info-import-sig-ids ui))] - [(esig ...) (map unprocess (unit-info-export-sig-ids ui))]) - (build-unit/new-import-export - (syntax/loc stx - ((import i ...) (export e ...) (init-depend d ...) ((esig ...) u isig ...))))))])) + (let () + (define-unit-from-context u isig) + ... + (define-compound-unit u2 (import) (export) + (link [((U : isig-id)) u] ... [() unit Ul ...])) + (invoke-unit/core u2))))) + (_ (raise-stx-err (format + "expected (~a ) or (~a (import ...))" + (syntax-e (stx-car stx)) + (syntax-e (stx-car stx))))))) - (define-syntax/err-param (define-unit/s stx) - (build-define-unit stx (λ (stx) (build-unit/s (check-unit-syntax stx))) - "missing unit name")) - - (define-syntax/err-param (unit/s stx) - (syntax-case stx () - [(_ . stx) - (let-values ([(u x y z) (build-unit/s (check-unit-syntax #'stx))]) - u)])) - - ) -;(load "test-unit.ss") +(define-syntax/err-param (invoke-unit/infer stx) + (syntax-case stx () + [(_ (link unit ...)) + (build-invoke-unit/infer (syntax->list #'(unit ...)) #f #f)] + [(_ u) (build-invoke-unit/infer #'u #f #f)] + [(_) + (raise-stx-err "missing unit" stx)] + [(_ . b) + (raise-stx-err + (format "expected syntax matching (~a ) or (~a (link ...))" + (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))])) + +(define-for-syntax (build-unit/s stx) + (syntax-case stx (import export init-depend) + [((import i ...) (export e ...) (init-depend d ...) u) + (let* ([ui (lookup-def-unit #'u)] + [unprocess (let ([i (make-syntax-delta-introducer #'u (unit-info-orig-binder ui))]) + (lambda (p) + (unprocess-tagged-id (cons (car p) (i (cdr p))))))]) + (with-syntax ([(isig ...) (map unprocess (unit-info-import-sig-ids ui))] + [(esig ...) (map unprocess (unit-info-export-sig-ids ui))]) + (build-unit/new-import-export + (syntax/loc stx + ((import i ...) (export e ...) (init-depend d ...) ((esig ...) u isig ...))))))])) + +(define-syntax/err-param (define-unit/s stx) + (build-define-unit stx (λ (stx) (build-unit/s (check-unit-syntax stx))) + "missing unit name")) + +(define-syntax/err-param (unit/s stx) + (syntax-case stx () + [(_ . stx) + (let-values ([(u x y z) (build-unit/s (check-unit-syntax #'stx))]) + u)]))