Ported mzlib units to new contract system.
svn: r17718
This commit is contained in:
Carl Eastlund
parent
1014dd2da4
commit
7763a4079a
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user