#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")) (require mzlib/etc scheme/contract/base scheme/stxparam unstable/location "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-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 "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) (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) (quote #,var) (quote-syntax #,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) ;; 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 (quote #,id) (quote-syntax #,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) (quote #,var) (quote-syntax #,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) (quote #,var) (quote-syntax #,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)) [((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-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) (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 l) (cons t (lnkid-record-siginfo l))) tags lnkid-recs)) (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 (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) ...) ...) ...)))) ) (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 #'(quote-module-path))) (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) (quote #,v) (quote-syntax #,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-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 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 ...)) ...) (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] ...) ...))))]) (values (syntax/loc stx (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name))) 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) (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-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 ...)))))))] ;; 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) (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 ...))))))])) (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)]))