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

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

@ -62,62 +62,66 @@
;; 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
(let* ([doms/c (map (λ (x) ((proj-get x) x)) #:property proj-prop
(if (->-dom-rest ctc) (λ (ctc)
(append (->-doms ctc) (list (->-dom-rest ctc))) (let* ([doms/c (map (λ (x) ((proj-get x) x))
(->-doms ctc)))] (if (->-dom-rest ctc)
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))] (append (->-doms ctc) (list (->-dom-rest ctc)))
[kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))] (->-doms ctc)))]
[mandatory-keywords (->-quoted-kwds ctc)] [rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
[func (->-func ctc)] [kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
[dom-length (length (->-doms ctc))] [mandatory-keywords (->-quoted-kwds ctc)]
[has-rest? (and (->-dom-rest ctc) #t)]) [func (->-func ctc)]
(lambda (pos-blame neg-blame src-info orig-str) [dom-length (length (->-doms ctc))]
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) [has-rest? (and (->-dom-rest ctc) #t)])
doms/c)] (lambda (pos-blame neg-blame src-info orig-str)
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str)) (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
rngs/c)] doms/c)]
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
kwds/c)]) rngs/c)]
(apply func [partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
(λ (val) kwds/c)])
(if has-rest? (apply func
(check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str) (λ (val)
(check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str))) (if has-rest?
(append partial-doms partial-ranges partial-kwds))))))) (check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str)
(name-prop (λ (ctc) (single-arrow-name-maker (check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str)))
(->-doms ctc) (append partial-doms partial-ranges partial-kwds))))))
(->-dom-rest ctc)
(->-kwds ctc) #:property name-prop
(->-quoted-kwds ctc) (λ (ctc) (single-arrow-name-maker
(->-rng-any? ctc) (->-doms ctc)
(->-rngs ctc)))) (->-dom-rest ctc)
(first-order-prop (->-kwds ctc)
(λ (ctc) (->-quoted-kwds ctc)
(let ([l (length (->-doms ctc))]) (->-rng-any? ctc)
(if (->-dom-rest ctc) (->-rngs ctc)))
(λ (x) #:property first-order-prop
(and (procedure? x) (λ (ctc)
(procedure-accepts-and-more? x l))) (let ([l (length (->-doms ctc))])
(λ (x) (if (->-dom-rest ctc)
(and (procedure? x) (λ (x)
(procedure-arity-includes? x l) (and (procedure? x)
(no-mandatory-keywords? x))))))) (procedure-accepts-and-more? x l)))
(stronger-prop (λ (x)
(λ (this that) (and (procedure? x)
(and (->? that) (procedure-arity-includes? x l)
(= (length (->-doms that)) (no-mandatory-keywords? x))))))
(length (->-doms this))) #:property stronger-prop
(andmap contract-stronger? (λ (this that)
(->-doms that) (and (->? that)
(->-doms this)) (= (length (->-doms that))
(= (length (->-rngs that)) (length (->-doms this)))
(length (->-rngs this))) (andmap contract-stronger?
(andmap contract-stronger? (->-doms that)
(->-rngs this) (->-doms this))
(->-rngs that))))))) (= (length (->-rngs that))
(length (->-rngs this)))
(andmap contract-stronger?
(->-rngs this)
(->-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