From 4a9153d2f67d986a485492576a014520fc16871b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Feb 2001 22:37:32 +0000 Subject: [PATCH] . original commit: 8c3db99e55c865987e1a18376973271980d65989 --- collects/mzlib/private/sigmatch.ss | 2 +- collects/mzlib/private/sigutil.ss | 2 + collects/mzlib/unit.ss | 80 ++++++++++++++++++++++++++- collects/mzlib/unitsig.ss | 87 +++++++++++++++++++++++++++++- 4 files changed, 167 insertions(+), 4 deletions(-) diff --git a/collects/mzlib/private/sigmatch.ss b/collects/mzlib/private/sigmatch.ss index a55b42b..946877c 100644 --- a/collects/mzlib/private/sigmatch.ss +++ b/collects/mzlib/private/sigmatch.ss @@ -130,4 +130,4 @@ exact? who src-context dest-context) (raise-type-error 'verify-signature-match "signature" dest-sig)))) - (export verify-signature-match exn:unit?)) + (export verify-signature-match)) diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index 45382a4..d11805a 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -4,6 +4,7 @@ (import "sigmatch.ss") (import "../exstruct.ss") + (import "../unit.ss") (define-struct signature (name ; sym src ; sym @@ -966,4 +967,5 @@ explode-sig explode-named-sigs check-signature-unit-body + flatten-signature flatten-signatures)) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 03c93d3..271c393 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -622,7 +622,85 @@ ((list-ref ((unit-go u)) 1) bx ...))))))]))) + (define-syntax do-define-values/invoke-unit + (lambda (stx) + (syntax-case stx () + [(_ global? exports unite prefix imports orig) + (let* ([badsyntax (lambda (s why) + (raise-syntax-error + (if (syntax-e (syntax global?)) + 'global-define-values/invoke-unit + 'define-values/invoke-unit) + (format "bad syntax (~a)" why) + (syntax orig) + 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))) + (unless (or (not (syntax-e (syntax prefix))) + (identifier? (syntax prefix))) + (badsyntax (syntax prefix) "prefix is not an identifier")) + (for-each symcheck (syntax->list (syntax imports))) + + (with-syntax ([(tagged-export ...) + (if (syntax-e (syntax prefix)) + (let ([prefix (string-append + (symbol->string + (syntax-e (syntax prefix))) + ":")]) + (map (lambda (s) + (datum->syntax + (string->symbol + (string-append + prefix + (symbol->string s))) + s s)) + (syntax->list (syntax exports)))) + (syntax exports))] + [extract-unit (syntax (unit + (import . exports) + (export) + (values . exports)))]) + (with-syntax ([invoke-unit (syntax (invoke-unit + (compound-unit + (import . imports) + (link [unit-to-invoke (unite . imports)] + [export-extractor + (extract-unit (unit-to-invoke . exports))]) + (export)) + . imports))]) + (if (syntax-e (syntax global?)) + (syntax (let-values ([(tagged-export ...) invoke-unit]) + (global-defined-value 'tagged-export tagged-export) + ... + (void))) + (syntax (define-values (tagged-export ...) invoke-unit))))))]))) + + (define-syntax define-values/invoke-unit + (lambda (stx) + (with-syntax ([orig stx]) + (syntax-case stx () + [(_ exports unit name . imports) + (syntax (do-define-values/invoke-unit #f exports unit name imports orig))] + [(_ exports unit) + (syntax (do-define-values/invoke-unit #f exports unit #f () orig))])))) + + (define-syntax global-define-values/invoke-unit + (lambda (stx) + (with-syntax ([orig stx]) + (syntax-case stx () + [(_ exports unit name . imports) + (syntax (do-define-values/invoke-unit #t exports unit name imports orig))] + [(_ exports unit) + (syntax (do-define-values/invoke-unit #t exports unit #f () orig))])))) + (export-indirect make-unit check-unit undefined unit-go check-expected-interface) (export unit compound-unit invoke-unit unit? - exn:unit? struct:exn:unit make-exn:unit)) + exn:unit? struct:exn:unit make-exn:unit + + define-values/invoke-unit + global-define-values/invoke-unit)) diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss index eb2c550..a7d8e9d 100644 --- a/collects/mzlib/unitsig.ss +++ b/collects/mzlib/unitsig.ss @@ -207,7 +207,7 @@ (loop (cdr isig) (cdr expecteds) (add1 pos)))))) units tags isigs)))) - (define signature->symbols + (define-syntax signature->symbols (lambda (stx) (syntax-case stx () [(_ name) @@ -216,6 +216,85 @@ (with-syntax ([e (explode-sig sig)]) (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?)) + 'global-define-values/invoke-unit/sig + 'define-values/invoke-unit/sig)] + [badsyntax (lambda (s why) + (raise-syntax-error + formname + (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))]) + (let ([ex-exploded (explode-sig ex-sig)] + [ex-flattened (flatten-signature #f ex-sig)]) + (let ([im-sigs + (map + (lambda (s) + (get-sig formname (syntax orig) #f s)) + (syntax->list (syntax imports)))]) + (let ([im-explodeds (explode-named-sigs im-sigs)] + [im-flattened (flatten-signatures im-sigs)]) + (with-syntax ([dv/iu (if (syntax-e (syntax global?)) + (quote-syntax global-define-values/invoke-unit) + (quote-syntax define-values/invoke-unit))] + [ex-flattened ex-flattened] + [ex-exploded ex-exploded] + [im-explodeds im-explodeds] + [im-flattened im-flattened] + [formname formname]) + (syntax + (dv/iu + ex-flattened + (let ([unit-var unite]) + (verify-linkage-signature-match + 'formname + '(invoke) + (list unit-var) + '(ex-exploded) + '(im-explodeds)) + (unit/sig-unit unit-var)) + prefix + . im-flattened))))))))]))) + + (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 global-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 #t signame unit prefix imports orig))] + [(_ signame unit) + (syntax (do-define-values/invoke-unit/sig #t signame unit #f () orig))])))) + + (define-syntax export-signature-elements + (lambda (stx) + (with-syntax ([orig stx]) + (syntax-case stx () + [(_ signame) + (let ([sig (get-sig 'export-signature-elements stx #f (syntax signame))]) + (let ([flattened (flatten-signature #f sig)]) + (with-syntax ([flattened (map (lambda (x) (datum->syntax x #f (syntax signame))) + flattened)]) + (syntax + (export . flattened)))))])))) + (export-indirect verify-linkage-signature-match) (export define-signature @@ -224,5 +303,9 @@ compound-unit/sig invoke-unit/sig unit->unit/sig - signature->symbols)) + signature->symbols + + define-values/invoke-unit/sig + global-define-values/invoke-unit/sig + export-signature-elements))