From a9be78545d95d72e5076d14369afae8b5774dbad Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 9 Dec 2008 22:14:11 +0000 Subject: [PATCH] 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 --- collects/mzlib/private/unit-compiletime.ss | 30 ++++----- collects/mzlib/unit.ss | 76 +++++++++++++--------- 2 files changed, 61 insertions(+), 45 deletions(-) diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index 079764d012..db2b8ea90b 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -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 diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 48ba22921b..17370eac95 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -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) ... ...)))))