Add contracts to unit imports and values imported via
define-values/invoke-unit. We still need contracts on unit exports, and we might want to do the stuff here in a cleaner fashion (particularly for define-values/invoke-unit). svn: r12759
This commit is contained in:
Stevie Strickland
parent
61b66c0d9c
commit
a9be78545d
|
|
@ -57,10 +57,11 @@
|
|||
;; - (cons identifier identifier)
|
||||
;; A def is
|
||||
;; - (listof (cons (listof int/ext) syntax-object))
|
||||
;; A ctc-pair is
|
||||
;; - (cons int/ext syntax-object)
|
||||
;; A ctc is
|
||||
;; - syntax-object
|
||||
;; - #f
|
||||
;; A sig is
|
||||
;; - (list (listof int/ext) (listof def) (listof def) (listof ctc-pair))
|
||||
;; - (list (listof int/ext) (listof def) (listof def) (listof ctc))
|
||||
;; A tagged-sig is
|
||||
;; - (listof (cons #f siginfo) (cons #f identifier) sig)
|
||||
;; - (listof (cons symbol siginfo) (cons symbol identifier) sig)
|
||||
|
|
@ -97,9 +98,9 @@
|
|||
;; (listof identifier)
|
||||
;; (listof (cons (listof identifier) syntax-object))
|
||||
;; (listof (cons (listof identifier) syntax-object))
|
||||
;; (listof (cons identifier syntax-object))
|
||||
;; (listof syntax-object)
|
||||
;; identifier)
|
||||
(define-struct/proc signature (siginfo vars val-defs stx-defs ctc-pairs orig-binder)
|
||||
(define-struct/proc signature (siginfo vars val-defs stx-defs ctcs orig-binder)
|
||||
(lambda (_ stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
(raise-stx-err "illegal use of signature name"))))
|
||||
|
|
@ -222,7 +223,7 @@
|
|||
(vars (signature-vars sig))
|
||||
(vals (signature-val-defs sig))
|
||||
(stxs (signature-stx-defs sig))
|
||||
(cps (signature-ctc-pairs sig))
|
||||
(ctcs (signature-ctcs sig))
|
||||
(delta-introduce (if bind?
|
||||
(let ([f (syntax-local-make-delta-introducer
|
||||
spec)])
|
||||
|
|
@ -248,11 +249,7 @@
|
|||
(car stx))
|
||||
(cdr stx)))
|
||||
stxs)
|
||||
(map
|
||||
(λ (cp)
|
||||
(cons (cons (car cp) (car cp))
|
||||
(cdr cp)))
|
||||
cps)))))
|
||||
ctcs))))
|
||||
|
||||
(define (sig-names sig)
|
||||
(append (car sig)
|
||||
|
|
@ -273,10 +270,11 @@
|
|||
(car def))
|
||||
(g (cdr def))))
|
||||
|
||||
;; map-ctc-pair : (identifier -> identifier) (syntax-object -> syntax-object) ctc-pair -> ctc-pair
|
||||
(define (map-ctc-pair f g cp)
|
||||
(cons (cons (f (caar cp)) (g (cdar cp)))
|
||||
(g (cdr cp))))
|
||||
;; map-ctc : (identifier -> identifier) (syntax-object -> syntax-object) ctc -> ctc
|
||||
(define (map-ctc f g ctc)
|
||||
(if ctc
|
||||
(g ctc)
|
||||
ctc))
|
||||
|
||||
;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object) sig -> sig
|
||||
;; applies f to the internal parts, and g to the external parts.
|
||||
|
|
@ -284,7 +282,7 @@
|
|||
(list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig))
|
||||
(map (lambda (x) (map-def f g x)) (cadr sig))
|
||||
(map (lambda (x) (map-def f g x)) (caddr sig))
|
||||
(map (lambda (x) (map-ctc-pair f g x)) (cadddr sig))))
|
||||
(map (lambda (x) (map-ctc f g x)) (cadddr sig))))
|
||||
|
||||
;; An import-spec is one of
|
||||
;; - signature-name
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@
|
|||
"private/unit-compiletime.ss"
|
||||
"private/unit-syntax.ss")
|
||||
|
||||
(require mzlib/etc
|
||||
(require mzlib/contract
|
||||
mzlib/etc
|
||||
"private/unit-keywords.ss"
|
||||
"private/unit-runtime.ss")
|
||||
|
||||
|
|
@ -124,7 +125,7 @@
|
|||
(with-syntax ([(((int-ivar . ext-ivar) ...)
|
||||
((((int-vid . ext-vid) ...) . vbody) ...)
|
||||
((((int-sid . ext-sid) ...) . sbody) ...)
|
||||
(((int-cid . ext-cid) . cbody) ...))
|
||||
(cbody ...))
|
||||
(map-sig (lambda (x) x)
|
||||
(make-syntax-introducer)
|
||||
sig)])
|
||||
|
|
@ -165,17 +166,13 @@
|
|||
(cons (map syntax-local-introduce (car d))
|
||||
(syntax-local-introduce (cdr d))))
|
||||
|
||||
(define-for-syntax (introduce-ctc-pair cp)
|
||||
(cons (syntax-local-introduce (car cp))
|
||||
(syntax-local-introduce (cdr cp))))
|
||||
|
||||
;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object
|
||||
(define-for-syntax (build-define-signature sigid super-sigid sig-exprs)
|
||||
(unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs))
|
||||
(raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs))
|
||||
(let ([ses (checked-syntax->list sig-exprs)])
|
||||
(define-values (super-names super-ctimes super-rtimes super-bindings
|
||||
super-val-defs super-stx-defs super-ctc-pairs)
|
||||
super-val-defs super-stx-defs super-ctcs)
|
||||
(if super-sigid
|
||||
(let* ([super-sig (lookup-signature super-sigid)]
|
||||
[super-siginfo (signature-siginfo super-sig)])
|
||||
|
|
@ -186,19 +183,23 @@
|
|||
(map syntax-local-introduce (signature-vars super-sig))
|
||||
(map introduce-def (signature-val-defs super-sig))
|
||||
(map introduce-def (signature-stx-defs super-sig))
|
||||
(map introduce-ctc-pair (signature-ctc-pairs super-sig))))
|
||||
(map (lambda (ctc)
|
||||
(if ctc
|
||||
(syntax-local-introduce ctc)
|
||||
ctc))
|
||||
(signature-ctcs super-sig))))
|
||||
(values '() '() '() '() '() '() '())))
|
||||
(let loop ((sig-exprs ses)
|
||||
(bindings null)
|
||||
(val-defs null)
|
||||
(stx-defs null)
|
||||
(ctc-pairs null))
|
||||
(ctcs null))
|
||||
(cond
|
||||
((null? sig-exprs)
|
||||
(let* ([all-bindings (append super-bindings (reverse bindings))]
|
||||
[all-val-defs (append super-val-defs (reverse val-defs))]
|
||||
[all-stx-defs (append super-stx-defs (reverse stx-defs))]
|
||||
[all-ctc-pairs (append super-ctc-pairs (reverse ctc-pairs))]
|
||||
[all-ctcs (append super-ctcs (reverse ctcs))]
|
||||
[dup
|
||||
(check-duplicate-identifier
|
||||
(append all-bindings
|
||||
|
|
@ -210,8 +211,7 @@
|
|||
((super-name ...) super-names)
|
||||
((var ...) all-bindings)
|
||||
((((vid ...) . vbody) ...) all-val-defs)
|
||||
((((sid ...) . sbody) ...) all-stx-defs)
|
||||
(((cid . cbody) ...) all-ctc-pairs))
|
||||
((((sid ...) . sbody) ...) all-stx-defs))
|
||||
#`(begin
|
||||
(define signature-tag (gensym))
|
||||
(define-syntax #,sigid
|
||||
|
|
@ -230,16 +230,18 @@
|
|||
((syntax-local-certifier)
|
||||
(quote-syntax sbody)))
|
||||
...)
|
||||
(list (cons (quote-syntax cid)
|
||||
((syntax-local-certifier)
|
||||
(quote-syntax cbody)))
|
||||
...)
|
||||
(list #,@(map (lambda (c)
|
||||
(if c
|
||||
#`((syntax-local-certifier)
|
||||
(quote-syntax #,c))
|
||||
#'#f))
|
||||
all-ctcs))
|
||||
(quote-syntax #,sigid))))))))
|
||||
(else
|
||||
(syntax-case (car sig-exprs) (define-values define-syntaxes contracted)
|
||||
(x
|
||||
(identifier? #'x)
|
||||
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs ctc-pairs))
|
||||
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs)))
|
||||
((x y z)
|
||||
(and (identifier? #'x)
|
||||
(module-identifier=? #'x #'contracted)
|
||||
|
|
@ -248,7 +250,7 @@
|
|||
(cons #'y bindings)
|
||||
val-defs
|
||||
stx-defs
|
||||
(cons (cons #'y #'z) ctc-pairs)))
|
||||
(cons #'z ctcs)))
|
||||
((x . y)
|
||||
(and (identifier? #'x)
|
||||
(or (module-identifier=? #'x #'define-values)
|
||||
|
|
@ -271,7 +273,7 @@
|
|||
(cons (cons (syntax->list #'(name ...)) b)
|
||||
stx-defs)
|
||||
stx-defs)
|
||||
ctc-pairs)))))))
|
||||
ctcs)))))))
|
||||
((x . y)
|
||||
(let ((trans
|
||||
(set!-trans-extract
|
||||
|
|
@ -290,7 +292,7 @@
|
|||
bindings
|
||||
val-defs
|
||||
stx-defs
|
||||
ctc-pairs))))
|
||||
ctcs))))
|
||||
(x (raise-stx-err
|
||||
"expected either an identifier or signature form"
|
||||
#'x))))))))
|
||||
|
|
@ -449,6 +451,13 @@
|
|||
(define-for-syntax process-unit-export
|
||||
(process-unit-import/export process-tagged-export))
|
||||
|
||||
(define-for-syntax (make-import-unboxing loc ctc name)
|
||||
(if ctc
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name)))
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(quote-syntax (unbox #,loc)))))
|
||||
|
||||
;; build-unit : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
;; constructs the code for a unit expression. stx must be
|
||||
|
|
@ -525,11 +534,17 @@
|
|||
(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))
|
||||
...)]
|
||||
...
|
||||
(letrec-syntaxes (#,@(map (lambda (ivs ils ics)
|
||||
(quasisyntax/loc (error-syntax)
|
||||
[#,ivs
|
||||
(make-id-mappers
|
||||
#,@(map (lambda (l c)
|
||||
(make-import-unboxing l c #'name))
|
||||
(syntax->list ils)
|
||||
ics))]))
|
||||
(syntax->list #'((int-ivar ...) ...))
|
||||
(syntax->list #'((iloc ...) ...))
|
||||
(map cadddr import-sigs))
|
||||
[(int-evar ...)
|
||||
(make-id-mappers
|
||||
(quote-syntax (unbox eloc))
|
||||
|
|
@ -1205,9 +1220,12 @@
|
|||
(map
|
||||
(lambda (os ov)
|
||||
(map
|
||||
(lambda (i)
|
||||
#`(vector-ref #,ov #,i))
|
||||
(iota (length (car os)))))
|
||||
(lambda (i c)
|
||||
(if c
|
||||
#`(contract #,c (unbox (vector-ref #,ov #,i)) 'cant-happen (#%variable-reference))
|
||||
#`(unbox (vector-ref #,ov #,i))))
|
||||
(iota (length (car os)))
|
||||
(cadddr os)))
|
||||
out-sigs
|
||||
out-vec)))
|
||||
(quasisyntax/loc stx
|
||||
|
|
@ -1225,7 +1243,7 @@
|
|||
((unit-go unit-tmp))))
|
||||
(let ([out-vec (hash-table-get export-table key1)] ...)
|
||||
(unit-fn #f)
|
||||
(values (unbox out-code) ... ...))))))
|
||||
(values out-code ... ...))))))
|
||||
(define-syntaxes . renames) ...
|
||||
(define-syntaxes (mac-name ...) mac-body) ... ...
|
||||
(define-values (val-name ...) val-body) ... ...)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user