From 5401208e733b48c96f2b3ecb8d9cdfd5ce8dedae Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 5 Dec 2006 20:31:14 +0000 Subject: [PATCH] merged units branch svn: r5033 original commit: 3459c3a58f1cdc52fbc916acf306b29408468912 --- collects/mzlib/a-signature.ss | 29 + collects/mzlib/a-unit.ss | 28 + collects/mzlib/deflate.ss | 2 +- collects/mzlib/private/sigmatch.ss | 2 +- collects/mzlib/private/sigutil.ss | 2 +- collects/mzlib/unit-exptime.ss | 26 + collects/mzlib/unit.ss | 2475 +++++++++++++++++---------- collects/mzlib/unit200.ss | 869 ++++++++++ collects/mzlib/unitsig.ss | 360 +--- collects/mzlib/unitsig200.ss | 359 ++++ collects/net/base64-sig.ss | 18 +- collects/net/base64-unit.ss | 14 +- collects/net/cgi-sig.ss | 51 +- collects/net/cgi-unit.ss | 13 +- collects/net/cookie-sig.ss | 33 +- collects/net/cookie-unit.ss | 547 +++--- collects/net/dns-sig.ss | 16 +- collects/net/dns-unit.ss | 22 +- collects/net/ftp-sig.ss | 19 +- collects/net/ftp-unit.ss | 14 +- collects/net/head-sig.ss | 31 +- collects/net/head-unit.ss | 19 +- collects/net/imap-sig.ss | 80 +- collects/net/imap-unit.ss | 14 +- collects/net/mime-sig.ss | 57 +- collects/net/mime-unit.ss | 13 +- collects/net/nntp-sig.ss | 40 +- collects/net/nntp-unit.ss | 16 +- collects/net/pop3-sig.ss | 46 +- collects/net/pop3-unit.ss | 17 +- collects/net/qp-sig.ss | 27 +- collects/net/qp-unit.ss | 11 +- collects/net/sendmail-sig.ss | 14 +- collects/net/sendmail-unit.ss | 17 +- collects/net/smtp-sig.ss | 15 +- collects/net/smtp-unit.ss | 19 +- collects/net/uri-codec-sig.ss | 24 +- collects/net/uri-codec-unit.ss | 16 +- collects/net/url-sig.ss | 32 +- collects/net/url-unit.ss | 10 +- collects/tests/mzscheme/pconvert.ss | 12 +- collects/tests/mzscheme/unit.ss | 2 +- collects/tests/mzscheme/unitsig.ss | 4 +- 43 files changed, 3494 insertions(+), 1941 deletions(-) create mode 100644 collects/mzlib/a-signature.ss create mode 100644 collects/mzlib/a-unit.ss create mode 100644 collects/mzlib/unit-exptime.ss create mode 100644 collects/mzlib/unit200.ss create mode 100644 collects/mzlib/unitsig200.ss diff --git a/collects/mzlib/a-signature.ss b/collects/mzlib/a-signature.ss new file mode 100644 index 0000000..423abb7 --- /dev/null +++ b/collects/mzlib/a-signature.ss @@ -0,0 +1,29 @@ +(module a-signature mzscheme + (require-for-syntax "private/unit-compiletime.ss" + "private/unit-syntax.ss") + (require "unit.ss") + + (provide (rename module-begin #%module-begin) + (all-from-except mzscheme #%module-begin) + (all-from "unit.ss")) + + (define-for-syntax (make-name s) + (string->symbol + (string-append (regexp-replace "-sig$" (symbol->string s) "") + "^"))) + + (define-syntax (module-begin stx) + (parameterize ((error-syntax stx)) + (with-syntax ((name (make-name (syntax-property stx 'enclosing-module-name)))) + (syntax-case stx () + ((_ . x) + (with-syntax ((((reqs ...) . (body ...)) + (split-requires (checked-syntax->list #'x)))) + (datum->syntax-object + stx + (syntax-e #'(#%module-begin + reqs ... + (provide name) + (define-signature name (body ...)))) + stx)))))))) + diff --git a/collects/mzlib/a-unit.ss b/collects/mzlib/a-unit.ss new file mode 100644 index 0000000..29ff654 --- /dev/null +++ b/collects/mzlib/a-unit.ss @@ -0,0 +1,28 @@ +(module a-unit mzscheme + (require-for-syntax "private/unit-compiletime.ss" + "private/unit-syntax.ss") + (require "unit.ss") + + (provide (rename module-begin #%module-begin) + (all-from-except mzscheme #%module-begin) + (all-from "unit.ss")) + + (define-for-syntax (make-name s) + (string->symbol + (string-append (regexp-replace "-unit$" (symbol->string s) "") + "@"))) + + (define-syntax (module-begin stx) + (parameterize ((error-syntax stx)) + (with-syntax ((name (make-name (syntax-property stx 'enclosing-module-name)))) + (syntax-case stx () + ((_ . x) + (with-syntax ((((reqs ...) . (body ...)) + (split-requires (checked-syntax->list #'x)))) + (datum->syntax-object + stx + (syntax-e #'(#%module-begin + reqs ... + (provide name) + (define-unit name body ...))) + stx)))))))) diff --git a/collects/mzlib/deflate.ss b/collects/mzlib/deflate.ss index 95e0991..c3c4f99 100644 --- a/collects/mzlib/deflate.ss +++ b/collects/mzlib/deflate.ss @@ -12,7 +12,7 @@ (provide deflate gzip-through-ports gzip) - (require "unit.ss") + (require "unit200.ss") (define-syntax INSERT_STRING (syntax-rules () diff --git a/collects/mzlib/private/sigmatch.ss b/collects/mzlib/private/sigmatch.ss index 2ae9a42..784a535 100644 --- a/collects/mzlib/private/sigmatch.ss +++ b/collects/mzlib/private/sigmatch.ss @@ -1,7 +1,7 @@ (module sigmatch mzscheme - (require "../unit.ss") + (require "../unit200.ss") (define (hash-sig src-sig table) (and (pair? src-sig) diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index 33021b2..2209a98 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -8,7 +8,7 @@ (lib "context.ss" "syntax")) (require "sigmatch.ss") - (require "../unit.ss") + (require "../unit200.ss") (require "../list.ss") (define-struct signature (name ; sym diff --git a/collects/mzlib/unit-exptime.ss b/collects/mzlib/unit-exptime.ss new file mode 100644 index 0000000..3a6be57 --- /dev/null +++ b/collects/mzlib/unit-exptime.ss @@ -0,0 +1,26 @@ +(module unit-exptime mzscheme + (require "private/unit-syntax.ss" + "private/unit-compiletime.ss") + + (provide unit-static-signatures + signature-members) + + (define (unit-static-signatures name err-stx) + (parameterize ((error-syntax err-stx)) + (let ((ui (lookup-def-unit name))) + (values (apply list-immutable (unit-info-import-sig-ids ui)) + (apply list-immutable (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-immutable (signature-vars s)) + ;; defined vars + (apply list-immutable (apply append (map car (signature-val-defs s)))) + ;; defined stxs + (apply list-immutable (apply append (map car (signature-stx-defs s))))))))) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 67f90e5..f5e201c 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -1,869 +1,1620 @@ - -;; Unit system - (module unit mzscheme - (require-for-syntax (lib "kerncase.ss" "syntax") - (lib "stx.ss" "syntax") - (lib "name.ss" "syntax") - (lib "context.ss" "syntax") - "list.ss" - "private/unitidmap.ss") - - ;; ---------------------------------------------------------------------- - ;; Structures and helpers - - (define undefined (letrec ([x x]) x)) ; initial value - - (define insp (current-inspector)) ; for named structures - - (define-struct unit (num-imports exports go)) ; unit value - (define-struct (exn:fail:unit exn:fail) ()) ; run-time exception - - ;; For units with inferred names, generate a struct that prints using the name: - (define (make-naming-constructor type name) - (let-values ([(struct: make- ? -accessor -mutator) - (make-struct-type name type 0 0 #f null insp)]) - make-)) - - ;; Make a unt value (call by the macro expansion of `unit') - (define (make-a-unit name num-imports exports go) - ((if name - (make-naming-constructor - struct:unit - (string->symbol (format "unit:~a" name))) - make-unit) - num-imports exports go)) - - ;; ---------------------------------------------------------------------- - ;; The `unit' syntactic form - - (define-syntaxes (_unit unit/no-expand) - (let ([do-unit - (lambda (stx expand?) - (syntax-case stx (import export) - [(_ (import ivar ...) - (export evar ...) - defn&expr ...) - (let ([check-id (lambda (v) - (unless (identifier? v) - (raise-syntax-error - #f - "import is not an identifier" - stx - v)))] - [check-renamed-id - (lambda (v) - (syntax-case v () - [id (identifier? (syntax id)) (list v)] - [(lid eid) (and (identifier? (syntax lid)) - (identifier? (syntax eid))) - (list #'lid #'eid)] - [else (raise-syntax-error - #f - "export is not an identifier or renamed identifier" - stx - v)]))] - [expand-context (generate-expand-context)] - [def-ctx (and expand? - (syntax-local-make-definition-context))] - [localify (lambda (ids def-ctx) - (if (andmap identifier? ids) - ;; In expand mode, add internal defn context - (if expand? - (begin - ;; Treat imports as internal-defn names: - (syntax-local-bind-syntaxes ids #f def-ctx) - (cdr (syntax->list - (local-expand #`(stop #,@ids) - 'expression - (list #'stop) - def-ctx)))) - ids) - ;; Let later checking report an error: - ids))]) - (let ([ivars (localify (syntax->list (syntax (ivar ...))) def-ctx)] - [evars (syntax->list (syntax (evar ...)))]) - (for-each check-id ivars) - (for-each check-renamed-id evars) - - ;; Get import/export declared names: - (let* ([exported-names - (localify - (map (lambda (v) - (syntax-case v () - [(lid eid) (syntax lid)] - [id (syntax id)])) - evars) - def-ctx)] - [extnames (map (lambda (v) - (syntax-case v () - [(lid eid) (syntax eid)] - [id (syntax id)])) - evars)] - [imported-names ivars] - [declared-names (append imported-names exported-names)]) - ;; Check that all exports are distinct (as symbols) - (let ([ht (make-hash-table)]) - (for-each (lambda (name) - (when (hash-table-get ht (syntax-e name) #f) - (raise-syntax-error - #f - "duplicate export" - stx - name)) - (hash-table-put! ht (syntax-e name) #t)) - extnames)) - - ;; Expand all body expressions - ;; so that all definitions are exposed. - (letrec ([expand-all - (if expand? - (lambda (defns&exprs) - (apply - append - (map - (lambda (defn-or-expr) - (let ([defn-or-expr - (local-expand - defn-or-expr - expand-context - (append - (kernel-form-identifier-list (quote-syntax here)) - declared-names) - def-ctx)]) - (syntax-case defn-or-expr (begin define-values define-syntaxes) - [(begin . l) - (let ([l (syntax->list (syntax l))]) - (unless l - (raise-syntax-error - #f - "bad syntax (illegal use of `.')" - defn-or-expr)) - (expand-all (map (lambda (s) - (syntax-track-origin s defn-or-expr #'begin)) - l)))] - [(define-syntaxes (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (with-syntax ([rhs (local-transformer-expand - #'rhs - 'expression - null)]) - (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx) - (list #'(define-syntaxes (id ...) rhs)))] - [(define-values (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (begin - (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f def-ctx) - (list defn-or-expr))] - [else (list defn-or-expr)]))) - defns&exprs))) - values)]) - (let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))]) - ;; Get all the defined names, sorting out variable definitions - ;; from syntax definitions. - (let* ([definition? - (lambda (id) - (and (identifier? id) - (or (module-identifier=? id (quote-syntax define-values)) - (module-identifier=? id (quote-syntax define-syntaxes)))))] - [all-defined-names/kinds - (apply - append - (map - (lambda (defn-or-expr) - (syntax-case defn-or-expr (define-values define-syntaxes) - [(dv (id ...) expr) - (definition? (syntax dv)) - (let ([l (syntax->list (syntax (id ...)))]) - (for-each (lambda (i) - (unless (identifier? i) - (raise-syntax-error - #f - "not an identifier in definition" - defn-or-expr - i))) - l) - (let ([key (if (module-identifier=? (syntax dv) (quote-syntax define-syntaxes)) - 'stx - 'val)]) - (map (lambda (id) (cons key id)) l)))] - [(define-values . l) - (raise-syntax-error - #f - "bad definition form" - defn-or-expr)] - [(define-syntaxes . l) - (raise-syntax-error - #f - "bad syntax definition form" - defn-or-expr)] - [else null])) - all-expanded))] - [all-defined-names (map cdr all-defined-names/kinds)] - [all-defined-val-names (map cdr - (filter (lambda (i) (eq? (car i) 'val)) - all-defined-names/kinds))]) - ;; Check that all defined names (var + stx) are distinct: - (let ([name (check-duplicate-identifier - (append imported-names all-defined-names))]) - (when name - (raise-syntax-error - #f - "variable imported and/or defined twice" - stx - name))) - ;; Check that all exported names are defined (as var): - (let ([ht (make-hash-table)] - [stx-ht (make-hash-table)]) - (for-each - (lambda (kind+name) - (let ([name (cdr kind+name)]) - (let ([l (hash-table-get ht (syntax-e name) null)]) - (hash-table-put! (if (eq? (car kind+name) 'val) ht stx-ht) - (syntax-e name) - (cons name l))))) - all-defined-names/kinds) - (for-each - (lambda (n) - (let ([v (hash-table-get ht (syntax-e n) null)]) - (unless (ormap (lambda (i) (bound-identifier=? i n)) v) - ;; Either not defined, or defined as syntax: - (let ([stx-v (hash-table-get stx-ht (syntax-e n) null)]) - (if (ormap (lambda (i) (bound-identifier=? i n)) stx-v) - (raise-syntax-error - #f - "cannot export syntax from a unit" - stx - n) - (raise-syntax-error - #f - "exported variable is not defined" - stx - n)))))) - exported-names)) - - ;; Compute defined but not exported: - (let ([ht (make-hash-table)]) - (for-each - (lambda (name) - (let ([l (hash-table-get ht (syntax-e name) null)]) - (hash-table-put! ht (syntax-e name) (cons name l)))) - exported-names) - (let ([internal-names - (let loop ([l all-defined-val-names]) - (cond - [(null? l) null] - [(let ([v (hash-table-get ht (syntax-e (car l)) null)]) - (ormap (lambda (i) (bound-identifier=? i (car l))) v)) - (loop (cdr l))] - [else (cons (car l) (loop (cdr l)))]))]) - ;; Generate names for import/export boxes, etc: - (with-syntax ([(ivar ...) ivars] - [(iloc ...) (generate-temporaries ivars)] - [(eloc ...) (generate-temporaries evars)] - [(extname ...) extnames] - [(expname ...) exported-names] - [(intname ...) internal-names]) - ;; Change all definitions to set!s. Convert evars to set-box!, - ;; because set! on exported variables is not allowed. - (with-syntax ([(defn&expr ...) - (let ([elocs (syntax->list (syntax (eloc ...)))]) - (filter - values - (map (lambda (defn-or-expr) - (syntax-case defn-or-expr (define-values define-syntaxes) - [(define-values ids expr) - (let* ([ids (syntax->list (syntax ids))]) - (if (null? ids) - (syntax/loc defn-or-expr (set!-values ids expr)) - (let ([do-one - (lambda (id tmp name) - (let loop ([evars exported-names] - [elocs elocs]) - (cond - [(null? evars) - ;; not an exported id - (with-syntax ([id id][tmp tmp]) - (syntax/loc - defn-or-expr - (set! id tmp)))] - [(bound-identifier=? (car evars) id) - ;; set! exported id: - (with-syntax - ([loc (car elocs)] - [tmp - (if name - (with-syntax - ([tmp tmp] - [name name]) - (syntax - (let ([name tmp]) - name))) - tmp)]) - (syntax/loc defn-or-expr - (set-box! loc tmp)))] - [else (loop (cdr evars) - (cdr elocs))])))]) - (if (null? (cdr ids)) - (do-one (car ids) (syntax expr) (car ids)) - (let ([tmps (generate-temporaries ids)]) - (with-syntax ([(tmp ...) tmps] - [(set ...) - (map (lambda (id tmp) - (do-one id tmp #f)) - ids tmps)]) - (syntax/loc defn-or-expr - (let-values ([(tmp ...) expr]) - set ...))))))))] - [(define-syntaxes . l) #f] - [else defn-or-expr])) - all-expanded)))] - [(stx-defn ...) - (filter - values - (map (lambda (defn-or-expr) - (syntax-case defn-or-expr (define-syntaxes) - [(define-syntaxes . l) #'l] - [else #f])) - all-expanded))]) - ;; Build up set! redirection chain: - (with-syntax ([redirections - (let ([varlocs - (syntax->list - (syntax ((ivar iloc) ... (expname eloc) ...)))]) - (with-syntax ([vars (map stx-car varlocs)] - [rhss - (map - (lambda (varloc) - (with-syntax ([(var loc) varloc]) - (syntax - (make-id-mapper (quote-syntax (unbox loc)) - (quote-syntax var))))) - varlocs)]) - (syntax - ([vars (values . rhss)]))))] - [num-imports (datum->syntax-object - (quote-syntax here) - (length (syntax->list (syntax (iloc ...)))) - #f)] - [name (syntax-local-infer-name stx)]) - (syntax/loc stx - (make-a-unit - 'name - num-imports - (list (quote extname) ...) - (lambda () - (let ([eloc (box undefined)] ...) - (list (vector eloc ...) - (lambda (iloc ...) - (letrec-syntaxes+values - (stx-defn ... . redirections) - ([(intname) undefined] ...) - (void) ; in case the body would be empty - defn&expr ...))))))))))))))))))]))]) - (values (lambda (stx) (do-unit stx #t)) - (lambda (stx) (do-unit stx #f))))) - - ;; ---------------------------------------------------------------------- - ;; check-expected-interface: used by the expansion of `compound-unit' + (require-for-syntax (lib "list.ss") + (lib "boundmap.ss" "syntax") + (lib "context.ss" "syntax") + (lib "kerncase.ss" "syntax") + (lib "name.ss" "syntax") + (lib "struct.ss" "syntax") + (lib "stx.ss" "syntax") + "private/unit-compiletime.ss" + "private/unit-syntax.ss") - (define (check-expected-interface tag unit num-imports exports) - (unless (unit? unit) - (raise - (make-exn:fail:unit - (string->immutable-string - (format "compound-unit: result of expression for tag ~s not a unit: ~e" tag unit)) - (current-continuation-marks)))) - (unless (= num-imports (unit-num-imports unit)) - (raise - (make-exn:fail:unit - (string->immutable-string - (format "compound-unit: unit for tag ~s expects ~a imports, given ~a" - tag - (unit-num-imports unit) - num-imports)) - (current-continuation-marks)))) - (list->vector - (map (lambda (ex) - (let loop ([l (unit-exports unit)][i 0]) - (cond - [(null? l) - (raise - (make-exn:fail:unit - (string->immutable-string - (format "compound-unit: unit for tag ~s has no ~s export" - tag ex)) - (current-continuation-marks)))] - [(eq? (car l) ex) - i] - [else (loop (cdr l) (add1 i))]))) - exports))) - - ;; ---------------------------------------------------------------------- - ;; The `compound-unit' syntactic form - - (define-syntax compound-unit - (lambda (stx) - (syntax-case stx (import export link) - [(_ (import ivar ...) - (link [tag (unit-expr linkage ...)] ...) - (export exportage ...)) - (let ([check-id (lambda (v) - (unless (identifier? v) - (raise-syntax-error - #f - "import is not an identifier" - stx - v)))] - [check-tag (lambda (v) - (unless (identifier? v) - (raise-syntax-error - #f - "tag is not an identifier" - stx - v)))] - [check-linkage (lambda (v) - (syntax-case v () - [id (identifier? (syntax id)) #t] - [(tag id ...) - (for-each (lambda (v) - (unless (identifier? v) - (raise-syntax-error - #f - "non-identifier in linkage" - stx - v))) - (syntax->list v))] - [else - (raise-syntax-error - #f - "ill-formed linkage" - stx - v)]))] - [check-exportage (lambda (v) - (syntax-case v () - [(tag ex ...) - (begin - (unless (identifier? (syntax tag)) - (raise-syntax-error - #f - "export tag is not an identifier" - stx - (syntax tag))) - (for-each - (lambda (e) - (syntax-case e () - [id (identifier? (syntax id)) #t] - [(iid eid) - (begin - (unless (identifier? (syntax iid)) - (raise-syntax-error - #f - "export internal name is not an identifier" - stx - (syntax iid))) - (unless (identifier? (syntax eid)) - (raise-syntax-error - #f - "export internal name is not an identifier" - stx - (syntax eid))))] - [else - (raise-syntax-error - #f - (format "ill-formed export with tag ~a" - (syntax-e (syntax tag))) - stx - e)])) - (syntax->list (syntax (ex ...)))))] - [else - (raise-syntax-error - #f - "ill-formed export" - stx - v)]))] - [imports (syntax->list (syntax (ivar ...)))] - [tags (syntax->list (syntax (tag ...)))] - [linkages (map syntax->list (syntax->list (syntax ((linkage ...) ...))))] - [exports (syntax->list (syntax (exportage ...)))]) - ;; Syntax checks: - (for-each check-id imports) - (for-each check-tag tags) - (for-each (lambda (l) (for-each check-linkage l)) linkages) - (for-each check-exportage exports) - ;; Check for duplicate imports - (let ([dup (check-duplicate-identifier imports)]) - (when dup - (raise-syntax-error - #f - "duplicate import" - stx - dup))) - ;; Check for duplicate tags - (let ([dup (check-duplicate-identifier tags)]) - (when dup - (raise-syntax-error - #f - "duplicate tag" - stx - dup))) - ;; Check referenced imports and tags - (let ([check-linkage-refs (lambda (v) - (syntax-case v () - [(tag . exs) - (unless (ormap (lambda (t) - (bound-identifier=? t (syntax tag))) - tags) - (raise-syntax-error - #f - "linkage tag is not bound" - stx - (syntax tag)))] - [id (unless (ormap (lambda (i) - (bound-identifier=? i (syntax id))) - imports) - (raise-syntax-error - #f - "no imported identified for linkage" - stx - (syntax id)))]))] - [check-export-refs (lambda (v) - (syntax-case v () - [(tag . r) - (unless (ormap (lambda (t) - (bound-identifier=? t (syntax tag))) - tags) - (raise-syntax-error - #f - "export tag is not bound" - stx - (syntax tag)))]))]) - (for-each (lambda (l) (for-each check-linkage-refs l)) - linkages) - (for-each check-export-refs exports) - ;; Get all export names, and check for duplicates - (let ([export-names - (apply - append - (map - (lambda (v) - (syntax-case v () - [(tag . exs) - (map - (lambda (e) - (syntax-case e () - [(iid eid) (syntax eid)] - [id e])) - (syntax->list (syntax exs)))])) - exports))]) - (let ([dup (check-duplicate-identifier export-names)]) - (when dup - (raise-syntax-error - #f - "duplicate export" - stx - dup))) - - (let ([constituents (generate-temporaries tags)] - [unit-export-positionss (generate-temporaries tags)] - [unit-setups (generate-temporaries tags)] - [unit-extracts (generate-temporaries tags)] - [unit-export-lists - ;; For each tag, get all expected exports - (let* ([hts (map (lambda (x) (make-hash-table)) tags)] - [get-add-name - (lambda (tag) - (ormap (lambda (t ht) - (and (bound-identifier=? t tag) - (lambda (name) - (hash-table-put! ht (syntax-e name) name)))) - tags hts))]) - ;; Walk though linkages - (for-each - (lambda (linkage-list) - (for-each - (lambda (linkage) - (syntax-case linkage () - [(tag . ids) - (let ([add-name (get-add-name (syntax tag))]) - (for-each add-name (syntax->list (syntax ids))))] - [else (void)])) - linkage-list)) - linkages) - ;; Walk through exports - (for-each - (lambda (v) - (syntax-case v () - [(tag . exs) - (let ([add-name (get-add-name (syntax tag))]) - (for-each - (lambda (e) - (syntax-case e () - [(iid eid) (add-name (syntax iid))] - [id (add-name (syntax id))])) - (syntax->list (syntax exs))))])) - exports) - ;; Extract names from hash tables - (map (lambda (ht) - (hash-table-map ht (lambda (k v) v))) - hts))]) - ;; Map exports to imports and indices based on expected unit exports - (let ([map-tag (lambda (t l) - (let loop ([tags tags][l l]) - (if (bound-identifier=? (car tags) t) - (car l) - (loop (cdr tags) (cdr l)))))] - [unit-export-hts (map (lambda (export-list) - (let ([ht (make-hash-table)]) - (let loop ([l export-list][p 0]) - (unless (null? l) - (hash-table-put! ht (syntax-e (car l)) p) - (loop (cdr l) (add1 p)))) - ht)) - unit-export-lists)] - [interned-integer-lists null] - [interned-id-lists null]) - (let ([make-mapping - (lambda (v) - (syntax-case v () - [(tag . exs) - (let ([extract (map-tag (syntax tag) - unit-extracts)] - [ht (map-tag (syntax tag) - unit-export-hts)]) - (with-syntax ([extract extract] - [pos-name - (let ([il - (map - (lambda (e) - (hash-table-get - ht - (syntax-e - (syntax-case e () - [(iid eid) (syntax iid)] - [id e])))) - (syntax->list (syntax exs)))]) - (or (ormap (lambda (i) - (and (equal? il (cadadr i)) - (car i))) - interned-integer-lists) - (let ([name (car (generate-temporaries - (list (syntax tag))))]) - (set! interned-integer-lists - (cons `(,name ',il) - interned-integer-lists)) - name)))]) - (syntax (map extract pos-name))))] - [import v]))] - [collapse (lambda (l) - (let loop ([l l]) - (cond - [(null? l) null] - [(identifier? (car l)) - (let-values ([(ids rest) - (let loop ([l l][ids null]) - (if (or (null? l) - (not (identifier? (car l)))) - (values (reverse ids) l) - (loop (cdr l) (cons (car l) ids))))]) - (let ([name - (let ([id-syms (map syntax-e ids)]) - (or (ormap (lambda (i) - (and (equal? id-syms (cadr i)) - (car i))) - interned-id-lists) - (let ([name - (car (generate-temporaries (list 'ids)))]) - (set! interned-id-lists - (cons (list* name id-syms ids) - interned-id-lists)) - name)))]) - (cons name - (loop rest))))] - [else (cons (car l) (loop (cdr l)))])))]) - (let ([export-mapping (collapse (map make-mapping exports))] - [import-mappings (map (lambda (linkage-list) - (collapse - (map make-mapping linkage-list))) - linkages)]) - (with-syntax ([(constituent ...) constituents] - [(unit-export-positions ...) unit-export-positionss] - [(unit-setup ...) unit-setups] - [(unit-extract ...) unit-extracts] - [interned-integer-lists interned-integer-lists] - [interned-id-lists (map (lambda (i) - (with-syntax ([name (car i)] - [ids (cddr i)]) - (syntax [name (list . ids)]))) - interned-id-lists)] - [(unit-export-list ...) unit-export-lists] - [(import-mapping ...) import-mappings] - [(unit-import-count ...) - (map (lambda (l) - (datum->syntax-object - (quote-syntax here) - (apply - + - (map (lambda (v) - (if (identifier? v) - 1 - (length (cdr (syntax->list v))))) - l)) - #f)) - linkages)] - [num-imports (datum->syntax-object - (quote-syntax here) - (length imports) - #f)] - [export-names export-names] - [export-mapping export-mapping] - [name (syntax-local-infer-name stx)]) - (syntax/loc - stx - (let ([constituent unit-expr] - ...) - (let ([unit-export-positions - (check-expected-interface - 'tag - constituent - unit-import-count - 'unit-export-list)] - ...) - (make-a-unit - 'name - num-imports - (quote export-names) - (lambda () - (let ([unit-setup ((unit-go constituent))] ...) - (let ([unit-extract - (lambda (pos) - (vector-ref (car unit-setup) - (vector-ref unit-export-positions pos)))] - ... - . - interned-integer-lists) - (list (list->vector (append . export-mapping)) - (lambda (ivar ...) - (let interned-id-lists - (void) ;; in case there are no units - (apply (list-ref unit-setup 1) - (append . import-mapping)) - ...))))))))))))))))))]))) - - ;; ---------------------------------------------------------------------- - ;; check-unit: used by the expansion of `invoke-unit' + (require (lib "etc.ss") + "private/unit-keywords.ss" + "private/unit-runtime.ss" + (only "private/unit-compiletime.ss" apply-mac)) - (define (check-unit u n) - (unless (unit? u) - (raise - (make-exn:fail:unit - (string->immutable-string - (format "invoke-unit: result of unit expression was not a unit: ~e" u)) - (current-continuation-marks)))) - (unless (= (unit-num-imports u) n) - (raise - (make-exn:fail:unit - (string->immutable-string - (format "invoke-unit: expected a unit with ~a imports, given one with ~a imports" - n (unit-num-imports u))) - (current-continuation-marks))))) - - ;; ---------------------------------------------------------------------- - ;; The `invoke-unit' syntactic form + (provide define-signature-form struct open + define-signature provide-signature-elements + only except rename import export prefix link tag init-depend extends + 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) + + (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-syntax invoke-unit - (lambda (stx) - (syntax-case stx (import export) - [(_ unit-expr expr ...) - (let ([exprs (syntax (expr ...))]) - (with-syntax ([(bx ...) (generate-temporaries (syntax (expr ...)))] - [num (datum->syntax-object - (quote-syntax here) - (length (syntax->list exprs)) - #f)]) - (syntax/loc - stx - (let ([u unit-expr]) - (check-unit u num) - (let ([bx (box expr)] ...) - ((list-ref ((unit-go u)) 1) - bx ...))))))]))) + (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-immutable (car l) + (cons-immutable new-type + (cons-immutable 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-syntaxes (define-values/invoke-unit - namespace-variable-bind/invoke-unit) - (let ([mk - (lambda (global?) - (lambda (stx) - (syntax-case stx () - [(_ exports unite . prefix+imports) - (let* ([badsyntax (lambda (s why) - (raise-syntax-error - #f - (format "bad syntax (~a)" why) - stx - s))] - [symcheck (lambda (s) - (or (identifier? s) - (badsyntax s "not an identifier")))]) - (unless (stx-list? (syntax exports)) - (badsyntax (syntax exports) "not a sequence of identifiers")) - (for-each symcheck (syntax->list (syntax exports))) - (let ([prefix (if (stx-null? (syntax prefix+imports)) - #f - (stx-car (syntax prefix+imports)))]) - (unless (or (not prefix) - (not (syntax-e prefix)) - (identifier? prefix)) - (badsyntax prefix "prefix is not an identifier")) - (for-each symcheck (let ([v (syntax prefix+imports)]) - (cond - [(stx-null? v) null] - [(stx-list? v) (cdr (syntax->list v))] - [else - (badsyntax (syntax prefix+imports) "illegal use of `.'")]))) - (with-syntax ([(tagged-export ...) - (if (and prefix (syntax-e prefix)) - (let ([prefix (string-append - (symbol->string - (syntax-e prefix)) - ":")]) - (map (lambda (s) - (datum->syntax-object - s - (string->symbol - (string-append - prefix - (symbol->string (syntax-e s)))) - s)) - (syntax->list (syntax exports)))) - (syntax exports))] - [extract-unit (syntax (_unit - (import . exports) - (export) - (values . exports)))]) - (with-syntax ([invoke-unit (with-syntax ([(x . imports) - (if prefix - (syntax prefix+imports) - `(#f))]) - (syntax (invoke-unit - (compound-unit - (import . imports) - (link [unit-to-invoke (unite . imports)] - [export-extractor - (extract-unit (unit-to-invoke . exports))]) - (export)) - . imports)))]) - (if global? - (syntax (let-values ([(tagged-export ...) invoke-unit]) - (namespace-set-variable-value! 'tagged-export tagged-export) - ... - (void))) - (syntax (define-values (tagged-export ...) invoke-unit)))))))])))]) - (values (mk #f) (mk #t)))) - (provide (rename _unit unit) unit/no-expand - compound-unit invoke-unit unit? - (struct exn:fail:unit ()) + ;; 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) ...)) + (map-sig (lambda (x) x) + (make-syntax-introducer) + sig) + #;(add-context-to-sig 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) + (parameterize ([error-syntax stx]) + (syntax-case stx () + ((_ export-spec) + (let ([sig (process-spec #'export-spec)]) + (with-syntax ((((int . ext) ...) (car sig)) + ((renames + (((mac-name ...) mac-body) ...) + (((val-name ...) val-body) ...)) + (build-val+macro-defs sig))) + (syntax->list + #'(int ... + (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) + (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)))) + (values '() '() '() '() '() '()))) + (let loop ((sig-exprs ses) + (bindings null) + (val-defs null) + (stx-defs 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))] + [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) + ((((vid ...) . vbody) ...) all-val-defs) + ((((sid ...) . sbody) ...) all-stx-defs)) + #`(begin + (define x (gensym)) + (define-syntax #,sigid + (make-set!-transformer + (make-signature + (make-siginfo (list #'#,sigid #'super-name ...) + (list ((syntax-local-certifier) (quote-syntax x)) + #'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))) + ...)))))))) + (else + (syntax-case (car sig-exprs) (define-values define-syntaxes) + (x + (identifier? #'x) + (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs)) + ((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)))))))) + ((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)))) + (x (raise-stx-err + "expected either an identifier or signature form" + #'x)))))))) - define-values/invoke-unit - namespace-variable-bind/invoke-unit)) + + (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)) + (apply append (map sig-int-names provide-sigs))) + + (define-syntax/err-param (provide-signature-elements stx) + (syntax-case stx () + ((_ . p) + (let* ((names (signature->identifiers (checked-syntax->list #'p))) + (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 (add-context-to-sig sig) + (let ((def-ctx (syntax-local-make-definition-context))) + (syntax-local-bind-syntaxes (sig-ext-names sig) #f def-ctx) + (map-sig (lambda (x) x) + (lambda (x) (localify x def-ctx)) + sig))) + + (define-for-syntax (iota n) + (let loop ((n n) + (acc null)) + (cond + ((= n 0) acc) + (else (loop (sub1 n) (cons (sub1 n) acc)))))) + + + (define-syntax (unit-export stx) + (syntax-case stx () + ((_ ((esig ...) elocs) ...) + (with-syntax ((((kv ...) ...) + (map + (lambda (esigs eloc) + (map + (lambda (esig) #`(#,esig #,eloc)) + (syntax->list esigs))) + (syntax->list #'((esig ...) ...)) + (syntax->list #'(elocs ...))))) + #'(hash-table 'equal kv ... ...))))) + + ;; build-key : (or symbol #f) identifier -> syntax-object + (define-for-syntax (build-key tag i) + (if tag + #`(cons '#,tag #,i) + i)) + + ;; tagged-info->keys : (cons (or symbol #f) siginfo) -> (listof syntax-object) + (define-for-syntax (tagged-info->keys tagged-info) + (define tag (car tagged-info)) + (map (lambda (rid) + (build-key tag (syntax-local-introduce rid))) + (siginfo-rtime-ids (cdr tagged-info)))) + + ;; check-duplicate-sigs : (listof (cons symbol siginfo)) (listof syntax-object) + ;; (listof (cons symbol siginfo)) (listof syntax-object) -> + (define-for-syntax (check-duplicate-sigs tagged-siginfos sources tagged-deps dsources) + (define import-idx (make-hash-table 'equal)) + (for-each + (lambda (tinfo s) + (define key (cons (car tinfo) + (car (siginfo-ctime-ids (cdr tinfo))))) + (when (hash-table-get import-idx key (lambda () #f)) + (raise-stx-err "duplicate import signature" s)) + (hash-table-put! import-idx key #t)) + tagged-siginfos + sources) + (for-each + (lambda (dep s) + (unless (hash-table-get import-idx + (cons (car dep) + (car (siginfo-ctime-ids (cdr dep)))) + (lambda () #f)) + (raise-stx-err "initialization dependency on unknown import" s))) + tagged-deps + dsources)) + + (define-for-syntax (tagged-sigid->tagged-siginfo x) + (cons (car x) + (signature-siginfo (lookup-signature (cdr x))))) + + (define-for-syntax (check-unit-ie-sigs import-sigs export-sigs) + (let ([dup (check-duplicate-identifier + (apply append (map sig-int-names import-sigs)))]) + (when dup + (raise-stx-err + (format "~a is imported by multiple signatures" (syntax-e dup))))) + + (let ([dup (check-duplicate-identifier + (apply append (map sig-int-names export-sigs)))]) + (when dup + (raise-stx-err (format "~a is exported by multiple signatures" + (syntax-e dup))))) + + (let ([dup (check-duplicate-identifier + (append + (apply append (map sig-int-names import-sigs)) + (apply append (map sig-int-names export-sigs))))]) + (when dup + (raise-stx-err (format "import ~a is exported" (syntax-e dup)))))) + + + (define-for-syntax (process-unit-import/export process) + (lambda (s) + (define x1 (syntax->list s)) + (define x2 (map process x1)) + (values x1 x2 (map car x2) (map cadr x2) (map caddr x2)))) + + (define-for-syntax process-unit-import + (process-unit-import/export process-tagged-import)) + + (define-for-syntax process-unit-export + (process-unit-import/export process-tagged-export)) + + ;; 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)] + [((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-immutable 'import-name + (vector-immutable import-key import-super-keys ...)) ...) + (vector-immutable (cons-immutable 'export-name + (vector-immutable export-key ...)) ...) + (list-immutable (cons-immutable 'dept depr) ...) + (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 ([(int-ivar ...) + (make-id-mappers + (quote-syntax (unbox iloc)) + ...)] + ... + [(int-evar ...) + (make-id-mappers + (quote-syntax (unbox eloc)) + ...)] + ...) + (letrec-syntaxes+values (renames ... + mac ... ...) + (val ... ...) + (unit-body #,(error-syntax) + (int-ivar ... ...) + (int-evar ... ...) + (eloc ... ...) + . body))))) + (unit-export ((export-key ...) (vector-immutable 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 (ivar ...) (evar ...) (eloc ...) body ...) + (parameterize ((error-syntax #'err-stx)) + (let* ([expand-context (generate-expand-context)] + [def-ctx (syntax-local-make-definition-context)] + [localify (lambda (ids) + (cdr (syntax->list + (local-expand #`(stop #,@ids) + 'expression + (list #'stop) + def-ctx))))] + [local-ivars (localify (syntax->list #'(ivar ...)))] + [local-evars (localify (syntax->list #'(evar ...)))] + [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 + (append + (kernel-form-identifier-list (quote-syntax here)) + (syntax->list #'(ivar ... evar ...))) + 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))) + (syntax->list #'(id ...)))] + [_ (void)]))) + [_ (void)])) + expanded-body) + table)]) + + ;; Mark exported names and + ;; check that all exported names are defined (as var): + (for-each + (lambda (name loc) + (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))) + local-evars + (syntax->list #'(eloc ...))) + + ;; 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))))) + local-ivars) + + (with-syntax ([(intname ...) + (foldr + (lambda (var res) + (cond + ((not (or (var-info-syntax? (cdr var)) + (var-info-exported? (cdr var)))) + (cons (car var) res)) + (else res))) + null + (bound-identifier-mapping-map defined-names-table cons))] + [(l-evar ...) local-evars] + [(defn&expr ...) + (filter + values + (map (lambda (defn-or-expr) + (syntax-case defn-or-expr (define-values define-syntaxes) + [(define-values () expr) + (syntax/loc defn-or-expr (set!-values () expr))] + [(define-values ids expr) + (let ([ids (syntax->list #'ids)] + [do-one + (lambda (id tmp name) + (let ([export-loc + (var-info-exported? + (bound-identifier-mapping-get + defined-names-table + id))]) + (cond + (export-loc + ;; set! exported id: + (quasisyntax/loc defn-or-expr + (set-box! #,export-loc + #,(if name + #`(let ([#,name #,tmp]) + #,name) + tmp)))) + (else + ;; not an exported id + (quasisyntax/loc defn-or-expr + (set! #,id #,tmp))))))]) + (if (null? (cdr ids)) + (do-one (car ids) (syntax expr) (car ids)) + (let ([tmps (generate-temporaries ids)]) + (with-syntax ([(tmp ...) tmps] + [(set ...) + (map (lambda (id tmp) + (do-one id tmp #f)) + ids tmps)]) + (syntax/loc defn-or-expr + (let-values ([(tmp ...) expr]) + set ...))))))] + [(define-syntaxes . l) #f] + [else defn-or-expr])) + expanded-body))] + [(stx-defn ...) + (filter + values + (map (lambda (defn-or-expr) + (syntax-case defn-or-expr (define-syntaxes) + [(define-syntaxes . l) #'l] + [else #f])) + expanded-body))]) + #'(letrec-syntaxes+values (stx-defn + ... + ((l-evar) (make-rename-transformer (quote-syntax evar))) + ...) + ([(intname) undefined] ...) + (void) ; in case the body would be empty + defn&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)) + (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) + (bound-identifier-mapping-put! def-table + (car int/ext-name) + #`(vector-ref #,v #,index))) + (car sig) + (iota (length (car sig))))) + import-tagged-infos + import-sigs) + (with-syntax ((((eloc ...) ...) + (map + (lambda (target-sig) + (map + (lambda (target-int/ext-name) + (bound-identifier-mapping-get + def-table + (car target-int/ext-name) + (lambda () + (raise-stx-err + (format (if import? + "identifier ~a is not present in new imports" + "identifier ~a is not present in old export") + (syntax-e (car target-int/ext-name))))))) + (car 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-immutable 'orig-import-name + (vector-immutable orig-import-key ...)) ...) + (vector-immutable + (cons-immutable 'orig-export-name + (vector-immutable orig-export-key ...)) ...) + 'form) + (make-unit + 'name + (vector-immutable (cons-immutable 'import-name + (vector-immutable import-key ...)) ...) + (vector-immutable (cons-immutable 'export-name + (vector-immutable export-key ...)) ...) + (list-immutable (cons-immutable 'dept depr) ...) + (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)) + (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))) + (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)) + (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-immutable 'sub-in-signame + (vector-immutable sub-in-key ...)) + ...) + (vector-immutable + (cons-immutable 'sub-out-signame + (vector-immutable sub-out-key ...)) + ...) + 'form)) + (let ([fht (hash-table 'equal + ((cons-immutable 'fdep-tag fdep-rtime) + (cons-immutable 'fsig-name 'flnk-name)) + ...)] + [rht (hash-table 'equal + ((cons-immutable '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 (lambda () #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-immutable 'import-name + (vector-immutable import-key ...)) + ...) + (vector-immutable + (cons-immutable '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 (hash-table 'equal 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))) + (when dup + (raise-stx-err (format "duplicate binding for ~e" (syntax-e dup)))) + (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)) + (((out-code ...) ...) + (map + (lambda (os ov) + (map + (lambda (i) + #`(vector-ref #,ov #,i)) + (iota (length (car os))))) + out-sigs + out-vec))) + (quasisyntax/loc stx + (begin + (define-values (int-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 (unbox out-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))))) + + + + ;; build-define-unit : syntax-object + ;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier)) + ;; string -> + ;; syntax-object + (define-for-syntax (build-define-unit stx build err-msg) + (syntax-case stx () + ((_ name . rest) + (begin + (check-id #'name) + (let-values (((exp i e d) (build #'rest))) + (with-syntax ((((itag . isig) ...) i) + (((etag . esig) ...) e) + (((deptag . depsig) ...) d)) + (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)) ...)))))))))) + ((_) + (raise-stx-err err-msg)))) + + (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-immutable 'import-name + (vector-immutable import-keys ...)) + ...) + (vector-immutable + (cons-immutable '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 (unprocess-tagged-id ti) + (if (car ti) + #`(tag #,(car ti) #,(cdr ti)) + (cdr ti))) + + (define-syntax/err-param (define-values/invoke-unit/infer stx) + (syntax-case stx () + ((_ u) + (let ((ui (lookup-def-unit #'u))) + (with-syntax (((sig ...) (map unprocess-tagged-id (unit-info-export-sig-ids ui))) + ((isig ...) (map unprocess-tagged-id (unit-info-import-sig-ids ui)))) + (quasisyntax/loc stx + (define-values/invoke-unit u (import isig ...) (export sig ...)))))) + ((_) + (raise-stx-err "missing unit" stx)) + ((_ . b) + (raise-stx-err + (format "expected syntax matching (~a )" + (syntax-e (stx-car stx))))))) + + (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 sid) + (make-link-record (car sid) #f (cdr sid) (signature-siginfo (lookup-signature (cdr sid))))) + + (syntax-case stx () + (((import ...) + (export ...) + (((out ...) u l ...) ...)) + (let* ([units (map lookup-def-unit (syntax->list #'(u ...)))] + [import-sigs (map process-signature + (syntax->list #'(import ...)))] + [sub-outs + (map + (lambda (outs unit) + (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 (unit-info-export-sig-ids unit)) + o)) + (syntax->list #'((out ...) ...)) + units)] + [link-defs (append import-sigs (apply append sub-outs))]) + + (define lnk-table (make-bound-identifier-mapping)) + (define sig-table (make-hash-table)) + + (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 (lambda () #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 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 + (unit-info-import-sig-ids unit)) + unit-stx)) + (syntax->list #'((l ...) ...)) + units + (syntax->list #'(u ...)))] + [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))))) + (lambda () #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-syntax/err-param (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 (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 () + ((_ u) + (let ((ui (lookup-def-unit #'u))) + (with-syntax (((isig ...) (map unprocess-tagged-id + (unit-info-import-sig-ids ui)))) + (quasisyntax/loc stx + (invoke-unit u (import isig ...)))))) + ((_) + (raise-stx-err "missing unit" stx)) + ((_ . b) + (raise-stx-err + (format "expected syntax matching (~a )" + (syntax-e (stx-car stx))))))) + + ) +;(load "test-unit.ss") diff --git a/collects/mzlib/unit200.ss b/collects/mzlib/unit200.ss new file mode 100644 index 0000000..0a47334 --- /dev/null +++ b/collects/mzlib/unit200.ss @@ -0,0 +1,869 @@ + +;; Unit system + +(module unit200 mzscheme + (require-for-syntax (lib "kerncase.ss" "syntax") + (lib "stx.ss" "syntax") + (lib "name.ss" "syntax") + (lib "context.ss" "syntax") + "list.ss" + "private/unitidmap.ss") + + ;; ---------------------------------------------------------------------- + ;; Structures and helpers + + (define undefined (letrec ([x x]) x)) ; initial value + + (define insp (current-inspector)) ; for named structures + + (define-struct unit (num-imports exports go)) ; unit value + (define-struct (exn:fail:unit exn:fail) ()) ; run-time exception + + ;; For units with inferred names, generate a struct that prints using the name: + (define (make-naming-constructor type name) + (let-values ([(struct: make- ? -accessor -mutator) + (make-struct-type name type 0 0 #f null insp)]) + make-)) + + ;; Make a unt value (call by the macro expansion of `unit') + (define (make-a-unit name num-imports exports go) + ((if name + (make-naming-constructor + struct:unit + (string->symbol (format "unit:~a" name))) + make-unit) + num-imports exports go)) + + ;; ---------------------------------------------------------------------- + ;; The `unit' syntactic form + + (define-syntaxes (:unit unit/no-expand) + (let ([do-unit + (lambda (stx expand?) + (syntax-case stx (import export) + [(_ (import ivar ...) + (export evar ...) + defn&expr ...) + (let ([check-id (lambda (v) + (unless (identifier? v) + (raise-syntax-error + #f + "import is not an identifier" + stx + v)))] + [check-renamed-id + (lambda (v) + (syntax-case v () + [id (identifier? (syntax id)) (list v)] + [(lid eid) (and (identifier? (syntax lid)) + (identifier? (syntax eid))) + (list #'lid #'eid)] + [else (raise-syntax-error + #f + "export is not an identifier or renamed identifier" + stx + v)]))] + [expand-context (generate-expand-context)] + [def-ctx (and expand? + (syntax-local-make-definition-context))] + [localify (lambda (ids def-ctx) + (if (andmap identifier? ids) + ;; In expand mode, add internal defn context + (if expand? + (begin + ;; Treat imports as internal-defn names: + (syntax-local-bind-syntaxes ids #f def-ctx) + (cdr (syntax->list + (local-expand #`(stop #,@ids) + 'expression + (list #'stop) + def-ctx)))) + ids) + ;; Let later checking report an error: + ids))]) + (let ([ivars (localify (syntax->list (syntax (ivar ...))) def-ctx)] + [evars (syntax->list (syntax (evar ...)))]) + (for-each check-id ivars) + (for-each check-renamed-id evars) + + ;; Get import/export declared names: + (let* ([exported-names + (localify + (map (lambda (v) + (syntax-case v () + [(lid eid) (syntax lid)] + [id (syntax id)])) + evars) + def-ctx)] + [extnames (map (lambda (v) + (syntax-case v () + [(lid eid) (syntax eid)] + [id (syntax id)])) + evars)] + [imported-names ivars] + [declared-names (append imported-names exported-names)]) + ;; Check that all exports are distinct (as symbols) + (let ([ht (make-hash-table)]) + (for-each (lambda (name) + (when (hash-table-get ht (syntax-e name) (lambda () #f)) + (raise-syntax-error + #f + "duplicate export" + stx + name)) + (hash-table-put! ht (syntax-e name) #t)) + extnames)) + + ;; Expand all body expressions + ;; so that all definitions are exposed. + (letrec ([expand-all + (if expand? + (lambda (defns&exprs) + (apply + append + (map + (lambda (defn-or-expr) + (let ([defn-or-expr + (local-expand + defn-or-expr + expand-context + (append + (kernel-form-identifier-list (quote-syntax here)) + declared-names) + def-ctx)]) + (syntax-case defn-or-expr (begin define-values define-syntaxes) + [(begin . l) + (let ([l (syntax->list (syntax l))]) + (unless l + (raise-syntax-error + #f + "bad syntax (illegal use of `.')" + defn-or-expr)) + (expand-all (map (lambda (s) + (syntax-track-origin s defn-or-expr #'begin)) + l)))] + [(define-syntaxes (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (with-syntax ([rhs (local-transformer-expand + #'rhs + 'expression + null)]) + (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx) + (list #'(define-syntaxes (id ...) rhs)))] + [(define-values (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (begin + (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f def-ctx) + (list defn-or-expr))] + [else (list defn-or-expr)]))) + defns&exprs))) + values)]) + (let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))]) + ;; Get all the defined names, sorting out variable definitions + ;; from syntax definitions. + (let* ([definition? + (lambda (id) + (and (identifier? id) + (or (module-identifier=? id (quote-syntax define-values)) + (module-identifier=? id (quote-syntax define-syntaxes)))))] + [all-defined-names/kinds + (apply + append + (map + (lambda (defn-or-expr) + (syntax-case defn-or-expr (define-values define-syntaxes) + [(dv (id ...) expr) + (definition? (syntax dv)) + (let ([l (syntax->list (syntax (id ...)))]) + (for-each (lambda (i) + (unless (identifier? i) + (raise-syntax-error + #f + "not an identifier in definition" + defn-or-expr + i))) + l) + (let ([key (if (module-identifier=? (syntax dv) (quote-syntax define-syntaxes)) + 'stx + 'val)]) + (map (lambda (id) (cons key id)) l)))] + [(define-values . l) + (raise-syntax-error + #f + "bad definition form" + defn-or-expr)] + [(define-syntaxes . l) + (raise-syntax-error + #f + "bad syntax definition form" + defn-or-expr)] + [else null])) + all-expanded))] + [all-defined-names (map cdr all-defined-names/kinds)] + [all-defined-val-names (map cdr + (filter (lambda (i) (eq? (car i) 'val)) + all-defined-names/kinds))]) + ;; Check that all defined names (var + stx) are distinct: + (let ([name (check-duplicate-identifier + (append imported-names all-defined-names))]) + (when name + (raise-syntax-error + #f + "variable imported and/or defined twice" + stx + name))) + ;; Check that all exported names are defined (as var): + (let ([ht (make-hash-table)] + [stx-ht (make-hash-table)]) + (for-each + (lambda (kind+name) + (let ([name (cdr kind+name)]) + (let ([l (hash-table-get ht (syntax-e name) (lambda () null))]) + (hash-table-put! (if (eq? (car kind+name) 'val) ht stx-ht) + (syntax-e name) + (cons name l))))) + all-defined-names/kinds) + (for-each + (lambda (n) + (let ([v (hash-table-get ht (syntax-e n) (lambda () null))]) + (unless (ormap (lambda (i) (bound-identifier=? i n)) v) + ;; Either not defined, or defined as syntax: + (let ([stx-v (hash-table-get stx-ht (syntax-e n) (lambda () null))]) + (if (ormap (lambda (i) (bound-identifier=? i n)) stx-v) + (raise-syntax-error + #f + "cannot export syntax from a unit" + stx + n) + (raise-syntax-error + #f + "exported variable is not defined" + stx + n)))))) + exported-names)) + + ;; Compute defined but not exported: + (let ([ht (make-hash-table)]) + (for-each + (lambda (name) + (let ([l (hash-table-get ht (syntax-e name) (lambda () null))]) + (hash-table-put! ht (syntax-e name) (cons name l)))) + exported-names) + (let ([internal-names + (let loop ([l all-defined-val-names]) + (cond + [(null? l) null] + [(let ([v (hash-table-get ht (syntax-e (car l)) (lambda () null))]) + (ormap (lambda (i) (bound-identifier=? i (car l))) v)) + (loop (cdr l))] + [else (cons (car l) (loop (cdr l)))]))]) + ;; Generate names for import/export boxes, etc: + (with-syntax ([(ivar ...) ivars] + [(iloc ...) (generate-temporaries ivars)] + [(eloc ...) (generate-temporaries evars)] + [(extname ...) extnames] + [(expname ...) exported-names] + [(intname ...) internal-names]) + ;; Change all definitions to set!s. Convert evars to set-box!, + ;; because set! on exported variables is not allowed. + (with-syntax ([(defn&expr ...) + (let ([elocs (syntax->list (syntax (eloc ...)))]) + (filter + values + (map (lambda (defn-or-expr) + (syntax-case defn-or-expr (define-values define-syntaxes) + [(define-values ids expr) + (let* ([ids (syntax->list (syntax ids))]) + (if (null? ids) + (syntax/loc defn-or-expr (set!-values ids expr)) + (let ([do-one + (lambda (id tmp name) + (let loop ([evars exported-names] + [elocs elocs]) + (cond + [(null? evars) + ;; not an exported id + (with-syntax ([id id][tmp tmp]) + (syntax/loc + defn-or-expr + (set! id tmp)))] + [(bound-identifier=? (car evars) id) + ;; set! exported id: + (with-syntax + ([loc (car elocs)] + [tmp + (if name + (with-syntax + ([tmp tmp] + [name name]) + (syntax + (let ([name tmp]) + name))) + tmp)]) + (syntax/loc defn-or-expr + (set-box! loc tmp)))] + [else (loop (cdr evars) + (cdr elocs))])))]) + (if (null? (cdr ids)) + (do-one (car ids) (syntax expr) (car ids)) + (let ([tmps (generate-temporaries ids)]) + (with-syntax ([(tmp ...) tmps] + [(set ...) + (map (lambda (id tmp) + (do-one id tmp #f)) + ids tmps)]) + (syntax/loc defn-or-expr + (let-values ([(tmp ...) expr]) + set ...))))))))] + [(define-syntaxes . l) #f] + [else defn-or-expr])) + all-expanded)))] + [(stx-defn ...) + (filter + values + (map (lambda (defn-or-expr) + (syntax-case defn-or-expr (define-syntaxes) + [(define-syntaxes . l) #'l] + [else #f])) + all-expanded))]) + ;; Build up set! redirection chain: + (with-syntax ([redirections + (let ([varlocs + (syntax->list + (syntax ((ivar iloc) ... (expname eloc) ...)))]) + (with-syntax ([vars (map stx-car varlocs)] + [rhss + (map + (lambda (varloc) + (with-syntax ([(var loc) varloc]) + (syntax + (make-id-mapper (quote-syntax (unbox loc)) + (quote-syntax var))))) + varlocs)]) + (syntax + ([vars (values . rhss)]))))] + [num-imports (datum->syntax-object + (quote-syntax here) + (length (syntax->list (syntax (iloc ...)))) + #f)] + [name (syntax-local-infer-name stx)]) + (syntax/loc stx + (make-a-unit + 'name + num-imports + (list (quote extname) ...) + (lambda () + (let ([eloc (box undefined)] ...) + (list (vector eloc ...) + (lambda (iloc ...) + (letrec-syntaxes+values + (stx-defn ... . redirections) + ([(intname) undefined] ...) + (void) ; in case the body would be empty + defn&expr ...))))))))))))))))))]))]) + (values (lambda (stx) (do-unit stx #t)) + (lambda (stx) (do-unit stx #f))))) + + ;; ---------------------------------------------------------------------- + ;; check-expected-interface: used by the expansion of `compound-unit' + + (define (check-expected-interface tag unit num-imports exports) + (unless (unit? unit) + (raise + (make-exn:fail:unit + (string->immutable-string + (format "compound-unit: result of expression for tag ~s not a unit: ~e" tag unit)) + (current-continuation-marks)))) + (unless (= num-imports (unit-num-imports unit)) + (raise + (make-exn:fail:unit + (string->immutable-string + (format "compound-unit: unit for tag ~s expects ~a imports, given ~a" + tag + (unit-num-imports unit) + num-imports)) + (current-continuation-marks)))) + (list->vector + (map (lambda (ex) + (let loop ([l (unit-exports unit)][i 0]) + (cond + [(null? l) + (raise + (make-exn:fail:unit + (string->immutable-string + (format "compound-unit: unit for tag ~s has no ~s export" + tag ex)) + (current-continuation-marks)))] + [(eq? (car l) ex) + i] + [else (loop (cdr l) (add1 i))]))) + exports))) + + ;; ---------------------------------------------------------------------- + ;; The `compound-unit' syntactic form + + (define-syntax compound-unit + (lambda (stx) + (syntax-case stx (import export link) + [(_ (import ivar ...) + (link [tag (unit-expr linkage ...)] ...) + (export exportage ...)) + (let ([check-id (lambda (v) + (unless (identifier? v) + (raise-syntax-error + #f + "import is not an identifier" + stx + v)))] + [check-tag (lambda (v) + (unless (identifier? v) + (raise-syntax-error + #f + "tag is not an identifier" + stx + v)))] + [check-linkage (lambda (v) + (syntax-case v () + [id (identifier? (syntax id)) #t] + [(tag id ...) + (for-each (lambda (v) + (unless (identifier? v) + (raise-syntax-error + #f + "non-identifier in linkage" + stx + v))) + (syntax->list v))] + [else + (raise-syntax-error + #f + "ill-formed linkage" + stx + v)]))] + [check-exportage (lambda (v) + (syntax-case v () + [(tag ex ...) + (begin + (unless (identifier? (syntax tag)) + (raise-syntax-error + #f + "export tag is not an identifier" + stx + (syntax tag))) + (for-each + (lambda (e) + (syntax-case e () + [id (identifier? (syntax id)) #t] + [(iid eid) + (begin + (unless (identifier? (syntax iid)) + (raise-syntax-error + #f + "export internal name is not an identifier" + stx + (syntax iid))) + (unless (identifier? (syntax eid)) + (raise-syntax-error + #f + "export internal name is not an identifier" + stx + (syntax eid))))] + [else + (raise-syntax-error + #f + (format "ill-formed export with tag ~a" + (syntax-e (syntax tag))) + stx + e)])) + (syntax->list (syntax (ex ...)))))] + [else + (raise-syntax-error + #f + "ill-formed export" + stx + v)]))] + [imports (syntax->list (syntax (ivar ...)))] + [tags (syntax->list (syntax (tag ...)))] + [linkages (map syntax->list (syntax->list (syntax ((linkage ...) ...))))] + [exports (syntax->list (syntax (exportage ...)))]) + ;; Syntax checks: + (for-each check-id imports) + (for-each check-tag tags) + (for-each (lambda (l) (for-each check-linkage l)) linkages) + (for-each check-exportage exports) + ;; Check for duplicate imports + (let ([dup (check-duplicate-identifier imports)]) + (when dup + (raise-syntax-error + #f + "duplicate import" + stx + dup))) + ;; Check for duplicate tags + (let ([dup (check-duplicate-identifier tags)]) + (when dup + (raise-syntax-error + #f + "duplicate tag" + stx + dup))) + ;; Check referenced imports and tags + (let ([check-linkage-refs (lambda (v) + (syntax-case v () + [(tag . exs) + (unless (ormap (lambda (t) + (bound-identifier=? t (syntax tag))) + tags) + (raise-syntax-error + #f + "linkage tag is not bound" + stx + (syntax tag)))] + [id (unless (ormap (lambda (i) + (bound-identifier=? i (syntax id))) + imports) + (raise-syntax-error + #f + "no imported identified for linkage" + stx + (syntax id)))]))] + [check-export-refs (lambda (v) + (syntax-case v () + [(tag . r) + (unless (ormap (lambda (t) + (bound-identifier=? t (syntax tag))) + tags) + (raise-syntax-error + #f + "export tag is not bound" + stx + (syntax tag)))]))]) + (for-each (lambda (l) (for-each check-linkage-refs l)) + linkages) + (for-each check-export-refs exports) + ;; Get all export names, and check for duplicates + (let ([export-names + (apply + append + (map + (lambda (v) + (syntax-case v () + [(tag . exs) + (map + (lambda (e) + (syntax-case e () + [(iid eid) (syntax eid)] + [id e])) + (syntax->list (syntax exs)))])) + exports))]) + (let ([dup (check-duplicate-identifier export-names)]) + (when dup + (raise-syntax-error + #f + "duplicate export" + stx + dup))) + + (let ([constituents (generate-temporaries tags)] + [unit-export-positionss (generate-temporaries tags)] + [unit-setups (generate-temporaries tags)] + [unit-extracts (generate-temporaries tags)] + [unit-export-lists + ;; For each tag, get all expected exports + (let* ([hts (map (lambda (x) (make-hash-table)) tags)] + [get-add-name + (lambda (tag) + (ormap (lambda (t ht) + (and (bound-identifier=? t tag) + (lambda (name) + (hash-table-put! ht (syntax-e name) name)))) + tags hts))]) + ;; Walk though linkages + (for-each + (lambda (linkage-list) + (for-each + (lambda (linkage) + (syntax-case linkage () + [(tag . ids) + (let ([add-name (get-add-name (syntax tag))]) + (for-each add-name (syntax->list (syntax ids))))] + [else (void)])) + linkage-list)) + linkages) + ;; Walk through exports + (for-each + (lambda (v) + (syntax-case v () + [(tag . exs) + (let ([add-name (get-add-name (syntax tag))]) + (for-each + (lambda (e) + (syntax-case e () + [(iid eid) (add-name (syntax iid))] + [id (add-name (syntax id))])) + (syntax->list (syntax exs))))])) + exports) + ;; Extract names from hash tables + (map (lambda (ht) + (hash-table-map ht (lambda (k v) v))) + hts))]) + ;; Map exports to imports and indices based on expected unit exports + (let ([map-tag (lambda (t l) + (let loop ([tags tags][l l]) + (if (bound-identifier=? (car tags) t) + (car l) + (loop (cdr tags) (cdr l)))))] + [unit-export-hts (map (lambda (export-list) + (let ([ht (make-hash-table)]) + (let loop ([l export-list][p 0]) + (unless (null? l) + (hash-table-put! ht (syntax-e (car l)) p) + (loop (cdr l) (add1 p)))) + ht)) + unit-export-lists)] + [interned-integer-lists null] + [interned-id-lists null]) + (let ([make-mapping + (lambda (v) + (syntax-case v () + [(tag . exs) + (let ([extract (map-tag (syntax tag) + unit-extracts)] + [ht (map-tag (syntax tag) + unit-export-hts)]) + (with-syntax ([extract extract] + [pos-name + (let ([il + (map + (lambda (e) + (hash-table-get + ht + (syntax-e + (syntax-case e () + [(iid eid) (syntax iid)] + [id e])))) + (syntax->list (syntax exs)))]) + (or (ormap (lambda (i) + (and (equal? il (cadadr i)) + (car i))) + interned-integer-lists) + (let ([name (car (generate-temporaries + (list (syntax tag))))]) + (set! interned-integer-lists + (cons `(,name ',il) + interned-integer-lists)) + name)))]) + (syntax (map extract pos-name))))] + [import v]))] + [collapse (lambda (l) + (let loop ([l l]) + (cond + [(null? l) null] + [(identifier? (car l)) + (let-values ([(ids rest) + (let loop ([l l][ids null]) + (if (or (null? l) + (not (identifier? (car l)))) + (values (reverse ids) l) + (loop (cdr l) (cons (car l) ids))))]) + (let ([name + (let ([id-syms (map syntax-e ids)]) + (or (ormap (lambda (i) + (and (equal? id-syms (cadr i)) + (car i))) + interned-id-lists) + (let ([name + (car (generate-temporaries (list 'ids)))]) + (set! interned-id-lists + (cons (list* name id-syms ids) + interned-id-lists)) + name)))]) + (cons name + (loop rest))))] + [else (cons (car l) (loop (cdr l)))])))]) + (let ([export-mapping (collapse (map make-mapping exports))] + [import-mappings (map (lambda (linkage-list) + (collapse + (map make-mapping linkage-list))) + linkages)]) + (with-syntax ([(constituent ...) constituents] + [(unit-export-positions ...) unit-export-positionss] + [(unit-setup ...) unit-setups] + [(unit-extract ...) unit-extracts] + [interned-integer-lists interned-integer-lists] + [interned-id-lists (map (lambda (i) + (with-syntax ([name (car i)] + [ids (cddr i)]) + (syntax [name (list . ids)]))) + interned-id-lists)] + [(unit-export-list ...) unit-export-lists] + [(import-mapping ...) import-mappings] + [(unit-import-count ...) + (map (lambda (l) + (datum->syntax-object + (quote-syntax here) + (apply + + + (map (lambda (v) + (if (identifier? v) + 1 + (length (cdr (syntax->list v))))) + l)) + #f)) + linkages)] + [num-imports (datum->syntax-object + (quote-syntax here) + (length imports) + #f)] + [export-names export-names] + [export-mapping export-mapping] + [name (syntax-local-infer-name stx)]) + (syntax/loc + stx + (let ([constituent unit-expr] + ...) + (let ([unit-export-positions + (check-expected-interface + 'tag + constituent + unit-import-count + 'unit-export-list)] + ...) + (make-a-unit + 'name + num-imports + (quote export-names) + (lambda () + (let ([unit-setup ((unit-go constituent))] ...) + (let ([unit-extract + (lambda (pos) + (vector-ref (car unit-setup) + (vector-ref unit-export-positions pos)))] + ... + . + interned-integer-lists) + (list (list->vector (append . export-mapping)) + (lambda (ivar ...) + (let interned-id-lists + (void) ;; in case there are no units + (apply (list-ref unit-setup 1) + (append . import-mapping)) + ...))))))))))))))))))]))) + + ;; ---------------------------------------------------------------------- + ;; check-unit: used by the expansion of `invoke-unit' + + (define (check-unit u n) + (unless (unit? u) + (raise + (make-exn:fail:unit + (string->immutable-string + (format "invoke-unit: result of unit expression was not a unit: ~e" u)) + (current-continuation-marks)))) + (unless (= (unit-num-imports u) n) + (raise + (make-exn:fail:unit + (string->immutable-string + (format "invoke-unit: expected a unit with ~a imports, given one with ~a imports" + n (unit-num-imports u))) + (current-continuation-marks))))) + + ;; ---------------------------------------------------------------------- + ;; The `invoke-unit' syntactic form + + (define-syntax invoke-unit + (lambda (stx) + (syntax-case stx (import export) + [(_ unit-expr expr ...) + (let ([exprs (syntax (expr ...))]) + (with-syntax ([(bx ...) (generate-temporaries (syntax (expr ...)))] + [num (datum->syntax-object + (quote-syntax here) + (length (syntax->list exprs)) + #f)]) + (syntax/loc + stx + (let ([u unit-expr]) + (check-unit u num) + (let ([bx (box expr)] ...) + ((list-ref ((unit-go u)) 1) + bx ...))))))]))) + + (define-syntaxes (define-values/invoke-unit + namespace-variable-bind/invoke-unit) + (let ([mk + (lambda (global?) + (lambda (stx) + (syntax-case stx () + [(_ exports unite . prefix+imports) + (let* ([badsyntax (lambda (s why) + (raise-syntax-error + #f + (format "bad syntax (~a)" why) + stx + s))] + [symcheck (lambda (s) + (or (identifier? s) + (badsyntax s "not an identifier")))]) + (unless (stx-list? (syntax exports)) + (badsyntax (syntax exports) "not a sequence of identifiers")) + (for-each symcheck (syntax->list (syntax exports))) + (let ([prefix (if (stx-null? (syntax prefix+imports)) + #f + (stx-car (syntax prefix+imports)))]) + (unless (or (not prefix) + (not (syntax-e prefix)) + (identifier? prefix)) + (badsyntax prefix "prefix is not an identifier")) + (for-each symcheck (let ([v (syntax prefix+imports)]) + (cond + [(stx-null? v) null] + [(stx-list? v) (cdr (syntax->list v))] + [else + (badsyntax (syntax prefix+imports) "illegal use of `.'")]))) + (with-syntax ([(tagged-export ...) + (if (and prefix (syntax-e prefix)) + (let ([prefix (string-append + (symbol->string + (syntax-e prefix)) + ":")]) + (map (lambda (s) + (datum->syntax-object + s + (string->symbol + (string-append + prefix + (symbol->string (syntax-e s)))) + s)) + (syntax->list (syntax exports)))) + (syntax exports))] + [extract-unit (syntax (:unit + (import . exports) + (export) + (values . exports)))]) + (with-syntax ([invoke-unit (with-syntax ([(x . imports) + (if prefix + (syntax prefix+imports) + `(#f))]) + (syntax (invoke-unit + (compound-unit + (import . imports) + (link [unit-to-invoke (unite . imports)] + [export-extractor + (extract-unit (unit-to-invoke . exports))]) + (export)) + . imports)))]) + (if global? + (syntax (let-values ([(tagged-export ...) invoke-unit]) + (namespace-set-variable-value! 'tagged-export tagged-export) + ... + (void))) + (syntax (define-values (tagged-export ...) invoke-unit)))))))])))]) + (values (mk #f) (mk #t)))) + + (provide (rename :unit unit) unit/no-expand + compound-unit invoke-unit unit? + (struct exn:fail:unit ()) + + define-values/invoke-unit + namespace-variable-bind/invoke-unit)) diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss index 3e2a82d..c6fc7bb 100644 --- a/collects/mzlib/unitsig.ss +++ b/collects/mzlib/unitsig.ss @@ -1,360 +1,4 @@ -;; This implementation of `unit/sig' was ported from the old v100 -;; implementation, and then hacked a bit to produce more compact -;; output, and finally mangled to handle the v200 `struct' (with -;; compile-time information). It's in dire need of an overhaul. - (module unitsig mzscheme - (require "unit.ss") - (require "private/sigmatch.ss") - - (require-for-syntax "private/sigutil.ss") - (require-for-syntax "private/sigmatch.ss") - (require-for-syntax (lib "kerncase.ss" "syntax")) - - (define-struct signed-unit (unit imports exports)) - - (define-syntax define-signature - (lambda (expr) - (syntax-case expr () - [(_ name sig) - (identifier? (syntax name)) - (let ([sig (get-sig 'define-signature expr (syntax-e (syntax name)) - (syntax sig) #f)]) - (with-syntax ([content (explode-sig sig #f)]) - (syntax (define-syntax name - (make-sig (quote content))))))]))) - - (define-syntax let-signature - (lambda (expr) - (syntax-case expr () - [(_ name sig . body) - (identifier? (syntax name)) - (let ([sig (get-sig 'let-signature expr (syntax-e (syntax name)) - (syntax sig) #f)]) - (with-syntax ([content (explode-sig sig #f)]) - (syntax (letrec-syntax ([name (make-sig (quote content))]) - . body))))]))) - - (define-syntax unit/sig - (lambda (expr) - (syntax-case expr () - [(_ sig . rest) - (let ([sig (get-sig 'unit/sig expr #f (syntax sig) #f)]) - (let ([a-unit (parse-unit expr (syntax rest) sig - (kernel-form-identifier-list (quote-syntax here)) - (quote-syntax define-values) - (quote-syntax define-syntaxes) - (quote-syntax begin))]) - (check-signature-unit-body sig a-unit (parsed-unit-renames a-unit) 'unit/sig expr) - (with-syntax ([imports (parsed-unit-import-vars a-unit)] - [exports (datum->syntax-object - expr - (let ([vars (make-hash-table)]) - (for-each (lambda (var) - (hash-table-put! vars (syntax-e var) var)) - (parsed-unit-vars a-unit)) - (map - (lambda (name) - (list (let ([name (do-rename name (parsed-unit-renames a-unit))]) - (hash-table-get vars name name)) - name)) - (signature-vars sig))) - expr)] - [body (append - (reverse! (parsed-unit-body a-unit)) - ((parsed-unit-stx-checks a-unit) expr))] - [import-sigs (explode-named-sigs (parsed-unit-imports a-unit) #f)] - [export-sig (explode-sig sig #f)]) - (syntax/loc expr - (make-signed-unit - (unit/no-expand - (import . imports) - (export . exports) - . body) - (quote import-sigs) - (quote export-sig))))))]))) - - (define-syntax compound-unit/sig - (lambda (expr) - (syntax-case expr () - [(_ . body) - (let-values ([(tags - exprs - exploded-link-imports - exploded-link-exports - flat-imports - link-imports - flat-exports - exploded-imports - exploded-exports - boxed-interned-symbol-vectors) - (parse-compound-unit expr (syntax body))] - [(t) (lambda (l) (datum->syntax-object expr l expr))]) - (with-syntax ([(tag ...) (t tags)] - [(uexpr ...) (t exprs)] - [(tagx ...) (t (map (lambda (t) (string->symbol (format "u:~a" t))) tags))] - [exploded-link-imports (t exploded-link-imports)] - [exploded-link-exports (t exploded-link-exports)] - [flat-imports (t flat-imports)] - [(link-import ...) (t link-imports)] - [flat-exports (t flat-exports)] - [exploded-imports (t exploded-imports)] - [exploded-exports (t exploded-exports)] - [interned-vectors (t (map (lambda (x) `(,(car x) (quote ,(cadr x)))) - (unbox boxed-interned-symbol-vectors)))]) - (syntax/loc - expr - (let ([tagx uexpr] ... . interned-vectors) - (alt-verify-linkage-signature-match - 'compound-unit/sig - '(tag ...) - (list tagx ...) - `exploded-link-imports - `exploded-link-exports) - ;; All checks done. Make the unit: - (make-signed-unit - (compound-unit - (import . flat-imports) - (link [tag ((signed-unit-unit tagx) - . link-import)] - ...) - (export . flat-exports)) - `exploded-imports - `exploded-exports)))))]))) - - (define-syntax invoke-unit/sig - (lambda (expr) - (syntax-case expr () - [(_ u sig ...) - (let ([sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)]) - (with-syntax ([exploded-sigs (datum->syntax-object - expr - (explode-named-sigs sigs #f) - expr)] - [flat-sigs (datum->syntax-object - expr - (flatten-signatures sigs #f) - expr)]) - (syntax/loc - expr - (let ([unt u]) - (alt-verify-linkage-signature-match - (quote invoke-unit/sig) - (quote (invoke)) - (list unt) - (quote ((#() . #()))) - (quote (exploded-sigs))) - (invoke-unit (signed-unit-unit unt) - . flat-sigs)))))]))) - - (define-syntax unit->unit/sig - (lambda (expr) - (syntax-case expr () - [(_ e (im-sig ...) ex-sig) - (let ([im-sigs (map (lambda (sig) - (get-sig 'unit->unit/sig expr #f sig #f)) - (syntax->list (syntax (im-sig ...))))] - [ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig) #f)]) - (with-syntax ([exploded-imports (datum->syntax-object - expr - (explode-named-sigs im-sigs #f) - expr)] - [exploded-exports (datum->syntax-object - expr - (explode-sig ex-sig #f) - expr)]) - (syntax - (make-signed-unit - e - (quote exploded-imports) - (quote exploded-exports)))))]))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define -verify-linkage-signature-match - (let ([make-exn make-exn:fail:unit] - [p-suffix (lambda (pos) (case pos [(1) 'st][(2) 'nd][(3) 'rd][else 'th]))]) - (lambda (who tags units esigs isigs wrapped? unwrap) - (for-each - (lambda (u tag) - (unless (signed-unit? u) - (raise - (make-exn - (string->immutable-string - (format - "~s: expression for \"~s\" is not a signed unit: ~e" - who tag u)) - (current-continuation-marks))))) - units tags) - (for-each - (lambda (u tag esig) - (-verify-signature-match - who #f - (format "specified export signature for ~a" tag) - esig - (format "export signature for actual ~a sub-unit" tag) - (signed-unit-exports u) - wrapped? unwrap)) - units tags esigs) - (for-each - (lambda (u tag isig) - (let ([n (length (signed-unit-imports u))] - [c (length isig)]) - (unless (= c n) - (raise - (make-exn - (string->immutable-string - (format - "~s: ~a unit imports ~a units, but ~a units were provided" - who tag n c)) - (current-continuation-marks)))))) - units tags isigs) - (for-each - (lambda (u tag isig) - (let loop ([isig isig][expecteds (signed-unit-imports u)][pos 1]) - (unless (null? isig) - (let ([expected (car expecteds)] - [provided (car isig)]) - (-verify-signature-match - who #t - (format "~a unit's ~s~s import (which is ~a)" tag - pos (p-suffix pos) - (car expected)) - (cdr expected) - (format "~a's ~s~s linkage (which is ~a)" - tag - pos (p-suffix pos) - (car provided)) - (cdr provided) - wrapped? unwrap) - (loop (cdr isig) (cdr expecteds) (add1 pos)))))) - units tags isigs)))) - - (define verify-linkage-signature-match - (lambda (who tags units esigs isigs) - (-verify-linkage-signature-match who tags units esigs isigs values values))) - - (define alt-verify-linkage-signature-match - (lambda (who tags units esigs isigs) - (-verify-linkage-signature-match who tags units esigs isigs pair? car))) - - (define-syntax signature->symbols - (lambda (stx) - (syntax-case stx () - [(_ name) - (identifier? (syntax name)) - (let ([sig (get-sig 'signature->symbols stx #f (syntax name) #f)]) - (with-syntax ([e (let cleanup ([p (explode-sig sig #f)]) - ;; Strip struct info: - (list->vector - (map (lambda (i) - (if (symbol? i) - i - (cons (car i) (cleanup (cdr i))))) - (vector->list (car p)))))]) - (syntax 'e)))]))) - - ;; Internal: - (define-syntax do-define-values/invoke-unit/sig - (lambda (stx) - (syntax-case stx () - [(_ global? signame unite prefix imports orig) - (let* ([formname (if (syntax-e (syntax global?)) - 'namespace-variable-bind/invoke-unit/sig - 'define-values/invoke-unit/sig)] - [badsyntax (lambda (s why) - (raise-syntax-error - #f - (format "bad syntax (~a)" why) - (syntax orig) - s))]) - (unless (or (not (syntax-e (syntax prefix))) - (identifier? (syntax prefix))) - (badsyntax (syntax prefix) "prefix is not an identifier")) - (let ([ex-sig (get-sig formname (syntax orig) #f (syntax signame) (syntax signame))]) - (let ([ex-exploded (explode-sig ex-sig #f)] - [ex-flattened (flatten-signature #f ex-sig #'signame)]) - (let ([im-sigs - (parse-invoke-vars formname (syntax imports) (syntax orig))]) - (let ([im-explodeds (explode-named-sigs im-sigs #f)] - [im-flattened (flatten-signatures im-sigs #f)] - [d->s (lambda (x) (datum->syntax-object (syntax orig) x (syntax orig)))]) - (with-syntax ([dv/iu (if (syntax-e (syntax global?)) - (quote-syntax namespace-variable-bind/invoke-unit) - (quote-syntax define-values/invoke-unit))] - [ex-flattened ex-flattened] - [ex-exploded (d->s ex-exploded)] - [im-explodeds (d->s im-explodeds)] - [im-flattened (d->s im-flattened)] - [formname formname] - [stx-decls (if (syntax-e (syntax global?)) - null - (make-struct-stx-decls ex-sig #f #f (syntax signame) #f))]) - (syntax/loc stx - (begin - (dv/iu - ex-flattened - (let ([unit-var unite]) - (alt-verify-linkage-signature-match - 'formname - '(invoke) - (list unit-var) - '(ex-exploded) - '(im-explodeds)) - (signed-unit-unit unit-var)) - prefix - . im-flattened) - . stx-decls))))))))]))) - - (define-syntax define-values/invoke-unit/sig - (lambda (stx) - (with-syntax ([orig stx]) - (syntax-case stx () - [(_ signame unit prefix . imports) - (syntax (do-define-values/invoke-unit/sig #f signame unit prefix imports orig))] - [(_ signame unit) - (syntax (do-define-values/invoke-unit/sig #f signame unit #f () orig))])))) - - (define-syntax namespace-variable-bind/invoke-unit/sig - (lambda (stx) - (with-syntax ([orig stx]) - (syntax-case stx () - [(_ signame unit prefix . imports) - (syntax (do-define-values/invoke-unit/sig #t signame unit prefix imports orig))] - [(_ signame unit) - (syntax (do-define-values/invoke-unit/sig #t signame unit #f () orig))])))) - - (define-syntax provide-signature-elements - (lambda (stx) - (with-syntax ([orig stx]) - (syntax-case stx () - [(_ signame) - (let ([sig (get-sig 'provide-signature-elements stx #f (syntax signame) (syntax signame))]) - (let ([flattened (flatten-signature #f sig (syntax signame))] - [structs (map struct-def-name (signature-structs sig))]) - (with-syntax ([flattened (map (lambda (x) (datum->syntax-object (syntax signame) x #f)) - (append flattened structs))]) - (syntax/loc stx - (provide . flattened)))))])))) - - (define (unit/sig? x) (signed-unit? x)) - (define (unit/sig->unit x) (signed-unit-unit x)) - - (provide define-signature - let-signature - unit/sig - compound-unit/sig - invoke-unit/sig - unit->unit/sig - signature->symbols - verify-signature-match - verify-linkage-signature-match - - (struct signed-unit (unit imports exports)) - unit/sig? unit/sig->unit - - define-values/invoke-unit/sig - namespace-variable-bind/invoke-unit/sig - provide-signature-elements)) - + (require (lib "unitsig200.ss")) + (provide (all-from (lib "unitsig200.ss")))) diff --git a/collects/mzlib/unitsig200.ss b/collects/mzlib/unitsig200.ss new file mode 100644 index 0000000..551b0d1 --- /dev/null +++ b/collects/mzlib/unitsig200.ss @@ -0,0 +1,359 @@ + +;; This implementation of `unit/sig' was ported from the old v100 +;; implementation, and then hacked a bit to produce more compact +;; output, and finally mangled to handle the v200 `struct' (with +;; compile-time information). It's in dire need of an overhaul. + +(module unitsig200 mzscheme + (require "unit200.ss") + (require "private/sigmatch.ss") + + (require-for-syntax "private/sigutil.ss") + (require-for-syntax "private/sigmatch.ss") + (require-for-syntax (lib "kerncase.ss" "syntax")) + + (define-struct signed-unit (unit imports exports)) + + (define-syntax define-signature + (lambda (expr) + (syntax-case expr () + [(_ name sig) + (identifier? (syntax name)) + (let ([sig (get-sig 'define-signature expr (syntax-e (syntax name)) + (syntax sig) #f)]) + (with-syntax ([content (explode-sig sig #f)]) + (syntax (define-syntax name + (make-sig (quote content))))))]))) + + (define-syntax let-signature + (lambda (expr) + (syntax-case expr () + [(_ name sig . body) + (identifier? (syntax name)) + (let ([sig (get-sig 'let-signature expr (syntax-e (syntax name)) + (syntax sig) #f)]) + (with-syntax ([content (explode-sig sig #f)]) + (syntax (letrec-syntax ([name (make-sig (quote content))]) + . body))))]))) + + (define-syntax unit/sig + (lambda (expr) + (syntax-case expr () + [(_ sig . rest) + (let ([sig (get-sig 'unit/sig expr #f (syntax sig) #f)]) + (let ([a-unit (parse-unit expr (syntax rest) sig + (kernel-form-identifier-list (quote-syntax here)) + (quote-syntax define-values) + (quote-syntax define-syntaxes) + (quote-syntax begin))]) + (check-signature-unit-body sig a-unit (parsed-unit-renames a-unit) 'unit/sig expr) + (with-syntax ([imports (parsed-unit-import-vars a-unit)] + [exports (datum->syntax-object + expr + (let ([vars (make-hash-table)]) + (for-each (lambda (var) + (hash-table-put! vars (syntax-e var) var)) + (parsed-unit-vars a-unit)) + (map + (lambda (name) + (list (let ([name (do-rename name (parsed-unit-renames a-unit))]) + (hash-table-get vars name name)) + name)) + (signature-vars sig))) + expr)] + [body (append + (reverse! (parsed-unit-body a-unit)) + ((parsed-unit-stx-checks a-unit) expr))] + [import-sigs (explode-named-sigs (parsed-unit-imports a-unit) #f)] + [export-sig (explode-sig sig #f)]) + (syntax/loc expr + (make-signed-unit + (unit/no-expand + (import . imports) + (export . exports) + . body) + (quote import-sigs) + (quote export-sig))))))]))) + + (define-syntax compound-unit/sig + (lambda (expr) + (syntax-case expr () + [(_ . body) + (let-values ([(tags + exprs + exploded-link-imports + exploded-link-exports + flat-imports + link-imports + flat-exports + exploded-imports + exploded-exports + boxed-interned-symbol-vectors) + (parse-compound-unit expr (syntax body))] + [(t) (lambda (l) (datum->syntax-object expr l expr))]) + (with-syntax ([(tag ...) (t tags)] + [(uexpr ...) (t exprs)] + [(tagx ...) (t (map (lambda (t) (string->symbol (format "u:~a" t))) tags))] + [exploded-link-imports (t exploded-link-imports)] + [exploded-link-exports (t exploded-link-exports)] + [flat-imports (t flat-imports)] + [(link-import ...) (t link-imports)] + [flat-exports (t flat-exports)] + [exploded-imports (t exploded-imports)] + [exploded-exports (t exploded-exports)] + [interned-vectors (t (map (lambda (x) `(,(car x) (quote ,(cadr x)))) + (unbox boxed-interned-symbol-vectors)))]) + (syntax/loc + expr + (let ([tagx uexpr] ... . interned-vectors) + (alt-verify-linkage-signature-match + 'compound-unit/sig + '(tag ...) + (list tagx ...) + `exploded-link-imports + `exploded-link-exports) + ;; All checks done. Make the unit: + (make-signed-unit + (compound-unit + (import . flat-imports) + (link [tag ((signed-unit-unit tagx) + . link-import)] + ...) + (export . flat-exports)) + `exploded-imports + `exploded-exports)))))]))) + + (define-syntax invoke-unit/sig + (lambda (expr) + (syntax-case expr () + [(_ u sig ...) + (let ([sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)]) + (with-syntax ([exploded-sigs (datum->syntax-object + expr + (explode-named-sigs sigs #f) + expr)] + [flat-sigs (datum->syntax-object + expr + (flatten-signatures sigs #f) + expr)]) + (syntax/loc + expr + (let ([unt u]) + (alt-verify-linkage-signature-match + (quote invoke-unit/sig) + (quote (invoke)) + (list unt) + (quote ((#() . #()))) + (quote (exploded-sigs))) + (invoke-unit (signed-unit-unit unt) + . flat-sigs)))))]))) + + (define-syntax unit->unit/sig + (lambda (expr) + (syntax-case expr () + [(_ e (im-sig ...) ex-sig) + (let ([im-sigs (map (lambda (sig) + (get-sig 'unit->unit/sig expr #f sig #f)) + (syntax->list (syntax (im-sig ...))))] + [ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig) #f)]) + (with-syntax ([exploded-imports (datum->syntax-object + expr + (explode-named-sigs im-sigs #f) + expr)] + [exploded-exports (datum->syntax-object + expr + (explode-sig ex-sig #f) + expr)]) + (syntax + (make-signed-unit + e + (quote exploded-imports) + (quote exploded-exports)))))]))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define -verify-linkage-signature-match + (let ([make-exn make-exn:fail:unit] + [p-suffix (lambda (pos) (case pos [(1) 'st][(2) 'nd][(3) 'rd][else 'th]))]) + (lambda (who tags units esigs isigs wrapped? unwrap) + (for-each + (lambda (u tag) + (unless (signed-unit? u) + (raise + (make-exn + (string->immutable-string + (format + "~s: expression for \"~s\" is not a signed unit: ~e" + who tag u)) + (current-continuation-marks))))) + units tags) + (for-each + (lambda (u tag esig) + (-verify-signature-match + who #f + (format "specified export signature for ~a" tag) + esig + (format "export signature for actual ~a sub-unit" tag) + (signed-unit-exports u) + wrapped? unwrap)) + units tags esigs) + (for-each + (lambda (u tag isig) + (let ([n (length (signed-unit-imports u))] + [c (length isig)]) + (unless (= c n) + (raise + (make-exn + (string->immutable-string + (format + "~s: ~a unit imports ~a units, but ~a units were provided" + who tag n c)) + (current-continuation-marks)))))) + units tags isigs) + (for-each + (lambda (u tag isig) + (let loop ([isig isig][expecteds (signed-unit-imports u)][pos 1]) + (unless (null? isig) + (let ([expected (car expecteds)] + [provided (car isig)]) + (-verify-signature-match + who #t + (format "~a unit's ~s~s import (which is ~a)" tag + pos (p-suffix pos) + (car expected)) + (cdr expected) + (format "~a's ~s~s linkage (which is ~a)" + tag + pos (p-suffix pos) + (car provided)) + (cdr provided) + wrapped? unwrap) + (loop (cdr isig) (cdr expecteds) (add1 pos)))))) + units tags isigs)))) + + (define verify-linkage-signature-match + (lambda (who tags units esigs isigs) + (-verify-linkage-signature-match who tags units esigs isigs values values))) + + (define alt-verify-linkage-signature-match + (lambda (who tags units esigs isigs) + (-verify-linkage-signature-match who tags units esigs isigs pair? car))) + + (define-syntax signature->symbols + (lambda (stx) + (syntax-case stx () + [(_ name) + (identifier? (syntax name)) + (let ([sig (get-sig 'signature->symbols stx #f (syntax name) #f)]) + (with-syntax ([e (let cleanup ([p (explode-sig sig #f)]) + ;; Strip struct info: + (list->vector + (map (lambda (i) + (if (symbol? i) + i + (cons (car i) (cleanup (cdr i))))) + (vector->list (car p)))))]) + (syntax 'e)))]))) + + ;; Internal: + (define-syntax do-define-values/invoke-unit/sig + (lambda (stx) + (syntax-case stx () + [(_ global? signame unite prefix imports orig) + (let* ([formname (if (syntax-e (syntax global?)) + 'namespace-variable-bind/invoke-unit/sig + 'define-values/invoke-unit/sig)] + [badsyntax (lambda (s why) + (raise-syntax-error + #f + (format "bad syntax (~a)" why) + (syntax orig) + s))]) + (unless (or (not (syntax-e (syntax prefix))) + (identifier? (syntax prefix))) + (badsyntax (syntax prefix) "prefix is not an identifier")) + (let ([ex-sig (get-sig formname (syntax orig) #f (syntax signame) (syntax signame))]) + (let ([ex-exploded (explode-sig ex-sig #f)] + [ex-flattened (flatten-signature #f ex-sig #'signame)]) + (let ([im-sigs + (parse-invoke-vars formname (syntax imports) (syntax orig))]) + (let ([im-explodeds (explode-named-sigs im-sigs #f)] + [im-flattened (flatten-signatures im-sigs #f)] + [d->s (lambda (x) (datum->syntax-object (syntax orig) x (syntax orig)))]) + (with-syntax ([dv/iu (if (syntax-e (syntax global?)) + (quote-syntax namespace-variable-bind/invoke-unit) + (quote-syntax define-values/invoke-unit))] + [ex-flattened ex-flattened] + [ex-exploded (d->s ex-exploded)] + [im-explodeds (d->s im-explodeds)] + [im-flattened (d->s im-flattened)] + [formname formname] + [stx-decls (if (syntax-e (syntax global?)) + null + (make-struct-stx-decls ex-sig #f #f (syntax signame) #f))]) + (syntax/loc stx + (begin + (dv/iu + ex-flattened + (let ([unit-var unite]) + (alt-verify-linkage-signature-match + 'formname + '(invoke) + (list unit-var) + '(ex-exploded) + '(im-explodeds)) + (signed-unit-unit unit-var)) + prefix + . im-flattened) + . stx-decls))))))))]))) + + (define-syntax define-values/invoke-unit/sig + (lambda (stx) + (with-syntax ([orig stx]) + (syntax-case stx () + [(_ signame unit prefix . imports) + (syntax (do-define-values/invoke-unit/sig #f signame unit prefix imports orig))] + [(_ signame unit) + (syntax (do-define-values/invoke-unit/sig #f signame unit #f () orig))])))) + + (define-syntax namespace-variable-bind/invoke-unit/sig + (lambda (stx) + (with-syntax ([orig stx]) + (syntax-case stx () + [(_ signame unit prefix . imports) + (syntax (do-define-values/invoke-unit/sig #t signame unit prefix imports orig))] + [(_ signame unit) + (syntax (do-define-values/invoke-unit/sig #t signame unit #f () orig))])))) + + (define-syntax provide-signature-elements + (lambda (stx) + (with-syntax ([orig stx]) + (syntax-case stx () + [(_ signame) + (let ([sig (get-sig 'provide-signature-elements stx #f (syntax signame) (syntax signame))]) + (let ([flattened (flatten-signature #f sig (syntax signame))] + [structs (map struct-def-name (signature-structs sig))]) + (with-syntax ([flattened (map (lambda (x) (datum->syntax-object (syntax signame) x #f)) + (append flattened structs))]) + (syntax/loc stx + (provide . flattened)))))])))) + + (define (unit/sig? x) (signed-unit? x)) + (define (unit/sig->unit x) (signed-unit-unit x)) + + (provide define-signature + let-signature + unit/sig + compound-unit/sig + invoke-unit/sig + unit->unit/sig + signature->symbols + verify-signature-match + verify-linkage-signature-match + + (struct signed-unit (unit imports exports)) + unit/sig? unit/sig->unit + + define-values/invoke-unit/sig + namespace-variable-bind/invoke-unit/sig + provide-signature-elements)) diff --git a/collects/net/base64-sig.ss b/collects/net/base64-sig.ss index 8440f8b..242f953 100644 --- a/collects/net/base64-sig.ss +++ b/collects/net/base64-sig.ss @@ -1,13 +1,7 @@ - -(module base64-sig mzscheme - (require (lib "unitsig.ss")) - - (provide net:base64^) - - (define-signature net:base64^ - (base64-filename-safe - base64-encode-stream - base64-decode-stream - base64-encode - base64-decode))) +(module base64-sig (lib "a-signature.ss") + base64-filename-safe + base64-encode-stream + base64-decode-stream + base64-encode + base64-decode) diff --git a/collects/net/base64-unit.ss b/collects/net/base64-unit.ss index f410fac..730b9a0 100644 --- a/collects/net/base64-unit.ss +++ b/collects/net/base64-unit.ss @@ -1,14 +1,8 @@ - - -(module base64-unit mzscheme - (require (lib "unitsig.ss")) - +(module base64-unit (lib "a-unit.ss") (require "base64-sig.ss") - (provide net:base64@) - (define net:base64@ - (unit/sig net:base64^ - (import) + (import) + (export base64^) (define base64-digit (make-vector 256)) (let loop ([n 0]) @@ -142,5 +136,5 @@ (let ([s (open-output-bytes)]) (base64-encode-stream (open-input-bytes src) s (bytes 13 10)) - (get-output-bytes s)))))) + (get-output-bytes s)))) diff --git a/collects/net/cgi-sig.ss b/collects/net/cgi-sig.ss index 8b88696..61c9528 100644 --- a/collects/net/cgi-sig.ss +++ b/collects/net/cgi-sig.ss @@ -1,30 +1,23 @@ - -(module cgi-sig mzscheme - (require (lib "unitsig.ss")) - - (provide net:cgi^) - - (define-signature net:cgi^ - ( - ;; -- exceptions raised -- - (struct cgi-error ()) - (struct incomplete-%-suffix (chars)) - (struct invalid-%-suffix (char)) - - ;; -- cgi methods -- - get-bindings - get-bindings/post - get-bindings/get - output-http-headers - generate-html-output - generate-error-output - bindings-as-html - extract-bindings - extract-binding/single - get-cgi-method - - ;; -- general HTML utilities -- - string->html - generate-link-text - ))) +(module cgi-sig (lib "a-signature.ss") + ;; -- exceptions raised -- + (struct cgi-error ()) + (struct incomplete-%-suffix (chars)) + (struct invalid-%-suffix (char)) + + ;; -- cgi methods -- + get-bindings + get-bindings/post + get-bindings/get + output-http-headers + generate-html-output + generate-error-output + bindings-as-html + extract-bindings + extract-binding/single + get-cgi-method + + ;; -- general HTML utilities -- + string->html + generate-link-text + ) diff --git a/collects/net/cgi-unit.ss b/collects/net/cgi-unit.ss index e034e71..58c7600 100644 --- a/collects/net/cgi-unit.ss +++ b/collects/net/cgi-unit.ss @@ -1,10 +1,9 @@ -(module cgi-unit mzscheme - (require (lib "unitsig.ss") "cgi-sig.ss" (lib "etc.ss")) +(module cgi-unit (lib "a-unit.ss") + (require (lib "etc.ss") + "cgi-sig.ss") - (provide net:cgi@) - (define net:cgi@ - (unit/sig net:cgi^ - (import) + (import) + (export cgi^) ;; type bindings = list ((symbol . string)) @@ -239,5 +238,5 @@ (define (generate-link-text url anchor-text) (string-append "" anchor-text "")) - ))) + ) diff --git a/collects/net/cookie-sig.ss b/collects/net/cookie-sig.ss index ef216c6..dc93601 100644 --- a/collects/net/cookie-sig.ss +++ b/collects/net/cookie-sig.ss @@ -1,19 +1,16 @@ -(module cookie-sig mzscheme - (require (lib "unitsig.ss")) - (provide net:cookie^) +(module cookie-sig (lib "a-signature.ss") - (define-signature net:cookie^ - (set-cookie - cookie:add-comment - cookie:add-domain - cookie:add-max-age - cookie:add-path - cookie:secure - cookie:version - ;; To actually return a cookie (string formated as a cookie): - print-cookie - ;; To parse the Cookies header: - get-cookie - get-cookie/single - ;; exceptions - (struct cookie-error ())))) + set-cookie + cookie:add-comment + cookie:add-domain + cookie:add-max-age + cookie:add-path + cookie:secure + cookie:version + ;; To actually return a cookie (string formated as a cookie): + print-cookie + ;; To parse the Cookies header: + get-cookie + get-cookie/single + ;; exceptions + (struct cookie-error ())) diff --git a/collects/net/cookie-unit.ss b/collects/net/cookie-unit.ss index 98f5d8a..6f1f059 100644 --- a/collects/net/cookie-unit.ss +++ b/collects/net/cookie-unit.ss @@ -47,304 +47,297 @@ ;; ;; You should think of this procedures as a `format' for cookies. -(module cookie-unit mzscheme - (require (lib "unitsig.ss") - (lib "etc.ss") +(module cookie-unit (lib "a-unit.ss") + (require (lib "etc.ss") (lib "list.ss") (lib "string.ss" "srfi" "13") (lib "char-set.ss" "srfi" "14") "cookie-sig.ss") - (provide cookie@) + (import) + (export cookie^) + + (define-struct cookie (name value comment domain max-age path secure version)) + (define-struct (cookie-error exn:fail) ()) + + ;; The syntax for the Set-Cookie response header is + ;; set-cookie = "Set-Cookie:" cookies + ;; cookies = 1#cookie + ;; cookie = NAME "=" VALUE *(";" cookie-av) + ;; NAME = attr + ;; VALUE = value + ;; cookie-av = "Comment" "=" value + ;; | "Domain" "=" value + ;; | "Max-Age" "=" value + ;; | "Path" "=" value + ;; | "Secure" + ;; | "Version" "=" 1*DIGIT + (define set-cookie + (lambda (name pre-value) + (let ([value (to-rfc2109:value pre-value)]) + (unless (rfc2068:token? name) + (raise (build-cookie-error (format "Invalid cookie name: ~a / ~a" name value)))) + (make-cookie name value + #f;; comment + #f;; current domain + #f;; at the end of session + #f;; current path + #f;; normal (non SSL) + #f;; default version + )))) + + ;;! + ;; + ;; (function (print-cookie cookie)) + ;; + ;; (param cookie Cookie-structure "The cookie to return as a string") + ;; + ;; Formats the cookie contents in a string ready to be appended to a + ;; "Set-Cookie: " header, and sent to a client (browser). + (define print-cookie + (lambda (cookie) + (unless (cookie? cookie) + (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) + (string-join + (filter (lambda (s) + (not (string-null? s))) + (list (format "~a=~a" (cookie-name cookie) (cookie-value cookie)) + (let ((c (cookie-comment cookie))) (if c (format "Comment=~a" c) "")) + (let ((d (cookie-domain cookie))) (if d (format "Domain=~a" d) "")) + (let ((age (cookie-max-age cookie))) (if age (format "Max-Age=~a" age) "")) + (let ((p (cookie-path cookie))) (if p (format "Path=~a" p) "")) + (let ((s (cookie-secure cookie))) (if s "Secure" "")) + (let ((v (cookie-version cookie))) (format "Version=~a" (if v v 1))))) + "; "))) + + (define cookie:add-comment + (lambda (cookie pre-comment) + (let ([comment (to-rfc2109:value pre-comment)]) + (unless (cookie? cookie) + (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) + (set-cookie-comment! cookie comment) + cookie))) + + (define cookie:add-domain + (lambda (cookie domain) + (unless (valid-domain? domain) + (raise (build-cookie-error (format "Invalid domain: ~a" domain)))) + (unless (cookie? cookie) + (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) + (set-cookie-domain! cookie domain) + cookie)) + + (define cookie:add-max-age + (lambda (cookie seconds) + (unless (and (integer? seconds) (not (negative? seconds))) + (raise (build-cookie-error (format "Invalid Max-Age for cookie: ~a" seconds)))) + (unless (cookie? cookie) + (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) + (set-cookie-max-age! cookie seconds) + cookie)) + + (define cookie:add-path + (lambda (cookie pre-path) + (let ([path (to-rfc2109:value pre-path)]) + (unless (cookie? cookie) + (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) + (set-cookie-path! cookie path) + cookie))) + + (define cookie:secure + (lambda (cookie secure?) + (unless (boolean? secure?) + (raise (build-cookie-error (format "Invalid argument (boolean expected), received: ~a" secure?)))) + (unless (cookie? cookie) + (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) + (set-cookie-secure! cookie secure?) + cookie)) + + (define cookie:version + (lambda (cookie version) + (unless (integer? version) + (raise (build-cookie-error (format "Unsupported version: ~a" version)))) + (unless (cookie? cookie) + (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) + (set-cookie-version! cookie version) + cookie)) - (define cookie@ - (unit/sig net:cookie^ - (import) - - (define-struct cookie (name value comment domain max-age path secure version)) - (define-struct (cookie-error exn:fail) ()) - - ;; The syntax for the Set-Cookie response header is - ;; set-cookie = "Set-Cookie:" cookies - ;; cookies = 1#cookie - ;; cookie = NAME "=" VALUE *(";" cookie-av) - ;; NAME = attr - ;; VALUE = value - ;; cookie-av = "Comment" "=" value - ;; | "Domain" "=" value - ;; | "Max-Age" "=" value - ;; | "Path" "=" value - ;; | "Secure" - ;; | "Version" "=" 1*DIGIT - (define set-cookie - (lambda (name pre-value) - (let ([value (to-rfc2109:value pre-value)]) - (unless (rfc2068:token? name) - (raise (build-cookie-error (format "Invalid cookie name: ~a / ~a" name value)))) - (make-cookie name value - #f;; comment - #f;; current domain - #f;; at the end of session - #f;; current path - #f;; normal (non SSL) - #f;; default version - )))) + ;; Parsing the Cookie header: - ;;! - ;; - ;; (function (print-cookie cookie)) - ;; - ;; (param cookie Cookie-structure "The cookie to return as a string") - ;; - ;; Formats the cookie contents in a string ready to be appended to a - ;; "Set-Cookie: " header, and sent to a client (browser). - (define print-cookie - (lambda (cookie) - (unless (cookie? cookie) - (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) - (string-join - (filter (lambda (s) - (not (string-null? s))) - (list (format "~a=~a" (cookie-name cookie) (cookie-value cookie)) - (let ((c (cookie-comment cookie))) (if c (format "Comment=~a" c) "")) - (let ((d (cookie-domain cookie))) (if d (format "Domain=~a" d) "")) - (let ((age (cookie-max-age cookie))) (if age (format "Max-Age=~a" age) "")) - (let ((p (cookie-path cookie))) (if p (format "Path=~a" p) "")) - (let ((s (cookie-secure cookie))) (if s "Secure" "")) - (let ((v (cookie-version cookie))) (format "Version=~a" (if v v 1))))) - "; "))) + (define char-set:all-but= + (char-set-difference char-set:full (string->char-set "="))) - (define cookie:add-comment - (lambda (cookie pre-comment) - (let ([comment (to-rfc2109:value pre-comment)]) - (unless (cookie? cookie) - (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) - (set-cookie-comment! cookie comment) - cookie))) + (define char-set:all-but-semicolon + (char-set-difference char-set:full (string->char-set ";"))) - (define cookie:add-domain - (lambda (cookie domain) - (unless (valid-domain? domain) - (raise (build-cookie-error (format "Invalid domain: ~a" domain)))) - (unless (cookie? cookie) - (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) - (set-cookie-domain! cookie domain) - cookie)) + ;;! + ;; + ;; (function (get-all-results name cookies)) + ;; + ;; Auxiliar procedure that returns all values associated with + ;; `name' in the association list (cookies). + (define get-all-results + (lambda (name cookies) + (let loop ((c cookies)) + (cond ((null? c) ()) + (else + (let ((pair (car c))) + (if (string=? name (car pair)) + ;; found an instance of cookie named `name' + (cons (cadr pair) (loop (cdr c))) + (loop (cdr c))))))))) - (define cookie:add-max-age - (lambda (cookie seconds) - (unless (and (integer? seconds) (not (negative? seconds))) - (raise (build-cookie-error (format "Invalid Max-Age for cookie: ~a" seconds)))) - (unless (cookie? cookie) - (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) - (set-cookie-max-age! cookie seconds) - cookie)) + ;; which tipically looks like: (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"") + ;; note that it can be multi-valued: `test1' has values: "1", and "20". + ;; Of course, in the same spirit, we only receive the "string content". + (define get-cookie + (lambda (name cookies) + (let ((cookies (map (lambda (p) + (map string-trim-both + (string-tokenize p char-set:all-but=))) + (string-tokenize cookies char-set:all-but-semicolon)))) + (get-all-results name cookies)))) - (define cookie:add-path - (lambda (cookie pre-path) - (let ([path (to-rfc2109:value pre-path)]) - (unless (cookie? cookie) - (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) - (set-cookie-path! cookie path) - cookie))) - - (define cookie:secure - (lambda (cookie secure?) - (unless (boolean? secure?) - (raise (build-cookie-error (format "Invalid argument (boolean expected), received: ~a" secure?)))) - (unless (cookie? cookie) - (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) - (set-cookie-secure! cookie secure?) - cookie)) - - (define cookie:version - (lambda (cookie version) - (unless (integer? version) - (raise (build-cookie-error (format "Unsupported version: ~a" version)))) - (unless (cookie? cookie) - (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) - (set-cookie-version! cookie version) - cookie)) + ;;! + ;; + ;; (function (get-cookie/single name cookies)) + ;; + ;; (param name String "The name of the cookie we are looking for") + ;; (param cookies String "The string (from the environment) with the content of the cookie header.") + ;; + ;; Returns the first name associated with the cookie named `name', if any, or #f. + (define get-cookie/single + (lambda (name cookies) + (let ((cookies (get-cookie name cookies))) + (and (not (null? cookies)) + (car cookies))))) - ;; Parsing the Cookie header: + ;;;;; + ;; Auxiliary procedures + ;;;;; + ;; token = 1* + ;; + ;; tspecials = "(" | ")" | "<" | ">" | "@" + ;; | "," | ";" | ":" | "\" | <"> + ;; | "/" | "[" | "]" | "?" | "=" + ;; | "{" | "}" | SP | HT + (define char-set:tspecials + (char-set-union (string->char-set "()<>@,;:\\\"/[]?={}") + char-set:whitespace + (char-set #\tab))) - (define char-set:all-but= - (char-set-difference char-set:full (string->char-set "="))) + (define char-set:control + (char-set-union char-set:iso-control + (char-set (integer->char 127))));; DEL + (define char-set:token (char-set-difference char-set:ascii char-set:tspecials char-set:control)) - (define char-set:all-but-semicolon - (char-set-difference char-set:full (string->char-set ";"))) + ;; token? : string -> boolean + ;; + ;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise. + (define rfc2068:token? + (lambda (s) (string-every char-set:token s))) - ;;! - ;; - ;; (function (get-all-results name cookies)) - ;; - ;; Auxiliar procedure that returns all values associated with - ;; `name' in the association list (cookies). - (define get-all-results - (lambda (name cookies) - (let loop ((c cookies)) - (cond ((null? c) ()) - (else - (let ((pair (car c))) - (if (string=? name (car pair)) - ;; found an instance of cookie named `name' - (cons (cadr pair) (loop (cdr c))) - (loop (cdr c))))))))) - - ;; which tipically looks like: (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"") - ;; note that it can be multi-valued: `test1' has values: "1", and "20". - ;; Of course, in the same spirit, we only receive the "string content". - (define get-cookie - (lambda (name cookies) - (let ((cookies (map (lambda (p) - (map string-trim-both - (string-tokenize p char-set:all-but=))) - (string-tokenize cookies char-set:all-but-semicolon)))) - (get-all-results name cookies)))) + ;;! + ;; + ;; (function (quoted-string? s)) + ;; + ;; (param s String "The string to check") + ;; + ;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in: + ;; quoted-string = ( <"> *(qdtext) <"> ) + ;; qdtext = > + ;; + ;; The backslash character ("\") may be used as a single-character quoting + ;; mechanism only within quoted-string and comment constructs. + ;; + ;; quoted-pair = "\" CHAR + ;; + ;; implementation note: I have chosen to use a regular expression rather than + ;; a character set for this definition because of two dependencies: CRLF must appear + ;; as a block to be legal, and " may only appear as \" + (define rfc2068:quoted-string? + (lambda (s) + (if (regexp-match #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$" s) + s + #f))) - ;;! - ;; - ;; (function (get-cookie/single name cookies)) - ;; - ;; (param name String "The name of the cookie we are looking for") - ;; (param cookies String "The string (from the environment) with the content of the cookie header.") - ;; - ;; Returns the first name associated with the cookie named `name', if any, or #f. - (define get-cookie/single - (lambda (name cookies) - (let ((cookies (get-cookie name cookies))) - (and (not (null? cookies)) - (car cookies))))) + ;; value: token | quoted-string + (define (rfc2109:value? s) + (or (rfc2068:token? s) (rfc2068:quoted-string? s))) - - - ;;;;; - ;; Auxiliar procedures - ;;;;; - + ;; convert-to-quoted : string -> quoted-string? + ;; takes the given string as a particular message, and converts the given string to that + ;; representatation + (define (convert-to-quoted str) + (string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\"")) - ;; token = 1* - ;; - ;; tspecials = "(" | ")" | "<" | ">" | "@" - ;; | "," | ";" | ":" | "\" | <"> - ;; | "/" | "[" | "]" | "?" | "=" - ;; | "{" | "}" | SP | HT - (define char-set:tspecials - (char-set-union - (string->char-set "()<>@,;:\\\"/[]?={}") - char-set:whitespace - (char-set #\tab))) - - (define char-set:control (char-set-union char-set:iso-control - (char-set (integer->char 127))));; DEL - (define char-set:token (char-set-difference char-set:ascii char-set:tspecials char-set:control)) - - ;; token? : string -> boolean - ;; - ;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise. - (define rfc2068:token? - (lambda (s) (string-every char-set:token s))) - - ;;! - ;; - ;; (function (quoted-string? s)) - ;; - ;; (param s String "The string to check") - ;; - ;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in: - ;; quoted-string = ( <"> *(qdtext) <"> ) - ;; qdtext = > - ;; - ;; The backslash character ("\") may be used as a single-character quoting - ;; mechanism only within quoted-string and comment constructs. - ;; - ;; quoted-pair = "\" CHAR - ;; - ;; implementation note: I have chosen to use a regular expression rather than - ;; a character set for this definition because of two dependencies: CRLF must appear - ;; as a block to be legal, and " may only appear as \" - (define rfc2068:quoted-string? - (lambda (s) - (if (regexp-match #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$" s) - s - #f))) - - ;; value: token | quoted-string - (define (rfc2109:value? s) - (or (rfc2068:token? s) (rfc2068:quoted-string? s))) - - ;; convert-to-quoted : string -> quoted-string? - ;; takes the given string as a particular message, and converts the given string to that - ;; representatation - (define (convert-to-quoted str) - (string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\"")) - - ;; string -> rfc2109:value? - (define (to-rfc2109:value s) - (cond - [(not (string? s)) - (raise (build-cookie-error (format "Expected string, given: ~e" s)))] - - ; for backwards compatibility, just use the given string if it will work - [(rfc2068:token? s) s] - [(rfc2068:quoted-string? s) s] - - ; ... but if it doesn't work (i.e., it's just a normal message) then try to - ; convert it into a representation that will work - [(rfc2068:quoted-string? (convert-to-quoted s)) - => (λ (x) x)] - [else - (raise - (build-cookie-error - (format "Could not convert the given string to an acceptable RFC 2109 value: ~s" s)))])) - - - ;;! - ;; - ;; (function (cookie-string? s)) - ;; - ;; (param s String "String to check") - ;; - ;; Returns whether this is a valid string to use as the value or the - ;; name (depending on value?) of an HTTP cookie. - (define cookie-string? - (opt-lambda (s (value? #t)) - (unless (string? s) - (raise (build-cookie-error (format "String expected, received: ~a" s)))) - (if value? - (rfc2109:value? s) - ;; name: token - (rfc2068:token? s)))) + ;; string -> rfc2109:value? + (define (to-rfc2109:value s) + (cond + [(not (string? s)) + (raise (build-cookie-error (format "Expected string, given: ~e" s)))] + + ;; for backwards compatibility, just use the given string if it will work + [(rfc2068:token? s) s] + [(rfc2068:quoted-string? s) s] + + ;; ... but if it doesn't work (i.e., it's just a normal message) then try + ;; to convert it into a representation that will work + [(rfc2068:quoted-string? (convert-to-quoted s)) + => (λ (x) x)] + [else + (raise + (build-cookie-error + (format "Could not convert the given string to an acceptable RFC 2109 value: ~s" s)))])) + + ;;! + ;; + ;; (function (cookie-string? s)) + ;; + ;; (param s String "String to check") + ;; + ;; Returns whether this is a valid string to use as the value or the + ;; name (depending on value?) of an HTTP cookie. + (define cookie-string? + (opt-lambda (s (value? #t)) + (unless (string? s) + (raise (build-cookie-error (format "String expected, received: ~a" s)))) + (if value? + (rfc2109:value? s) + ;; name: token + (rfc2068:token? s)))) + + ;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-) + (define char-set:hostname + (let ((a-z-lowercase (ucs-range->char-set #x61 #x7B)) + (a-z-uppercase (ucs-range->char-set #x41 #x5B))) + (char-set-adjoin! + (char-set-union char-set:digit a-z-lowercase a-z-uppercase) + #\. ))) + + (define valid-domain? + (lambda (dom) + (and + ;; Domain must start with a dot (.) + (string=? (string-take dom 1) ".") + ;; The rest are tokens-like strings separated by dots + (string-every char-set:hostname dom) + (<= (string-length dom) 76)))) + + (define (valid-path? v) + (and (string? v) + (rfc2109:value? v))) + + ;; build-cookie-error : string -> cookie-error + ;; constructs a cookie-error struct from the given error message + ;; (added to fix exceptions-must-take-immutable-strings bug) + (define (build-cookie-error msg) + (make-cookie-error (string->immutable-string msg) + (current-continuation-marks))) - ;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-) - (define char-set:hostname - (let ((a-z-lowercase (ucs-range->char-set #x61 #x7B)) - (a-z-uppercase (ucs-range->char-set #x41 #x5B))) - (char-set-adjoin! - (char-set-union char-set:digit a-z-lowercase a-z-uppercase) - #\. ))) - - (define valid-domain? - (lambda (dom) - (and - ;; Domain must start with a dot (.) - (string=? (string-take dom 1) ".") - ;; The rest are tokens-like strings separated by dots - (string-every char-set:hostname dom) - (<= (string-length dom) 76)))) - - (define (valid-path? v) - (and (string? v) - (rfc2109:value? v))) - - ;; build-cookie-error : string -> cookie-error - ;; constructs a cookie-error struct from the given error message - ;; (added to fix exceptions-must-take-immutable-strings bug) - (define (build-cookie-error msg) - (make-cookie-error (string->immutable-string msg) (current-continuation-marks))))) ) -;;; cookie-unit.ss ends here \ No newline at end of file +;;; cookie-unit.ss ends here diff --git a/collects/net/dns-sig.ss b/collects/net/dns-sig.ss index 020f460..02407eb 100644 --- a/collects/net/dns-sig.ss +++ b/collects/net/dns-sig.ss @@ -1,12 +1,6 @@ - -(module dns-sig mzscheme - (require (lib "unitsig.ss")) - - (provide net:dns^) - - (define-signature net:dns^ - (dns-get-address - dns-get-name - dns-get-mail-exchanger - dns-find-nameserver))) +(module dns-sig (lib "a-signature.ss") + dns-get-address + dns-get-name + dns-get-mail-exchanger + dns-find-nameserver) diff --git a/collects/net/dns-unit.ss b/collects/net/dns-unit.ss index 4f15164..7ff9760 100644 --- a/collects/net/dns-unit.ss +++ b/collects/net/dns-unit.ss @@ -1,18 +1,14 @@ +(module dns-unit (lib "a-unit.ss") + (require (lib "list.ss") + (lib "process.ss") + "dns-sig.ss") -(module dns-unit mzscheme - (require (lib "unitsig.ss") - (lib "list.ss") - (lib "process.ss")) - (require "dns-sig.ss") + (import) + (export dns^) - ;; UDP retry timeout: - (define INIT-TIMEOUT 50) - - (provide net:dns@) - (define net:dns@ - (unit/sig net:dns^ - (import) + ;; UDP retry timeout: + (define INIT-TIMEOUT 50) (define types '((a 1) @@ -365,5 +361,5 @@ line)) => (lambda (m) (loop name (cadr m) #f))] [else (loop name ip #f)]))))))] - [else #f]))))) + [else #f]))) diff --git a/collects/net/ftp-sig.ss b/collects/net/ftp-sig.ss index 3de7fdc..2d2712c 100644 --- a/collects/net/ftp-sig.ss +++ b/collects/net/ftp-sig.ss @@ -1,13 +1,8 @@ -(module ftp-sig mzscheme - (require (lib "unitsig.ss")) - - (provide net:ftp^) - - (define-signature net:ftp^ - (ftp-cd - ftp-establish-connection ftp-establish-connection* - ftp-close-connection - ftp-directory-list - ftp-download-file - ftp-make-file-seconds))) +(module ftp-sig (lib "a-signature.ss") + ftp-cd + ftp-establish-connection ftp-establish-connection* + ftp-close-connection + ftp-directory-list + ftp-download-file + ftp-make-file-seconds) diff --git a/collects/net/ftp-unit.ss b/collects/net/ftp-unit.ss index 4e3723b..3c0c5b3 100644 --- a/collects/net/ftp-unit.ss +++ b/collects/net/ftp-unit.ss @@ -1,4 +1,4 @@ -(module ftp-unit mzscheme +(module ftp-unit (lib "a-unit.ss") ;; Version 0.2 ;; Version 0.1a ;; Micah Flatt @@ -6,13 +6,9 @@ (require (lib "date.ss") (lib "file.ss") (lib "port.ss") - "ftp-sig.ss" - (lib "unitsig.ss")) - - (provide net:ftp@) - (define net:ftp@ - (unit/sig net:ftp^ - (import) + "ftp-sig.ss") + (import) + (export ftp^) ;; opqaue record to represent an FTP connection: (define-struct tcp-connection (in out)) @@ -216,4 +212,4 @@ (rename-file-or-directory tmpfile (build-path folder filename) #t))) ;; (printf "FTP Client Installed...~n") - ))) + ) diff --git a/collects/net/head-sig.ss b/collects/net/head-sig.ss index d32cae1..631802a 100644 --- a/collects/net/head-sig.ss +++ b/collects/net/head-sig.ss @@ -1,19 +1,14 @@ - -(module head-sig mzscheme - (require (lib "unitsig.ss")) - - (provide net:head^) - (define-signature net:head^ - (empty-header - validate-header - extract-field - remove-field - insert-field - replace-field - extract-all-fields - append-headers - standard-message-header - data-lines->data - extract-addresses - assemble-address-field))) +(module head-sig (lib "a-signature.ss") + empty-header + validate-header + extract-field + remove-field + insert-field + replace-field + extract-all-fields + append-headers + standard-message-header + data-lines->data + extract-addresses + assemble-address-field) diff --git a/collects/net/head-unit.ss b/collects/net/head-unit.ss index 5adb90e..93644fd 100644 --- a/collects/net/head-unit.ss +++ b/collects/net/head-unit.ss @@ -1,16 +1,11 @@ +(module head-unit (lib "a-unit.ss") + (require (lib "date.ss") + (lib "string.ss") + "head-sig.ss") -(module head-unit mzscheme - (require (lib "unitsig.ss") - (lib "date.ss") - (lib "string.ss")) + (import) + (export head^) - (require "head-sig.ss") - - (provide net:head@) - (define net:head@ - (unit/sig net:head^ - (import) - ;; NB: I've done a copied-code adaptation of a number of these definitions into ;; "bytes-compatible" versions. Finishing the rest will require some kind of interface ;; decision---that is, when you don't supply a header, should the resulting operation @@ -402,4 +397,4 @@ alen) (loop (cdr addresses) (format "~a, ~a" s addr) - (+ len alen 2))))))))))) + (+ len alen 2))))))))) diff --git a/collects/net/imap-sig.ss b/collects/net/imap-sig.ss index 44d8dda..df074c0 100644 --- a/collects/net/imap-sig.ss +++ b/collects/net/imap-sig.ss @@ -1,44 +1,38 @@ - - -(module imap-sig mzscheme - (require (lib "unitsig.ss")) - - (provide net:imap^) - (define-signature net:imap^ - (imap-port-number - imap-connection? - - imap-connect imap-connect* - imap-disconnect - imap-force-disconnect - imap-reselect - imap-examine - imap-noop - imap-status - imap-poll - - imap-new? - imap-messages - imap-recent - imap-uidnext - imap-uidvalidity - imap-unseen - imap-reset-new! - - imap-get-expunges - imap-pending-expunges? - imap-get-updates - imap-pending-updates? - - imap-get-messages - imap-copy imap-append - imap-store imap-flag->symbol symbol->imap-flag - imap-expunge - - imap-mailbox-exists? - imap-create-mailbox - - imap-list-child-mailboxes - imap-mailbox-flags - imap-get-hierarchy-delimiter))) +(module imap-sig (lib "a-signature.ss") + imap-port-number + imap-connection? + + imap-connect imap-connect* + imap-disconnect + imap-force-disconnect + imap-reselect + imap-examine + imap-noop + imap-status + imap-poll + + imap-new? + imap-messages + imap-recent + imap-uidnext + imap-uidvalidity + imap-unseen + imap-reset-new! + + imap-get-expunges + imap-pending-expunges? + imap-get-updates + imap-pending-updates? + + imap-get-messages + imap-copy imap-append + imap-store imap-flag->symbol symbol->imap-flag + imap-expunge + + imap-mailbox-exists? + imap-create-mailbox + + imap-list-child-mailboxes + imap-mailbox-flags + imap-get-hierarchy-delimiter) diff --git a/collects/net/imap-unit.ss b/collects/net/imap-unit.ss index a6c6978..c30b76c 100644 --- a/collects/net/imap-unit.ss +++ b/collects/net/imap-unit.ss @@ -1,14 +1,10 @@ - -(module imap-unit mzscheme - (require (lib "unitsig.ss") - (lib "list.ss") +(module imap-unit (lib "a-unit.ss") + (require (lib "list.ss") "imap-sig.ss" "private/rbtree.ss") - (provide net:imap@) - (define net:imap@ - (unit/sig net:imap^ - (import) + (import) + (export imap^) (define debug-via-stdio? #f) @@ -572,4 +568,4 @@ (cons (list flags name) sub-folders)))))))) - (reverse sub-folders)))))) + (reverse sub-folders)))) diff --git a/collects/net/mime-sig.ss b/collects/net/mime-sig.ss index 6983623..99383d2 100644 --- a/collects/net/mime-sig.ss +++ b/collects/net/mime-sig.ss @@ -1,33 +1,26 @@ -(module mime-sig mzscheme - (require (lib "unitsig.ss")) - - (provide net:mime^) +(module mime-sig (lib "a-signature.ss") + ;; -- exceptions raised -- + (struct mime-error () -setters -constructor) + (struct unexpected-termination (msg) -setters -constructor) + (struct missing-multipart-boundary-parameter () -setters -constructor) + (struct malformed-multipart-entity (msg) -setters -constructor) + (struct empty-mechanism () -setters -constructor) + (struct empty-type () -setters -constructor) + (struct empty-subtype () -setters -constructor) + (struct empty-disposition-type () -setters -constructor) - (define-signature net:mime^ - ( - ;; -- exceptions raised -- - (struct mime-error () -setters (- make-mime-error)) - (struct unexpected-termination (msg) -setters (- make-unexpected-termination)) - (struct missing-multipart-boundary-parameter () -setters - (- make-missing-multipart-boundary-parameter)) - (struct malformed-multipart-entity (msg) -setters (- make-malformed-multipart-entity)) - (struct empty-mechanism () -setters (- make-empty-mechanism)) - (struct empty-type () -setters (- make-empty-type)) - (struct empty-subtype () -setters (- make-empty-subtype)) - (struct empty-disposition-type () -setters (- make-empty-disposition-type)) - - ;; -- basic mime structures -- - (struct message (version entity fields)) - (struct entity - (type subtype charset encoding - disposition params id - description other fields - parts body)) - (struct disposition - (type filename creation - modification read - size params)) - - ;; -- mime methods -- - mime-analyze - ))) + ;; -- basic mime structures -- + (struct message (version entity fields)) + (struct entity + (type subtype charset encoding + disposition params id + description other fields + parts body)) + (struct disposition + (type filename creation + modification read + size params)) + + ;; -- mime methods -- + mime-analyze + ) diff --git a/collects/net/mime-unit.ss b/collects/net/mime-unit.ss index 8abeec0..f0e2d19 100644 --- a/collects/net/mime-unit.ss +++ b/collects/net/mime-unit.ss @@ -27,23 +27,18 @@ ;; Commentary: MIME support for PLT Scheme: an implementation of ;; rfc2045, rfc2046, rfc2047, rfc2048, and rfc2049. -(module mime-unit mzscheme +(module mime-unit (lib "a-unit.ss") (require "mime-sig.ss" "qp-sig.ss" "base64-sig.ss" "head-sig.ss" "mime-util.ss" - (lib "unitsig.ss") (lib "etc.ss") (lib "string.ss") (lib "port.ss")) - (provide net:mime@) - (define net:mime@ - (unit/sig net:mime^ - (import net:base64^ - net:qp^ - net:head^) + (import base64^ qp^ head^) + (export mime^) ;; Constants: (define discrete-alist '(("text" . text) @@ -783,4 +778,4 @@ (define disp-quoted-data-time date-time) - ))) + ) diff --git a/collects/net/nntp-sig.ss b/collects/net/nntp-sig.ss index 2fd7e4d..d08d200 100644 --- a/collects/net/nntp-sig.ss +++ b/collects/net/nntp-sig.ss @@ -1,26 +1,20 @@ - -(module nntp-sig mzscheme - (require (lib "unitsig.ss")) - - (provide net:nntp^) +(module nntp-sig (lib "a-signature.ss") + (struct communicator (sender receiver server port)) + connect-to-server connect-to-server* disconnect-from-server + authenticate-user open-news-group + head-of-message body-of-message + newnews-since generic-message-command + make-desired-header extract-desired-headers - (define-signature net:nntp^ - ((struct communicator (sender receiver server port)) - connect-to-server connect-to-server* disconnect-from-server - authenticate-user open-news-group - head-of-message body-of-message - newnews-since generic-message-command - make-desired-header extract-desired-headers - - (struct nntp ()) - (struct unexpected-response (code text)) - (struct bad-status-line (line)) - (struct premature-close (communicator)) - (struct bad-newsgroup-line (line)) - (struct non-existent-group (group)) - (struct article-not-in-group (article)) - (struct no-group-selected ()) - (struct article-not-found (article)) - (struct authentication-rejected ())))) + (struct nntp ()) + (struct unexpected-response (code text)) + (struct bad-status-line (line)) + (struct premature-close (communicator)) + (struct bad-newsgroup-line (line)) + (struct non-existent-group (group)) + (struct article-not-in-group (article)) + (struct no-group-selected ()) + (struct article-not-found (article)) + (struct authentication-rejected ())) diff --git a/collects/net/nntp-unit.ss b/collects/net/nntp-unit.ss index f5aa600..ae306d1 100644 --- a/collects/net/nntp-unit.ss +++ b/collects/net/nntp-unit.ss @@ -1,13 +1,9 @@ -(module nntp-unit mzscheme - (require (lib "unitsig.ss") - (lib "etc.ss")) +(module nntp-unit (lib "a-unit.ss") + (require (lib "etc.ss") + "nntp-sig.ss") - (require "nntp-sig.ss") - - (provide net:nntp@) - (define net:nntp@ - (unit/sig net:nntp^ - (import) + (import) + (export nntp^) ;; sender : oport ;; receiver : iport @@ -337,5 +333,5 @@ (regexp-match matcher first)) desireds) (cons first (loop rest)) - (loop rest)))))))))) + (loop rest)))))))) diff --git a/collects/net/pop3-sig.ss b/collects/net/pop3-sig.ss index 3b0db30..67cf18d 100644 --- a/collects/net/pop3-sig.ss +++ b/collects/net/pop3-sig.ss @@ -1,27 +1,21 @@ - -(module pop3-sig mzscheme - (require (lib "unitsig.ss")) - - (provide net:pop3^) +(module pop3-sig (lib "a-signature.ss") + (struct communicator (sender receiver server port state)) + connect-to-server connect-to-server* disconnect-from-server + authenticate/plain-text + get-mailbox-status + get-message/complete get-message/headers get-message/body + delete-message + get-unique-id/single get-unique-id/all - (define-signature net:pop3^ - ((struct communicator (sender receiver server port state)) - connect-to-server connect-to-server* disconnect-from-server - authenticate/plain-text - get-mailbox-status - get-message/complete get-message/headers get-message/body - delete-message - get-unique-id/single get-unique-id/all - - make-desired-header extract-desired-headers - - (struct pop3 ()) - (struct cannot-connect ()) - (struct username-rejected ()) - (struct password-rejected ()) - (struct not-ready-for-transaction (communicator)) - (struct not-given-headers (communicator message)) - (struct illegal-message-number (communicator message)) - (struct cannot-delete-message (communicator message)) - (struct disconnect-not-quiet (communicator)) - (struct malformed-server-response (communicator))))) + make-desired-header extract-desired-headers + + (struct pop3 ()) + (struct cannot-connect ()) + (struct username-rejected ()) + (struct password-rejected ()) + (struct not-ready-for-transaction (communicator)) + (struct not-given-headers (communicator message)) + (struct illegal-message-number (communicator message)) + (struct cannot-delete-message (communicator message)) + (struct disconnect-not-quiet (communicator)) + (struct malformed-server-response (communicator))) diff --git a/collects/net/pop3-unit.ss b/collects/net/pop3-unit.ss index 46ed806..e9c2717 100644 --- a/collects/net/pop3-unit.ss +++ b/collects/net/pop3-unit.ss @@ -1,14 +1,9 @@ +(module pop3-unit (lib "a-unit.ss") + (require (lib "etc.ss") + "pop3-sig.ss") -(module pop3-unit mzscheme - (require (lib "unitsig.ss") - (lib "etc.ss")) - - (require "pop3-sig.ss") - - (provide net:pop3@) - (define net:pop3@ - (unit/sig net:pop3^ - (import) + (import) + (export pop3^) ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose @@ -411,5 +406,5 @@ (regexp-match matcher first)) desireds) (cons first (loop rest)) - (loop rest)))))))))) + (loop rest)))))))) diff --git a/collects/net/qp-sig.ss b/collects/net/qp-sig.ss index c381844..90b30ca 100644 --- a/collects/net/qp-sig.ss +++ b/collects/net/qp-sig.ss @@ -1,17 +1,12 @@ -(module qp-sig mzscheme - (require (lib "unitsig.ss")) +(module qp-sig (lib "a-signature.ss") + ;; -- exceptions raised -- + (struct qp-error () -setters -constructor) + (struct qp-wrong-input () -setters -constructor) + (struct qp-wrong-line-size (size) -setters -constructor) - (provide net:qp^) - (define-signature net:qp^ - ( - ;; -- exceptions raised -- - (struct qp-error () -setters (- make-qp-error)) - (struct qp-wrong-input () -setters (- make-qp-wrong-input)) - (struct qp-wrong-line-size (size) -setters (- make-qp-wrong-line-size)) - - ;; -- qp methods -- - qp-encode - qp-decode - qp-encode-stream - qp-decode-stream - ))) + ;; -- qp methods -- + qp-encode + qp-decode + qp-encode-stream + qp-decode-stream + ) diff --git a/collects/net/qp-unit.ss b/collects/net/qp-unit.ss index b02c37a..d9510be 100644 --- a/collects/net/qp-unit.ss +++ b/collects/net/qp-unit.ss @@ -25,15 +25,12 @@ ;; ;; Commentary: -(module qp-unit mzscheme +(module qp-unit (lib "a-unit.ss") (require "qp-sig.ss" - (lib "unitsig.ss") (lib "etc.ss")) - (provide net:qp@) - (define net:qp@ - (unit/sig net:qp^ - (import) + (import) + (export qp^) ;; Exceptions: ;; String or input-port expected: @@ -171,6 +168,6 @@ (vector-set! hex-values (+ i 65) (+ 10 i)) (vector-set! hex-values (+ i 97) (+ 10 i)) (vector-set! hex-bytes (+ 10 i) (+ i 65)) - (loop (add1 i))))))) + (loop (add1 i))))) ;;; qp-unit.ss ends here diff --git a/collects/net/sendmail-sig.ss b/collects/net/sendmail-sig.ss index f3ce211..3339c80 100644 --- a/collects/net/sendmail-sig.ss +++ b/collects/net/sendmail-sig.ss @@ -1,11 +1,5 @@ - -(module sendmail-sig mzscheme - (require (lib "unitsig.ss")) - - (provide net:sendmail^) - - (define-signature net:sendmail^ - (send-mail-message/port - send-mail-message - (struct no-mail-recipients ())))) +(module sendmail-sig (lib "a-signature.ss") + send-mail-message/port + send-mail-message + (struct no-mail-recipients ())) diff --git a/collects/net/sendmail-unit.ss b/collects/net/sendmail-unit.ss index b3cc5d7..45f3e42 100644 --- a/collects/net/sendmail-unit.ss +++ b/collects/net/sendmail-unit.ss @@ -1,14 +1,9 @@ +(module sendmail-unit (lib "a-unit.ss") + (require (lib "process.ss") + "sendmail-sig.ss") -(module sendmail-unit mzscheme - (require (lib "unitsig.ss") - (lib "process.ss")) - - (require "sendmail-sig.ss") - - (provide net:sendmail@) - (define net:sendmail@ - (unit/sig net:sendmail^ - (import) + (import) + (export sendmail^) (define-struct (no-mail-recipients exn) ()) @@ -121,4 +116,4 @@ (display s writer) ; We use -i, so "." is not a problem (newline writer)) text) - (close-output-port writer))))))) + (close-output-port writer))))) diff --git a/collects/net/smtp-sig.ss b/collects/net/smtp-sig.ss index 96dd7c7..314cdcb 100644 --- a/collects/net/smtp-sig.ss +++ b/collects/net/smtp-sig.ss @@ -1,11 +1,6 @@ - -(module smtp-sig mzscheme - (require (lib "unitsig.ss")) - - (provide net:smtp^) - (define-signature net:smtp^ - (smtp-sending-server - smtp-send-message - smtp-send-message* - smtp-sending-end-of-message))) +(module smtp-sig (lib "a-signature.ss") + smtp-sending-server + smtp-send-message + smtp-send-message* + smtp-sending-end-of-message) diff --git a/collects/net/smtp-unit.ss b/collects/net/smtp-unit.ss index fb95ca3..233135c 100644 --- a/collects/net/smtp-unit.ss +++ b/collects/net/smtp-unit.ss @@ -1,15 +1,10 @@ +(module smtp-unit (lib "a-unit.ss") + (require (lib "kw.ss") + "base64.ss" + "smtp-sig.ss") -(module smtp-unit mzscheme - (require (lib "unitsig.ss") - (lib "kw.ss") - "base64.ss") - - (require "smtp-sig.ss") - - (provide net:smtp@) - (define net:smtp@ - (unit/sig net:smtp^ - (import) + (import) + (export smtp^) (define smtp-sending-server (make-parameter "localhost")) @@ -133,4 +128,4 @@ (values (current-input-port) (current-output-port)) (tcp-connect server opt-port-no))]) (smtp-send-message* r w sender recipients header message-lines - auth-user auth-passwd))))))) + auth-user auth-passwd))))) diff --git a/collects/net/uri-codec-sig.ss b/collects/net/uri-codec-sig.ss index 2d13a55..7c419c2 100644 --- a/collects/net/uri-codec-sig.ss +++ b/collects/net/uri-codec-sig.ss @@ -1,14 +1,10 @@ -(module uri-codec-sig mzscheme - (require (lib "unitsig.ss")) - (provide net:uri-codec^) - - (define-signature net:uri-codec^ - (uri-encode - uri-decode - uri-path-segment-encode - uri-path-segment-decode - form-urlencoded-encode - form-urlencoded-decode - alist->form-urlencoded - form-urlencoded->alist - current-alist-separator-mode))) \ No newline at end of file +(module uri-codec-sig (lib "a-signature.ss") + uri-encode + uri-decode + uri-path-segment-encode + uri-path-segment-decode + form-urlencoded-encode + form-urlencoded-decode + alist->form-urlencoded + form-urlencoded->alist + current-alist-separator-mode) \ No newline at end of file diff --git a/collects/net/uri-codec-unit.ss b/collects/net/uri-codec-unit.ss index 8c1f158..0fb6673 100644 --- a/collects/net/uri-codec-unit.ss +++ b/collects/net/uri-codec-unit.ss @@ -167,21 +167,17 @@ JALQefhDMCATcl2/bZL0bw== ;; Draws inspiration from encode-decode.scm by Kurt Normark and a code ;; sample provided by Eli Barzilay -(module uri-codec-unit mzscheme +(module uri-codec-unit (lib "a-unit.ss") - (require (lib "unitsig.ss") - (lib "match.ss") + (require (lib "match.ss") (lib "string.ss") (lib "list.ss") (lib "etc.ss") "uri-codec-sig.ss") - (provide uri-codec@) - - (define uri-codec@ - (unit/sig net:uri-codec^ - (import) - + (import) + (export uri-codec^) + (define (self-map-char ch) (cons ch ch)) (define (self-map-chars str) (map self-map-char (string->list str))) @@ -375,6 +371,6 @@ JALQefhDMCATcl2/bZL0bw== (raise-type-error 'current-alist-separator-mode "'amp, 'semi, or 'amp-or-semi" s)) - s)))))) + s)))) ;;; uri-codec-unit.ss ends here diff --git a/collects/net/url-sig.ss b/collects/net/url-sig.ss index 7094f19..22d55b0 100644 --- a/collects/net/url-sig.ss +++ b/collects/net/url-sig.ss @@ -1,19 +1,15 @@ -(module url-sig mzscheme - (require (lib "unitsig.ss")) - (provide net:url^) - - (define-signature net:url^ - (get-pure-port - get-impure-port - post-pure-port - post-impure-port - display-pure-port - purify-port - netscape/string->url - string->url - url->string - call/input-url - combine-url/relative - url-exception? - current-proxy-servers))) +(module url-sig (lib "a-signature.ss") + get-pure-port + get-impure-port + post-pure-port + post-impure-port + display-pure-port + purify-port + netscape/string->url + string->url + url->string + call/input-url + combine-url/relative + url-exception? + current-proxy-servers) diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss index c354a0c..b04e20b 100644 --- a/collects/net/url-unit.ss +++ b/collects/net/url-unit.ss @@ -11,7 +11,7 @@ (module url-unit mzscheme (require (lib "file.ss") - (lib "unitsig.ss") + (lib "unit.ss") (lib "port.ss") (lib "string.ss") (lib "list.ss") @@ -26,9 +26,9 @@ (define url:os-type (system-type)) (define (set-url:os-type! new) (set! url:os-type new)) - (define url@ - (unit/sig net:url^ - (import net:tcp^) + (define-unit url@ + (import tcp^) + (export url^) (define-struct (url-exception exn:fail) ()) @@ -445,4 +445,4 @@ (apply string-append (reverse! r)) (loop (cdr strings) (list* (car strings) sep r))))])) - ))) + )) diff --git a/collects/tests/mzscheme/pconvert.ss b/collects/tests/mzscheme/pconvert.ss index 5e95c4a..b283fda 100644 --- a/collects/tests/mzscheme/pconvert.ss +++ b/collects/tests/mzscheme/pconvert.ss @@ -3,8 +3,7 @@ (Section 'pconvert) -(require (lib "unit.ss") - (lib "file.ss") +(require (lib "file.ss") (lib "class.ss") (lib "pconvert.ss")) @@ -12,7 +11,6 @@ (quasi-read-style-printing #f) (define (xl) 1) -(define (xu) (unit (import) (export))) (define (xc) (class object% () (sequence (super-init)))) (let () @@ -174,7 +172,6 @@ (make-pctest null 'empty 'empty 'empty '`() '`() '`() 'empty) (make-same-test add1 'add1) (make-same-test (void) '(void)) - (make-same-test (unit (import) (export)) '(unit ...)) (make-same-test (make-weak-box 12) '(make-weak-box 12)) (make-same-test (regexp "1") '(regexp "1")) (make-same-test (module-path-index-join #f #f) '(module-path-index-join false false)) @@ -190,12 +187,6 @@ (make-same-test (letrec ([xc-ID-BETTER-NOT-BE-DEFINED (class object% ())]) xc-ID-BETTER-NOT-BE-DEFINED) '(class ...)) - (make-same-test xu 'xu) - (make-same-test (letrec ([xu (unit (import) (export))]) xu) - '(unit ...)) - (make-same-test (letrec ([xu-ID-BETTER-NOT-BE-DEFINED (unit (import) (export))]) - xu-ID-BETTER-NOT-BE-DEFINED) - '(unit ...)) (make-same-test (lambda (x) x) '(lambda (a1) ...)) (make-same-test (lambda x x) '(lambda args ...)) (make-same-test (lambda (a b . c) a) '(lambda (a1 a2 . args) ...)) @@ -360,7 +351,6 @@ (test-shared (lambda (x) x) '(lambda (a1) ...)) (test-shared (delay 1) '(delay ...)) (test-shared (class object% ()) '(class ...)) - (test-shared (unit (import) (export)) '(unit ...)) (test-shared (new (class object% (super-new))) '(instantiate (class ...) ...)) (test-shared "abc" "abc") diff --git a/collects/tests/mzscheme/unit.ss b/collects/tests/mzscheme/unit.ss index 337e165..67b6c2a 100644 --- a/collects/tests/mzscheme/unit.ss +++ b/collects/tests/mzscheme/unit.ss @@ -2,7 +2,7 @@ (load-relative "loadtest.ss") (Section 'unit) -(require (lib "unit.ss")) +(require (lib "unit200.ss")) (syntax-test #'(unit)) (syntax-test #'(unit (import))) diff --git a/collects/tests/mzscheme/unitsig.ss b/collects/tests/mzscheme/unitsig.ss index 2de5947..c0e03b5 100644 --- a/collects/tests/mzscheme/unitsig.ss +++ b/collects/tests/mzscheme/unitsig.ss @@ -1,8 +1,8 @@ (load-relative "loadtest.ss") -(require (lib "unit.ss")) -(require (lib "unitsig.ss")) +(require (lib "unit200.ss")) +(require (lib "unitsig200.ss")) (require (lib "include.ss")) (Section 'unit/sig)