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

..

Browse Source 
original commit: 4d74daf4d9752872e2edd02ab3ac60e1de96649d
This commit is contained in:
Robby Findler 2003-01-15 22:00:20 +00:00
parent 0eb3c57f1b
commit e0b93e85f5
2 changed files with 176 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

238
collects/mzlib/contracts.ss
View File

@ -425,7 +425,52 @@
; ;
; ;
;; contract = (make-contract (alpha
;; sym
;; sym
;; (union syntax #f)
;; ->
;; alpha)
;; (contract alpha sym src-info -> alpha)
;; (??? -> ???)
;; generic contract container;
;; the first argument to wrap is the value to test the contract.
;; the second to wrap is a symbol representing the name of the positive blame
;; the third to wrap is the symbol representing the name of the negative blame
;; the fourth argument to wrap is the src-info.
;;
;; impl-builder and impl-info are two pieces used to build
;; implication contracts.
(define-struct contract (wrap impl-builder impl-info))
;; flat-named-contract = (make-flat-named-contract string (any -> boolean))
;; this holds flat contracts that have names for error reporting
(define-struct flat-named-contract (type-name predicate))
(provide (rename build-flat-named-contract flat-named-contract)
flat-named-contract-type-name
flat-named-contract-predicate)
(define build-flat-named-contract
(let ([flat-named-contract
(lambda (name contract)
(unless (and (string? name)
(procedure? contract)
(procedure-arity-includes? contract 1))
(error 'flat-named-contract "expected string and procedure of one argument as arguments, given: ~e and ~e"
name contract))
(make-flat-named-contract name contract))])
flat-named-contract))
(define -contract?
(let ([contract?
(lambda (val)
(or (contract? val) ;; refers to struct predicate
(flat-named-contract? val)
(and (procedure? val)
(procedure-arity-includes? val 1))))])
contract?))
(define-syntax -contract (define-syntax -contract
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
@ -468,7 +513,7 @@
(define (check-contract contract val pos neg src-info) (define (check-contract contract val pos neg src-info)
(cond (cond
[(contract? contract) [(contract? contract)
((contract-f contract) val pos neg src-info)] ((contract-wrap contract) val pos neg src-info)]
[(flat-named-contract? contract) [(flat-named-contract? contract)
(if ((flat-named-contract-predicate contract) val) (if ((flat-named-contract-predicate contract) val)
val val
@ -492,17 +537,17 @@
(define-syntax (contract-=> stx) (define-syntax (contract-=> stx)
(syntax-case stx () (syntax-case stx ()
[(_ c1-e c2-e val-e tbb-e) [(_ ant-e conq-e val-e tbb-e)
(with-syntax ([src-loc (datum->syntax-object stx 'here)]) (with-syntax ([src-loc (datum->syntax-object stx 'here)])
(syntax/loc stx (syntax/loc stx
(contract-=> c1-e c2-e val-e tbb-e (quote-syntax src-loc))))] (contract-=> ant-e conq-e val-e tbb-e (quote-syntax src-loc))))]
[(_ c1-e c2-e val-e tbb-e src-loc-e) [(_ ant-e conq-e val-e tbb-e src-info-e)
(syntax/loc stx (syntax/loc stx
(let ([c1 c1-e] (let ([c1 ant-e]
[c2 c2-e] [c2 conq-e]
[val val-e] [val val-e]
[tbb tbb-e] [tbb tbb-e]
[src-loc src-loc-e]) [src-info src-info-e])
(unless (-contract? c1) (unless (-contract? c1)
(error 'contract-=> "expected a contract as first argument, given: ~e, other args ~e ~e ~e ~e" (error 'contract-=> "expected a contract as first argument, given: ~e, other args ~e ~e ~e ~e"
c1 c1
@ -534,38 +579,43 @@
(check-implication c1 c2 val tbb src-info)))])) (check-implication c1 c2 val tbb src-info)))]))
;; check-implication : contract contract any symbol (union syntax #f) -> any ;; check-implication : contract contract any symbol (union syntax #f) -> any
(define (check-implication c1 c2 val tbb src-info) (define (check-implication antecedent consequent val tbb src-info)
(cond (cond
[(and (contract? c1) (contract? c2)) [(and (contract? antecedent) (contract? consequent))
(error 'check-implication "not implemented")] ((contract-impl-builder consequent)
[(or (contract? c1) (contract? c2)) antecedent
(raise-contract-implication-error c1 c2 val tbb src-info)] consequent
val
tbb
src-info)]
[(or (contract? antecedent) (contract? consequent))
(raise-contract-implication-error antecedent consequent val tbb src-info)]
[else [else
(let ([test-contract (let ([test-contract
(lambda (c) (lambda (c)
(cond (cond
[(flat-named-contract? c) ((flat-named-contract-predicate c) val)] [(flat-named-contract? c) ((flat-named-contract-predicate c) val)]
[else (c val)]))]) [else (c val)]))])
(if (or (not (test-contract c1)) (if (or (not (test-contract antecedent))
(test-contract c2)) (test-contract consequent))
val val
(raise-contract-implication-error c1 c2 val tbb src-info)))])) (raise-contract-implication-error antecedent consequent val tbb src-info)))]))
;; raise-contract-implication-error : contract contract any symbol (union syntax #f) -> alpha ;; raise-contract-implication-error : contract contract any symbol (union syntax #f) -> alpha
;; escapes ;; escapes
(define (raise-contract-implication-error c1 c2 val tbb src-info) (define (raise-contract-implication-error antecedent consequent val tbb src-info)
(let ([blame-src (src-info-as-string src-info)]) (let ([blame-src (src-info-as-string src-info)])
(raise (raise
(make-exn (make-exn
(string->immutable-string (string->immutable-string
(format "~a~a does not imply ~a for ~e" (format "~a~a: ~a does not imply ~a for ~e"
blame-src blame-src
(contract->type-name c1) tbb
(contract->type-name c2) (contract->type-name antecedent)
(contract->type-name consequent)
val)) val))
(current-continuation-marks))))) (current-continuation-marks)))))
;; raise-contract-error : (union syntax #f) symbol symbol string args ... -> alpha ;; raise-contract-error : (union syntax #f) symbol symbol string args ... -> alpha
;; doesn't return ;; doesn't return
(define (raise-contract-error src-info to-blame other-party fmt . args) (define (raise-contract-error src-info to-blame other-party fmt . args)
@ -595,49 +645,6 @@
"")) ""))
"")) ""))
;; contract = (make-contract (alpha
;; sym
;; sym
;; (union syntax #f)
;; ->
;; alpha))
;; generic contract container;
;; the first argument to f is the value to test the contract.
;; the second to f is a symbol representing the name of the positive blame
;; the third to f is the symbol representing the name of the negative blame
;; the fourth argument is the src-info.
(define-struct contract (f))
(define-struct (->*contract contract) (doms rngs implication-maker))
;; flat-named-contract = (make-flat-named-contract string (any -> boolean))
;; this holds flat contracts that have names for error reporting
(define-struct flat-named-contract (type-name predicate))
(provide (rename build-flat-named-contract flat-named-contract)
flat-named-contract-type-name
flat-named-contract-predicate)
(define build-flat-named-contract
(let ([flat-named-contract
(lambda (name contract)
(unless (and (string? name)
(procedure? contract)
(procedure-arity-includes? contract 1))
(error 'flat-named-contract "expected string and procedure of one argument as arguments, given: ~e and ~e"
name contract))
(make-flat-named-contract name contract))])
flat-named-contract))
(define -contract?
(let ([contract?
(lambda (val)
(or (contract? val) ;; refers to struct predicate
(flat-named-contract? val)
(and (procedure? val)
(procedure-arity-includes? val 1))))])
contract?))
;; predicate->expected-msg : function -> string ;; predicate->expected-msg : function -> string
;; if the function has a name and the name ends ;; if the function has a name and the name ends
;; with a question mark, turn it into a mzscheme ;; with a question mark, turn it into a mzscheme
@ -711,7 +718,7 @@
(define (case->/proc stx) (define (case->/proc stx)
(syntax-case stx () (syntax-case stx ()
[(_ case ...) [(_ case ...)
(let-values ([(add-outer-check make-inner-check make-bodies) (let-values ([(add-outer-check make-inner-check make-bodies _1 _2)
(case->/h stx (syntax->list (syntax (case ...))))]) (case->/h stx (syntax->list (syntax (case ...))))])
(let ([outer-args (syntax (val pos-blame neg-blame src-info))]) (let ([outer-args (syntax (val pos-blame neg-blame src-info))])
(with-syntax ([outer-args outer-args] (with-syntax ([outer-args outer-args]
@ -726,7 +733,9 @@
(make-contract (make-contract
(lambda outer-args (lambda outer-args
inner-check ... inner-check ...
inner-lambda))))))))])) inner-lambda)
(lambda x (error 'impl-contract "unimplemented"))
(lambda x (error 'impl-contract "unimplemented")) )))))))]))
(define (class-contract/proc stx) (define (class-contract/proc stx)
(syntax-case stx () (syntax-case stx ()
@ -735,7 +744,8 @@
(match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...) (match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...)
(map (lambda (meth-contract-stx) (map (lambda (meth-contract-stx)
(let ([/h (select/h meth-contract-stx 'class-contract stx)]) (let ([/h (select/h meth-contract-stx 'class-contract stx)])
(let-values ([(make-outer-check xxx build-pieces) (/h meth-contract-stx)]) (let-values ([(make-outer-check xxx build-pieces impl-builder impl-info)
(/h meth-contract-stx)])
(list make-outer-check xxx build-pieces)))) (list make-outer-check xxx build-pieces))))
(syntax->list (syntax (meth-contract ...))))]) (syntax->list (syntax (meth-contract ...))))])
(let* ([outer-args (syntax (val pos-blame neg-blame src-info))] (let* ([outer-args (syntax (val pos-blame neg-blame src-info))]
@ -767,7 +777,9 @@
(class val (class val
(rename [super-meth-name meth-name] ...) (rename [super-meth-name meth-name] ...)
method ... method ...
(super-instantiate ()))))) (super-instantiate ())))
(lambda x (error 'impl-contract "unimplemented"))
(lambda x (error 'impl-contract "unimplemented"))))
make-outer-checks))))] make-outer-checks))))]
[(_ (meth-name meth-contract) ...) [(_ (meth-name meth-contract) ...)
(for-each (lambda (name) (for-each (lambda (name)
@ -857,7 +869,12 @@
(error '-> "expected contract as argument, given: ~e" rng-x)) (error '-> "expected contract as argument, given: ~e" rng-x))
body))))] body))))]
[->body (syntax (->* (dom-x ...) (rng-x)))]) [->body (syntax (->* (dom-x ...) (rng-x)))])
(let-values ([(->*add-outer-check ->*make-inner-check ->*make-body) (->*/h ->body)]) (let-values ([(->*add-outer-check
->*make-inner-check
->*make-body
impl-builder
impl-info)
(->*/h ->body)])
(values (values
(lambda (body) (->add-outer-check (->*add-outer-check body))) (lambda (body) (->add-outer-check (->*add-outer-check body)))
(lambda (stx) (->*make-inner-check stx)) (lambda (stx) (->*make-inner-check stx))
@ -870,15 +887,21 @@
(check-contract dom-x arg-x neg-blame pos-blame src-info) (check-contract dom-x arg-x neg-blame pos-blame src-info)
...))))) ...)))))
(lambda (stx) (lambda (stx)
(->*make-body stx)))))))))])) (->*make-body stx)))
impl-builder
impl-info))))))]))
;; ->*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->*/h stx) (define (->*/h stx)
(syntax-case stx () (syntax-case stx ()
[(_ (dom ...) (rng ...)) [(_ (dom ...) (rng ...))
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
[(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
[(rng-x ...) (generate-temporaries (syntax (rng ...)))] [(rng-x ...) (generate-temporaries (syntax (rng ...)))]
[(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))]
[(res-x ...) (generate-temporaries (syntax (rng ...)))] [(res-x ...) (generate-temporaries (syntax (rng ...)))]
[arity (length (syntax->list (syntax (dom ...))))]) [arity (length (syntax->list (syntax (dom ...))))])
(values (values
@ -918,7 +941,21 @@
pos-blame pos-blame
neg-blame neg-blame
src-info) src-info)
...))))))))] ...))))))
(syntax
(lambda (ant conq val tbb src-info)
(let* ([ant-info (contract-impl-info conq)]
[dom-ant-info (ant-info dom-length)])
(if dom-ant-info
(let ([dom-ant-x (vector-ref dom-ant-info dom-index)] ...)
(lambda (arg-x ...)
(val (check-implication dom-x dom-ant-x arg-x tbb src-info) ...)))
(raise-contract-implication-error ant conq val tbb src-info)))))
(syntax
(lambda (len)
(cond
[(= len dom-length) (vector dom-x ...)]
[else #f])))))]
[(_ (dom ...) rest (rng ...)) [(_ (dom ...) rest (rng ...))
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
@ -966,7 +1003,9 @@
pos-blame pos-blame
neg-blame neg-blame
src-info) src-info)
...))))))))])) ...))))))
(syntax (lambda x (error 'impl-contract "unimplemented")))
(syntax (lambda x (error 'impl-contract "unimplemented")))))]))
;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->d/h stx) (define (->d/h stx)
@ -1017,7 +1056,9 @@
(val (check-contract dom-x arg-x neg-blame pos-blame src-info) ...) (val (check-contract dom-x arg-x neg-blame pos-blame src-info) ...)
pos-blame pos-blame
neg-blame neg-blame
src-info)))))))))])) src-info))))))
(syntax (lambda x (error 'impl-contract "unimplemented")))
(syntax (lambda x (error 'impl-contract "unimplemented"))))))]))
;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->d*/h stx) (define (->d*/h stx)
@ -1079,7 +1120,9 @@
neg-blame neg-blame
src-info)) src-info))
rng-contracts rng-contracts
results))))))))))))] results))))))))))
(syntax (lambda x (error 'impl-contract "unimplemented")))
(syntax (lambda x (error 'impl-contract "unimplemented")))))]
[(_ (dom ...) rest rng-mk) [(_ (dom ...) rest rng-mk)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
@ -1140,30 +1183,35 @@
neg-blame neg-blame
src-info )) src-info ))
rng-contracts rng-contracts
results))))))))))))])) results))))))))))
(syntax (lambda x (error 'impl-contract "unimplemented")))
(syntax (lambda x (error 'impl-contract "unimplemented")))))]))
;; make-/proc : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) ;; make-/proc : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
;; syntax ;; syntax
;; -> (syntax -> syntax) ;; -> (syntax -> syntax)
(define (make-/proc /h stx) (define (make-/proc /h stx)
(let-values ([(add-outer-check make-inner-check make-main) (/h stx)]) (let-values ([(add-outer-check make-inner-check make-main impl-first impl-second) (/h stx)])
(let ([outer-args (syntax (val pos-blame neg-blame src-info))]) (let ([outer-args (syntax (val pos-blame neg-blame src-info))])
(with-syntax ([outer-args outer-args] (with-syntax ([outer-args outer-args]
[inner-check (make-inner-check outer-args)] [inner-check (make-inner-check outer-args)]
[(inner-args body) (make-main outer-args)]) [(inner-args body) (make-main outer-args)]
[impl-first impl-first]
[impl-second impl-second])
(with-syntax ([inner-lambda (with-syntax ([inner-lambda
(set-inferred-name-from (set-inferred-name-from
stx stx
(syntax/loc stx (lambda inner-args body)))]) (syntax/loc stx (lambda inner-args body)))])
(add-outer-check (add-outer-check
(set-inferred-name-from (set-inferred-name-from
stx stx
(syntax/loc stx (syntax/loc stx
(make-contract (make-contract
(lambda outer-args (lambda outer-args
inner-check inner-check
inner-lambda)))))))))) inner-lambda)
impl-first
impl-second)))))))))
;; case->/h : syntax (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; case->/h : syntax (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
;; like the other /h functions, but composes the wrapper functions ;; like the other /h functions, but composes the wrapper functions
@ -1173,11 +1221,13 @@
(cond (cond
[(null? cases) (values (lambda (x) x) [(null? cases) (values (lambda (x) x)
(lambda (args) (syntax ())) (lambda (args) (syntax ()))
(lambda (args) (syntax ())))] (lambda (args) (syntax ()))
(syntax (lambda x (error 'impl-contract "unimplemented")))
(syntax (lambda x (error 'impl-contract "unimplemented"))))]
[else [else
(let ([/h (select/h (car cases) 'case-> orig-stx)]) (let ([/h (select/h (car cases) 'case-> orig-stx)])
(let-values ([(add-outer-checks make-inner-checks make-bodies) (loop (cdr cases))] (let-values ([(add-outer-checks make-inner-checks make-bodies _a _b) (loop (cdr cases))]
[(add-outer-check make-inner-check make-body) (/h (car cases))]) [(add-outer-check make-inner-check make-body _1 _2) (/h (car cases))])
(values (values
(lambda (x) (add-outer-check (add-outer-checks x))) (lambda (x) (add-outer-check (add-outer-checks x)))
(lambda (args) (lambda (args)
@ -1187,7 +1237,9 @@
(lambda (args) (lambda (args)
(with-syntax ([case (make-body args)] (with-syntax ([case (make-body args)]
[cases (make-bodies args)]) [cases (make-bodies args)])
(syntax (case . cases)))))))]))) (syntax (case . cases))))
(syntax (lambda x (error 'impl-contract "unimplemented")))
(syntax (lambda x (error 'impl-contract "unimplemented"))))))])))
;; select/h : syntax -> /h-function ;; select/h : syntax -> /h-function
(define (select/h stx err-name ctxt-stx) (define (select/h stx err-name ctxt-stx)
@ -1216,7 +1268,19 @@
(cond (cond
[(null? l) (error 'all-but-last "bad input")] [(null? l) (error 'all-but-last "bad input")]
[(null? (cdr l)) null] [(null? (cdr l)) null]
[else (cons (car l) (all-but-last (cdr l)))]))) [else (cons (car l) (all-but-last (cdr l)))]))
;; generate-indicies : syntax[list] -> (cons number (listof number))
;; given a syntax list of length `n', returns a list containing
;; the number n followed by th numbers from 0 to n-1
(define (generate-indicies stx)
(let ([n (length (syntax->list stx))])
(cons n
(let loop ([i n])
(cond
[(zero? i) null]
[else (cons (- n i)
(loop (- i 1)))]))))))
(define-syntax (opt-> stx) (define-syntax (opt-> stx)
(syntax-case stx () (syntax-case stx ()
@ -1307,7 +1371,9 @@
[(null? contracts) [(null? contracts)
(raise-contract-error src-info pos neg "union failed, given: ~e" val)] (raise-contract-error src-info pos neg "union failed, given: ~e" val)]
[(null? (cdr contracts)) [(null? (cdr contracts))
((contract-f (car contracts)) val pos neg src-info)])))]))) ((contract-wrap (car contracts)) val pos neg src-info)]))
(lambda x (error 'impl-contract "unimplemented"))
(lambda x (error 'impl-contract "unimplemented")))])))
(provide and/f or/f (provide and/f or/f
>=/c <=/c </c >/c >=/c <=/c </c >/c

26
collects/tests/mzscheme/contracts.ss
View File

@ -13,13 +13,20 @@
(let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval)
(list expression '(void)))) (list expression '(void))))
(define (test/spec-passed/result name expression result)
(test result
eval
expression))
;; test/spec-failed : symbol sexp string -> void ;; test/spec-failed : symbol sexp string -> void
;; tests a failing specification with blame assigned to `blame' ;; tests a failing specification with blame assigned to `blame'
(define (test/spec-failed name expression blame) (define (test/spec-failed name expression blame)
(define (failed-contract x) (define (failed-contract x)
(and (string? x) (and (string? x)
(let ([m (regexp-match ": ([^ ]*) broke" x)]) (cond
(and m (cadr m))))) [(regexp-match ": ([^ ]*) broke" x) => cadr]
[(regexp-match "([^ ]+): .* does not imply" x) => cadr]
[else #f])))
(test blame (test blame
failed-contract failed-contract
(with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x))) (with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
@ -540,6 +547,21 @@
(define-struct s (a)))) (define-struct s (a))))
(eval '(require contract-test-suite6)) (eval '(require contract-test-suite6))
(eval '(define-struct (t s) ())))) (eval '(define-struct (t s) ()))))
(test/spec-passed/result
'contract-=>1
'(contract-=> (>=/c 5) (>=/c 10) 1 'badguy)
1)
(test/spec-passed/result
'contract-=>2
'(contract-=> (>=/c 5) (>=/c 10) 12 'badguy)
12)
(test/spec-failed
'contract-=>3
'(contract-=> (>=/c 5) (>=/c 10) 6 'badguy)
"badguy")
)) ))
(report-errs) (report-errs)