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

mostly finished the contract library changes

Browse Source 
svn: r8195
This commit is contained in:
Robby Findler 2008-01-03 18:10:43 +00:00
parent cbcb5bf57b
commit 3cf6ed4673
11 changed files with 853 additions and 2368 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/mred/private/editor.ss
View File

@ -81,6 +81,20 @@
set-modified set-filename
get-file put-file
get-max-undo-history)
(rename-super [super-on-char on-char])
(define time 0)
(define count 0)
(override* [on-char
(λ (evt)
(let-values ([(results cpu real gc)
(time-apply (λ () (super-on-char evt)) '())])
(set! time (+ real time))
(set! count (+ count 1))
(when (= count 20)
(printf "time ~s\n" time)
(set! count 0)
(set! time 0))
(apply values results)))])
(define canvases null)
(define active-canvas #f)
(define auto-set-wrap? #f)

3
collects/mzlib/private/contract-object.ss
View File

@ -338,7 +338,8 @@
(let ([cls (make-wrapper-class 'wrapper-class
'(method-name ...)
(list methods ...)
'(field-name ...))])
'(field-name ...)
#t)])
(make-proj-contract
`(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ...

6
collects/scheme/contract.ss
View File

@ -22,7 +22,11 @@ differences from v3:
(except-out (all-from-out "private/contract-ds.ss")
lazy-depth-to-look)
(all-from-out "private/contract-arrow.ss")
(except-out (all-from-out "private/contract-arrow.ss")
making-a-method
procedure-accepts-and-more?
check-procedure
check-procedure/more)
(except-out (all-from-out "private/contract.ss")
check-between/c
check-unary-between/c))

40
collects/scheme/private/class-internal.ss
View File

@ -3363,8 +3363,9 @@
;; make-wrapper-class : symbol
;; (listof symbol)
;; (listof (selector -> method-func-spec[object args -> result]))
;; method-spec [depends on the boolean what it is]
;; (listof symbol)
;; boolean
;; -> class
;; the resulting class is the "proxy" class for the contracted version of an
;; object with contracts on the method-ids.
@ -3379,7 +3380,7 @@
;; The class accepts one initialization argument per method and
;; one init arg per field (in that order) using the make-object style
;; initialization.
(define (make-wrapper-class class-name method-ids methods field-ids)
(define (make-wrapper-class class-name method-ids methods field-ids old-style?)
(let* ([supers (vector object% #f)]
[method-ht (make-hash-table)]
[method-count (length method-ids)]
@ -3403,7 +3404,9 @@
(list->vector (map (lambda (x) 'final) method-ids))
'dont-use-me!
(+ 1 field-count method-count)
(if old-style?
(+ field-count method-count 1)
field-count)
field-ht
field-ids
@ -3423,7 +3426,9 @@
(make-struct-type 'wrapper-object
struct:wrapper-object
0
(+ (length field-ids) (length method-ids))
(if old-style?
(+ (length field-ids) (length method-ids))
(length field-ids))
undefined
(list (cons prop:object cls))
insp)])
@ -3435,11 +3440,8 @@
(let ([init
(lambda (o continue-make-super c inited? named-args leftover-args)
;; leftover args will contain:
;; the original object,
;; all of the contract-ized versions of the methods,
;; and all of the contract-ized versions of the fields
;; just fill them into `o'.
;; leftover args will contain the original object and new field values
;; fill the original object in and then fill in the fields.
(set-wrapper-object-wrapped! o (car leftover-args))
(let loop ([leftover-args (cdr leftover-args)]
[i 0])
@ -3450,27 +3452,24 @@
(continue-make-super o c inited? '() '() '()))])
(set-class-init! cls init))
;; fill in the methods vector
(let loop ([i 0]
[methods methods])
(when (< i method-count)
(vector-set! methods-vec i ((car methods) field-ref))
(loop (+ i 1)
(cdr methods))))
;; fill in the methods-ht
;; fill in the methods vector & methods-ht
(let loop ([i 0]
[methods methods]
[method-ids method-ids])
(when (< i method-count)
(vector-set! methods-vec i (if old-style?
((car methods) field-ref)
(car methods)))
(hash-table-put! method-ht (car method-ids) i)
(loop (+ i 1)
(cdr methods)
(cdr method-ids))))
;; fill in the fields-ht
(let loop ([i 0]
[field-ids field-ids])
(when (< i field-count)
(hash-table-put! field-ht (car field-ids) (cons cls (+ i method-count)))
(hash-table-put! field-ht (car field-ids) (cons cls i))
(loop (+ i 1)
(cdr field-ids))))
@ -3655,7 +3654,8 @@
(provide (protect-out make-wrapper-class
wrapper-object-wrapped
extract-vtable
extract-method-ht)
extract-method-ht
get-field/proc)
(rename-out [_class class]) class* class/derived
define-serializable-class define-serializable-class*

234
collects/scheme/private/contract-arr-checks.ss
View File

@ -1,234 +0,0 @@
#lang scheme/base
(provide (all-defined-out))
(require "contract-guts.ss")
(define empty-case-lambda/c
(flat-named-contract '(case->)
(λ (x) (and (procedure? x) (null? (procedure-arity x))))))
;; ----------------------------------------
;; Checks and error functions used in macro expansions
;; procedure-accepts-and-more? : procedure number -> boolean
;; returns #t if val accepts dom-length arguments and
;; any number of arguments more than dom-length.
;; returns #f otherwise.
(define (procedure-accepts-and-more? val dom-length)
(let ([arity (procedure-arity val)])
(cond
[(number? arity) #f]
[(arity-at-least? arity)
(<= (arity-at-least-value arity) dom-length)]
[else
(let ([min-at-least (let loop ([ars arity]
[acc #f])
(cond
[(null? ars) acc]
[else (let ([ar (car ars)])
(cond
[(arity-at-least? ar)
(if (and acc
(< acc (arity-at-least-value ar)))
(loop (cdr ars) acc)
(loop (cdr ars) (arity-at-least-value ar)))]
[(number? ar)
(loop (cdr ars) acc)]))]))])
(and min-at-least
(begin
(let loop ([counts (sort (filter number? arity) >=)])
(unless (null? counts)
(let ([count (car counts)])
(cond
[(= (+ count 1) min-at-least)
(set! min-at-least count)
(loop (cdr counts))]
[(< count min-at-least)
(void)]
[else (loop (cdr counts))]))))
(<= min-at-least dom-length))))])))
(define (check->* f arity-count)
(unless (procedure? f)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
(unless (and (procedure-arity-includes? f arity-count)
(no-mandatory-keywords? f))
(error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
arity-count
f)))
(define (get-mandatory-keywords f)
(let-values ([(mandatory optional) (procedure-keywords f)])
mandatory))
(define (no-mandatory-keywords? f)
(let-values ([(mandatory optional) (procedure-keywords f)])
(null? mandatory)))
(define (check->*/more f arity-count)
(unless (procedure? f)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
(unless (procedure-accepts-and-more? f arity-count)
(error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a argument~a and arbitrarily many more, got ~e"
arity-count
(if (= 1 arity-count) "" "s")
f)))
(define (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(unless pre-expr
(raise-contract-error val
src-info
blame
orig-str
"pre-condition expression failure")))
(define (check-post-expr->pp/h val post-expr src-info blame orig-str)
(unless post-expr
(raise-contract-error val
src-info
blame
orig-str
"post-condition expression failure")))
(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str)
(unless (and (procedure? val)
(procedure-arity-includes?/optionals val dom-length optionals)
(keywords-match mandatory-kwds optional-keywords val))
(raise-contract-error
val
src-info
blame
orig-str
"expected a procedure that accepts ~a arguments~a, given: ~e"
dom-length
(keyword-error-text mandatory-kwds)
val)))
(define (procedure-arity-includes?/optionals f base optionals)
(cond
[(zero? optionals) (procedure-arity-includes? f base)]
[else (and (procedure-arity-includes? f (+ base optionals))
(procedure-arity-includes?/optionals f base (- optionals 1)))]))
(define (keywords-match mandatory-kwds optional-kwds val)
(let-values ([(proc-mandatory proc-all) (procedure-keywords val)])
(and (equal? proc-mandatory mandatory-kwds)
(andmap (λ (kwd) (and (member kwd proc-all)
(not (member kwd proc-mandatory))))
optional-kwds))))
(define (keyword-error-text mandatory-keywords)
(cond
[(null? mandatory-keywords) " without any keywords"]
[(null? (cdr mandatory-keywords))
(format " and the keyword ~a" (car mandatory-keywords))]
[else
(format
" and the keywords ~a~a"
(car mandatory-keywords)
(apply string-append (map (λ (x) (format " ~a" x)) (cdr mandatory-keywords))))]))
(define ((check-procedure? arity) val)
(and (procedure? val)
(procedure-arity-includes? val arity)
(no-mandatory-keywords? val)))
(define ((check-procedure/more? arity) val)
(and (procedure? val)
(procedure-accepts-and-more? val arity)))
(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str)
(unless (procedure? val)
(raise-contract-error val
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(unless (procedure-arity-includes? val arity)
(raise-contract-error val
src-info
blame
orig-str
"expected a ~a of arity ~a (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str)
(unless (procedure? val)
(raise-contract-error val
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(unless (procedure-accepts-and-more? val arity)
(raise-contract-error val
src-info
blame
orig-str
"expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(define (check-procedure/more val dom-length mandatory-kwds optional-kwds src-info blame orig-str)
(unless (and (procedure? val)
(procedure-accepts-and-more? val dom-length)
(keywords-match mandatory-kwds optional-kwds val))
(raise-contract-error
val
src-info
blame
orig-str
"expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e"
dom-length
(keyword-error-text mandatory-kwds)
val)))
(define (check-rng-procedure who rng-x arity)
(unless (and (procedure? rng-x)
(procedure-arity-includes? rng-x arity))
(error who "expected range position to be a procedure that accepts ~a arguments, given: ~e"
arity
rng-x)))
(define (check-rng-procedure/more rng-mk-x arity)
(unless (and (procedure? rng-mk-x)
(procedure-accepts-and-more? rng-mk-x arity))
(error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e"
arity
rng-mk-x)))
(define (check-rng-lengths results rng-contracts)
(unless (= (length results) (length rng-contracts))
(error '->d*
"expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively"
(length results) (length rng-contracts))))
#|
test cases for procedure-accepts-and-more?
(and (procedure-accepts-and-more? (lambda (x . y) 1) 3)
(procedure-accepts-and-more? (lambda (x . y) 1) 2)
(procedure-accepts-and-more? (lambda (x . y) 1) 1)
(not (procedure-accepts-and-more? (lambda (x . y) 1) 0))
(procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3)
(procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2)
(procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1)
(not (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0))
(procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2)
(procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1)
(not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0)))
|#

1112
collects/scheme/private/contract-arr-obj-helpers.ss
View File

File diff suppressed because it is too large Load Diff

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

@ -8,14 +8,15 @@ v4 done:
- rewrote ->* using new notation
- rewrote ->d using new notation
- rewrote case->
- rewrote object-contract
v4 todo:
- rewrite object-contract to use new function combinators.
- add case-> to object-contract
- remove opt-> opt->* ->pp ->pp-rest ->r ->d*
- improve the generation of wrappers to avoid 'apply' and to make keywords work.
- remove extra checks from contract-arr-checks.ss (after object-contract is done).
- test object-contract with keywords (both optional and mandatory)
- change mzlib/contract to rewrite into scheme/contract (maybe?)
@ -23,15 +24,16 @@ v4 todo:
. multiple identical keywords syntax error, sort-keywords
. split-doms
- note timing/size tests at the end of the file.
|#
(require "contract-guts.ss"
"contract-arr-checks.ss"
"contract-opt.ss")
"contract-opt.ss"
scheme/stxparam)
(require (for-syntax scheme/base)
(for-syntax "contract-opt-guts.ss")
(for-syntax "contract-helpers.ss")
(for-syntax "contract-arr-obj-helpers.ss")
(for-syntax syntax/stx)
(for-syntax syntax/name))
@ -40,7 +42,13 @@ v4 todo:
->d
case->
unconstrained-domain->
the-unsupplied-arg)
the-unsupplied-arg
making-a-method
procedure-accepts-and-more?
check-procedure
check-procedure/more)
(define-syntax-parameter making-a-method #f)
(define-syntax (unconstrained-domain-> stx)
(syntax-case stx ()
@ -136,9 +144,10 @@ v4 todo:
[partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
optional-kwds-proj)])
(apply func
(λ (val) (if has-rest?
(check-procedure/more val dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str)
(check-procedure val dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
(λ (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
partial-mandatory-kwds partial-optional-kwds
partial-ranges)))))))
@ -198,7 +207,7 @@ v4 todo:
(apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c))))
(apply build-compound-type-name (append optional-doms/c (apply append (map list optional-kwds optional-kwds/c))))
(if doms-rest
(list doms-rest range)
(list '#:rest doms-rest range)
(list range))))]
[else
(let ([rng-name
@ -279,7 +288,11 @@ v4 todo:
(with-syntax ([(keyword-call/ctc ...) (apply append (map syntax->list (syntax->list #'((dom-kwd (dom-kwd-ctc-id dom-kwd-arg)) ...))))]
[(keyword-formal-parameters ...) (apply append (map syntax->list (syntax->list #'((dom-kwd dom-kwd-arg) ...))))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))])
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(this-parameter ...)
(if (syntax-parameter-value #'making-a-method)
(generate-temporaries '(this))
'())])
(syntax-case* #'last-one (-> any values) module-or-top-identifier=?
[any
(with-syntax ([(ignored) (generate-temporaries (syntax (rng)))])
@ -290,7 +303,8 @@ v4 todo:
(syntax (any/c))
(syntax (dom-kwd-ctc ...))
(syntax (dom-kwd ...))
(syntax ((args ... keyword-formal-parameters ...) (val (dom-ctc args) ... keyword-call/ctc ...)))
(syntax ((this-parameter ... args ... keyword-formal-parameters ...)
(val this-parameter ... (dom-ctc args) ... keyword-call/ctc ...)))
#t))]
[(values rngs ...)
(with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
@ -302,8 +316,8 @@ v4 todo:
(syntax (rngs ...))
(syntax (dom-kwd-ctc ...))
(syntax (dom-kwd ...))
(syntax ((args ... keyword-formal-parameters ...)
(let-values ([(rng-x ...) (val (dom-ctc args) ... keyword-call/ctc ...)])
(syntax ((this-parameter ... args ... keyword-formal-parameters ...)
(let-values ([(rng-x ...) (val this-parameter ... (dom-ctc args) ... keyword-call/ctc ...)])
(values (rng-ctc rng-x) ...))))
#f))]
[rng
@ -315,9 +329,15 @@ v4 todo:
(syntax (rng))
(syntax (dom-kwd-ctc ...))
(syntax (dom-kwd ...))
(syntax ((args ... keyword-formal-parameters ...) (rng-ctc (val (dom-ctc args) ... keyword-call/ctc ...))))
(syntax ((this-parameter ... args ... keyword-formal-parameters ...)
(rng-ctc (val this-parameter ... (dom-ctc args) ... keyword-call/ctc ...))))
#f))]))))]))
(define-for-syntax (maybe-a-method/name stx)
(if (syntax-parameter-value #'making-a-method)
(syntax-property stx 'method-arity-error #t)
stx))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define-for-syntax (->/proc/main stx)
(let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)])
@ -330,16 +350,16 @@ v4 todo:
[(kwd-ctcs ...) kwd-ctcs]
[(kwds ...) kwds]
[inner-lambda
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body)))]
(maybe-a-method/name
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body))))]
[use-any? use-any?])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-names ... kwd-names ... rng-names ...)
(lambda (val)
(chk val)
inner-lambda)))])
#`(lambda (chk dom-names ... kwd-names ... rng-names ...)
(lambda (val)
(chk val #,(syntax-parameter-value #'making-a-method))
inner-lambda))])
(values
(syntax
(build--> '->
@ -352,8 +372,7 @@ v4 todo:
(define-syntax (-> stx)
(let-values ([(stx _1 _2) (->/proc/main stx)])
stx))
#`(syntax-parameterize ((making-a-method #f)) #,stx)))
;;
;; arrow opter
@ -426,7 +445,7 @@ v4 todo:
(dom-len (length dom-vars))
((next-rng ...) next-rngs))
(syntax (begin
(check-procedure val dom-len 0 '() '() #| keywords |# src-info pos orig-str)
(check-procedure val #f dom-len 0 '() '() #| keywords |# src-info pos orig-str)
(λ (dom-arg ...)
(let-values ([(rng-arg ...) (val next-dom ...)])
(values next-rng ...))))))
@ -474,7 +493,7 @@ v4 todo:
((next-dom ...) next-doms)
(dom-len (length dom-vars)))
(syntax (begin
(check-procedure val dom-len 0 '() '() #|keywords|# src-info pos orig-str)
(check-procedure val #f dom-len 0 '() '() #|keywords|# src-info pos orig-str)
(λ (dom-arg ...)
(val next-dom ...)))))
lifts-doms
@ -572,14 +591,18 @@ v4 todo:
;; rng-ctc (or/c #f syntax) -- #f means `any', syntax is a sequence of result values
(syntax-case #'rst (any values)
[(any) (values #f #f)]
[(rest-expr any) (values #'rest-expr #f)]
[(#:rest rest-expr any) (values #'rest-expr #f)]
[((values res-ctc ...)) (values #f #'(res-ctc ...))]
[(rest-expr (values res-ctc ...)) (values #'rest-expr #'(res-ctc ...))]
[(#:rest rest-expr (values res-ctc ...)) (values #'rest-expr #'(res-ctc ...))]
[(res-ctc) (values #f #'(res-ctc))]
[(rest-expr res-ctc) (values #'rest-expr #'(res-ctc))]
[(#:rest rest-expr res-ctc) (values #'rest-expr #'(res-ctc))]
[_ (raise-syntax-error #f "bad syntax" stx)])])
(with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
[(rng ...) (generate-temporaries (or rng-ctc '()))])
[(rng ...) (generate-temporaries (or rng-ctc '()))]
[(this-parameter ...)
(if (syntax-parameter-value #'making-a-method)
(generate-temporaries '(this))
'())])
#`(build-->
'->*
(list mandatory-dom ...)
@ -603,10 +626,11 @@ v4 todo:
optional-dom-kwd-proj ...
rng-proj ...)
(λ (f)
(chk f)
(chk f #,(syntax-parameter-value #'making-a-method))
#,(add-name-prop
(syntax-local-infer-name stx)
#`(λ (mandatory-dom-arg ...
#`(λ (this-parameter ...
mandatory-dom-arg ...
[optional-dom-arg unspecified-dom] ...
mandatory-dom-kwd/var-seq ...
optional-dom-kwd/var-seq ...
@ -625,15 +649,16 @@ v4 todo:
opt-args
(cons (rev-optional-dom-proj rev-optional-dom-arg) opt-args))]
...)
#,(let ([call (if (null? (syntax->list #'(rev-sorted-dom-kwd ...)))
#'(apply f (mandatory-dom-proj mandatory-dom-arg) ... opt-args)
#'(keyword-apply f kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args))])
#,(let ([call
(if (null? (syntax->list #'(rev-sorted-dom-kwd ...)))
#'(apply f this-parameter ... (mandatory-dom-proj mandatory-dom-arg) ... opt-args)
#'(keyword-apply f this-parameter ... kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args))])
(if rng-ctc
#`(let-values ([(rng ...) #,call])
(values (rng-proj rng) ...))
call))))))))))))))]))
(define-syntax (->* stx) (->*/proc/main stx))
(define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx)))
@ -656,10 +681,16 @@ v4 todo:
(define-for-syntax (parse-leftover stx leftover)
(let*-values ([(id/rest-id leftover)
(syntax-case leftover ()
[(id rest-expr . leftover)
[(#:rest id rest-expr . leftover)
(and (identifier? #'id)
(not (keyword? (syntax-e #'rest-expr))))
(values #'(id rest-expr) #'leftover)]
[(#:rest id rest-expr . leftover)
(begin
(unless (identifier? #'id)
(raise-syntax-error #f "expected an identifier" stx #'id))
(when (keyword? (syntax-e #'rest-expr))
(raise-syntax-error #f "expected an expression, not a keyword" stx #'rest-expr)))]
[_ (values #f leftover)])]
[(pre-cond leftover)
(syntax-case leftover ()
@ -670,7 +701,7 @@ v4 todo:
(syntax-case leftover ()
[(range . leftover) (values #'range #'leftover)]
[_
(raise-syntax-error #f "bad syntax" stx)])]
(raise-syntax-error #f "expected a range expression, but found nothing" stx)])]
[(post-cond leftover)
(syntax-case leftover ()
[(#:post-cond post-cond . leftover)
@ -722,10 +753,15 @@ v4 todo:
stx
(syntax->list
#'((optional-kwd optional-kwd-id) ...
(mandatory-kwd mandatory-kwd-id) ...)))])
(mandatory-kwd mandatory-kwd-id) ...)))]
[(this-parameter ...)
(if (syntax-parameter-value #'making-a-method)
(list (datum->syntax stx 'this #f))
'())])
(let-values ([(id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)])
(with-syntax ([(dom-params ...)
#`(mandatory-regular-id ...
#`(this-parameter ...
mandatory-regular-id ...
optional-regular-id ...
#,@(if id/rest
(with-syntax ([(id rst-ctc) id/rest])
@ -738,49 +774,59 @@ v4 todo:
[(values [id ctc] ... x . y) (raise-syntax-error #f "expected binding pair" stx #'x)]
[any #'(() #f)]
[[id ctc] #'((id) (ctc))]
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])])
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
[mtd? (syntax-parameter-value #'making-a-method)])
(let ([dup (check-duplicate-identifier (syntax->list #'(dom-params ... rng-params ...)))])
(when dup
(raise-syntax-error #f "duplicate identifier" stx dup)))
#`(build-->d (list (λ (dom-params ...) mandatory-doms) ...)
(list (λ (dom-params ...) optional-doms) ...)
(list (λ (dom-params ...) mandatory-kwd-dom) ...)
(list (λ (dom-params ...) optional-kwd-dom) ...)
#,(if id/rest
(with-syntax ([(id rst-ctc) id/rest])
#`(λ (dom-params ...) rst-ctc))
#f)
#,(if pre-cond
#`(λ (dom-params ...) #,pre-cond)
#f)
#,(syntax-case #'rng-ctcs ()
[#f #f]
[(ctc ...) #'(list (λ (rng-params ... dom-params ...) ctc) ...)])
#,(if post-cond
#`(λ (rng-params ... dom-params ...) #,post-cond)
#f)
'(mandatory-kwd ...)
'(optional-kwd ...)
(λ (f)
#,(add-name-prop
(syntax-local-infer-name stx)
#`(λ args (apply f args))))))))))]))
#`(syntax-parameterize
((making-a-method #f))
(build-->d mtd?
(list (λ (dom-params ...) mandatory-doms) ...)
(list (λ (dom-params ...) optional-doms) ...)
(list (λ (dom-params ...) mandatory-kwd-dom) ...)
(list (λ (dom-params ...) optional-kwd-dom) ...)
#,(if id/rest
(with-syntax ([(id rst-ctc) id/rest])
#`(λ (dom-params ...) rst-ctc))
#f)
#,(if pre-cond
#`(λ (dom-params ...) #,pre-cond)
#f)
#,(syntax-case #'rng-ctcs ()
[#f #f]
[(ctc ...) #'(list (λ (rng-params ... dom-params ...) ctc) ...)])
#,(if post-cond
#`(λ (rng-params ... dom-params ...) #,post-cond)
#f)
'(mandatory-kwd ...)
'(optional-kwd ...)
(λ (f)
#,(add-name-prop
(syntax-local-infer-name stx)
#`(λ args (apply f args)))))))))))]))
(define (->d-proj ->d-stct)
(let ([non-kwd-ctc-count (+ (length (->d-mandatory-dom-ctcs ->d-stct))
(length (->d-optional-dom-ctcs ->d-stct)))])
(length (->d-optional-dom-ctcs ->d-stct))
(if (->d-mtd? ->d-stct) 1 0))])
(λ (pos-blame neg-blame src-info orig-str)
(λ (val)
(check-procedure val
(->d-mtd? ->d-stct)
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct)
src-info pos-blame orig-str)
(let ([kwd-proc
(λ (kwd-args kwd-arg-vals . orig-args)
(let* ([dep-pre-args
(build-dep-ctc-args non-kwd-ctc-count orig-args (->d-rest-ctc ->d-stct)
(λ (kwd-args kwd-arg-vals . raw-orig-args)
(let* ([orig-args (if (->d-mtd? ->d-stct)
(cdr raw-orig-args)
raw-orig-args)]
[this (and (->d-mtd? ->d-stct) (car raw-orig-args))]
[dep-pre-args
(build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)]
[thnk
(λ ()
@ -808,34 +854,41 @@ v4 todo:
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))
;; contracted ordinary arguments
(let loop ([args orig-args]
[non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct)
(->d-optional-dom-ctcs ->d-stct))])
(cond
[(null? args)
(if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str)
'())]
[(null? non-kwd-ctcs)
(if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args neg-blame pos-blame src-info orig-str)
;; ran out of arguments, but don't have a rest parameter.
;; procedure-reduce-arity (or whatever the new thing is
;; going to be called) should ensure this doesn't happen.
(error 'shouldnt\ happen))]
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str)
(loop (cdr args)
(cdr non-kwd-ctcs)))]))))])
(append
;; this parameter (if necc.)
(if (->d-mtd? ->d-stct)
(list (car raw-orig-args))
'())
;; contracted ordinary arguments
(let loop ([args orig-args]
[non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct)
(->d-optional-dom-ctcs ->d-stct))])
(cond
[(null? args)
(if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str)
'())]
[(null? non-kwd-ctcs)
(if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args neg-blame pos-blame src-info orig-str)
;; ran out of arguments, but don't have a rest parameter.
;; procedure-reduce-arity (or whatever the new thing is
;; going to be called) should ensure this doesn't happen.
(error 'shouldnt\ happen))]
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str)
(loop (cdr args)
(cdr non-kwd-ctcs)))])))))])
(if (->d-range ->d-stct)
(call-with-values
thnk
(λ orig-results
(let* ([range-count (length (->d-range ->d-stct))]
[post-args (append orig-results orig-args)]
[post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count post-args (->d-rest-ctc ->d-stct)
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
post-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (->d-post-cond ->d-stct)
(unless (apply (->d-post-cond ->d-stct) dep-post-args)
@ -877,7 +930,7 @@ v4 todo:
(define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args)
(append
;; ordinary args
;; ordinary args (possibly including `this' as the first element)
(let loop ([count non-kwd-ctc-count]
[args args])
(cond
@ -903,7 +956,8 @@ v4 todo:
(define-struct unsupplied-arg ())
(define the-unsupplied-arg (make-unsupplied-arg))
(define (build-->d mandatory-dom-ctcs optional-dom-ctcs
(define (build-->d mtd?
mandatory-dom-ctcs optional-dom-ctcs
mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs
rest-ctc pre-cond range post-cond
mandatory-kwds optional-kwds
@ -913,7 +967,8 @@ v4 todo:
(append mandatory-kwds optional-kwds)
(append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
(λ (x y) (keyword<? (car x) (car y))))])
(make-->d mandatory-dom-ctcs optional-dom-ctcs
(make-->d mtd?
mandatory-dom-ctcs optional-dom-ctcs
(map cdr kwd/ctc-pairs)
rest-ctc pre-cond range post-cond
(map car kwd/ctc-pairs)
@ -921,7 +976,8 @@ v4 todo:
optional-kwds
name-wrapper)))
(define-struct/prop ->d (mandatory-dom-ctcs ;; (listof (-> ??? ctc))
(define-struct/prop ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
mandatory-dom-ctcs ;; (listof (-> ??? ctc))
optional-dom-ctcs ;; (listof (-> ??? ctc))
keyword-ctcs ;; (listof (-> ??? ctc))
rest-ctc ;; (or/c false/c (-> ??? ctc))
@ -955,7 +1011,7 @@ v4 todo:
(,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc))
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc))))
,@(if (->d-rest-ctc ctc)
(list (next-id) '...)
(list '#:rest (next-id) '...)
'())
,@(if (->d-pre-cond ctc)
(list '#:pre-cond '...)
@ -1018,14 +1074,18 @@ v4 todo:
[(rst-formal) (generate-temporaries '(rest-param))]
[(rng-id ...) (if rng
(generate-temporaries rng)
'())])
'())]
[(this-parameter ...)
(if (syntax-parameter-value #'making-a-method)
(generate-temporaries '(this))
'())])
#`(#,doms
#,rst
#,(if rng #`(list #,@rng) #f)
#,(length (syntax->list doms)) ;; spec
(dom-proj-x ... #,@(if rst #'(rst-proj-x) #'()))
(rng-proj-x ...)
(dom-formals ... . #,(if rst #'rst-formal '()))
(this-parameter ... dom-formals ... . #,(if rst #'rst-formal '()))
#,(cond
[rng
(with-syntax ([(rng-exp ...) #'((rng-proj-x rng-id) ...)])
@ -1033,14 +1093,14 @@ v4 todo:
(car (syntax->list #'(rng-exp ...)))
#`(values rng-exp ...))])
(if rst
#`(let-values ([(rng-id ...) (apply f (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))])
#`(let-values ([(rng-id ...) (apply f this-parameter ... (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))])
rng)
#`(let-values ([(rng-id ...) (f (dom-proj-x dom-formals) ...)])
#`(let-values ([(rng-id ...) (f this-parameter ... (dom-proj-x dom-formals) ...)])
rng))))]
[rst
#`(apply f (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))]
#`(apply f this-parameter ... (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))]
[else
#`(f (dom-proj-x dom-formals) ...)]))))))
#`(f this-parameter ... (dom-proj-x dom-formals) ...)]))))))
(define-syntax (case-> stx)
(syntax-case stx ()
@ -1055,17 +1115,19 @@ v4 todo:
formals
body) ...)
(map (λ (x) (parse-out-case stx x)) (syntax->list #'(cases ...)))])
#`(build-case-> (list (list dom-proj ...) ...)
(list rst-proj ...)
(list rng-proj ...)
'(spec ...)
(λ (chk
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
(λ (f)
(chk f)
(case-lambda
[formals body] ...))))))]))
#`(syntax-parameterize
((making-a-method #f))
(build-case-> (list (list dom-proj ...) ...)
(list rst-proj ...)
(list rng-proj ...)
'(spec ...)
(λ (chk
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
(λ (f)
(chk f #,(syntax-parameter-value #'making-a-method))
(case-lambda
[formals body] ...)))))))]))
;; dom-ctcs : (listof (listof contract))
;; rst-ctcs : (listof contract)
@ -1084,7 +1146,7 @@ v4 todo:
(let ([projs (append (map (λ (f) (f neg-blame pos-blame src-info orig-str)) dom-ctcs)
(map (λ (f) (f pos-blame neg-blame src-info orig-str)) rng-ctcs))]
[chk
(λ (val)
(λ (val mtd?)
(cond
[(null? specs)
(unless (procedure? val)
@ -1097,8 +1159,8 @@ v4 todo:
(for-each
(λ (dom-length has-rest?)
(if has-rest?
(check-procedure/more val dom-length '() '() src-info pos-blame orig-str)
(check-procedure val dom-length 0 '() '() src-info pos-blame orig-str)))
(check-procedure/more val mtd? dom-length '() '() src-info pos-blame orig-str)
(check-procedure val mtd? dom-length 0 '() '() src-info pos-blame orig-str)))
specs rst-ctcs)]))])
(apply (case->-wrapper ctc)
chk
@ -1123,7 +1185,7 @@ v4 todo:
(case->-dom-ctcs ctc)
(case->-rst-ctcs ctc)
(case->-rng-ctcs ctc)))))
(first-order-prop (λ (ctc) #f))
(first-order-prop (λ (ctc) (λ (val) #f)))
(stronger-prop (λ (this that) #f))))
(define (build-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper)
@ -1143,3 +1205,203 @@ v4 todo:
(case->-rst-ctcs ctc))))
(define (get-case->-rng-ctcs ctc) (apply append (case->-rng-ctcs ctc)))
;
;
;
; ;;;; ;;;;
; ;;;; ;;;;
; ;;;;;;; ;;; ;;; ;;; ;;; ;;;;; ;;;; ;;; ;;; ;;;;; ;;;; ;;; ;;;;;
; ;;;;;;;; ;;;;;;; ;;;;;;; ;;;;;; ;;;;;;;;; ;;;;; ;;;;;; ;;;; ;;; ;;;;;;
; ;;;; ;;;; ;; ;;;; ;; ;;;;;;; ;;;; ;;;; ;;;; ;; ;;;;;;; ;;;;;;; ;;;;
; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;;;;; ;;;;
; ;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;;; ;;;;;;; ;;;; ;;; ;;;;
; ;;;;;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;;;;; ;;;;;; ;;;; ;;; ;;;;;;
; ;; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;; ;;;;;
;
;
;
;; ----------------------------------------
;; Checks and error functions used in macro expansions
;; procedure-accepts-and-more? : procedure number -> boolean
;; returns #t if val accepts dom-length arguments and
;; any number of arguments more than dom-length.
;; returns #f otherwise.
(define (procedure-accepts-and-more? val dom-length)
(let ([arity (procedure-arity val)])
(cond
[(number? arity) #f]
[(arity-at-least? arity)
(<= (arity-at-least-value arity) dom-length)]
[else
(let ([min-at-least (let loop ([ars arity]
[acc #f])
(cond
[(null? ars) acc]
[else (let ([ar (car ars)])
(cond
[(arity-at-least? ar)
(if (and acc
(< acc (arity-at-least-value ar)))
(loop (cdr ars) acc)
(loop (cdr ars) (arity-at-least-value ar)))]
[(number? ar)
(loop (cdr ars) acc)]))]))])
(and min-at-least
(begin
(let loop ([counts (sort (filter number? arity) >=)])
(unless (null? counts)
(let ([count (car counts)])
(cond
[(= (+ count 1) min-at-least)
(set! min-at-least count)
(loop (cdr counts))]
[(< count min-at-least)
(void)]
[else (loop (cdr counts))]))))
(<= min-at-least dom-length))))])))
(define (get-mandatory-keywords f)
(let-values ([(mandatory optional) (procedure-keywords f)])
mandatory))
(define (no-mandatory-keywords? f)
(let-values ([(mandatory optional) (procedure-keywords f)])
(null? mandatory)))
(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str)
(unless (and (procedure? val)
(procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
(keywords-match mandatory-kwds optional-keywords val))
(raise-contract-error
val
src-info
blame
orig-str
"expected a ~a that accepts ~a arguments~a, given: ~e"
(if mtd? "method" "procedure")
dom-length
(keyword-error-text mandatory-kwds)
val)))
(define (procedure-arity-includes?/optionals f base optionals)
(cond
[(zero? optionals) (procedure-arity-includes? f base)]
[else (and (procedure-arity-includes? f (+ base optionals))
(procedure-arity-includes?/optionals f base (- optionals 1)))]))
(define (keywords-match mandatory-kwds optional-kwds val)
(let-values ([(proc-mandatory proc-all) (procedure-keywords val)])
(and (equal? proc-mandatory mandatory-kwds)
(andmap (λ (kwd) (and (member kwd proc-all)
(not (member kwd proc-mandatory))))
optional-kwds))))
(define (keyword-error-text mandatory-keywords)
(cond
[(null? mandatory-keywords) " without any keywords"]
[(null? (cdr mandatory-keywords))
(format " and the keyword ~a" (car mandatory-keywords))]
[else
(format
" and the keywords ~a~a"
(car mandatory-keywords)
(apply string-append (map (λ (x) (format " ~a" x)) (cdr mandatory-keywords))))]))
(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds src-info blame orig-str)
(unless (and (procedure? val)
(procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))
(keywords-match mandatory-kwds optional-kwds val))
(raise-contract-error
val
src-info
blame
orig-str
"expected a ~a that accepts ~a arguments and and arbitrarily more~a, given: ~e"
(if mtd? "method" "procedure")
dom-length
(keyword-error-text mandatory-kwds)
val)))
;; timing & size tests
#;
(begin
(require (prefix-in mz: mzlib/contract))
(define (time-test f)
(time
(let loop ([n 2000])
(unless (zero? n)
(f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
(f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
(f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
(f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
(f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
(f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
(f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
(f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
(loop (- n 1))))))
(define (size stx)
(let ([sp (open-output-string)])
(write (compile stx) sp)
(close-output-port sp)
(string-length (get-output-string sp))))
'raw
(size #'(λ (x) x))
(time-test (λ (x) x))
'->
(size #'(-> number? number?))
(time-test (contract (-> number? number?) (λ (x) x) 'pos 'neg))
'mz:->
(size #'(mz:-> number? number?))
(time-test (contract (mz:-> number? number?) (λ (x) x) 'pos 'neg))
'->*
(size #'(->* (number?) () number?))
(time-test (contract (->* (number?) () number?) (λ (x) x) 'pos 'neg))
'mz:->*
(size #'(mz:->* (number?) any/c (number?)))
(time-test (contract (mz:->* (number?) any/c (number?)) (λ (x . y) x) 'pos 'neg))
'case->
(size #'(case-> (-> number? number?)))
(time-test (contract (case-> (-> number? number?)) (λ (x) x) 'pos 'neg))
'mz:case->
(size #'(mz:case-> (-> number? number?)))
(time-test (contract (mz:case-> (-> number? number?)) (λ (x) x) 'pos 'neg))
'->d
(size #'(->d ([x number?]) () [r number?]))
(time-test (contract (->d ([x number?]) () [r number?]) (λ (x) x) 'pos 'neg))
'mz:->r
(size #'(mz:->r ([x number?]) number?))
(time-test (contract (mz:->r ([x number?]) number?) (λ (x) x) 'pos 'neg))
'object-contract
(size #'(object-contract [m (-> number? number?)]))
(time-test
(let ([o (contract (object-contract [m (-> number? number?)])
(new (class object% (define/public (m x) x) (super-new)))
'pos
'neg)])
(λ (x) (send o m x))))
'mz:object-contract
(size #'(mz:object-contract [m (mz:-> number? number?)]))
(time-test
(let ([o (contract (mz:object-contract [m (mz:-> number? number?)])
(new (class object% (define/public (m x) x) (super-new)))
'pos
'neg)])
(λ (x) (send o m x)))))

505
collects/scheme/private/contract-object.ss
View File

@ -2,11 +2,9 @@
(require "contract-arrow.ss"
"contract-guts.ss"
"class-internal.ss"
"contract-arr-checks.ss")
scheme/stxparam)
(require (for-syntax scheme/base
"contract-helpers.ss"
"contract-arr-obj-helpers.ss"))
(require (for-syntax scheme/base))
(provide mixin-contract
make-mixin-contract
@ -15,396 +13,127 @@
implementation?/c
object-contract)
(define-syntax object-contract
(let ()
(define (obj->/proc stx) (make-/proc #t ->/h stx))
(define (obj->*/proc stx) (make-/proc #t ->*/h stx))
(define (obj->d/proc stx) (make-/proc #t ->d/h stx))
(define (obj->d*/proc stx) (make-/proc #t ->d*/h stx))
(define (obj->r/proc stx) (make-/proc #t ->r/h stx))
(define (obj->pp/proc stx) (make-/proc #t ->pp/h stx))
(define (obj->pp-rest/proc stx) (make-/proc #t ->pp-rest/h stx))
(define (obj-case->/proc stx) (make-case->/proc #t stx stx select/h))
;; WARNING: select/h is copied from contract-arrow.ss. I'm not sure how
;; I can avoid this duplication -robby
(define (select/h stx err-name ctxt-stx)
(syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
[(-> . args) ->/h]
[(->* . args) ->*/h]
[(->d . args) ->d/h]
[(->d* . args) ->d*/h]
[(->r . args) ->r/h]
[(->pp . args) ->pp/h]
[(->pp-rest . args) ->pp-rest/h]
[(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
[_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
(define (obj-opt->/proc stx) (make-opt->/proc #t stx select/h #'case-> #'->))
(define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx select/h #'case-> #'->))
(λ (stx)
;; name : syntax
;; ctc-stx : syntax[evals to a contract]
;; mtd-arg-stx : syntax[list of arg-specs] (ie, for use in a case-lambda)
(define-struct mtd (name ctc-stx mtd-arg-stx))
;; name : syntax
;; ctc-stx : syntax[evals to a contract]
(define-struct fld (name ctc-stx))
;; expand-field/mtd-spec : stx -> (union mtd fld)
(define (expand-field/mtd-spec f/m-stx)
(syntax-case f/m-stx (field)
[(field field-name ctc)
(identifier? (syntax field-name))
(make-fld (syntax field-name) (syntax ctc))]
[(field field-name ctc)
(raise-syntax-error 'object-contract "expected name of field" stx (syntax field-name))]
[(mtd-name ctc)
(identifier? (syntax mtd-name))
(let-values ([(ctc-stx proc-stx) (expand-mtd-contract (syntax ctc))])
(make-mtd (syntax mtd-name)
ctc-stx
proc-stx))]
[(mtd-name ctc)
(raise-syntax-error 'object-contract "expected name of method" stx (syntax mtd-name))]
[_ (raise-syntax-error 'object-contract "expected field or method clause" stx f/m-stx)]))
;; expand-mtd-contract : syntax -> (values syntax[expanded ctc] syntax[mtd-arg])
(define (expand-mtd-contract mtd-stx)
(syntax-case mtd-stx (case-> opt-> opt->*)
[(case-> cases ...)
(let loop ([cases (syntax->list (syntax (cases ...)))]
[ctc-stxs null]
[args-stxs null])
(cond
[(null? cases)
(values
(with-syntax ([(x ...) (reverse ctc-stxs)])
(obj-case->/proc (syntax (case-> x ...))))
(with-syntax ([(x ...) (apply append (map syntax->list (reverse args-stxs)))])
(syntax (x ...))))]
[else
(let-values ([(trans ctc-stx mtd-args) (expand-mtd-arrow (car cases))])
(loop (cdr cases)
(cons ctc-stx ctc-stxs)
(cons mtd-args args-stxs)))]))]
[(opt->* (req-contracts ...) (opt-contracts ...) (res-contracts ...))
(values
(obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) (res-contracts ...))))
(generate-opt->vars (syntax (req-contracts ...))
(syntax (opt-contracts ...))))]
[(opt->* (req-contracts ...) (opt-contracts ...) any)
(values
(obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) any)))
(generate-opt->vars (syntax (req-contracts ...))
(syntax (opt-contracts ...))))]
[(opt-> (req-contracts ...) (opt-contracts ...) res-contract)
(values
(obj-opt->/proc (syntax (opt-> (any/c req-contracts ...) (opt-contracts ...) res-contract)))
(generate-opt->vars (syntax (req-contracts ...))
(syntax (opt-contracts ...))))]
[else
(let-values ([(x y z) (expand-mtd-arrow mtd-stx)])
(values (x y) z))]))
;; generate-opt->vars : syntax[requried contracts] syntax[optional contracts] -> syntax[list of arg specs]
(define (generate-opt->vars req-stx opt-stx)
(with-syntax ([(req-vars ...) (generate-temporaries req-stx)]
[(ths) (generate-temporaries (syntax (ths)))])
(let loop ([opt-vars (generate-temporaries opt-stx)])
(cond
[(null? opt-vars) (list (syntax (ths req-vars ...)))]
[else (with-syntax ([(opt-vars ...) opt-vars]
[(rests ...) (loop (cdr opt-vars))])
(syntax ((ths req-vars ... opt-vars ...)
rests ...)))]))))
;; expand-mtd-arrow : stx -> (values (syntax[ctc] -> syntax[expanded ctc]) syntax[ctc] syntax[mtd-arg])
(define (expand-mtd-arrow mtd-stx)
(syntax-case mtd-stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
[(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)]
[(-> args ...)
;; this case cheats a little bit --
;; (args ...) contains the right number of arguments
;; to the method because it also contains one arg for the result! urgh.
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))])
(values obj->/proc
(syntax (-> any/c args ...))
(syntax ((arg-vars ...)))))]
[(->* (doms ...) (rngs ...))
(with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))])
(values obj->*/proc
(syntax (->* (any/c doms ...) (rngs ...)))
(syntax ((this-var args-vars ...)))))]
[(->* (doms ...) rst (rngs ...))
(with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
[(rst-var) (generate-temporaries (syntax (rst)))]
[(this-var) (generate-temporaries (syntax (this-var)))])
(values obj->*/proc
(syntax (->* (any/c doms ...) rst (rngs ...)))
(syntax ((this-var args-vars ... . rst-var)))))]
[(->* x ...)
(raise-syntax-error 'object-contract "malformed ->*" stx mtd-stx)]
[(->d) (raise-syntax-error 'object-contract "->d must have arguments" stx mtd-stx)]
[(->d doms ... rng-proc)
(let ([doms-val (syntax->list (syntax (doms ...)))])
(values
obj->d/proc
(with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
[arity-count (length doms-val)])
(syntax
(->d any/c doms ...
(let ([f rng-proc])
(check->* f arity-count)
(lambda (_this-var arg-vars ...)
(f arg-vars ...))))))
(with-syntax ([(args-vars ...) (generate-temporaries doms-val)])
(syntax ((this-var args-vars ...))))))]
[(->d* (doms ...) rng-proc)
(values
obj->d*/proc
(let ([doms-val (syntax->list (syntax (doms ...)))])
(with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
[arity-count (length doms-val)])
(syntax (->d* (any/c doms ...)
(let ([f rng-proc])
(check->* f arity-count)
(lambda (_this-var arg-vars ...)
(f arg-vars ...)))))))
(with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))])
(syntax ((this-var args-vars ...)))))]
[(->d* (doms ...) rst-ctc rng-proc)
(let ([doms-val (syntax->list (syntax (doms ...)))])
(values
obj->d*/proc
(with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
[(rest-var) (generate-temporaries (syntax (rst-ctc)))]
[arity-count (length doms-val)])
(syntax (->d* (any/c doms ...)
rst-ctc
(let ([f rng-proc])
(check->*/more f arity-count)
(lambda (_this-var arg-vars ... . rest-var)
(apply f arg-vars ... rest-var))))))
(with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
[(rst-var) (generate-temporaries (syntax (rst-ctc)))]
[(this-var) (generate-temporaries (syntax (this-var)))])
(syntax ((this-var args-vars ... . rst-var))))))]
[(->d* x ...)
(raise-syntax-error 'object-contract "malformed ->d* method contract" stx mtd-stx)]
[(->r ([x dom] ...) rng)
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax mtd-stx 'this)])
(values
obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rng))
(syntax ((this-var arg-vars ...)))))]
[(->r ([x dom] ...) rest-x rest-dom rng)
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax mtd-stx 'this)])
(values
obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng))
(syntax ((this-var arg-vars ... . rest-var)))))]
[(->r . x)
(raise-syntax-error 'object-contract "malformed ->r declaration")]
[(->pp ([x dom] ...) . other-stuff)
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax mtd-stx 'this)])
(values
obj->pp/proc
(syntax (->pp ([this any/c] [x dom] ...) . other-stuff))
(syntax ((this-var arg-vars ...)))))]
[(->pp . x)
(raise-syntax-error 'object-contract "malformed ->pp declaration")]
[(->pp-rest ([x dom] ...) rest-id . other-stuff)
(and (identifier? (syntax id))
(andmap identifier? (syntax->list (syntax (x ...)))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax mtd-stx 'this)])
(values
obj->pp-rest/proc
(syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff))
(syntax ((this-var arg-vars ... . rest-id)))))]
[(->pp-rest . x)
(raise-syntax-error 'object-contract "malformed ->pp-rest declaration")]
[else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)]))
;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
(define (build-methods-stx mtds)
(define (last-pair l)
(cond
[(not (pair? (cdr l))) l]
[else (last-pair (cdr l))]))
(let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)]
[names (map mtd-name mtds)]
[i 0])
(cond
[(null? arg-spec-stxss) null]
[else (let ([arg-spec-stxs (car arg-spec-stxss)])
(with-syntax ([(cases ...)
(map (lambda (arg-spec-stx)
(with-syntax ([i i])
(syntax-case arg-spec-stx ()
[(this rest-ids ...)
(syntax
((this rest-ids ...)
((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))]
[else
(let-values ([(this rest-ids last-var)
(let ([lst (syntax->improper-list arg-spec-stx)])
(values (car lst)
(all-but-last (cdr lst))
(cdr (last-pair lst))))])
(with-syntax ([this this]
[(rest-ids ...) rest-ids]
[last-var last-var])
(syntax
((this rest-ids ... . last-var)
(apply (field-ref this i)
(wrapper-object-wrapped this)
rest-ids ...
last-var)))))])))
(syntax->list arg-spec-stxs))]
[name (string->symbol (format "~a method" (syntax->datum (car names))))])
(with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)])
(cons (syntax (lambda (field-ref) (let ([name proc]) name)))
(loop (cdr arg-spec-stxss)
(cdr names)
(+ i 1))))))])))
(define (syntax->improper-list stx)
(define (se->il se)
(cond
[(pair? se) (sp->il se)]
[else se]))
(define (stx->il stx)
(se->il (syntax-e stx)))
(define (sp->il p)
(cond
[(null? (cdr p)) p]
[(pair? (cdr p)) (cons (car p) (sp->il (cdr p)))]
[(syntax? (cdr p))
(let ([un (syntax-e (cdr p))])
(if (pair? un)
(cons (car p) (sp->il un))
p))]))
(stx->il stx))
(syntax-case stx ()
[(_ field/mtd-specs ...)
(let* ([mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (field/mtd-specs ...))))]
[mtds (filter mtd? mtd/flds)]
[flds (filter fld? mtd/flds)])
(with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)]
[(method-name ...) (map mtd-name mtds)]
[(method-ctc-var ...) (generate-temporaries mtds)]
[(method-var ...) (generate-temporaries mtds)]
[(method/app-var ...) (generate-temporaries mtds)]
[(methods ...) (build-methods-stx mtds)]
[(field-ctc-stx ...) (map fld-ctc-stx flds)]
[(field-name ...) (map fld-name flds)]
[(field-ctc-var ...) (generate-temporaries flds)]
[(field-var ...) (generate-temporaries flds)]
[(field/app-var ...) (generate-temporaries flds)])
(syntax
(let ([method-ctc-var method-ctc-stx]
...
[field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
...)
(let ([method-var (contract-proc method-ctc-var)]
...
[field-var (contract-proc field-ctc-var)]
...)
(let ([cls (make-wrapper-class 'wrapper-class
'(method-name ...)
(list methods ...)
'(field-name ...))])
(make-proj-contract
`(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ...
,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
(lambda (pos-blame neg-blame src-info orig-str)
(let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)]
...
[field/app-var (field-var pos-blame neg-blame src-info orig-str)]
...)
(let ([field-names-list '(field-name ...)])
(lambda (val)
(check-object val src-info pos-blame orig-str)
(let ([val-mtd-names
(interface->method-names
(object-interface
val))])
(void)
(check-method val 'method-name val-mtd-names src-info pos-blame orig-str)
...)
(unless (field-bound? field-name val)
(field-error val 'field-name src-info pos-blame orig-str)) ...
(let ([vtable (extract-vtable val)]
[method-ht (extract-method-ht val)])
(make-object cls
val
(method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ...
))))))
#f)))))))]))))
;; example of how one contract is constructed
#;
(let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))]
[cf (-> integer? integer?)]
[m-proj (((proj-get cm) cm) 'pos 'neg #'here "whatever")]
[f-proj (((proj-get cf) cf) 'pos 'neg #'here "whatever")]
[cls (make-wrapper-class 'wrapper-class
'(m)
(list
(m-proj (λ (this x) (send (wrapper-object-wrapped this) m x))))
'(f)
#f)]
[o (new (class object%
(field [f (λ (x) x)])
(define/public (m x) x)
(super-new)))]
[wo (make-object cls o (f-proj (get-field/proc 'f o)))])
((get-field/proc 'f wo) #f))
(define-for-syntax (parse-object-contract stx args)
(let loop ([args (syntax->list args)]
[mtds '()]
[flds '()])
(cond
[(null? args) (list mtds flds)]
[else (syntax-case (car args) (field)
[(field id ctc)
(identifier? #'id)
(loop (cdr args) mtds (cons #'(id ctc) flds))]
[(field . rst)
(raise-syntax-error #f "malformed field specification" stx (car args))]
[(id ctc)
(identifier? #'id)
(loop (cdr args) (cons #`(id ctc) mtds) flds)]
[_
(raise-syntax-error #f "malformed object-contract clause" stx (car args))])])))
(define (check-object val src-info blame orig-str)
(unless (object? val)
(raise-contract-error val
src-info
blame
orig-str
"expected an object, got ~e"
val)))
(define-struct/prop object-contract (methods method-ctcs method-wrappers fields field-ctcs)
((proj-prop
(λ (ctc)
(let ([meth-names (object-contract-methods ctc)]
[meth-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-method-ctcs ctc))]
[ctc-field-names (object-contract-fields ctc)]
[field-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-field-ctcs ctc))])
(λ (pos-blame neg-blame src-info orig-str)
(let* ([meth-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str))
meth-param-projs)]
[meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))]
[cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)]
[field-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str)) field-param-projs)])
(λ (val)
(unless (object? val)
(raise-contract-error val src-info pos-blame orig-str
"expected an object, got ~e"
val))
(let ([objs-mtds (interface->method-names (object-interface val))]
[vtable (extract-vtable val)]
[method-ht (extract-method-ht val)])
(for-each (λ (m proj)
(let ([index (hash-table-get method-ht m #f)])
(unless index
(raise-contract-error val src-info pos-blame orig-str
"expected an object with method ~s"
m))
;; verify the first-order properties by apply the projection and
;; throwing the result away. Without this, the contract wrappers
;; just check the first-order properties of the wrappers, which is
;; the wrong thing.
(proj (vector-ref vtable index))))
meth-names
meth-projs))
(let ([fields (field-names val)])
(for-each (λ (f)
(unless (memq f fields)
(raise-contract-error val src-info pos-blame orig-str
"expected an object with field ~s"
f)))
ctc-field-names))
(define (check-method val method-name val-mtd-names src-info blame orig-str)
(unless (memq method-name val-mtd-names)
(raise-contract-error val
src-info
blame
orig-str
"expected an object with method ~s"
method-name)))
(apply make-object cls val
(map (λ (field proj) (proj (get-field/proc field val)))
ctc-field-names field-projs))))))))
(name-prop (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
(object-contract-fields ctc)
(object-contract-field-ctcs ctc))
,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc))
(object-contract-methods ctc)
(object-contract-method-ctcs ctc)))))
(first-order-prop (λ (ctc) (λ (val) #f)))
(stronger-prop (λ (this that) #f))))
(define (field-error val field-name src-info blame orig-str)
(raise-contract-error val
src-info
blame
orig-str
"expected an object with field ~s"
field-name))
(define-syntax (object-contract stx)
(syntax-case stx ()
[(_ spec ...)
(with-syntax ([(((method-id method-ctc) ...)
((field-id field-ctc) ...))
(parse-object-contract stx #'(spec ...))])
(with-syntax ([(method-name ...) (map (λ (x) (string->symbol (format "~a method" (syntax-e x))))
(syntax->list #'(method-id ...)))])
#'(build-object-contract '(method-id ...)
(syntax-parameterize ((making-a-method #t)) (list (let ([method-name method-ctc]) method-name) ...))
(list (λ (this . x) (send (wrapper-object-wrapped this) method-id . x)) ...)
'(field-id ...)
(list field-ctc ...))))]))
(define (build-object-contract methods method-ctcs wrappers fields field-ctcs)
(make-object-contract methods
(map (λ (x) (coerce-contract 'object-contract x)) method-ctcs)
wrappers
fields
(map (λ (x) (coerce-contract 'object-contract x)) field-ctcs)))
(define-syntax (old->d stx) (make-/proc #f ->d/h stx)) ;; just here for now so the mixin contracts work.
(define (make-mixin-contract . %/<%>s)
((and/c (flat-contract class?)
(apply and/c (map sub/impl?/c %/<%>s)))
. old->d .
subclass?/c))
(->d ([c% (and/c (flat-contract class?)
(apply and/c (map sub/impl?/c %/<%>s)))])
()
[res (subclass?/c c%)]))
(define (subclass?/c %)
(unless (class? %)
@ -442,4 +171,4 @@
[else `(is-a?/c unknown<%>)])
(lambda (x) (is-a? x <%>)))))
(define mixin-contract (class? . old->d . subclass?/c))
(define mixin-contract (->d ([c% class?]) () [res (subclass?/c c%)]))

73
collects/scribblings/reference/class.scrbl
View File

@ -1358,7 +1358,7 @@ resulting trait is the same as for @scheme[trait-sum], otherwise the
@section{Object and Class Contracts}
@defform/subs[
#:literals (field opt-> opt->* case-> -> ->* ->d ->d* ->r ->pp ->pp-rest)
#:literals (field -> ->* ->d)
(object-contract member-spec ...)
@ -1367,49 +1367,42 @@ resulting trait is the same as for @scheme[trait-sum], otherwise the
(field field-id contract-expr)]
[method-contract
(opt-> (required-contract-expr ...)
(optional-contract-expr ...)
any)
(opt-> (required-contract-expr ...)
(optional-contract-expr ...)
result-contract-expr)
(opt->* (required-contract-expr ...)
(optional-contract-expr ...)
(result-contract-expr ...))
(case-> arrow-contract ...)
arrow-contract]
(-> dom ... range)
(->* (mandatory-dom ...)
(optional-dom ...)
rest
range)
(->d (mandatory-dependent-dom ...)
(optional-dependent-dom ...)
dependent-rest
pre-cond
dep-range)]
[arrow-contract
(-> expr ... res-expr)
(-> expr ... (values res-expr ...))
(->* (expr ...) (res-expr ...))
(->* (expr ...) rest-expr (res-expr ...))
(->d expr ... res-proc-expr)
(->d* (expr ...) res-proc-expr)
(->d* (expr ...) rest-expr res-gen-expr)
(->r ((id expr) ...) expr)
(->r ((id expr) ...) id expr expr)
(->pp ((id expr) ...) pre-expr
res-expr res-id post-expr)
(->pp ((id expr) ...) pre-expr any)
(->pp ((id expr) ...) pre-expr
(values (id expr) ...) post-expr)
(->pp-rest ((id expr) ...) id expr pre-expr
res-expr res-id post-expr)
(->pp-rest ((id expr) ...) id expr pre-expr any)
(->pp-rest ((id expr) ...) id expr pre-expr
(values (id expr) ...) post-expr)])]{
[dom dom-expr (code:line keyword dom-expr)]
[range range-expr (values range-expr ...) any]
[mandatory-dom dom-expr (code:line keyword dom-expr)]
[optional-dom dom-expr (code:line keyword dom-expr)]
[rest (code:line) (code:line #:rest rest-expr)]
[mandatory-dependent-dom [id dom-expr] (code:line keyword [id dom-expr])]
[optional-dependent-dom [id dom-expr] (code:line keyword [id dom-expr])]
[dependent-rest (code:line) (code:line #:rest id rest-expr)]
[pre-cond (code:line) (code:line #:pre-cond boolean-expr)]
[dep-range any
(code:line [id range-expr] post-cond)
(code:line (values [id range-expr] ...) post-cond)]
[post-cond (code:line) (code:line #:post-cond boolean-expr)]
)]{
Produces a contract for an object.
Each of the contracts for a method has the same semantics as the
corresponding function contract, but the syntax of the method contract
must be written directly in the body of the object-contract---much
like the way that methods in class definitions use the same syntax as
regular function definitions, but cannot be arbitrary procedures. The
only exception is that the @scheme[->r], @scheme[->pp], and
@scheme[->pp-rest] contracts implicitly bind @scheme[this] to the
object itself.}
Each of the contracts for a method has the same semantics as
the corresponding function contract, but the syntax of the
method contract must be written directly in the body of the
object-contract---much like the way that methods in class
definitions use the same syntax as regular function
definitions, but cannot be arbitrary procedures. The only
exception is that @scheme[->d] contracts implicitly bind
@scheme[this] to the object itself.}
@defthing[mixin-contract contract?]{

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

@ -290,6 +290,12 @@ The @scheme[any] form can only be used in a result position of
contracts like @scheme[->]. Using @scheme[any] elsewhere is a syntax
error.}
@defform[(promise/c expr)]{
Constructs a contract on a promise. The contract does not force the
promise, but when the promise is forced, the contract checks that the
result value meets the contract produced by @scheme[expr].}
@; ------------------------------------------------------------------------
@section{Function Contracts}
@ -308,7 +314,11 @@ because it requires delaying the evaluation of the contract
expressions for the domain and range until the function
itself is called or returns.
The @scheme[case->] contract ...
The @scheme[case->] contract is a specialized contract,
designed to match @scheme[case-lambda] and
@scheme[unconstrained-domain->] allows range checking
without requiring that the domain have any particular shape
(see below for an exmaple use).
@defform*/subs[#:literals (any values)
[(-> dom ... range)]
@ -359,10 +369,10 @@ each values must match its respective contract.}
@defform*/subs[#:literals (any)
[(->* (mandatory-dom ...) (optional-dom ...) rest-expr range)
(->* (mandatory-dom ...) (optional-dom ...) range)]
[(->* (mandatory-dom ...) (optional-dom ...) rest range)]
([mandatory-dom dom-expr (code:line keyword dom-expr)]
[optional-dom dom-expr (code:line keyword dom-expr)]
[rest (code:line) (code:line #:rest rest-expr)]
[range range-expr (values range-expr ...) any])]{
The @scheme[->*] contract combinator produces contracts for
@ -388,12 +398,12 @@ symbols, and that return a symbol.
@defform*/subs[#:literals (any values)
[(->d (mandatory-dependent-dom ...)
(optional-dependent-dom ...)
rest
dependent-rest
pre-cond
dep-range)]
([mandatory-dependent-dom [id dom-expr] (code:line keyword [id dom-expr])]
[optional-dependent-dom [id dom-expr] (code:line keyword [id dom-expr])]
[rest (code:line) (code:line id rest-expr)]
[dependent-rest (code:line) (code:line #:rest id rest-expr)]
[pre-cond (code:line) (code:line #:pre-cond boolean-expr)]
[dep-range any
(code:line [id range-expr] post-cond)
@ -477,12 +487,6 @@ be blamed using the above contract:
]}
@defform[(promise/c expr)]{
Constructs a contract on a promise. The contract does not force the
promise, but when the promise is forced, the contract checks that the
result value meets the contract produced by @scheme[expr].}
@; ------------------------------------------------------------------------
@section{Lazy Data-structure Contracts}

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

File diff suppressed because it is too large Load Diff