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

Adding with-contract from sstrickl/with-contract, with a slight nudge to

Browse Source 
the recent unit contract work to use the same syntax parameter as this
work.

svn: r13185
This commit is contained in:
Stevie Strickland 2009-01-16 22:59:48 +00:00
commit 654a70ff90
10 changed files with 750 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mzlib/contract.ss
View File

@ -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

70
collects/mzlib/private/contract-define.ss Normal file
View File

@ -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))]))

20
collects/mzlib/scribblings/contract.scrbl
View File

@ -56,7 +56,6 @@ from @schememodname[scheme/contract]:
contract-violation->string
contract?
define-contract-struct
define/contract
false/c
flat-contract
flat-contract-predicate
@ -91,3 +90,22 @@ from @schememodname[scheme/contract]:
vector/c
vectorof]
It also provides the old version of @scheme[define/contract]:
@defform[(define/contract id contract-expr init-value-expr)]{
Attaches the contract @scheme[contract-expr] to
@scheme[init-value-expr] and binds that to @scheme[id].
The @scheme[define/contract] form treats individual definitions as
units of blame. The definition itself is responsible for positive
(co-variant) positions of the contract and each reference to
@scheme[id] (including those in the initial value expression) must
meet the negative positions of the contract.
Error messages with @scheme[define/contract] are not as clear as those
provided by @scheme[provide/contract], because
@scheme[define/contract] cannot detect the name of the definition
where the reference to the defined variable occurs. Instead, it uses
the source location of the reference to the variable as the name of
that definition.}

10
collects/mzlib/unit.ss
View File

@ -469,13 +469,11 @@
#,(syntax-span id))
#,(format "~s" (syntax-object->datum id))))
(define-syntax-parameter current-unit-blame-stx (lambda (stx) #'(#%variable-reference)))
(define-for-syntax (make-import-unboxing var loc ctc)
(if ctc
(quasisyntax/loc (error-syntax)
(quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen
(current-unit-blame-stx)
(current-contract-region)
#,(id->contract-src-info var))))
(quasisyntax/loc (error-syntax)
(quote-syntax (unbox #,loc)))))
@ -556,7 +554,7 @@
(vector-immutable (cons 'export-name
(vector-immutable export-key ...)) ...)
(list (cons 'dept depr) ...)
(syntax-parameterize ([current-unit-blame-stx (lambda (stx) #'(quote (unit name)))])
(syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
(lambda ()
(let ([eloc (box undefined)] ... ...)
(values
@ -693,7 +691,7 @@
(set-var-info-add-ctc!
v
(λ (e)
#`(contract #,(cdr (syntax-e ctc)) #,e (current-unit-blame-stx)
#`(contract #,(cdr (syntax-e ctc)) #,e (current-contract-region)
'cant-happen #,(id->contract-src-info e)))))))
(syntax->list (localify #'evars def-ctx))
(syntax->list #'elocs)
@ -1219,7 +1217,7 @@
(lambda (i v c)
(if c
#`(contract #,c (unbox (vector-ref #,ov #,i))
'cant-happen (current-unit-blame-stx)
'cant-happen (current-contract-region)
#,(id->contract-src-info v))
#`(unbox (vector-ref #,ov #,i))))
(iota (length (car os)))

3
collects/scheme/private/contract-guts.ss
View File

@ -180,8 +180,7 @@
[formatted-contract-sexp
(let ([one-line
(let ([sp (open-output-string)])
(parameterize ([pretty-print-print-line print-contract-liner]
[pretty-print-columns 'infinity])
(parameterize ([pretty-print-columns 'infinity])
(pretty-print contract-sexp sp)
(get-output-string sp)))])
(if (< (string-length one-line) 30)

384
collects/scheme/private/contract.ss
View File

@ -12,13 +12,20 @@ improve method arity mismatch contract violation error messages?
(provide (rename-out [-contract contract])
recursive-contract
provide/contract
define/contract)
define/contract
with-contract
current-contract-region)
(require (for-syntax scheme/base)
(for-syntax "contract-opt-guts.ss")
(for-syntax scheme/struct-info)
(for-syntax scheme/list)
scheme/promise)
(for-syntax syntax/define)
(for-syntax syntax/kerncase)
scheme/promise
scheme/stxparam
scheme/splicing
mzlib/etc)
(require "contract-arrow.ss"
"contract-guts.ss"
@ -28,6 +35,24 @@ improve method arity mismatch contract violation error messages?
(for-syntax (prefix-in a: "contract-helpers.ss")))
;; These are useful for all below.
(define-syntax (verify-contract stx)
(syntax-case stx ()
[(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)]))
;; 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 #,id
#,(syntax-line id)
#,(syntax-column id)
#,(syntax-position id)
#,(syntax-span id))
#,(format "~s" (syntax->datum id))))
;
;
@ -46,6 +71,267 @@ improve method arity mismatch contract violation error messages?
; ;
;
;; (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)
(when (eq? (syntax-local-context) 'expression)
(raise-syntax-error 'define/contract
"used in expression context"
define-stx))
(syntax-case define-stx ()
[(_ name)
(raise-syntax-error 'define/contract
"no contract or body"
define-stx)]
[(_ name contract-expr)
(raise-syntax-error 'define/contract
"no body after contract"
define-stx)]
[(_ name contract-expr expr)
(identifier? #'name)
(let ([contract (if (a:known-good-contract? #'contract-expr)
#'contract-expr
#'(verify-contract 'define/contract contract-expr))])
(quasisyntax/loc define-stx
(with-contract #:type definition name
([name #,contract])
(define name expr))))]
[(_ name contract-expr expr0 expr ...)
(identifier? #'name)
(raise-syntax-error 'define/contract
"multiple expressions after identifier and contract"
define-stx)]
[(_ name+arg-list contract body0 body ...)
(let-values ([(name lam-expr)
(normalize-definition
(datum->syntax #'define-stx (list* 'define/contract #'name+arg-list
#'body0 #'(body ...)))
#'lambda #t #t)])
(with-syntax ([name name]
[lam-expr lam-expr])
(syntax/loc define-stx
(with-contract #:type function name
([name (verify-contract 'define/contract contract)])
(define name lam-expr)))))]))
;
;
; ; ;
; ; ; ; ;
; ; ; ; ;
; ; ; ; ; ;;;; ; ;;; ;;; ;;; ; ;;; ;;;; ; ;; ;;;; ;;; ;;;;
; ; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ;
; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
; ; ; ; ;;; ; ; ;;; ;;; ; ; ;;; ; ;;;; ; ;;; ;;;
;
;
;
(define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference)))
(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id)
(make-set!-transformer
(lambda (stx)
(with-syntax ([neg-blame-id #'(current-contract-region)]
[pos-blame-id pos-blame-id]
[contract-id contract-id]
[id id])
(syntax-case stx (set!)
[(set! id arg)
(raise-syntax-error 'with-contract
"cannot set! a with-contract variable"
stx
(syntax id))]
[(f arg ...)
(syntax/loc stx
((-contract contract-id
id
pos-blame-id
neg-blame-id
#'f)
arg ...))]
[ident
(identifier? (syntax ident))
(syntax/loc stx
(-contract contract-id
id
pos-blame-id
neg-blame-id
#'ident))])))))
(define-for-syntax (head-expand-all body-stxs)
(apply append
(for/list ([stx body-stxs])
(let ([exp-form (local-expand stx
(syntax-local-context)
(kernel-form-identifier-list))])
(syntax-case exp-form (begin)
[(begin form ...)
(head-expand-all (syntax->list #'(form ...)))]
[_
(list exp-form)])))))
(define-for-syntax (check-exports ids body-stxs)
(let ([defd-ids (for/fold ([id-list null])
([stx body-stxs])
(kernel-syntax-case stx #f
[(define-values ids expr)
(append (syntax->list #'ids)
id-list)]
[_ id-list]))])
(for ([id (in-list ids)])
(unless (findf (lambda (s)
(bound-identifier=? s id))
defd-ids)
(raise-syntax-error 'with-contract
"identifier not defined in body"
id)))))
(define-for-syntax (check-and-split-with-contract-args args)
(let loop ([args args]
[unprotected null]
[protected null]
[protections null])
(cond
[(null? args)
(values unprotected protected protections)]
[(identifier? (car args))
(loop (cdr args)
(cons (car args) unprotected)
protected
protections)]
[(let ([lst (syntax->list (car args))])
(and (list? lst)
(= (length lst) 2)
(identifier? (first lst))
lst))
=>
(lambda (l)
(loop (cdr args)
unprotected
(cons (first l) protected)
(cons (second l) protections)))]
[else
(raise-syntax-error 'with-contract
"expected an identifier or (identifier contract)"
(car args))])))
(define-syntax (with-contract stx)
(when (eq? (syntax-local-context) 'expression)
(raise-syntax-error 'with-contract
"used in expression context"
stx))
(syntax-case stx ()
[(_ #:type type blame (arg ...) body0 body ...)
(and (identifier? #'blame)
(identifier? #'type))
(let*-values ([(marker) (make-syntax-introducer)]
[(unprotected protected protections)
(check-and-split-with-contract-args (syntax->list #'(arg ...)))]
[(expanded-bodies)
(head-expand-all (cons #'body0 (syntax->list #'(body ...))))]
[(protected-ids contracts contract-defs)
(for/lists (protected-ids contracts contract-defs)
([n protected]
[c protections])
(if (a:known-good-contract? c)
(values n c #f)
(let ([contract-id (a:mangle-id stx "with-contract-contract-id" n)])
(values n contract-id
(quasisyntax/loc stx
(define-values (#,contract-id)
(verify-contract 'with-contract #,c)))))))])
(begin
(let* ([all-ids (append unprotected protected)]
[dupd-id (check-duplicate-identifier all-ids)])
(when dupd-id
(raise-syntax-error 'with-contract
"identifier appears twice in exports"
dupd-id))
(check-exports (append unprotected protected) expanded-bodies))
(with-syntax ([(contract-def ...) (map marker (filter values contract-defs))]
[blame-stx #''(type blame)]
[(marked-body ...) (map marker expanded-bodies)])
(quasisyntax/loc stx
(splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)])
marked-body ...
contract-def ...
#,@(map (λ (p c)
#`(define-syntax #,p
(make-with-contract-transformer
(quote-syntax #,(marker c))
(quote-syntax #,(marker p))
(quote-syntax blame-stx))))
protected-ids contracts)
#,@(map (λ (u)
#`(define-syntax #,u
(make-rename-transformer (quote-syntax #,(marker u)))))
unprotected)
(define-values ()
(begin
#,@(map (λ (p c)
#`(-contract #,(marker c) #,(marker p) blame-stx 'ignored #,(id->contract-src-info p)))
protected-ids contracts)
(values)))
)))))]
[(_ #:type type blame (arg ...) body0 body ...)
(raise-syntax-error 'with-contract
"expected identifier for blame"
#'blame)]
[(_ #:type type blame (arg ...))
(identifier? #'blame)
(raise-syntax-error 'with-contract
"empty body"
stx)]
[(_ #:type type blame bad-args etc ...)
(identifier? #'blame)
(raise-syntax-error 'with-contract
"expected list of identifier and/or (identifier contract)"
#'bad-args)]
[(_ #:type type args etc ...)
(not (identifier? #'args))
(raise-syntax-error 'with-contract
"expected identifier for blame"
#'args)]
[(_ #:type type etc ...)
(not (identifier? #'type))
(raise-syntax-error 'with-contract
"expected identifier for type"
#'type)]
[(_ #:type type blame)
(raise-syntax-error 'with-contract
"only blame"
stx)]
[(_ etc ...)
(syntax/loc stx
(with-contract #:type region etc ...))]))
;
;
;
; ; ; ;
; ; ;
; ; ; ; ;
; ; ;; ; ; ;;; ; ; ; ;; ; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;;
; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;; ; ;;; ; ; ;; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;;
; ; ;
; ; ;
; ;
;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
(define-for-syntax (lookup-struct-info stx provide-stx)
(let ([id (syntax-case stx ()
@ -59,46 +345,6 @@ improve method arity mismatch contract violation error messages?
provide-stx
id)))))
(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)))])))))
;; 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 #,id
#,(syntax-line id)
#,(syntax-column id)
#,(syntax-position id)
#,(syntax-span id))
#,(format "~s" (syntax->datum id))))
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
(make-set!-transformer
(let ([saved-id-table (make-hasheq)])
@ -140,51 +386,6 @@ improve method arity mismatch contract violation error messages?
;; delay expansion until it's a good time to lift expressions:
(quasisyntax/loc stx (#%expression #,stx)))))))
;; (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))]))
;
;
;
; ; ; ;
; ; ;
; ; ; ; ;
; ; ;; ; ; ;;; ; ; ; ;; ; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;;
; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;; ; ;;; ; ; ;; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;;
; ; ;
; ; ;
; ;
;; (provide/contract p/c-ele ...)
;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...)
@ -483,7 +684,7 @@ improve method arity mismatch contract violation error messages?
#f
(with-syntax ([field-contract-id field-contract-id]
[field-contract field-contract])
#'(define field-contract-id (verify-contract field-contract)))))
#'(define field-contract-id (verify-contract 'provide/contract field-contract)))))
field-contract-ids
field-contracts))]
[(field-contracts ...) field-contracts]
@ -671,7 +872,7 @@ improve method arity mismatch contract violation error messages?
#,@(if no-need-to-check-ctrct?
(list)
(list #'(define contract-id (verify-contract ctrct))))
(list #'(define contract-id (verify-contract 'provide/contract ctrct))))
(define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id)
(quote-syntax id)
@ -691,11 +892,6 @@ improve method arity mismatch contract violation error messages?
(begin
bodies ...))))]))
(define-syntax (verify-contract stx)
(syntax-case stx ()
[(_ x) (a:known-good-contract? #'x) #'x]
[(_ x) #'(coerce-contract 'provide/contract x)]))
(define (make-pc-struct-type struct-name struct:struct-name . ctcs)
(let-values ([(struct:struct-name _make _pred _get _set)
(make-struct-type struct-name

35
collects/scribblings/reference/contracts.scrbl
View File

@ -673,23 +673,36 @@ contract on the fields that the sub-struct shares with its parent are
only used in the contract for the sub-struct's maker, and the selector
or mutators for the super-struct are not provided.}
@defform[(define/contract id contract-expr init-value-expr)]{
@defform/subs[
(with-contract blame-id (wc-export ...) body ...+)
([wc-export
id
(id contract-expr)])]{
Generates a local contract boundary. The @scheme[contract-expr]
form cannot appear in expression position. The @scheme[body] of the
form allows definition/expression interleaving like a @scheme[module]
body. Names bound within the @scheme[body] must be exported to be
accessible from outside the @scheme[with-contract] form. Such
@scheme[id]s can either be paired with a @scheme[contract-expr] or
exported without a contract.
Attaches the contract @scheme[contract-expr] to
@scheme[init-value-expr] and binds that to @scheme[id].
The @scheme[blame-id] is used for the positive positions of
contracts paired with exported @scheme[id]s. Contracts broken
within the @scheme[with-contract] @scheme[body] will use the
@scheme[blame-id] for their negative position.}
@defform*[[(define/contract id contract-expr init-value-expr)
(define/contract (head args) contract-expr body ...+)]]{
Works like @scheme[define], except that the contract
@scheme[contract-expr] is attached to the bound value.
The @scheme[define/contract] form treats individual definitions as
units of blame. The definition itself is responsible for positive
(co-variant) positions of the contract and each reference to
@scheme[id] (including those in the initial value expression) must
meet the negative positions of the contract.
Error messages with @scheme[define/contract] are not as clear as those
provided by @scheme[provide/contract], because
@scheme[define/contract] cannot detect the name of the definition
where the reference to the defined variable occurs. Instead, it uses
the source location of the reference to the variable as the name of
that definition.}
meet the negative positions of the contract. It is equivalent to
wrapping a single @scheme[define] with a @scheme[with-contract] form
that pairs the @scheme[contract-expr] with the bound identifier.}
@defform*[[(contract contract-expr to-protect-expr
positive-blame-expr negative-blame-expr)

4
collects/tests/mzscheme/contract-mzlib-test.ss
View File

@ -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

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

@ -1,3 +1,4 @@
(load-relative "loadtest.ss")
(Section 'contract)
@ -75,7 +76,7 @@
(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)])))
@ -2160,6 +2161,323 @@
;
;
;
; ; ;;;; ;
; ;; ; ; ;
; ; ; ; ; ;
; ; ; ; ; ;
; ;; ; ;;; ;;;; ; ; ;; ;;; ; ;;; ;; ; ;; ;;;; ; ;; ;;; ;;; ;;;;
; ; ;; ; ; ; ;; ;;; ; ; ; ; ; ; ; ; ;;; ; ; ;;; ; ; ; ; ;
; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;
; ;; ; ;;; ;;;;;;;;;; ;;; ;;; ; ;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;;
;
;
;
(test/spec-passed
'define/contract1
'(let ()
(define/contract i integer? 1)
i))
(test/spec-failed
'define/contract2
'(let ()
(define/contract i integer? #t)
i)
"(definition i)")
(test/spec-failed
'define/contract3
'(let ()
(define/contract i (-> integer? integer?) (lambda (x) #t))
(i 1))
"(definition i)")
(test/spec-failed
'define/contract4
'(let ()
(define/contract i (-> integer? integer?) (lambda (x) 1))
(i #f))
"top-level")
(test/spec-failed
'define/contract5
'(let ()
(define/contract (i x) (-> integer? integer?) 1)
(i #f))
"top-level")
(test/spec-passed
'define/contract6
'(let ()
(define/contract (i x) (-> integer? integer?)
(cond
[(not (integer? x)) 1]
[else (i #f)]))
(i 1)))
(test/spec-passed
'define/contract7
'(let ()
(define/contract (contracted-func label t)
(string? string? . -> . string?)
t)
(contracted-func
"I'm a string constant with side effects"
"ans")))
(test/spec-passed
'define/contract8
'(let ()
(eval '(module contract-test-suite-define1 scheme/base
(require scheme/contract)
(define/contract x string? "a")
x))
(eval '(require 'contract-test-suite-define1))))
(test/spec-failed
'define/contract9
'(let ()
(define/contract (a n)
(-> number? number?)
(define/contract (b m)
(-> number? number?)
(+ m 1))
(b (zero? n)))
(a 5))
"(function a)")
(test/spec-failed
'define/contract10
'(let ()
(define/contract (a n)
(-> number? number?)
(define/contract (b m)
(-> number? number?)
#t)
(b (add1 n)))
(a 5))
"(function b)")
(test/spec-passed
'define/contract11
'(let ()
(define/contract (f n)
(-> number? number?)
(+ n 1))
(define/contract (g b m)
(-> boolean? number? number?)
(if b (f m) (f #t)))
(g #t 3)))
(test/spec-failed
'define/contract12
'(let ()
(define/contract (f n)
(-> number? number?)
(+ n 1))
(define/contract (g b m)
(-> boolean? number? number?)
(if b (f m) (f #t)))
(g #f 3))
"(function g)")
(test/spec-failed
'define/contract13
'(begin
(eval '(module foo-dc13 scheme/base
(require scheme/contract)
(define/contract (foo-dc13 n)
(-> number? number?)
(+ n 1))
(foo-dc13 #t)))
(eval '(require 'foo-dc13)))
"'foo-dc13")
(test/spec-failed
'define/contract14
'(begin
(eval '(module foo-dc14 scheme/base
(require scheme/contract)
(provide foo-dc14)
(define/contract (foo-dc14 n)
(-> number? number?)
(+ n 1))))
(eval '(module bar-dc14 scheme/base
(require 'foo-dc14)
(foo-dc14 #t)))
(eval '(require 'bar-dc14)))
"'bar-dc14")
(test/spec-failed
'define/contract15
'(begin
(eval '(module foo-dc15 scheme/base
(require scheme/contract)
(provide foo-dc15)
(define/contract (foo-dc15 n)
(-> number? number?)
(+ n 1))))
(eval '(require 'foo-dc15))
(eval '(foo-dc15 #t)))
"top-level")
;; Let's see how units + define/contract interact
(test/spec-failed
'define/contract16
'(begin
(eval '(module foo-dc16 scheme/base
(require scheme/contract)
(require scheme/unit)
(let ()
(define/contract (foo n)
(-> number? number?)
(define-signature U^
((contracted [x (-> number? number?)])))
(define-unit U@
(import)
(export U^)
(define (x n) #t))
(define-values/invoke-unit U@
(import)
(export U^))
(x n))
(foo 3))))
(eval '(require 'foo-dc16)))
"(unit U@)")
(test/spec-failed
'define/contract17
'(begin
(eval '(module foo-dc17 scheme/base
(require scheme/contract)
(require scheme/unit)
(let ()
(define/contract (foo n)
(-> number? number?)
(define-signature U^
((contracted [x (-> number? number?)])))
(define-unit U@
(import)
(export U^)
(define (x n) 3))
(define-values/invoke-unit U@
(import)
(export U^))
(x (zero? n)))
(foo 3))))
(eval '(require 'foo-dc17)))
"(function foo)")
(test/spec-failed
'define/contract18
'(begin
(eval '(module foo-dc17 scheme/base
(require scheme/contract)
(require scheme/unit)
(let ()
(define-signature U^
((contracted [x (-> number? number?)])))
(define-unit U@
(import)
(export U^)
;; Can't define/contract x directly because
;; x ends up bound to a transformer and thus
;; is syntax.
(define/contract (y n)
(-> number? boolean?) #t)
(define x y))
(define-values/invoke-unit U@
(import)
(export U^))
(x 3))))
(eval '(require 'foo-dc18)))
"(unit U@)")
;
;
;
; ; ;
; ;;
; ; ; ; ;
; ; ; ; ;
; ;;; ;;; ;;; ; ;;;; ; ;; ;;; ;; ; ;; ;;;; ; ;; ;;; ;;; ;;;;
; ; ; ; ;; ; ;; ; ; ; ; ; ;;; ; ; ;;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;
; ; ; ;;; ;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;;
;
;
;
(test/spec-passed
'with-contract1
'(let ()
(with-contract odd-even
([odd? (-> number? boolean?)]
[even? (-> number? boolean?)])
(define (odd? n)
(if (zero? n) #f (even? (sub1 n))))
(define (even? n)
(if (zero? n) #t (odd? (sub1 n)))))
(odd? 5)))
(test/spec-failed
'with-contract2
'(let ()
(with-contract odd-even
([odd? (-> number? boolean?)]
[even? (-> number? boolean?)])
(define (odd? n)
(if (zero? n) #f (even? (sub1 n))))
(define (even? n)
(if (zero? n) #t (odd? (sub1 n)))))
(odd? #t))
"top-level")
(test/spec-failed
'with-contract3
'(let ()
(with-contract odd-even
([odd? (-> number? boolean?)]
[even? (-> number? boolean?)])
(define (odd? n)
(if (zero? n) n (even? (sub1 n))))
(define (even? n)
(if (zero? n) #t (odd? (sub1 n)))))
(odd? 4))
"(region odd-even)")
;; Functions within the same with-contract region can call
;; each other however they want, so here we have even?
;; call odd? with a boolean, even though its contract in
;; the odd-even contract says it only takes numbers.
(test/spec-passed
'with-contract4
'(let ()
(with-contract odd-even
([odd? (-> number? boolean?)]
[even? (-> number? boolean?)])
(define (odd? n)
(cond
[(not (number? n)) #f]
[(zero? n) #f]
[else (even? (sub1 n))]))
(define (even? n)
(if (zero? n) #t (odd? (zero? n)))))
(odd? 5)))
;
;
;
@ -5623,7 +5941,7 @@ so that propagation occurs.
(make-s 1 2)
[s-a #f])))
(eval '(require 'pc11b-n)))
'n)
"'n")
|#
(test/spec-passed

10
collects/tests/units/test-unit-contracts.ss
View File

@ -152,3 +152,13 @@
(test-runtime-error exn:fail:contract? "unit9-1 provides wrong value for function f"
(invoke-unit unit9))
(define-values/invoke-unit
(unit
(import) (export sig2)
(define f values))
(import)
(export sig2))
(test-runtime-error exn:fail:contract? "top-level misuses f"
(f #t))