suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Ported mzlib units to new contract system.

Browse Source 
svn: r17718
This commit is contained in:
Carl Eastlund 2010-01-18 18:26:02 +00:00
parent 1014dd2da4
commit 7763a4079a
3 changed files with 29 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/mzlib/private/unit-contract.ss
View File

@ -15,7 +15,7 @@
(provide (for-syntax unit/c/core) unit/c) (provide (for-syntax unit/c/core) unit/c)
(define-for-syntax (contract-imports/exports import?) (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 def-table (make-bound-identifier-mapping))
(define (convert-reference var vref ctc sig-ctc rename-bindings) (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 ;; store the result in a local box, then just check the box to
;; see if we need to coerce. ;; see if we need to coerce.
#`(let ([ctc (coerce-contract 'unit/c (letrec-syntax #,rename-bindings #,ctc))]) #`(let ([ctc (coerce-contract 'unit/c (letrec-syntax #,rename-bindings #,ctc))])
((((proj-get ctc) ctc) (((contract-projection ctc)
#,(if import? neg pos) #,(if import? #`(blame-swap #,blame-id) blame-id))
#,(if import? pos neg)
#,src-info
#,name
#,(if import? (not positive-position?) positive-position?))
#,stx)))]) #,stx)))])
(if ctc (if ctc
#`(λ () #`(λ ()
@ -43,9 +39,9 @@
var)]) var)])
#`(let ([old-v/c (#,vref)]) #`(let ([old-v/c (#,vref)])
(contract sig-ctc-stx (car old-v/c) (contract sig-ctc-stx (car old-v/c)
(cdr old-v/c) #,pos (cdr old-v/c) (blame-guilty #,blame-id)
#,(id->contract-src-info var))))) (quote #,var) (quote-syntax #,var)))))
#,neg) (blame-innocent #,blame-id))
(wrap-with-proj ctc #`(#,vref)))) (wrap-with-proj ctc #`(#,vref))))
vref))) vref)))
(for ([tagged-info (in-list import-tagged-infos)] (for ([tagged-info (in-list import-tagged-infos)]
@ -57,7 +53,7 @@
#`(vector-ref #,v #,index))))) #`(vector-ref #,v #,index)))))
(with-syntax ((((eloc ...) ...) (with-syntax ((((eloc ...) ...)
(for/list ([target-sig import-sigs]) (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))] (for/list ([target-int/ext-name (in-list (car target-sig))]
[sig-ctc (in-list (cadddr target-sig))]) [sig-ctc (in-list (cadddr target-sig))])
(let* ([var (car target-int/ext-name)] (let* ([var (car target-int/ext-name)]
@ -148,11 +144,10 @@
(map list (list 'e.x ...) (map list (list 'e.x ...)
(build-compound-type-name 'e.c ...))) (build-compound-type-name 'e.c ...)))
...))) ...)))
(λ (pos neg src-info name positive-position?) (λ (blame)
(λ (unit-tmp) (λ (unit-tmp)
(unless (unit? unit-tmp) (unless (unit? unit-tmp)
(raise-contract-error unit-tmp src-info pos name (raise-blame-error blame unit-tmp "value is not a unit"))
"value is not a unit"))
(contract-check-sigs (contract-check-sigs
unit-tmp unit-tmp
(vector-immutable (vector-immutable
@ -161,7 +156,7 @@
(vector-immutable (vector-immutable
(cons 'export-name (cons 'export-name
(vector-immutable export-key ...)) ...) (vector-immutable export-key ...)) ...)
src-info pos name) blame)
(make-unit (make-unit
'#,name '#,name
(vector-immutable (cons 'import-name (vector-immutable (cons 'import-name
@ -177,21 +172,13 @@
import-tagged-infos import-tagged-infos
import-sigs import-sigs
contract-table contract-table
#'pos #'blame)))
#'neg
#'src-info
#'name
#'positive-position?)))
#,(contract-exports #,(contract-exports
#'export-table #'export-table
export-tagged-infos export-tagged-infos
export-sigs export-sigs
contract-table contract-table
#'pos #'blame)))))))
#'neg
#'src-info
#'name
#'positive-position?)))))))
(λ (v) (λ (v)
(and (unit? v) (and (unit? v)
(with-handlers ([exn:fail:contract? (λ () #f)]) (with-handlers ([exn:fail:contract? (λ () #f)])
@ -212,7 +199,7 @@
(let ([name (syntax-local-infer-name stx)]) (let ([name (syntax-local-infer-name stx)])
(unit/c/core name #'sstx))])) (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)) (define t (make-hash))
(let loop ([i (sub1 (vector-length sub-sig))]) (let loop ([i (sub1 (vector-length sub-sig))])
(when (>= i 0) (when (>= i 0)
@ -232,8 +219,8 @@
[r (hash-ref t v0 #f)]) [r (hash-ref t v0 #f)])
(when (not r) (when (not r)
(let ([sub-name (car (vector-ref super-sig i))]) (let ([sub-name (car (vector-ref super-sig i))])
(raise-contract-error (raise-blame-error
val src-info blame ctc blame val
(cond (cond
[import? [import?
(format "contract does not list import ~a" sub-name)] (format "contract does not list import ~a" sub-name)]
@ -241,6 +228,6 @@
(format "unit must export signature ~a" sub-name)]))))) (format "unit must export signature ~a" sub-name)])))))
(loop (sub1 i))))) (loop (sub1 i)))))
(define (contract-check-sigs unit expected-imports expected-exports 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 src-info blame ctc) (contract-check-helper expected-imports (unit-import-sigs unit) #t unit blame)
(contract-check-helper (unit-export-sigs unit) expected-exports #f unit src-info blame ctc)) (contract-check-helper (unit-export-sigs unit) expected-exports #f unit blame))

17
collects/mzlib/private/unit-utils.ss
View File

@ -13,7 +13,6 @@
process-unit-import process-unit-import
process-unit-export process-unit-export
tagged-info->keys tagged-info->keys
id->contract-src-info
get-member-bindings)) get-member-bindings))
(provide equal-hash-table (provide equal-hash-table
@ -26,20 +25,10 @@
((= n 0) acc) ((= n 0) acc)
(else (loop (sub1 n) (cons (sub1 n) 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] ...) (define-syntax-rule (equal-hash-table [k v] ...)
(make-immutable-hash (list (cons 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)))] (for/list ([i (in-list (map car (car sig)))]
[c (in-list (cadddr sig))]) [c (in-list (cadddr sig))])
(let ([add-ctc (let ([add-ctc
@ -47,8 +36,8 @@
(if c (if c
(with-syntax ([c-stx (syntax-property c 'inferred-name v)]) (with-syntax ([c-stx (syntax-property c 'inferred-name v)])
#`(let ([v/c (#,stx)]) #`(let ([v/c (#,stx)])
(contract c-stx (car v/c) (cdr v/c) #,blame (contract c-stx (car v/c) (cdr v/c) #,pos
#,(id->contract-src-info v)))) (quote #,v) (quote-syntax #,v))))
#`(#,stx)))]) #`(#,stx)))])
#`[#,i #`[#,i
(make-set!-transformer (make-set!-transformer

16
collects/mzlib/unit.ss
View File

@ -482,7 +482,7 @@
(if (pair? v/c) (if (pair? v/c)
(contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info var)) (quote #,var) (quote-syntax #,var))
(error 'unit "contracted import ~a used before definition" (error 'unit "contracted import ~a used before definition"
(quote #,(syntax->datum var)))))))) (quote #,(syntax->datum var))))))))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
@ -747,7 +747,8 @@
(contract #,ctc #,tmp (contract #,ctc #,tmp
(current-contract-region) (current-contract-region)
'cant-happen 'cant-happen
#,(id->contract-src-info id)) (quote #,id)
(quote-syntax #,id))
(set-box! #,export-loc (set-box! #,export-loc
(cons #,tmp (current-contract-region))))) (cons #,tmp (current-contract-region)))))
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
@ -824,7 +825,7 @@
#`(let ([old-v/c (#,vref)]) #`(let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c) (contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region) (cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var))) (quote #,var) (quote-syntax #,var)))
#`(#,vref)) #`(#,vref))
(current-contract-region))) (current-contract-region)))
(if ctc (if ctc
@ -832,7 +833,7 @@
(let ([old-v/c (#,vref)]) (let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c) (contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region) (cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var)))) (quote #,var) (quote-syntax #,var))))
vref))))) vref)))))
(car target-sig) (car target-sig)
(cadddr target-sig))) (cadddr target-sig)))
@ -1303,7 +1304,7 @@
#`(let ([v/c (#,tb)]) #`(let ([v/c (#,tb)])
(contract ctc-stx (car v/c) (cdr v/c) (contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info v)))) (quote #,v) (quote-syntax #,v))))
#`(#,tb))) #`(#,tb)))
tbs tbs
(iota (length (car os))) (iota (length (car os)))
@ -1503,11 +1504,10 @@
#'name #'name
(syntax/loc stx (syntax/loc stx
((import (import-tagged-sig-id [i.x i.c] ...) ...) ((import (import-tagged-sig-id [i.x i.c] ...) ...)
(export (export-tagged-sig-id [e.x e.c] ...) ...))))] (export (export-tagged-sig-id [e.x e.c] ...) ...))))])
[src-info (id->contract-src-info #'name)])
(values (values
(syntax/loc stx (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))))] isigs esigs deps))))]
[(ic:import-clause/contract ec:export-clause/contract . body) [(ic:import-clause/contract ec:export-clause/contract . body)
(build-unit/contract (build-unit/contract