diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 30abf6d..a07bee7 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -15,6 +15,13 @@ (require "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 ;; -(require scheme/private/contract +(require (except-in scheme/private/contract + define/contract + with-contract) scheme/private/contract-guts scheme/private/contract-ds scheme/private/contract-opt diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss new file mode 100644 index 0000000..12891e1 --- /dev/null +++ b/collects/mzlib/private/contract-define.ss @@ -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))])) + + + diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 593155f..e2d1b30 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -10,12 +10,14 @@ "private/unit-syntax.ss") (require mzlib/etc + mzlib/contract + mzlib/stxparam "private/unit-keywords.ss" "private/unit-runtime.ss") (provide define-signature-form struct open 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? (rename :unit unit) define-unit compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer @@ -123,7 +125,8 @@ (define-for-syntax (build-val+macro-defs sig) (with-syntax ([(((int-ivar . ext-ivar) ...) ((((int-vid . ext-vid) ...) . vbody) ...) - ((((int-sid . ext-sid) ...) . sbody) ...)) + ((((int-sid . ext-sid) ...) . sbody) ...) + (cbody ...)) (map-sig (lambda (x) x) (make-syntax-introducer) sig)]) @@ -170,7 +173,7 @@ (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-val-defs super-stx-defs super-ctcs) (if super-sigid (let* ([super-sig (lookup-signature super-sigid)] [super-siginfo (signature-siginfo super-sig)]) @@ -180,17 +183,24 @@ (siginfo-rtime-ids super-siginfo)) (map syntax-local-introduce (signature-vars super-sig)) (map introduce-def (signature-val-defs super-sig)) - (map introduce-def (signature-stx-defs super-sig)))) - (values '() '() '() '() '() '()))) + (map introduce-def (signature-stx-defs 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)) + (stx-defs 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-ctcs (append super-ctcs (reverse ctcs))] [dup (check-duplicate-identifier (append all-bindings @@ -221,12 +231,34 @@ ((syntax-local-certifier) (quote-syntax sbody))) ...) + (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) + (syntax-case (car sig-exprs) (define-values define-syntaxes contracted) (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) (and (identifier? #'x) (or (module-identifier=? #'x #'define-values) @@ -248,7 +280,8 @@ (if (module-identifier=? #'x #'define-syntaxes) (cons (cons (syntax->list #'(name ...)) b) stx-defs) - stx-defs)))))))) + stx-defs) + ctcs))))))) ((x . y) (let ((trans (set!-trans-extract @@ -266,7 +299,8 @@ (loop (append results (cdr sig-exprs)) bindings val-defs - stx-defs)))) + stx-defs + ctcs)))) (x (raise-stx-err "expected either an identifier or signature form" #'x)))))))) @@ -425,6 +459,26 @@ (define-for-syntax process-unit-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 -> ;; (values syntax-object (listof identifier) (listof identifier)) ;; constructs the code for a unit expression. stx must be @@ -471,6 +525,13 @@ (map (lambda (x) (generate-temporaries (car x))) import-sigs)] [((eloc ...) ...) (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 ...) ...) (map tagged-info->keys import-tagged-infos)] [((export-key ...) ...) @@ -494,32 +555,36 @@ (vector-immutable (cons 'export-name (vector-immutable export-key ...)) ...) (list (cons 'dept depr) ...) - (lambda () - (let ([eloc (box undefined)] ... ...) - (values - (lambda (import-table) - (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)) - ...)] - ... - [(int-evar ...) - (make-id-mappers - (quote-syntax (unbox eloc)) - ...)] - ...) - (letrec-syntaxes+values (renames ... - mac ... ...) - (val ... ...) - (unit-body #,(error-syntax) - (int-ivar ... ...) - (int-evar ... ...) - (eloc ... ...) - . body))))) - (unit-export ((export-key ...) (vector-immutable eloc ...)) ...)))))) + (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) + (lambda () + (let ([eloc (box undefined)] ... ...) + (values + (lambda (import-table) + (let-values ([(iloc ...) + (vector->values (hash-table-get import-table import-key) 0 icount)] + ...) + (letrec-syntaxes (#,@(map (lambda (ivs ils ics) + (quasisyntax/loc (error-syntax) + [#,ivs + (make-id-mappers + #,@(map (lambda (iv l c) + (make-import-unboxing iv l c)) + (syntax->list ivs) + (syntax->list ils) + ics))])) + (syntax->list #'((int-ivar ...) ...)) + (syntax->list #'((iloc ...) ...)) + (map cadddr import-sigs))) + (letrec-syntaxes+values (renames ... + mac ... ...) + (val ... ...) + (unit-body #,(error-syntax) + (int-ivar ... ...) + (int-evar ... ...) + (eloc ... ...) + (ectc ... ...) + . body))))) + (unit-export ((export-key ...) (vector-immutable eloc ...)) ...))))))) import-tagged-sigids export-tagged-sigids dep-tagged-sigids)))))) @@ -533,17 +598,14 @@ (define-syntax (unit-body stx) (syntax-case stx () - ((_ err-stx ivars evars elocs body ...) + ((_ err-stx ivars evars elocs ectcs body ...) (parameterize ((error-syntax #'err-stx)) (let* ([expand-context (generate-expand-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 (append (kernel-form-identifier-list) - (syntax->list #'ivars) - (syntax->list #'evars))] + (syntax->list #'ivars))] [definition? (lambda (id) (and (identifier? id) @@ -605,7 +667,8 @@ table id (make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes)) #f - id))) + id + #f))) (syntax->list #'(id ...)))] [_ (void)]))) [_ (void)])) @@ -616,7 +679,7 @@ ;; Mark exported names and ;; check that all exported names are defined (as var): (for-each - (lambda (name loc) + (lambda (name loc ctc) (let ([v (bound-identifier-mapping-get defined-names-table name (lambda () #f))]) @@ -624,9 +687,12 @@ (raise-stx-err (format "undefined export ~a" (syntax-e name)))) (when (var-info-syntax? v) (raise-stx-err "cannot export syntax from a unit" name)) - (set-var-info-exported?! v loc))) - local-evars - (syntax->list #'elocs)) + (set-var-info-exported?! v loc) + (when (pair? (syntax-e ctc)) + (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 (for-each @@ -638,78 +704,51 @@ (raise-stx-err "definition for imported identifier" (var-info-id defid))))) - local-ivars) + (syntax->list (localify #'ivars def-ctx))) - (with-syntax ([(intname ...) - (foldr - (lambda (var res) - (cond - ((not (or (var-info-syntax? (cdr var)) - (var-info-exported? (cdr var)))) - (cons (car var) res)) - (else res))) - null - (bound-identifier-mapping-map defined-names-table cons))] - [(evar ...) #'evars] - [(l-evar ...) local-evars] - [(defn&expr ...) - (filter - values - (map (lambda (defn-or-expr) - (syntax-case defn-or-expr (define-values define-syntaxes) - [(define-values () expr) - (syntax/loc defn-or-expr (set!-values () expr))] - [(define-values ids expr) - (let ([ids (syntax->list #'ids)] - [do-one - (lambda (id tmp name) - (let ([export-loc - (var-info-exported? - (bound-identifier-mapping-get - defined-names-table - id))]) - (cond - (export-loc - ;; set! exported id: - (quasisyntax/loc defn-or-expr - (set-box! #,export-loc - #,(if name - #`(let ([#,name #,tmp]) - #,name) - tmp)))) - (else - ;; not an exported id - (quasisyntax/loc defn-or-expr - (set! #,id #,tmp))))))]) - (if (null? (cdr ids)) - (do-one (car ids) (syntax expr) (car ids)) - (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 ...))))))) + (let ([marker (make-syntax-introducer)]) + (with-syntax ([(defn-or-expr ...) + (apply append + (map (λ (defn-or-expr) + (syntax-case defn-or-expr (define-values) + [(define-values (id ...) body) + (let* ([ids (syntax->list #'(id ...))] + [tmps (map marker ids)] + [do-one + (λ (id tmp) + (let ([var-info (bound-identifier-mapping-get + defined-names-table + id)]) + (cond + [(var-info-exported? var-info) + => + (λ (export-loc) + (let ([ctc (var-info-ctc var-info)]) + (list (if ctc + (quasisyntax/loc defn-or-expr + (begin + (contract #,ctc #,tmp + (current-contract-region) + 'cant-happen + #,(id->contract-src-info id)) + (set-box! #,export-loc + (let ([#,id #,tmp]) + (cons #,id (current-contract-region)))))) + (quasisyntax/loc defn-or-expr + (set-box! #,export-loc + (let ([#,id #,tmp]) #,id)))) + (quasisyntax/loc defn-or-expr + (define-syntax #,id + (make-id-mapper (quote-syntax #,tmp)))))))] + [else (list (quasisyntax/loc defn-or-expr + (define-syntax #,id + (make-rename-transformer (quote-syntax #,tmp)))))])))]) + (cons (quasisyntax/loc defn-or-expr + (define-values #,tmps body)) + (apply append (map do-one ids tmps))))] + [else (list defn-or-expr)])) + expanded-body))]) + #'(begin-with-definitions defn-or-expr ...)))))))) (define-for-syntax (redirect-imports/exports import?) (lambda (table-stx @@ -1181,9 +1220,16 @@ (map (lambda (os ov) (map - (lambda (i) - #`(vector-ref #,ov #,i)) - (iota (length (car os))))) + (lambda (i v c) + (if c + #`(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-vec))) (quasisyntax/loc stx @@ -1201,7 +1247,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) ... ...))))) @@ -1256,7 +1302,8 @@ ((_ name . rest) (begin (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) (((etag . esig) ...) e) (((deptag . depsig) ...) d)) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 4d0b8c9..2e22f41 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -81,7 +81,7 @@ of the contract library does not change over time. (equal? blame (cond - [(regexp-match #rx"(^| )([^ ]*) broke" msg) + [(regexp-match #rx"(^| )(.*) broke" msg) => (λ (x) (caddr x))] [else (format "no blame in error message: \"~a\"" msg)]))) @@ -4820,7 +4820,7 @@ so that propagation occurs. (make-s 1 2) [s-a #f]))) (eval '(require 'pc11b-n))) - 'n) + "'n") |# (test/spec-passed