From 7763a4079ad4db29c3c42d7278e779e6ff604f90 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 18:26:02 +0000 Subject: [PATCH] Ported mzlib units to new contract system. svn: r17718 --- collects/mzlib/private/unit-contract.ss | 49 +++++++++---------------- collects/mzlib/private/unit-utils.ss | 17 ++------- collects/mzlib/unit.ss | 16 ++++---- 3 files changed, 29 insertions(+), 53 deletions(-) diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index 1290a7809c..11b45f84cc 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -15,7 +15,7 @@ (provide (for-syntax unit/c/core) unit/c) (define-for-syntax (contract-imports/exports import?) - (λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name positive-position?) + (λ (table-stx import-tagged-infos import-sigs ctc-table blame-id) (define def-table (make-bound-identifier-mapping)) (define (convert-reference var vref ctc sig-ctc rename-bindings) @@ -25,12 +25,8 @@ ;; store the result in a local box, then just check the box to ;; see if we need to coerce. #`(let ([ctc (coerce-contract 'unit/c (letrec-syntax #,rename-bindings #,ctc))]) - ((((proj-get ctc) ctc) - #,(if import? neg pos) - #,(if import? pos neg) - #,src-info - #,name - #,(if import? (not positive-position?) positive-position?)) + (((contract-projection ctc) + #,(if import? #`(blame-swap #,blame-id) blame-id)) #,stx)))]) (if ctc #`(λ () @@ -43,9 +39,9 @@ var)]) #`(let ([old-v/c (#,vref)]) (contract sig-ctc-stx (car old-v/c) - (cdr old-v/c) #,pos - #,(id->contract-src-info var))))) - #,neg) + (cdr old-v/c) (blame-guilty #,blame-id) + (quote #,var) (quote-syntax #,var))))) + (blame-innocent #,blame-id)) (wrap-with-proj ctc #`(#,vref)))) vref))) (for ([tagged-info (in-list import-tagged-infos)] @@ -57,7 +53,7 @@ #`(vector-ref #,v #,index))))) (with-syntax ((((eloc ...) ...) (for/list ([target-sig import-sigs]) - (let ([rename-bindings (get-member-bindings def-table target-sig pos)]) + (let ([rename-bindings (get-member-bindings def-table target-sig #`(blame-guilty #,blame-id))]) (for/list ([target-int/ext-name (in-list (car target-sig))] [sig-ctc (in-list (cadddr target-sig))]) (let* ([var (car target-int/ext-name)] @@ -148,11 +144,10 @@ (map list (list 'e.x ...) (build-compound-type-name 'e.c ...))) ...))) - (λ (pos neg src-info name positive-position?) + (λ (blame) (λ (unit-tmp) (unless (unit? unit-tmp) - (raise-contract-error unit-tmp src-info pos name - "value is not a unit")) + (raise-blame-error blame unit-tmp "value is not a unit")) (contract-check-sigs unit-tmp (vector-immutable @@ -161,7 +156,7 @@ (vector-immutable (cons 'export-name (vector-immutable export-key ...)) ...) - src-info pos name) + blame) (make-unit '#,name (vector-immutable (cons 'import-name @@ -177,21 +172,13 @@ import-tagged-infos import-sigs contract-table - #'pos - #'neg - #'src-info - #'name - #'positive-position?))) + #'blame))) #,(contract-exports #'export-table export-tagged-infos export-sigs contract-table - #'pos - #'neg - #'src-info - #'name - #'positive-position?))))))) + #'blame))))))) (λ (v) (and (unit? v) (with-handlers ([exn:fail:contract? (λ () #f)]) @@ -212,7 +199,7 @@ (let ([name (syntax-local-infer-name stx)]) (unit/c/core name #'sstx))])) -(define (contract-check-helper sub-sig super-sig import? val src-info blame ctc) +(define (contract-check-helper sub-sig super-sig import? val blame) (define t (make-hash)) (let loop ([i (sub1 (vector-length sub-sig))]) (when (>= i 0) @@ -232,8 +219,8 @@ [r (hash-ref t v0 #f)]) (when (not r) (let ([sub-name (car (vector-ref super-sig i))]) - (raise-contract-error - val src-info blame ctc + (raise-blame-error + blame val (cond [import? (format "contract does not list import ~a" sub-name)] @@ -241,6 +228,6 @@ (format "unit must export signature ~a" sub-name)]))))) (loop (sub1 i))))) -(define (contract-check-sigs unit expected-imports expected-exports src-info blame ctc) - (contract-check-helper expected-imports (unit-import-sigs unit) #t unit src-info blame ctc) - (contract-check-helper (unit-export-sigs unit) expected-exports #f unit src-info blame ctc)) +(define (contract-check-sigs unit expected-imports expected-exports blame) + (contract-check-helper expected-imports (unit-import-sigs unit) #t unit blame) + (contract-check-helper (unit-export-sigs unit) expected-exports #f unit blame)) diff --git a/collects/mzlib/private/unit-utils.ss b/collects/mzlib/private/unit-utils.ss index 91b82cb4b2..7b193aa2be 100644 --- a/collects/mzlib/private/unit-utils.ss +++ b/collects/mzlib/private/unit-utils.ss @@ -13,7 +13,6 @@ process-unit-import process-unit-export tagged-info->keys - id->contract-src-info get-member-bindings)) (provide equal-hash-table @@ -26,20 +25,10 @@ ((= n 0) acc) (else (loop (sub1 n) (cons (sub1 n) acc)))))) - ;; 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->datum id)))) - (define-syntax-rule (equal-hash-table [k v] ...) (make-immutable-hash (list (cons k v) ...))) -(define-for-syntax (get-member-bindings member-table sig blame) +(define-for-syntax (get-member-bindings member-table sig pos) (for/list ([i (in-list (map car (car sig)))] [c (in-list (cadddr sig))]) (let ([add-ctc @@ -47,8 +36,8 @@ (if c (with-syntax ([c-stx (syntax-property c 'inferred-name v)]) #`(let ([v/c (#,stx)]) - (contract c-stx (car v/c) (cdr v/c) #,blame - #,(id->contract-src-info v)))) + (contract c-stx (car v/c) (cdr v/c) #,pos + (quote #,v) (quote-syntax #,v)))) #`(#,stx)))]) #`[#,i (make-set!-transformer diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 64a77d6905..dec63d26fa 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -482,7 +482,7 @@ (if (pair? v/c) (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) (current-contract-region) - #,(id->contract-src-info var)) + (quote #,var) (quote-syntax #,var)) (error 'unit "contracted import ~a used before definition" (quote #,(syntax->datum var)))))))) (quasisyntax/loc (error-syntax) @@ -747,7 +747,8 @@ (contract #,ctc #,tmp (current-contract-region) 'cant-happen - #,(id->contract-src-info id)) + (quote #,id) + (quote-syntax #,id)) (set-box! #,export-loc (cons #,tmp (current-contract-region))))) (quasisyntax/loc defn-or-expr @@ -824,7 +825,7 @@ #`(let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - #,(id->contract-src-info var))) + (quote #,var) (quote-syntax #,var))) #`(#,vref)) (current-contract-region))) (if ctc @@ -832,7 +833,7 @@ (let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - #,(id->contract-src-info var)))) + (quote #,var) (quote-syntax #,var)))) vref))))) (car target-sig) (cadddr target-sig))) @@ -1303,7 +1304,7 @@ #`(let ([v/c (#,tb)]) (contract ctc-stx (car v/c) (cdr v/c) (current-contract-region) - #,(id->contract-src-info v)))) + (quote #,v) (quote-syntax #,v)))) #`(#,tb))) tbs (iota (length (car os))) @@ -1503,11 +1504,10 @@ #'name (syntax/loc stx ((import (import-tagged-sig-id [i.x i.c] ...) ...) - (export (export-tagged-sig-id [e.x e.c] ...) ...))))] - [src-info (id->contract-src-info #'name)]) + (export (export-tagged-sig-id [e.x e.c] ...) ...))))]) (values (syntax/loc stx - (contract unit-contract new-unit '(unit name) (current-contract-region) src-info)) + (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name))) isigs esigs deps))))] [(ic:import-clause/contract ec:export-clause/contract . body) (build-unit/contract