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

Add all changes from branches/with-contract (which this branch will replace

Browse Source 
eventually), plus a couple of fixes in contract-test.ss.

svn: r12451
This commit is contained in:
Stevie Strickland 2008-11-14 16:48:17 +00:00
parent 00abb80504
commit 3212d11712
7 changed files with 652 additions and 148 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

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

@ -1,5 +1,7 @@
#lang scribble/doc
@(require "common.ss"
scheme/sandbox
scribble/eval
scribble/struct
(for-label mzlib/contract))
@ -56,7 +58,6 @@ from @schememodname[scheme/contract]:
contract-violation->string
contract?
define-contract-struct
define/contract
false/c
flat-contract
flat-contract-predicate
@ -91,3 +92,42 @@ 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.
@examples[#:eval (parameterize ([sandbox-output 'string]
[sandbox-error-output 'string]
[sandbox-eval-limits #f])
(make-evaluator 'mzscheme))
(require mzlib/contract)
(define/contract f
(-> number? number?)
(lambda (x) (+ x 1)))
(define/contract g
(-> number? number?)
(lambda (x) (f #t)))
(define/contract i
(-> number? number?)
(lambda (x)
(if (number? x) (i #t) 0)))
(f 4)
(f #t)
(g 4)
(i 3)]}

43
collects/scheme/private/contract-arrow.ss
View File

@ -102,10 +102,9 @@ v4 todo:
#:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let* ([doms-proj (map (λ (x) ((proj-get x) x))
(if (->-dom-rest/c ctc)
(append (->-doms/c ctc) (list (->-dom-rest/c ctc)))
(->-doms/c ctc)))]
(let* ([doms-proj (map (λ (x) ((proj-get x) x)) (->-doms/c ctc))]
[rest-proj (and (->-dom-rest/c ctc)
((λ (x) ((proj-get x) x)) (->-dom-rest/c ctc)))]
[doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))]
[rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))]
[mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))]
@ -117,22 +116,36 @@ v4 todo:
[optionals-length (length (->-optional-doms/c ctc))]
[has-rest? (and (->-dom-rest/c ctc) #t)])
(λ (pos-blame neg-blame src-info orig-str)
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
doms-proj)]
[partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
doms-optional-proj)]
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
rngs-proj)]
[partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
mandatory-kwds-proj)]
[partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
optional-kwds-proj)])
(let ([partial-doms (for/list ([dom (in-list doms-proj)]
[n (in-naturals 1)])
(dom neg-blame pos-blame src-info
(cons (format "required argument ~a" n) orig-str)))]
[partial-rest (if rest-proj
(list (rest-proj neg-blame pos-blame src-info
(cons "rest argument" orig-str)))
null)]
[partial-optional-doms (for/list ([dom (in-list doms-optional-proj)]
[n (in-naturals 1)])
(dom neg-blame pos-blame src-info
(cons (format "optional argument ~a" n) orig-str)))]
[partial-ranges (for/list ([rng (in-list rngs-proj)]
[n (in-naturals 1)])
(rng pos-blame neg-blame src-info
(cons (format "result ~a" n) orig-str)))]
[partial-mandatory-kwds (for/list ([kwd (in-list mandatory-kwds-proj)]
[kwd-lit (in-list mandatory-keywords)])
(kwd neg-blame pos-blame src-info
(cons (format "keyword argument ~a" kwd-lit) orig-str)))]
[partial-optional-kwds (for/list ([kwd (in-list optional-kwds-proj)]
[kwd-lit (in-list optional-keywords)])
(kwd neg-blame pos-blame src-info
(cons (format "keyword argument ~a" kwd-lit) orig-str)))])
(apply func
(λ (val mtd?)
(if has-rest?
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str)
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
(append partial-doms partial-optional-doms
(append partial-doms partial-rest partial-optional-doms
partial-mandatory-kwds partial-optional-kwds
partial-ranges))))))

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

@ -1,7 +1,8 @@
#lang scheme/base
(require "contract-helpers.ss"
scheme/pretty)
scheme/pretty
(only-in scheme/list add-between))
(require (for-syntax scheme/base
"contract-helpers.ss"))
@ -175,23 +176,35 @@
(lambda (x) (get x 0))
(lambda (x) (get x 1)))))
(define (default-contract-violation->string val src-info to-blame contract-sexp msg)
(define (default-contract-violation->string val src-info to-blame contract-sexp+extra msg)
(define (add-modifiers-to-contract modifiers contract-str)
(if (null? modifiers)
contract-str
(string-append "for "
(apply string-append (add-between modifiers " of "))
" in " contract-str)))
(let ([blame-src (src-info-as-string src-info)]
[formatted-contract-sexp
(let ([one-line
(let ([sp (open-output-string)])
(parameterize ([pretty-print-print-line print-contract-liner]
[pretty-print-columns 'infinity])
(pretty-print contract-sexp sp)
(get-output-string sp)))])
(if (< (string-length one-line) 30)
one-line
(let ([sp (open-output-string)])
(newline sp)
(parameterize ([pretty-print-print-line print-contract-liner]
[pretty-print-columns 50])
(pretty-print contract-sexp sp))
(get-output-string sp))))]
(let-values ([(modifiers contract-sexp)
(let loop ([dlist contract-sexp+extra]
[modifiers null])
(if (and (pair? dlist)
(string? (car dlist)))
(loop (cdr dlist) (cons (car dlist) modifiers))
(values (reverse modifiers) dlist)))])
(let ([one-line
(let ([sp (open-output-string)])
(parameterize ([pretty-print-columns 'infinity])
(pretty-print contract-sexp sp)
(get-output-string sp)))])
(if (< (string-length one-line) 30)
(add-modifiers-to-contract modifiers one-line)
(let ([sp (open-output-string)])
(newline sp)
(parameterize ([pretty-print-print-line print-contract-liner]
[pretty-print-columns 50])
(pretty-print contract-sexp sp))
(add-modifiers-to-contract modifiers (get-output-string sp))))))]
[specific-blame
(cond
[(syntax? src-info)
@ -210,8 +223,9 @@
(pair? (cdr to-blame))
(null? (cddr to-blame))
(equal? 'quote (car to-blame)))
(format "'~s" (cadr to-blame))]
[else (format "~s" to-blame)])
(format "module '~s" (cadr to-blame))]
[(string? to-blame) to-blame]
[else (format "module ~s" to-blame)])
formatted-contract-sexp
specific-blame)
msg)))
@ -516,4 +530,4 @@
#:property name-prop (λ (ctc) (predicate-contract-name ctc))
#:property flat-prop (λ (ctc) (predicate-contract-pred ctc)))
(define (build-flat-contract name pred) (make-predicate-contract name pred))
(define (build-flat-contract name pred) (make-predicate-contract name pred))

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

@ -12,13 +12,19 @@ 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
mzlib/etc)
(require "contract-arrow.ss"
"contract-guts.ss"
@ -28,6 +34,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 +70,255 @@ 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 #f)
(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id)
(make-set!-transformer
(lambda (stx)
(with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region)
#'(#%variable-reference))]
[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)
(for/list ([stx body-stxs])
(local-expand stx
(syntax-local-context)
(kernel-form-identifier-list))))
(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 ([(unprotected protected protections)
(check-and-split-with-contract-args (syntax->list #'(arg ...)))]
[(expanded-bodies) (head-expand-all (cons #'body0
(syntax->list #'(body ...))))]
[(protected-ids ids contracts contract-defs)
(for/lists (protected-ids ids contracts contract-defs)
([n protected]
[c protections])
(let ([new-id (a:mangle-id stx "with-contract-id" n)])
(if (a:known-good-contract? c)
(values n new-id c #f)
(let ([contract-id (a:mangle-id stx "with-contract-contract-id" n)])
(values n new-id 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 ([((protected-id id contract) ...)
(map list protected-ids ids contracts)]
[(contract-def ...) (filter values contract-defs)]
[blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))]
[(unprotected-id ...) unprotected])
(quasisyntax/loc stx
(begin
(define-values (unprotected-id ... id ...)
(syntax-parameterize ([current-contract-region blame-str])
(begin-with-definitions
#,@expanded-bodies
(values unprotected-id ... protected-id ...))))
contract-def ...
(define-syntax protected-id
(make-with-contract-transformer
(quote-syntax contract)
(quote-syntax id)
blame-str)) ...)))))]
[(_ #: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 +332,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 +373,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 +671,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 +859,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 +879,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

20
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)])))
@ -103,8 +103,8 @@ of the contract library does not change over time.
(and (exn? exn)
(,has-proper-blame? (exn-message exn))))))))))
(define (test/pos-blame name expression) (test/spec-failed name expression "pos"))
(define (test/neg-blame name expression) (test/spec-failed name expression "neg"))
(define (test/pos-blame name expression) (test/spec-failed name expression "module pos"))
(define (test/neg-blame name expression) (test/spec-failed name expression "module neg"))
(define (test/well-formed stx)
(contract-eval
@ -126,7 +126,7 @@ of the contract library does not change over time.
(contract-eval `(,test #t flat-contract? ,contract))
(test/spec-failed (format "~a fail" name)
`(contract ,contract ',fail 'pos 'neg)
"pos")
"module pos")
(test/spec-passed/result
(format "~a pass" name)
`(contract ,contract ',pass 'pos 'neg)
@ -1577,14 +1577,14 @@ of the contract library does not change over time.
'(let ()
(define/contract i integer? #t)
i)
"i")
"definition i")
(test/spec-failed
'define/contract3
'(let ()
(define/contract i (-> integer? integer?) (lambda (x) #t))
(i 1))
"i")
"definition i")
(test/spec-failed
'define/contract4
@ -4643,7 +4643,7 @@ so that propagation occurs.
(provide/contract (x integer?))))
(eval '(require 'contract-test-suite3))
(eval 'x))
"'contract-test-suite3")
"module 'contract-test-suite3")
(test/spec-passed
'provide/contract4
@ -4820,7 +4820,7 @@ so that propagation occurs.
(make-s 1 2)
[s-a #f])))
(eval '(require 'pc11b-n)))
'n)
"module 'n")
|#
(test/spec-passed
@ -4888,7 +4888,7 @@ so that propagation occurs.
(define i #f)
(provide/contract [i integer?])))
(eval '(require 'pos)))
"'pos")
"module 'pos")
;; this is really a positive violation, but name the module `neg' just for an addl test
(test/spec-failed
@ -4899,7 +4899,7 @@ so that propagation occurs.
(define i #f)
(provide/contract [i integer?])))
(eval '(require 'neg)))
"'neg")
"module 'neg")
;; this test doesn't pass yet ... waiting for support from define-struct

261
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)])))
@ -97,8 +98,8 @@
(and (exn? exn)
(,has-proper-blame? (exn-message exn))))))))))
(define (test/pos-blame name expression) (test/spec-failed name expression "pos"))
(define (test/neg-blame name expression) (test/spec-failed name expression "neg"))
(define (test/pos-blame name expression) (test/spec-failed name expression "module pos"))
(define (test/neg-blame name expression) (test/spec-failed name expression "module neg"))
(define (test/well-formed stx)
(contract-eval
@ -120,7 +121,7 @@
(contract-eval `(,test #t flat-contract? ,contract))
(test/spec-failed (format "~a fail" name)
`(contract ,contract ',fail 'pos 'neg)
"pos")
"module pos")
(test/spec-passed/result
(format "~a pass" name)
`(contract ,contract ',pass 'pos 'neg)
@ -2160,6 +2161,250 @@
;
;
;
; ; ;;;; ;
; ;; ; ; ;
; ; ; ; ; ;
; ; ; ; ; ;
; ;; ; ;;; ;;;; ; ; ;; ;;; ; ;;; ;; ; ;; ;;;; ; ;; ;;; ;;; ;;;;
; ; ;; ; ; ; ;; ;;; ; ; ; ; ; ; ; ; ;;; ; ; ;;; ; ; ; ; ;
; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;
; ;; ; ;;; ;;;;;;;;;; ;;; ;;; ; ;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;;
;
;
;
(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))
"module top-level")
(test/spec-failed
'define/contract5
'(let ()
(define/contract (i x) (-> integer? integer?) 1)
(i #f))
"module 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)))
"module '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)))
"module '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)))
"module top-level")
;
;
;
; ; ;
; ;;
; ; ; ; ;
; ; ; ; ;
; ;;; ;;; ;;; ; ;;;; ; ;; ;;; ;; ; ;; ;;;; ; ;; ;;; ;;; ;;;;
; ; ; ; ;; ; ;; ; ; ; ; ; ;;; ; ; ;;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;
; ; ; ;;; ;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;;
;
;
;
(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))
"module 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)))
;
;
;
@ -5380,7 +5625,7 @@ so that propagation occurs.
(provide/contract (x integer?))))
(eval '(require 'contract-test-suite3))
(eval 'x))
"'contract-test-suite3")
"module 'contract-test-suite3")
(test/spec-passed
'provide/contract4
@ -5557,7 +5802,7 @@ so that propagation occurs.
(make-s 1 2)
[s-a #f])))
(eval '(require 'pc11b-n)))
'n)
"module 'n")
|#
(test/spec-passed
@ -5625,7 +5870,7 @@ so that propagation occurs.
(define i #f)
(provide/contract [i integer?])))
(eval '(require 'pos)))
"'pos")
"module 'pos")
;; this is really a positive violation, but name the module `neg' just for an addl test
(test/spec-failed
@ -5636,7 +5881,7 @@ so that propagation occurs.
(define i #f)
(provide/contract [i integer?])))
(eval '(require 'neg)))
"'neg")
"module 'neg")
;; this test doesn't pass yet ... waiting for support from define-struct