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

Sam and I did some work to allow automatic inferred linking in

Browse Source 
(define-values/)invoke-unit/infer.

svn: r14315
This commit is contained in:
Stevie Strickland 2009-03-27 13:47:12 +00:00
parent 747fd82a07
commit 99aac7d745
11 changed files with 229 additions and 174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/framework/main.ss
View File

@ -49,13 +49,10 @@
(prefix scheme: framework:scheme-class^)
(prefix main: framework:main-class^))
(define-compound-unit/infer framework+mred@
(import)
(define-values/invoke-unit/infer
(export framework^)
(link standard-mred@ framework@))
(define-values/invoke-unit/infer framework+mred@)
(provide/doc
(parameter-doc
text:autocomplete-append-after

7
collects/graphics/graphics.ss
View File

@ -6,9 +6,6 @@
"graphics-unit.ss")
(provide-signature-elements graphics^ graphics:posn^)
(define-compound-unit/infer graphics+mred@
(import)
(define-values/invoke-unit/infer
(export graphics^ graphics:posn^)
(link standard-mred@ graphics@))
(define-values/invoke-unit/infer graphics+mred@))
(link standard-mred@ graphics@)))

8
collects/graphics/turtles.ss
View File

@ -1,15 +1,9 @@
(module turtles mzscheme
(require mzlib/unit
mred/mred-sig
mred/mred-unit
"turtle-sig.ss"
"turtle-unit.ss")
(provide-signature-elements turtle^)
(define-compound-unit/infer turtle+mred@
(import)
(export turtle^)
(link standard-mred@ turtle@))
(define-values/invoke-unit/infer turtle+mred@))
(define-values/invoke-unit/infer (export turtle^) (link turtle@ standard-mred@)))

7
collects/htdp/big-draw.ss
View File

@ -12,10 +12,9 @@
graphics/graphics-sig
graphics/graphics-posn-less-unit)
(define-unit-from-context p@ graphics:posn^)
(define-compound-unit/infer g@ (import) (export graphics^)
(link standard-mred@ p@ graphics-posn-less@))
(define-values/invoke-unit/infer g@)
(define-values/invoke-unit/infer
(export graphics^)
(link graphics-posn-less@ standard-mred@))
(provide-signature-elements graphics^)

152
collects/mzlib/unit.ss
View File

@ -1496,23 +1496,126 @@
#`(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))
(unprocess (let ([i (make-syntax-delta-introducer #'u (unit-info-orig-binder ui))])
;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax
(define-for-syntax (build-invoke-unit/infer units define? exports)
(define (imps/exps-from-unit u)
(let* ([ui (lookup-def-unit u)]
[unprocess (let ([i (make-syntax-delta-introducer u (unit-info-orig-binder ui))])
(lambda (p)
(unprocess-tagged-id (cons (car p) (i (cdr p))))))))
(with-syntax (((sig ...) (map unprocess (unit-info-export-sig-ids ui)))
((isig ...) (map unprocess (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)
(unprocess-tagged-id (cons (car p) (i (cdr p))))))]
[isigs (map unprocess (unit-info-import-sig-ids ui))]
[esigs (map unprocess (unit-info-export-sig-ids ui))])
(values isigs esigs)))
(define (drop-from-other-list exp-tagged imp-tagged imp-sources)
(let loop ([ts imp-tagged] [ss imp-sources])
(cond
[(null? ts) null]
[(ormap (lambda (tinfo2)
(and (eq? (car (car ts)) (car tinfo2))
(siginfo-subtype (cdr tinfo2) (cdr (car ts)))))
exp-tagged)
(loop (cdr ts) (cdr ss))]
[else (cons (car ss) (loop (cdr ts) (cdr ss)))])))
(define (drop-duplicates tagged-siginfos sources)
(let loop ([ts tagged-siginfos] [ss sources] [res-t null] [res-s null])
(cond
[(null? ts) (values res-t res-s)]
[(ormap (lambda (tinfo2)
(and (eq? (car (car ts)) (car tinfo2))
(siginfo-subtype (cdr tinfo2) (cdr (car ts)))))
(cdr ts))
(loop (cdr ts) (cdr ss) res-t res-s)]
[else (loop (cdr ts) (cdr ss) (cons (car ts) res-t) (cons (car ss) res-s))])))
(define (imps/exps-from-units units exports)
(define-values (isigs esigs)
(let loop ([units units] [imps null] [exps null])
(if (null? units)
(values imps exps)
(let-values ([(i e) (imps/exps-from-unit (car units))])
(loop (cdr units) (append i imps) (append e exps))))))
(define-values (isig tagged-import-sigs import-tagged-infos
import-tagged-sigids import-sigs)
(process-unit-import (datum->syntax-object #f isigs)))
(define-values (esig tagged-export-sigs export-tagged-infos
export-tagged-sigids export-sigs)
(process-unit-export (datum->syntax-object #f esigs)))
(check-duplicate-subs export-tagged-infos esig)
(let-values ([(itagged isources) (drop-duplicates import-tagged-infos isig)])
(values (drop-from-other-list export-tagged-infos itagged isources)
(cond
[(list? exports)
(let-values ([(spec-esig spec-tagged-export-sigs spec-export-tagged-infos
spec-export-tagged-sigids spec-export-sigs)
(process-unit-export (datum->syntax-object #f exports))])
(restrict-exports export-tagged-infos
spec-esig spec-export-tagged-infos))]
[else esig]))))
(define (restrict-exports unit-tagged-exports spec-exports spec-tagged-exports)
(for-each (lambda (se ste)
(unless (ormap (lambda (ute)
(and (eq? (car ute) (car ste))
(siginfo-subtype (cdr ute) (cdr ste))))
unit-tagged-exports)
(raise-stx-err (format "no subunit exports signature ~a"
(syntax-object->datum se))
se)))
spec-exports
spec-tagged-exports)
spec-exports)
(when (and (not define?) exports)
(error 'build-invoke-unit/infer
"internal error: exports for invoke-unit/infer"))
(when (null? units)
(raise-stx-err "no units in link clause"))
(cond [(identifier? units)
(let-values ([(isig esig) (imps/exps-from-units (list units) exports)])
(with-syntax ([u units]
[(esig ...) esig]
[(isig ...) isig])
(if define?
(syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...)))
(syntax/loc (error-syntax) (invoke-unit u (import isig ...))))))]
[(list? units)
(let-values ([(isig esig) (imps/exps-from-units units exports)])
(with-syntax ([(new-unit) (generate-temporaries '(new-unit))]
[(unit ...) units]
[(esig ...) esig]
[(isig ...) isig])
(with-syntax ([cunit (syntax/loc (error-syntax)
(define-compound-unit/infer new-unit
(import isig ...) (export esig ...) (link unit ...)))])
(if define?
(syntax/loc (error-syntax)
(begin cunit
(define-values/invoke-unit new-unit (import isig ...) (export esig ...))))
(syntax/loc (error-syntax)
(let ()
cunit
(invoke-unit new-unit (import isig ...))))))))]
;; just for error handling
[else (lookup-def-unit units)]))
(define-syntax/err-param (define-values/invoke-unit/infer stx)
(syntax-case stx (export link)
[(_ (link unit ...))
(build-invoke-unit/infer (syntax->list #'(unit ...)) #t #f)]
[(_ (export e ...) (link unit ...))
(build-invoke-unit/infer (syntax->list #'(unit ...)) #t (syntax->list #'(e ...)))]
[(_ (export e ...) u)
(build-invoke-unit/infer #'u #t (syntax->list #'(e ...)))]
[(_ u)
(build-invoke-unit/infer #'u #t #f)]
[(_)
(raise-stx-err "missing unit" stx)]
[(_ . b)
(raise-stx-err
(format "expected syntax matching (~a <define-unit-identifier>)"
(syntax-e (stx-car stx)))))))
(format "expected syntax matching (~a [(export <define-signature-identifier>)] <define-unit-identifier>) or (~a [(export <define-signature-identifier>)] (link <define-unit-identifier> ...))"
(syntax-e (stx-car stx)) (syntax-e (stx-car stx))))]))
(define-for-syntax (temp-id-with-tags id i)
(syntax-case i (tag)
@ -1770,18 +1873,15 @@
(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)
[(_ (link unit ...))
(build-invoke-unit/infer (syntax->list #'(unit ...)) #f #f)]
[(_ u) (build-invoke-unit/infer #'u #f #f)]
[(_)
(raise-stx-err "missing unit" stx)]
[(_ . b)
(raise-stx-err
(format "expected syntax matching (~a <define-unit-identifier>)"
(syntax-e (stx-car stx)))))))
(format "expected syntax matching (~a <define-unit-identifier>) or (~a (link <define-unit-identifier> ...))"
(syntax-e (stx-car stx)) (syntax-e (stx-car stx))))]))
(define-for-syntax (build-unit/s stx)
(syntax-case stx (import export init-depend)

16
collects/net/mime.ss
View File

@ -30,21 +30,17 @@
(require scheme/unit
"mime-sig.ss"
"mime-unit.ss"
"qp-sig.ss"
"qp.ss"
"base64-sig.ss"
"base64.ss"
"head-sig.ss"
"head.ss")
(define-unit-from-context base64@ base64^)
(define-unit-from-context qp@ qp^)
(define-unit-from-context head@ head^)
;(define-unit-from-context base64@ base64^)
;(define-unit-from-context qp@ qp^)
;(define-unit-from-context head@ head^)
(define-compound-unit/infer mime@2 (import) (export mime^)
(link base64@ qp@ head@ mime@))
(define-values/invoke-unit/infer mime@2)
(define-values/invoke-unit/infer
(export mime^)
(link mime@))
(provide-signature-elements mime^)

19
collects/scribblings/reference/units.scrbl
View File

@ -484,18 +484,29 @@ with the declared imports and exports, otherwise the
@exnraise[exn:fail:contract] when the @scheme[define-unit-binding]
form is evaluated.}
@defform[(invoke-unit/infer unit-id)]{
@defform/subs[
#:literals (link)
(invoke-unit/infer unit-spec)
[(unit-spec unit-id (link link-unit-id ...))]]{
Like @scheme[invoke-unit], but uses static information associated with
@scheme[unit-id] to infer which imports must be assembled from the
current context.}
current context. If given a link form containing multiple
@scheme[link-unit-id]s, then the units are first linked via
@scheme[define-compound-unit/infer].}
@defform[(define-values/invoke-unit/infer unit-id)]{
@defform/subs[
#:literals (link)
(define-values/invoke-unit/infer maybe-exports unit-spec)
[(maybe-exports code:blank (export tagged-sig-spec ...))
(unit-spec unit-id (link link-unit-id ...))]]{
Like @scheme[define-values/invoke-unit], but uses static information
associated with @scheme[unit-id] to infer which imports must be
assembled from the current context and what exports should be bound
by the definition.}
by the definition. If given a link form containing multiple
@scheme[link-unit-id]s, then the units are first linked via
@scheme[define-compound-unit/infer].}
@; ------------------------------------------------------------------------

65
collects/tests/units/test-unit.ss
View File

@ -1304,6 +1304,30 @@
(test-syntax-error "define-compound-unit: bad name"
(define-compound-unit 1 (import) (link) (export)))
(test-syntax-error "invoke-unit/infer : no unit"
(invoke-unit/infer))
(test-syntax-error "invoke-unit/infer : not a unit"
(invoke-unit/infer 1))
(test-syntax-error "invoke-unit/infer : not a unit"
(let ([x 1]) (invoke-unit/infer x)))
(test-syntax-error "invoke-unit/infer : not a unit"
(let-syntax ([x 1]) (invoke-unit/infer x)))
(test-syntax-error "invoke-unit/infer: too much"
(invoke-unit/infer x y))
(define-unit u (import x-sig) (export))
(define-unit v (import) (export x-sig) (define x 3))
(test-syntax-error "invoke-unit/infer : no unit"
(invoke-unit/infer (link)))
(test-syntax-error "invoke-unit/infer : not a unit"
(invoke-unit/infer (link 1 u)))
(test-syntax-error "invoke-unit/infer : not a unit"
(let ([x 1]) (invoke-unit/infer (link u x))))
(test-syntax-error "invoke-unit/infer : not a unit"
(let-syntax ([x 1]) (invoke-unit/infer (link x u))))
(invoke-unit/infer (link u v))
(test-syntax-error "define-values/invoke-unit/infer: no unit"
(define-values/invoke-unit/infer))
(test-syntax-error "define-values/invoke-unit/infer: not a unit"
@ -1317,7 +1341,46 @@
(test-syntax-error "define-values/invoke-unit/infer: too much"
(define-values/invoke-unit/infer x y))
(define-unit u (import x-sig) (export))
(define-unit u (import x-sig) (export) x)
(define-unit v (import) (export x-sig) (define x 3))
(test-syntax-error "define-values/invoke-unit/infer: no unit"
(define-values/invoke-unit/infer (link)))
(test-syntax-error "define-values/invoke-unit/infer: not a unit"
(define-values/invoke-unit/infer (link 1 u)))
(test-syntax-error "define-values/invoke-unit/infer: not a unit"
(let ([x 1])
(define-values/invoke-unit/infer (link u x))))
(test-syntax-error "define-values/invoke-unit/infer: not a unit"
(let-syntax ([x 1])
(define-values/invoke-unit/infer (link u x))))
(let ()
(define-values/invoke-unit/infer (link u v))
x)
(let ()
(define-values/invoke-unit/infer (export x-sig) (link u v))
x)
(let ()
(define-values/invoke-unit/infer (export x-sig) v)
x)
(test-syntax-error "define-values/invoke-unit/infer: doesn't export y"
(define-values/invoke-unit/infer (export y-sig) (link u v)))
(test-runtime-error exn? "unbound variable: x"
(let ()
(define-values/invoke-unit/infer (export) (link u v))
x))
(test-syntax-error "define-values/invoke-unit/infer: doesn't export y"
(define-values/invoke-unit/infer (export y-sig) v))
(test-runtime-error exn? "unbound variable: x"
(let ()
(define-values/invoke-unit/infer (export) v)
x))
(define-unit u (import x-sig) (export) x)
(test-syntax-error "define-values/invoke-unit/infer: bad imports"
(define-values/invoke-unit/infer u))
(define-unit u (import x-sig y-sig) (export))

7
collects/typed-scheme/infer/infer.ss
View File

@ -3,10 +3,11 @@
(require (except-in "../utils/utils.ss" infer))
(require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss"
"restrict.ss" "promote-demote.ss"
(only-in scheme/unit provide-signature-elements)
(only-in scheme/unit provide-signature-elements
define-values/invoke-unit/infer link)
(utils unit-utils))
(provide-signature-elements restrict^ infer^)
(define-values/link-units/infer
infer@ constraints@ dmap@ restrict@ promote-demote@)
(define-values/invoke-unit/infer
(link infer@ constraints@ dmap@ restrict@ promote-demote@))

8
collects/typed-scheme/typecheck/typechecker.ss
View File

@ -3,7 +3,9 @@
(require "../utils/utils.ss")
(require (utils unit-utils)
mzlib/trace
(only-in scheme/unit provide-signature-elements)
(only-in scheme/unit
provide-signature-elements
define-values/invoke-unit/infer link)
"signatures.ss" "tc-toplevel.ss"
"tc-if-unit.ss" "tc-lambda-unit.ss" "tc-app-unit.ss"
"tc-let-unit.ss" "tc-dots-unit.ss"
@ -11,5 +13,5 @@
(provide-signature-elements typechecker^ tc-expr^)
(define-values/link-units/infer
tc-toplevel@ tc-if@ tc-lambda@ tc-dots@ tc-app@ tc-let@ tc-expr@ check-subforms@)
(define-values/invoke-unit/infer
(link tc-toplevel@ tc-if@ tc-lambda@ tc-dots@ tc-app@ tc-let@ tc-expr@ check-subforms@))

109
collects/typed-scheme/utils/unit-utils.ss
View File

@ -1,13 +1,8 @@
#lang scheme/base
(require scheme/unit
(for-syntax
scheme/base
(only-in srfi/1/list s:member delete-duplicates)
scheme/unit-exptime
scheme/match))
(require scheme/unit (for-syntax scheme/base))
(provide define-values/link-units/infer cnt)
(provide cnt)
(define-signature-form (cnt stx)
(syntax-case stx ()
@ -15,105 +10,5 @@
(list #'nm)
#;(list #'[contracted (nm cnt)])]))
(define-syntax (define-values/link-units/infer stx)
;; construct something we can put in the imports/exports clause from the datum
(define (datum->sig-elem d)
(if (car d)
(quasisyntax/loc (cdr d) (tag . #,(cdr d)))
(cdr d)))
;; identifier -> (list (listof imports) (listof exports))
(define (get-sigs id)
(define-values (imps exps) (unit-static-signatures id id))
(list imps exps))
;; flatten one level of a list
;; listof[listof[a]] -> listof[a]
(define (flatten l) (apply append l))
;; returns two lists of sig-elems
(define (get-all-sigs ids)
(define imps/exps (map get-sigs ids))
(define-values (imps exps) (values (map car imps/exps) (map cadr imps/exps)))
(values (flatten imps) (flatten exps)))
;; construct the runtime code
;; takes 3 lists of identifiers and a syntax object for location info
(define (mk imports exports units stx)
(quasisyntax/loc stx
(begin (define-compound-unit/infer new-unit@
(import #,@imports)
(export #,@exports)
(link #,@units))
(define-values/invoke-unit/infer new-unit@))))
;; compares two signature datums for equality
(define (sig=? sig1 sig2)
(and (eq? (car sig1) (car sig2))
(or (symbol? (car sig1)) (not (car sig1)))
(bound-identifier=? (cdr sig1) (cdr sig2))))
;; is imp in the list of exports?
(define (sig-in-sigs? imp exps)
(for/or ([e exps]) (sig=? imp e)))
;; produce the imports not satisfied by the exports, and all the exports
;; exports should not have duplicates
(define (imps/exps-from-units units)
(let-values ([(imps exps) (get-all-sigs units)])
(let* ([exps* (map datum->sig-elem exps)]
[imps* (map datum->sig-elem (filter (lambda (imp) (not (sig-in-sigs? imp exps))) imps))])
(values imps* exps*))))
(define (duplicates? sigs)
(for/or ([s sigs]
#:when
(> 1 (length (for/list ([s* sigs] #:when (free-identifier=? s s*)) s*))))
s))
(syntax-case stx (import export)
;; here the exports are specified - they ought to be a subset of the allowable exports
[(_ (export . sigs) . units)
(let*-values ([(units) (syntax->list #'units)]
[(imps exps) (imps/exps-from-units units)])
(mk imps (syntax->list #'sigs) units stx))]
;; here we just export everything that's available
[(_ . units)
(andmap identifier? (syntax->list #'units))
(let*-values ([(units) (syntax->list #'units)]
[(imps exps) (imps/exps-from-units units)])
(cond [(duplicates? exps)
=>
(lambda (d)
(raise-syntax-error #f (format "multiple units export the signature ~a" d) stx))]
[else
(mk (delete-duplicates imps) exps units stx)]))]))
;; Tests
#|
(define-signature x^ (x))
(define-signature y^ (y))
(define-signature z^ (z))
(define-unit y@
(import z^)
(export y^)
(define y (* 2 z)))
(define-unit x@
(import y^)
(export x^)
(define (x) (+ y 1)))
(define z 45)
(define-values/link-units/infer (export x^) x@ y@)
(define-signature y^ (y))
(define-unit x@ (import y^) (export))
(define-unit z@ (import y^) (export))
(define-values/link-units/infer x@ z@)
;(define-values/link-units/infer x@ y@)
|#