suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 8c3db99e55c865987e1a18376973271980d65989
This commit is contained in:
Matthew Flatt 2001-02-02 22:37:32 +00:00
parent c1cd82d152
commit 4a9153d2f6
4 changed files with 167 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/private/sigmatch.ss
View File

@ -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))

2
collects/mzlib/private/sigutil.ss
View File

@ -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))

80
collects/mzlib/unit.ss
View File

@ -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))

87
collects/mzlib/unitsig.ss
View File

@ -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))