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

got rid of define-struct/prop since scheme/base has a define-struct that does all that (and more) now

Browse Source 
svn: r11727

original commit: 06a4d0df4af94534e6186463a19b5c6982f1c65a
This commit is contained in:
Robby Findler 2008-09-13 16:29:01 +00:00
commit 8678e1cc6e
1 changed files with 60 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/mzlib/private/contract-arrow.ss
View File

@ -62,8 +62,10 @@
;; func : the wrapper function maker. It accepts a procedure for ;; func : the wrapper function maker. It accepts a procedure for
;; checking the first-order properties and the contracts ;; checking the first-order properties and the contracts
;; and it produces a wrapper-making function. ;; and it produces a wrapper-making function.
(define-struct/prop -> (rng-any? doms dom-rest rngs kwds quoted-kwds func) (define-struct -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
((proj-prop (λ (ctc) #:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let* ([doms/c (map (λ (x) ((proj-get x) x)) (let* ([doms/c (map (λ (x) ((proj-get x) x))
(if (->-dom-rest ctc) (if (->-dom-rest ctc)
(append (->-doms ctc) (list (->-dom-rest ctc))) (append (->-doms ctc) (list (->-dom-rest ctc)))
@ -86,15 +88,17 @@
(if has-rest? (if has-rest?
(check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str) (check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str)
(check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str))) (check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str)))
(append partial-doms partial-ranges partial-kwds))))))) (append partial-doms partial-ranges partial-kwds))))))
(name-prop (λ (ctc) (single-arrow-name-maker
#:property name-prop
(λ (ctc) (single-arrow-name-maker
(->-doms ctc) (->-doms ctc)
(->-dom-rest ctc) (->-dom-rest ctc)
(->-kwds ctc) (->-kwds ctc)
(->-quoted-kwds ctc) (->-quoted-kwds ctc)
(->-rng-any? ctc) (->-rng-any? ctc)
(->-rngs ctc)))) (->-rngs ctc)))
(first-order-prop #:property first-order-prop
(λ (ctc) (λ (ctc)
(let ([l (length (->-doms ctc))]) (let ([l (length (->-doms ctc))])
(if (->-dom-rest ctc) (if (->-dom-rest ctc)
@ -104,8 +108,8 @@
(λ (x) (λ (x)
(and (procedure? x) (and (procedure? x)
(procedure-arity-includes? x l) (procedure-arity-includes? x l)
(no-mandatory-keywords? x))))))) (no-mandatory-keywords? x))))))
(stronger-prop #:property stronger-prop
(λ (this that) (λ (this that)
(and (->? that) (and (->? that)
(= (length (->-doms that)) (= (length (->-doms that))
@ -117,7 +121,7 @@
(length (->-rngs this))) (length (->-rngs this)))
(andmap contract-stronger? (andmap contract-stronger?
(->-rngs this) (->-rngs this)
(->-rngs that))))))) (->-rngs that)))))
(define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs) (define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs)
(cond (cond