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

added first order checking and some stop-gap checking for sub-structs

Browse Source 
svn: r3675
This commit is contained in:
Robby Findler 2006-07-10 20:57:33 +00:00
parent f47d4a05c0
commit 0d07f36ab7
2 changed files with 28 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/mzlib/private/contract.ss
View File

@ -469,25 +469,11 @@ add struct contracts for immutable structs?
'
() ;; immutable-k-list
(λ (selector-ids ... ignore)
(values (-contract field-contract-ids selector-ids 'guess1 'guess2)
(values (-contract field-contract-ids selector-ids 'not-enough-info-for-blame 'not-enough-info-for-blame)
...)))])
struct:struct-name))
(provide (rename -struct:struct-name struct:struct-name)))))))))
;; map/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z)
#;
(define (map/count f l1 l2)
(let loop ([l1 l1]
[l2 l2]
[i 0])
(cond
[(and (null? l1) (null? l2)) '()]
[(or (null? l1) (null? l2)) (error 'map/count "mismatched lists")]
[else (cons (f (car l1) (car l2) i)
(loop (cdr l1)
(cdr l2)
(+ i 1)))])))
(define (map/count f . ls)
(let loop ([ls ls]
[i 0])
@ -592,13 +578,20 @@ add struct contracts for immutable structs?
(define pos-module-source (module-source-as-symbol #'pos-stx))
(define contract-id ctrct)
(if #f id)
;(if #f id)
; syntax-local-lift
;(check-first-order contract-id id #'pos-stx) ;; we'd like to use this ...
(define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id)
(quote-syntax id)
(quote-syntax pos-module-source)))))])
(syntax-local-lift-module-end-declaration
#'(begin
(-contract contract-id id pos-module-source 'ignored #'pos-stx)
(void)))
(syntax (code id-rename)))))
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
@ -606,9 +599,6 @@ add struct contracts for immutable structs?
(begin
bodies ...))))]))
(define (check-first-order ctc val src-info)
(-contract ctc val (module-source-as-symbol src-info) 'ignored src-info)
(void))
(define (test-proc/flat-contract f x)
(if (flat-contract? f)

21
collects/tests/mzscheme/contract-test.ss
View File

@ -1506,7 +1506,6 @@
(eval '(require contract-test-suite-define1))))
;
;
@ -4474,7 +4473,6 @@
;; provide/contract should signal errors without requiring a reference to the variable
;; this test is bogus, because provide/contract'd variables can be set!'d.
#;
(test/pos-blame
'provide/contract15
'(parameterize ([current-namespace (make-namespace)])
@ -4485,7 +4483,6 @@
(eval '(require pos))))
;; this is really a positive violation, but name the module `neg' just for an addl test
#;
(test/neg-blame
'provide/contract16
'(parameterize ([current-namespace (make-namespace)])
@ -4495,6 +4492,24 @@
(provide/contract [i integer?])))
(eval '(require neg))))
;; this test doesn't pass yet ... waiting for support from define-struct
#;
(test/neg-blame
'provide/contract17
'(parameterize ([current-namespace (make-namespace)])
(eval '(module pos mzscheme
(require (lib "contract.ss"))
(define-struct s (a))
(provide/contract [struct s ((a integer?))])))
(eval '(module neg mzscheme
(require pos)
(define-struct (t s) ())
(make-t #f)))
(eval '(require neg))))
))