Only apply a single contract wrapping to a value contracted through unit

exporting/importing.  Also add some more unit contract tests.

svn: r13203

original commit: e1d5ced45ea68ee376cd16728fa3a5dfc73eb8c2
This commit is contained in:
Stevie Strickland 2009-01-18 10:38:52 +00:00
commit caad0a01f3
4 changed files with 251 additions and 125 deletions

View File

@ -15,6 +15,13 @@
(require "private/contract-object.ss") (require "private/contract-object.ss")
(provide (all-from-out "private/contract-object.ss")) (provide (all-from-out "private/contract-object.ss"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; old-style define/contract
;;
(require "private/contract-define.ss")
(provide (all-from-out "private/contract-define.ss"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -22,7 +29,9 @@
;; except the arrow contracts ;; except the arrow contracts
;; ;;
(require scheme/private/contract (require (except-in scheme/private/contract
define/contract
with-contract)
scheme/private/contract-guts scheme/private/contract-guts
scheme/private/contract-ds scheme/private/contract-ds
scheme/private/contract-opt scheme/private/contract-opt

View File

@ -0,0 +1,70 @@
#lang scheme/base
(provide define/contract)
(require (for-syntax scheme/base)
(only-in scheme/contract contract)
(for-syntax (prefix-in a: scheme/private/contract-helpers)))
;; First, we have the old define/contract implementation, which
;; is still used in mzlib/contract.
(define-for-syntax (make-define/contract-transformer contract-id id)
(make-set!-transformer
(λ (stx)
(with-syntax ([neg-blame-str (a:build-src-loc-string stx)]
[contract-id contract-id]
[id id])
(syntax-case stx (set!)
[(set! id arg)
(raise-syntax-error 'define/contract
"cannot set! a define/contract variable"
stx
(syntax id))]
[(f arg ...)
(syntax/loc stx
((contract contract-id
id
(syntax->datum (quote-syntax f))
neg-blame-str
(quote-syntax f))
arg
...))]
[ident
(identifier? (syntax ident))
(syntax/loc stx
(contract contract-id
id
(syntax->datum (quote-syntax ident))
neg-blame-str
(quote-syntax ident)))])))))
;; (define/contract id contract expr)
;; defines `id' with `contract'; initially binding
;; it to the result of `expr'. These variables may not be set!'d.
(define-syntax (define/contract define-stx)
(syntax-case define-stx ()
[(_ name contract-expr expr)
(identifier? (syntax name))
(with-syntax ([contract-id
(a:mangle-id define-stx
"define/contract-contract-id"
(syntax name))]
[id (a:mangle-id define-stx
"define/contract-id"
(syntax name))])
(syntax/loc define-stx
(begin
(define contract-id contract-expr)
(define-syntax name
(make-define/contract-transformer (quote-syntax contract-id)
(quote-syntax id)))
(define id (let ([name expr]) name)) ;; let for procedure naming
)))]
[(_ name contract-expr expr)
(raise-syntax-error 'define/contract "expected identifier in first position"
define-stx
(syntax name))]))

View File

@ -10,12 +10,14 @@
"private/unit-syntax.ss") "private/unit-syntax.ss")
(require mzlib/etc (require mzlib/etc
mzlib/contract
mzlib/stxparam
"private/unit-keywords.ss" "private/unit-keywords.ss"
"private/unit-runtime.ss") "private/unit-runtime.ss")
(provide define-signature-form struct open (provide define-signature-form struct open
define-signature provide-signature-elements define-signature provide-signature-elements
only except rename import export prefix link tag init-depend extends only except rename import export prefix link tag init-depend extends contracted
unit? unit?
(rename :unit unit) define-unit (rename :unit unit) define-unit
compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer
@ -123,7 +125,8 @@
(define-for-syntax (build-val+macro-defs sig) (define-for-syntax (build-val+macro-defs sig)
(with-syntax ([(((int-ivar . ext-ivar) ...) (with-syntax ([(((int-ivar . ext-ivar) ...)
((((int-vid . ext-vid) ...) . vbody) ...) ((((int-vid . ext-vid) ...) . vbody) ...)
((((int-sid . ext-sid) ...) . sbody) ...)) ((((int-sid . ext-sid) ...) . sbody) ...)
(cbody ...))
(map-sig (lambda (x) x) (map-sig (lambda (x) x)
(make-syntax-introducer) (make-syntax-introducer)
sig)]) sig)])
@ -170,7 +173,7 @@
(raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs)) (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs))
(let ([ses (checked-syntax->list sig-exprs)]) (let ([ses (checked-syntax->list sig-exprs)])
(define-values (super-names super-ctimes super-rtimes super-bindings (define-values (super-names super-ctimes super-rtimes super-bindings
super-val-defs super-stx-defs) super-val-defs super-stx-defs super-ctcs)
(if super-sigid (if super-sigid
(let* ([super-sig (lookup-signature super-sigid)] (let* ([super-sig (lookup-signature super-sigid)]
[super-siginfo (signature-siginfo super-sig)]) [super-siginfo (signature-siginfo super-sig)])
@ -180,17 +183,24 @@
(siginfo-rtime-ids super-siginfo)) (siginfo-rtime-ids super-siginfo))
(map syntax-local-introduce (signature-vars super-sig)) (map syntax-local-introduce (signature-vars super-sig))
(map introduce-def (signature-val-defs super-sig)) (map introduce-def (signature-val-defs super-sig))
(map introduce-def (signature-stx-defs super-sig)))) (map introduce-def (signature-stx-defs super-sig))
(values '() '() '() '() '() '()))) (map (lambda (ctc)
(if ctc
(syntax-local-introduce ctc)
ctc))
(signature-ctcs super-sig))))
(values '() '() '() '() '() '() '())))
(let loop ((sig-exprs ses) (let loop ((sig-exprs ses)
(bindings null) (bindings null)
(val-defs null) (val-defs null)
(stx-defs null)) (stx-defs null)
(ctcs null))
(cond (cond
((null? sig-exprs) ((null? sig-exprs)
(let* ([all-bindings (append super-bindings (reverse bindings))] (let* ([all-bindings (append super-bindings (reverse bindings))]
[all-val-defs (append super-val-defs (reverse val-defs))] [all-val-defs (append super-val-defs (reverse val-defs))]
[all-stx-defs (append super-stx-defs (reverse stx-defs))] [all-stx-defs (append super-stx-defs (reverse stx-defs))]
[all-ctcs (append super-ctcs (reverse ctcs))]
[dup [dup
(check-duplicate-identifier (check-duplicate-identifier
(append all-bindings (append all-bindings
@ -221,12 +231,34 @@
((syntax-local-certifier) ((syntax-local-certifier)
(quote-syntax sbody))) (quote-syntax sbody)))
...) ...)
(list #,@(map (lambda (c)
(if c
#`((syntax-local-certifier)
(quote-syntax #,c))
#'#f))
all-ctcs))
(quote-syntax #,sigid)))))))) (quote-syntax #,sigid))))))))
(else (else
(syntax-case (car sig-exprs) (define-values define-syntaxes) (syntax-case (car sig-exprs) (define-values define-syntaxes contracted)
(x (x
(identifier? #'x) (identifier? #'x)
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs)) (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs)))
((x (y z) ...)
(and (identifier? #'x)
(module-identifier=? #'x #'contracted)
(andmap identifier? (syntax->list #'(y ...))))
(loop (cdr sig-exprs)
(append (syntax->list #'(y ...)) bindings)
val-defs
stx-defs
(append (syntax->list #'(z ...)) ctcs)))
((x . z)
(and (identifier? #'x)
(module-identifier=? #'x #'contracted))
(raise-syntax-error
'define-signature
"expected a list of [id contract] pairs after the contracted keyword"
(car sig-exprs)))
((x . y) ((x . y)
(and (identifier? #'x) (and (identifier? #'x)
(or (module-identifier=? #'x #'define-values) (or (module-identifier=? #'x #'define-values)
@ -248,7 +280,8 @@
(if (module-identifier=? #'x #'define-syntaxes) (if (module-identifier=? #'x #'define-syntaxes)
(cons (cons (syntax->list #'(name ...)) b) (cons (cons (syntax->list #'(name ...)) b)
stx-defs) stx-defs)
stx-defs)))))))) stx-defs)
ctcs)))))))
((x . y) ((x . y)
(let ((trans (let ((trans
(set!-trans-extract (set!-trans-extract
@ -266,7 +299,8 @@
(loop (append results (cdr sig-exprs)) (loop (append results (cdr sig-exprs))
bindings bindings
val-defs val-defs
stx-defs)))) stx-defs
ctcs))))
(x (raise-stx-err (x (raise-stx-err
"expected either an identifier or signature form" "expected either an identifier or signature form"
#'x)))))))) #'x))))))))
@ -425,6 +459,26 @@
(define-for-syntax process-unit-export (define-for-syntax process-unit-export
(process-unit-import/export process-tagged-export)) (process-unit-import/export process-tagged-export))
;; id->contract-src-info : identifier -> syntax
;; constructs the last argument to the contract, given an identifier
(define-for-syntax (id->contract-src-info id)
#`(list (make-srcloc (quote-syntax #,id)
#,(syntax-line id)
#,(syntax-column id)
#,(syntax-position id)
#,(syntax-span id))
#,(format "~s" (syntax-object->datum id))))
(define-for-syntax (make-import-unboxing var loc ctc)
(if ctc
(quasisyntax/loc (error-syntax)
(quote-syntax (let ([v/c (unbox #,loc)])
(contract #,ctc (car v/c) (cdr v/c)
(current-contract-region)
#,(id->contract-src-info var)))))
(quasisyntax/loc (error-syntax)
(quote-syntax (unbox #,loc)))))
;; build-unit : syntax-object -> ;; build-unit : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier)) ;; (values syntax-object (listof identifier) (listof identifier))
;; constructs the code for a unit expression. stx must be ;; constructs the code for a unit expression. stx must be
@ -471,6 +525,13 @@
(map (lambda (x) (generate-temporaries (car x))) import-sigs)] (map (lambda (x) (generate-temporaries (car x))) import-sigs)]
[((eloc ...) ...) [((eloc ...) ...)
(map (lambda (x) (generate-temporaries (car x))) export-sigs)] (map (lambda (x) (generate-temporaries (car x))) export-sigs)]
[((ectc ...) ...)
(map (λ (sig)
(map (λ (ctc)
(if ctc
(cons 'contract ctc)
#f))
(cadddr sig))) export-sigs)]
[((import-key import-super-keys ...) ...) [((import-key import-super-keys ...) ...)
(map tagged-info->keys import-tagged-infos)] (map tagged-info->keys import-tagged-infos)]
[((export-key ...) ...) [((export-key ...) ...)
@ -494,32 +555,36 @@
(vector-immutable (cons 'export-name (vector-immutable (cons 'export-name
(vector-immutable export-key ...)) ...) (vector-immutable export-key ...)) ...)
(list (cons 'dept depr) ...) (list (cons 'dept depr) ...)
(lambda () (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
(let ([eloc (box undefined)] ... ...) (lambda ()
(values (let ([eloc (box undefined)] ... ...)
(lambda (import-table) (values
(let-values ([(iloc ...) (lambda (import-table)
(vector->values (hash-table-get import-table import-key) 0 icount)] (let-values ([(iloc ...)
...) (vector->values (hash-table-get import-table import-key) 0 icount)]
(letrec-syntaxes ([(int-ivar ...) ...)
(make-id-mappers (letrec-syntaxes (#,@(map (lambda (ivs ils ics)
(quote-syntax (unbox iloc)) (quasisyntax/loc (error-syntax)
...)] [#,ivs
... (make-id-mappers
[(int-evar ...) #,@(map (lambda (iv l c)
(make-id-mappers (make-import-unboxing iv l c))
(quote-syntax (unbox eloc)) (syntax->list ivs)
...)] (syntax->list ils)
...) ics))]))
(letrec-syntaxes+values (renames ... (syntax->list #'((int-ivar ...) ...))
mac ... ...) (syntax->list #'((iloc ...) ...))
(val ... ...) (map cadddr import-sigs)))
(unit-body #,(error-syntax) (letrec-syntaxes+values (renames ...
(int-ivar ... ...) mac ... ...)
(int-evar ... ...) (val ... ...)
(eloc ... ...) (unit-body #,(error-syntax)
. body))))) (int-ivar ... ...)
(unit-export ((export-key ...) (vector-immutable eloc ...)) ...)))))) (int-evar ... ...)
(eloc ... ...)
(ectc ... ...)
. body)))))
(unit-export ((export-key ...) (vector-immutable eloc ...)) ...)))))))
import-tagged-sigids import-tagged-sigids
export-tagged-sigids export-tagged-sigids
dep-tagged-sigids)))))) dep-tagged-sigids))))))
@ -533,17 +598,14 @@
(define-syntax (unit-body stx) (define-syntax (unit-body stx)
(syntax-case stx () (syntax-case stx ()
((_ err-stx ivars evars elocs body ...) ((_ err-stx ivars evars elocs ectcs body ...)
(parameterize ((error-syntax #'err-stx)) (parameterize ((error-syntax #'err-stx))
(let* ([expand-context (generate-expand-context)] (let* ([expand-context (generate-expand-context)]
[def-ctx (syntax-local-make-definition-context)] [def-ctx (syntax-local-make-definition-context)]
[local-ivars (syntax->list (localify #'ivars def-ctx))]
[local-evars (syntax->list (localify #'evars def-ctx))]
[stop-list [stop-list
(append (append
(kernel-form-identifier-list) (kernel-form-identifier-list)
(syntax->list #'ivars) (syntax->list #'ivars))]
(syntax->list #'evars))]
[definition? [definition?
(lambda (id) (lambda (id)
(and (identifier? id) (and (identifier? id)
@ -605,7 +667,8 @@
table id table id
(make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes)) (make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes))
#f #f
id))) id
#f)))
(syntax->list #'(id ...)))] (syntax->list #'(id ...)))]
[_ (void)]))) [_ (void)])))
[_ (void)])) [_ (void)]))
@ -616,7 +679,7 @@
;; Mark exported names and ;; Mark exported names and
;; check that all exported names are defined (as var): ;; check that all exported names are defined (as var):
(for-each (for-each
(lambda (name loc) (lambda (name loc ctc)
(let ([v (bound-identifier-mapping-get defined-names-table (let ([v (bound-identifier-mapping-get defined-names-table
name name
(lambda () #f))]) (lambda () #f))])
@ -624,9 +687,12 @@
(raise-stx-err (format "undefined export ~a" (syntax-e name)))) (raise-stx-err (format "undefined export ~a" (syntax-e name))))
(when (var-info-syntax? v) (when (var-info-syntax? v)
(raise-stx-err "cannot export syntax from a unit" name)) (raise-stx-err "cannot export syntax from a unit" name))
(set-var-info-exported?! v loc))) (set-var-info-exported?! v loc)
local-evars (when (pair? (syntax-e ctc))
(syntax->list #'elocs)) (set-var-info-ctc! v (cdr (syntax-e ctc))))))
(syntax->list (localify #'evars def-ctx))
(syntax->list #'elocs)
(syntax->list #'ectcs))
;; Check that none of the imports are defined ;; Check that none of the imports are defined
(for-each (for-each
@ -638,78 +704,51 @@
(raise-stx-err (raise-stx-err
"definition for imported identifier" "definition for imported identifier"
(var-info-id defid))))) (var-info-id defid)))))
local-ivars) (syntax->list (localify #'ivars def-ctx)))
(with-syntax ([(intname ...) (let ([marker (make-syntax-introducer)])
(foldr (with-syntax ([(defn-or-expr ...)
(lambda (var res) (apply append
(cond (map (λ (defn-or-expr)
((not (or (var-info-syntax? (cdr var)) (syntax-case defn-or-expr (define-values)
(var-info-exported? (cdr var)))) [(define-values (id ...) body)
(cons (car var) res)) (let* ([ids (syntax->list #'(id ...))]
(else res))) [tmps (map marker ids)]
null [do-one
(bound-identifier-mapping-map defined-names-table cons))] (λ (id tmp)
[(evar ...) #'evars] (let ([var-info (bound-identifier-mapping-get
[(l-evar ...) local-evars] defined-names-table
[(defn&expr ...) id)])
(filter (cond
values [(var-info-exported? var-info)
(map (lambda (defn-or-expr) =>
(syntax-case defn-or-expr (define-values define-syntaxes) (λ (export-loc)
[(define-values () expr) (let ([ctc (var-info-ctc var-info)])
(syntax/loc defn-or-expr (set!-values () expr))] (list (if ctc
[(define-values ids expr) (quasisyntax/loc defn-or-expr
(let ([ids (syntax->list #'ids)] (begin
[do-one (contract #,ctc #,tmp
(lambda (id tmp name) (current-contract-region)
(let ([export-loc 'cant-happen
(var-info-exported? #,(id->contract-src-info id))
(bound-identifier-mapping-get (set-box! #,export-loc
defined-names-table (let ([#,id #,tmp])
id))]) (cons #,id (current-contract-region))))))
(cond (quasisyntax/loc defn-or-expr
(export-loc (set-box! #,export-loc
;; set! exported id: (let ([#,id #,tmp]) #,id))))
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
(set-box! #,export-loc (define-syntax #,id
#,(if name (make-id-mapper (quote-syntax #,tmp)))))))]
#`(let ([#,name #,tmp]) [else (list (quasisyntax/loc defn-or-expr
#,name) (define-syntax #,id
tmp)))) (make-rename-transformer (quote-syntax #,tmp)))))])))])
(else (cons (quasisyntax/loc defn-or-expr
;; not an exported id (define-values #,tmps body))
(quasisyntax/loc defn-or-expr (apply append (map do-one ids tmps))))]
(set! #,id #,tmp))))))]) [else (list defn-or-expr)]))
(if (null? (cdr ids)) expanded-body))])
(do-one (car ids) (syntax expr) (car ids)) #'(begin-with-definitions defn-or-expr ...))))))))
(let ([tmps (generate-temporaries ids)])
(with-syntax ([(tmp ...) tmps]
[(set ...)
(map (lambda (id tmp)
(do-one id tmp #f))
ids tmps)])
(syntax/loc defn-or-expr
(let-values ([(tmp ...) expr])
set ...))))))]
[(define-syntaxes . l) #f]
[else defn-or-expr]))
expanded-body))]
[(stx-defn ...)
(filter
values
(map (lambda (defn-or-expr)
(syntax-case defn-or-expr (define-syntaxes)
[(define-syntaxes . l) #'l]
[else #f]))
expanded-body))])
#'(letrec-syntaxes+values (stx-defn
...
((l-evar) (make-rename-transformer (quote-syntax evar)))
...)
([(intname) undefined] ...)
(void) ; in case the body would be empty
defn&expr ...)))))))
(define-for-syntax (redirect-imports/exports import?) (define-for-syntax (redirect-imports/exports import?)
(lambda (table-stx (lambda (table-stx
@ -1181,9 +1220,16 @@
(map (map
(lambda (os ov) (lambda (os ov)
(map (map
(lambda (i) (lambda (i v c)
#`(vector-ref #,ov #,i)) (if c
(iota (length (car os))))) #`(let ([v/c (unbox (vector-ref #,ov #,i))])
(contract #,c (car v/c) (cdr v/c)
(current-contract-region)
#,(id->contract-src-info v)))
#`(unbox (vector-ref #,ov #,i))))
(iota (length (car os)))
(map car (car os))
(cadddr os)))
out-sigs out-sigs
out-vec))) out-vec)))
(quasisyntax/loc stx (quasisyntax/loc stx
@ -1201,7 +1247,7 @@
((unit-go unit-tmp)))) ((unit-go unit-tmp))))
(let ([out-vec (hash-table-get export-table key1)] ...) (let ([out-vec (hash-table-get export-table key1)] ...)
(unit-fn #f) (unit-fn #f)
(values (unbox out-code) ... ...)))))) (values out-code ... ...))))))
(define-syntaxes . renames) ... (define-syntaxes . renames) ...
(define-syntaxes (mac-name ...) mac-body) ... ... (define-syntaxes (mac-name ...) mac-body) ... ...
(define-values (val-name ...) val-body) ... ...))))) (define-values (val-name ...) val-body) ... ...)))))
@ -1256,7 +1302,8 @@
((_ name . rest) ((_ name . rest)
(begin (begin
(check-id #'name) (check-id #'name)
(let-values (((exp i e d) (build #'rest))) (let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))])
(build #'rest ))))
(with-syntax ((((itag . isig) ...) i) (with-syntax ((((itag . isig) ...) i)
(((etag . esig) ...) e) (((etag . esig) ...) e)
(((deptag . depsig) ...) d)) (((deptag . depsig) ...) d))

View File

@ -81,7 +81,7 @@ of the contract library does not change over time.
(equal? (equal?
blame blame
(cond (cond
[(regexp-match #rx"(^| )([^ ]*) broke" msg) [(regexp-match #rx"(^| )(.*) broke" msg)
=> =>
(λ (x) (caddr x))] (λ (x) (caddr x))]
[else (format "no blame in error message: \"~a\"" msg)]))) [else (format "no blame in error message: \"~a\"" msg)])))
@ -4820,7 +4820,7 @@ so that propagation occurs.
(make-s 1 2) (make-s 1 2)
[s-a #f]))) [s-a #f])))
(eval '(require 'pc11b-n))) (eval '(require 'pc11b-n)))
'n) "'n")
|# |#
(test/spec-passed (test/spec-passed