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

removed links to old mzlib stuff and mzscheme module from the contract library (but not from all the libraries it depends on)

Browse Source 
svn: r8023

original commit: 8a7cdad926e8c3c9a8fa81f6f6966dcd453b6019
This commit is contained in:
Robby Findler 2007-12-16 00:20:18 +00:00
parent a23d25b76e
commit f0aa868ce8
4 changed files with 1772 additions and 1804 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,182 +1,182 @@
(module contract-arr-checks mzscheme #lang scheme/base
(provide (all-defined))
(require (lib "list.ss")
"contract-guts.ss")
(define empty-case-lambda/c (provide (all-defined-out))
(flat-named-contract '(case->) (require "contract-guts.ss")
(λ (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 (procedure-arity-includes? f arity-count)
(error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
arity-count
f)))
(define (check->*/more f arity-count) (define empty-case-lambda/c
(unless (procedure? f) (flat-named-contract '(case->)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) (λ (x) (and (procedure? x) (null? (procedure-arity x))))))
(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" ;; Checks and error functions used in macro expansions
arity-count
(if (= 1 arity-count) "" "s") ;; procedure-accepts-and-more? : procedure number -> boolean
f))) ;; 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 (procedure-arity-includes? f arity-count)
(error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
arity-count
f)))
(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) (define (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(unless pre-expr (unless pre-expr
(raise-contract-error val (raise-contract-error val
src-info src-info
blame blame
orig-str orig-str
"pre-condition expression failure"))) "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 src-info blame orig-str)
(unless (and (procedure? val)
(procedure-arity-includes? val dom-length))
(raise-contract-error
val
src-info
blame
orig-str
"expected a procedure that accepts ~a arguments, given: ~e"
dom-length
val)))
(define ((check-procedure? arity) val)
(and (procedure? val)
(procedure-arity-includes? val arity)))
(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) (define (check-post-expr->pp/h val post-expr src-info blame orig-str)
(unless (procedure? val) (unless post-expr
(raise-contract-error val (raise-contract-error val
src-info src-info
blame blame
orig-str orig-str
"expected a procedure, got ~e" "post-condition expression failure")))
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) (define (check-procedure val dom-length src-info blame orig-str)
(unless (procedure? val) (unless (and (procedure? val)
(raise-contract-error val (procedure-arity-includes? val dom-length))
src-info (raise-contract-error
blame val
orig-str src-info
"expected a procedure, got ~e" blame
val)) orig-str
(unless (procedure-accepts-and-more? val arity) "expected a procedure that accepts ~a arguments, given: ~e"
(raise-contract-error val dom-length
src-info val)))
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 src-info blame orig-str) (define ((check-procedure? arity) val)
(unless (and (procedure? val) (and (procedure? val)
(procedure-accepts-and-more? val dom-length)) (procedure-arity-includes? val arity)))
(raise-contract-error
val (define ((check-procedure/more? arity) val)
src-info (and (procedure? val)
blame (procedure-accepts-and-more? val arity)))
orig-str
"expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e" (define (check-procedure/kind val arity kind-of-thing src-info blame orig-str)
dom-length (unless (procedure? val)
dom-length (raise-contract-error val
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 src-info blame orig-str)
(unless (and (procedure? val)
(procedure-accepts-and-more? val dom-length))
(raise-contract-error
val
src-info
blame
orig-str
"expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e"
dom-length
dom-length
val)))
(define (check-rng-procedure who rng-x arity) (define (check-rng-procedure who rng-x arity)
(unless (and (procedure? rng-x) (unless (and (procedure? rng-x)
(procedure-arity-includes? rng-x arity)) (procedure-arity-includes? rng-x arity))
(error who "expected range position to be a procedure that accepts ~a arguments, given: ~e" (error who "expected range position to be a procedure that accepts ~a arguments, given: ~e"
arity arity
rng-x))) rng-x)))
(define (check-rng-procedure/more rng-mk-x arity) (define (check-rng-procedure/more rng-mk-x arity)
(unless (and (procedure? rng-mk-x) (unless (and (procedure? rng-mk-x)
(procedure-accepts-and-more? rng-mk-x arity)) (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" (error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e"
arity arity
rng-mk-x))) rng-mk-x)))
(define (check-rng-lengths results rng-contracts) (define (check-rng-lengths results rng-contracts)
(unless (= (length results) (length rng-contracts)) (unless (= (length results) (length rng-contracts))
(error '->d* (error '->d*
"expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively"
(length results) (length rng-contracts)))) (length results) (length rng-contracts))))
#| #|
test cases for procedure-accepts-and-more? test cases for procedure-accepts-and-more?
@ -195,4 +195,3 @@
(not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0))) (not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0)))
|# |#
)

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

File diff suppressed because it is too large Load Diff

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

@ -1,461 +1,424 @@
(module contract-arrow mzscheme #lang scheme/base
(require (lib "etc.ss") (require (lib "etc.ss")
"contract-guts.ss" "contract-guts.ss"
"contract-arr-checks.ss" "contract-arr-checks.ss"
"contract-opt.ss") "contract-opt.ss")
(require-for-syntax "contract-opt-guts.ss" (require (for-syntax scheme/base)
"contract-helpers.ss" (for-syntax "contract-opt-guts.ss")
"contract-arr-obj-helpers.ss" (for-syntax "contract-helpers.ss")
(lib "stx.ss" "syntax") (for-syntax "contract-arr-obj-helpers.ss")
(lib "name.ss" "syntax")) (for-syntax (lib "stx.ss" "syntax"))
(for-syntax (lib "name.ss" "syntax")))
(provide -> (provide ->
->d ->d
->* ->*
->d* ->d*
->r ->r
->pp ->pp
->pp-rest ->pp-rest
case-> case->
opt-> opt->
opt->* opt->*
unconstrained-domain-> unconstrained-domain->
check-procedure) check-procedure)
(define-syntax (unconstrained-domain-> stx)
(syntax-case stx ()
[(_ rngs ...)
(with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
[(proj-x ...) (generate-temporaries #'(rngs ...))]
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
(make-proj-contract
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
(λ (pos-blame neg-blame src-info orig-str)
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
(λ (val)
(if (procedure? val)
(λ args
(let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...)))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected a procedure")))))
procedure?))))]))
;; FIXME: need to pass in the name of the contract combinator.
(define (build--> name doms doms-rest rngs rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
[rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
[doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
(make--> rng-any? doms/c doms-rest/c rngs/c func)))
(define-struct/prop -> (rng-any? doms dom-rest rngs func)
((proj-prop (λ (ctc)
(let* ([doms/c (map (λ (x) ((proj-get x) x))
(if (->-dom-rest ctc)
(append (->-doms ctc) (list (->-dom-rest ctc)))
(->-doms ctc)))]
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
[func (->-func ctc)]
[dom-length (length (->-doms ctc))]
[check-proc
(if (->-dom-rest ctc)
check-procedure/more
check-procedure)])
(lambda (pos-blame neg-blame src-info orig-str)
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
doms/c)]
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
rngs/c)])
(apply func
(λ (val) (check-proc val dom-length src-info pos-blame orig-str))
(append partial-doms partial-ranges)))))))
(name-prop (λ (ctc) (single-arrow-name-maker
(->-doms ctc)
(->-dom-rest ctc)
(->-rng-any? ctc)
(->-rngs ctc))))
(first-order-prop
(λ (ctc)
(let ([l (length (->-doms ctc))])
(if (->-dom-rest ctc)
(λ (x)
(and (procedure? x)
(procedure-accepts-and-more? x l)))
(λ (x)
(and (procedure? x)
(procedure-arity-includes? x l)))))))
(stronger-prop
(λ (this that)
(and (->? that)
(= (length (->-doms that))
(length (->-doms this)))
(andmap contract-stronger?
(->-doms that)
(->-doms this))
(= (length (->-rngs that))
(length (->-rngs this)))
(andmap contract-stronger?
(->-rngs this)
(->-rngs that)))))))
(define (single-arrow-name-maker doms/c doms-rest rng-any? rngs)
(cond
[doms-rest
(build-compound-type-name
'->*
(apply build-compound-type-name doms/c)
doms-rest
(cond
[rng-any? 'any]
[else (apply build-compound-type-name rngs)]))]
[else
(let ([rng-name
(cond
[rng-any? 'any]
[(null? rngs) '(values)]
[(null? (cdr rngs)) (car rngs)]
[else (apply build-compound-type-name 'values rngs)])])
(apply build-compound-type-name '-> (append doms/c (list rng-name))))]))
(define arity-one-wrapper
(lambda (chk a3 c5) (lambda (val) (chk val) (lambda (a1) (c5 (val (a3 a1)))))))
(define arity-two-wrapper
(lambda (chk a3 b4 c5) (lambda (val) (chk val) (lambda (a1 b2) (c5 (val (a3 a1) (b4 b2)))))))
(define arity-three-wrapper
(lambda (chk a9 b10 c11 r12) (lambda (val) (chk val) (lambda (a6 b7 c8) (r12 (val (a9 a6) (b10 b7) (c11 c8)))))))
(define arity-four-wrapper
(lambda (chk a17 b18 c19 d20 r21) (lambda (val) (chk val) (lambda (a13 b14 c15 d16) (r21 (val (a17 a13) (b18 b14) (c19 c15) (d20 d16)))))))
(define arity-five-wrapper
(lambda (chk a27 b28 c29 d30 e31 r32)
(lambda (val) (chk val) (lambda (a22 b23 c24 d25 e26) (r32 (val (a27 a22) (b28 b23) (c29 c24) (d30 d25) (e31 e26)))))))
(define arity-six-wrapper
(lambda (chk a39 b40 c41 d42 e43 f44 r45)
(lambda (val) (chk val) (lambda (a33 b34 c35 d36 e37 f38) (r45 (val (a39 a33) (b40 b34) (c41 c35) (d42 d36) (e43 e37) (f44 f38)))))))
(define arity-seven-wrapper
(lambda (chk a53 b54 c55 d56 e57 f58 g59 r60)
(lambda (val) (chk val) (lambda (a46 b47 c48 d49 e50 f51 g52) (r60 (val (a53 a46) (b54 b47) (c55 c48) (d56 d49) (e57 e50) (f58 f51) (g59 g52)))))))
(define-syntax-set (-> ->*)
(define (->/proc stx)
(let-values ([(stx _1 _2) (->/proc/main stx)])
stx))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define (->/proc/main stx)
(let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)])
(with-syntax ([(args body) inner-args/body])
(with-syntax ([(dom-names ...) dom-names]
[(rng-names ...) rng-names]
[(dom-ctcs ...) dom-ctcs]
[(rng-ctcs ...) rng-ctcs]
[inner-lambda
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body)))]
[use-any? use-any?])
(with-syntax ([outer-lambda
(let* ([lst (syntax->list #'args)]
[len (and lst (length lst))])
(if (and #f ;; this optimization disables the names so is turned off for now
lst
(not (syntax-e #'use-any?))
(= len (length (syntax->list #'(dom-names ...))))
(= 1 (length (syntax->list #'(rng-names ...))))
(<= 1 len 7))
(case len
[(1) #'arity-one-wrapper]
[(2) #'arity-two-wrapper]
[(3) #'arity-three-wrapper]
[(4) #'arity-four-wrapper]
[(5) #'arity-five-wrapper]
[(6) #'arity-six-wrapper]
[(7) #'arity-seven-wrapper])
(syntax
(lambda (chk dom-names ... rng-names ...)
(lambda (val)
(chk val)
inner-lambda)))))])
(values
(syntax (build--> '->
(list dom-ctcs ...)
#f
(list rng-ctcs ...)
use-any?
outer-lambda))
inner-args/body
(syntax (dom-names ... rng-names ...))))))))
(define (->-helper stx)
(syntax-case* stx (-> any values) module-or-top-identifier=?
[(-> doms ... any)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(ignored) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...))
(syntax (ignored))
(syntax (doms ...))
(syntax (any/c))
(syntax ((args ...) (val (dom-ctc args) ...)))
#t))]
[(-> doms ... (values rngs ...))
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))])
(values (syntax (dom-ctc ...))
(syntax (rng-ctc ...))
(syntax (doms ...))
(syntax (rngs ...))
(syntax ((args ...)
(let-values ([(rng-x ...) (val (dom-ctc args) ...)])
(values (rng-ctc rng-x) ...))))
#f))]
[(_ doms ... rng)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-ctc) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...))
(syntax (rng-ctc))
(syntax (doms ...))
(syntax (rng))
(syntax ((args ...) (rng-ctc (val (dom-ctc args) ...))))
#f))]))
(define (->*/proc stx)
(let-values ([(stx _1 _2) (->*/proc/main stx)])
stx))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define (->*/proc/main stx)
(syntax-case* stx (->* any) module-or-top-identifier=?
[(->* (doms ...) any)
(->/proc/main (syntax (-> doms ... any)))]
[(->* (doms ...) (rngs ...))
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
[(->* (doms ...) rst (rngs ...))
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(rst-x) (generate-temporaries (syntax (rst)))]
[(rest-arg) (generate-temporaries (syntax (rst)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
(let ([inner-args/body
(syntax ((args ... . rest-arg)
(let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))])
(values (rng-x rng-args) ...))))])
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x rng-x ...)
(lambda (val)
(chk val)
inner-lambda)))])
(values (syntax (build--> '->*
(list doms ...)
rst
(list rngs ...)
#f
outer-lambda))
inner-args/body
(syntax (dom-x ... rst-x rng-x ...)))))))]
[(->* (doms ...) rst any)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(rst-x) (generate-temporaries (syntax (rst)))]
[(rest-arg) (generate-temporaries (syntax (rst)))])
(let ([inner-args/body
(syntax ((args ... . rest-arg)
(apply val (dom-x args) ... (rst-x rest-arg))))])
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x ignored)
(lambda (val)
(chk val)
inner-lambda)))])
(values (syntax (build--> '->*
(list doms ...)
rst
(list any/c)
#t
outer-lambda))
inner-args/body
(syntax (dom-x ... rst-x)))))))])))
(define-for-syntax (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-syntax (->d stx) (make-/proc #f ->d/h stx))
(define-syntax (->d* stx) (make-/proc #f ->d*/h stx))
(define-syntax (->r stx) (make-/proc #f ->r/h stx))
(define-syntax (->pp stx) (make-/proc #f ->pp/h stx))
(define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx))
(define-syntax (case-> stx) (make-case->/proc #f stx stx select/h))
(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
;; (define-syntax (unconstrained-domain-> stx)
;; arrow opter (syntax-case stx ()
;; [(_ rngs ...)
(define/opter (-> opt/i opt/info stx) (with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
(define (opt/arrow-ctc doms rngs) [(proj-x ...) (generate-temporaries #'(rngs ...))]
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms) [(p-app-x ...) (generate-temporaries #'(rngs ...))]
(generate-temporaries rngs))] [(res-x ...) (generate-temporaries #'(rngs ...))])
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let loop ([vars dom-vars] (let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
[doms doms] (make-proj-contract
[next-doms null] (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
[lifts-doms null] (λ (pos-blame neg-blame src-info orig-str)
[superlifts-doms null] (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
[partials-doms null] (λ (val)
[stronger-ribs null]) (if (procedure? val)
(cond (λ args
[(null? doms) (values (reverse next-doms) (let-values ([(res-x ...) (apply val args)])
lifts-doms (values (p-app-x res-x) ...)))
superlifts-doms (raise-contract-error val
partials-doms src-info
stronger-ribs)] pos-blame
[else orig-str
(let-values ([(next lift superlift partial _ __ this-stronger-ribs) "expected a procedure")))))
(opt/i (opt/info-swap-blame opt/info) (car doms))]) procedure?))))]))
(loop (cdr vars)
(cdr doms) ;; FIXME: need to pass in the name of the contract combinator.
(cons (with-syntax ((next next) (define (build--> name doms doms-rest rngs rng-any? func)
(car-vars (car vars))) (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
(syntax (let ((val car-vars)) next))) [rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
next-doms) [doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
(append lifts-doms lift) (make--> rng-any? doms/c doms-rest/c rngs/c func)))
(append superlifts-doms superlift)
(append partials-doms partial) (define-struct/prop -> (rng-any? doms dom-rest rngs func)
(append this-stronger-ribs stronger-ribs)))]))] ((proj-prop (λ (ctc)
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng) (let* ([doms/c (map (λ (x) ((proj-get x) x))
(let loop ([vars rng-vars] (if (->-dom-rest ctc)
[rngs rngs] (append (->-doms ctc) (list (->-dom-rest ctc)))
[next-rngs null] (->-doms ctc)))]
[lifts-rngs null] [rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
[superlifts-rngs null] [func (->-func ctc)]
[partials-rngs null] [dom-length (length (->-doms ctc))]
[stronger-ribs null]) [check-proc
(cond (if (->-dom-rest ctc)
[(null? rngs) (values (reverse next-rngs) check-procedure/more
lifts-rngs check-procedure)])
superlifts-rngs (lambda (pos-blame neg-blame src-info orig-str)
partials-rngs (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
stronger-ribs)] doms/c)]
[else [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
(let-values ([(next lift superlift partial _ __ this-stronger-ribs) rngs/c)])
(opt/i opt/info (car rngs))]) (apply func
(loop (cdr vars) (λ (val) (check-proc val dom-length src-info pos-blame orig-str))
(cdr rngs) (append partial-doms partial-ranges)))))))
(cons (with-syntax ((next next) (name-prop (λ (ctc) (single-arrow-name-maker
(car-vars (car vars))) (->-doms ctc)
(syntax (let ((val car-vars)) next))) (->-dom-rest ctc)
next-rngs) (->-rng-any? ctc)
(append lifts-rngs lift) (->-rngs ctc))))
(append superlifts-rngs superlift) (first-order-prop
(append partials-rngs partial) (λ (ctc)
(append this-stronger-ribs stronger-ribs)))]))]) (let ([l (length (->-doms ctc))])
(values (if (->-dom-rest ctc)
(with-syntax ((pos (opt/info-pos opt/info)) (λ (x)
(src-info (opt/info-src-info opt/info)) (and (procedure? x)
(orig-str (opt/info-orig-str opt/info)) (procedure-accepts-and-more? x l)))
((dom-arg ...) dom-vars) (λ (x)
((rng-arg ...) rng-vars) (and (procedure? x)
((next-dom ...) next-doms) (procedure-arity-includes? x l)))))))
(dom-len (length dom-vars)) (stronger-prop
((next-rng ...) next-rngs)) (λ (this that)
(syntax (begin (and (->? that)
(check-procedure val dom-len src-info pos orig-str) (= (length (->-doms that))
(λ (dom-arg ...) (length (->-doms this)))
(let-values ([(rng-arg ...) (val next-dom ...)]) (andmap contract-stronger?
(values next-rng ...)))))) (->-doms that)
(append lifts-doms lifts-rngs) (->-doms this))
(append superlifts-doms superlifts-rngs) (= (length (->-rngs that))
(append partials-doms partials-rngs) (length (->-rngs this)))
#f (andmap contract-stronger?
#f (->-rngs this)
(append stronger-ribs-dom stronger-ribs-rng)))) (->-rngs that)))))))
(define (opt/arrow-any-ctc doms) (define (single-arrow-name-maker doms/c doms-rest rng-any? rngs)
(let*-values ([(dom-vars) (generate-temporaries doms)] (cond
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) [doms-rest
(let loop ([vars dom-vars] (build-compound-type-name
[doms doms] '->*
[next-doms null] (apply build-compound-type-name doms/c)
[lifts-doms null] doms-rest
[superlifts-doms null] (cond
[partials-doms null] [rng-any? 'any]
[stronger-ribs null]) [else (apply build-compound-type-name rngs)]))]
(cond [else
[(null? doms) (values (reverse next-doms) (let ([rng-name
lifts-doms (cond
superlifts-doms [rng-any? 'any]
partials-doms [(null? rngs) '(values)]
stronger-ribs)] [(null? (cdr rngs)) (car rngs)]
[else [else (apply build-compound-type-name 'values rngs)])])
(let-values ([(next lift superlift partial flat _ this-stronger-ribs) (apply build-compound-type-name '-> (append doms/c (list rng-name))))]))
(opt/i (opt/info-swap-blame opt/info) (car doms))])
(loop (cdr vars) (define-syntax-set (-> ->*)
(cdr doms) (define (->/proc stx)
(cons (with-syntax ((next next) (let-values ([(stx _1 _2) (->/proc/main stx)])
(car-vars (car vars))) stx))
(syntax (let ((val car-vars)) next)))
next-doms) ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(append lifts-doms lift) (define (->/proc/main stx)
(append superlifts-doms superlift) (let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)])
(append partials-doms partial) (with-syntax ([(args body) inner-args/body])
(append this-stronger-ribs stronger-ribs)))]))]) (with-syntax ([(dom-names ...) dom-names]
(values [(rng-names ...) rng-names]
(with-syntax ((pos (opt/info-pos opt/info)) [(dom-ctcs ...) dom-ctcs]
(src-info (opt/info-src-info opt/info)) [(rng-ctcs ...) rng-ctcs]
(orig-str (opt/info-orig-str opt/info)) [inner-lambda
((dom-arg ...) dom-vars) (add-name-prop
((next-dom ...) next-doms) (syntax-local-infer-name stx)
(dom-len (length dom-vars))) (syntax (lambda args body)))]
(syntax (begin [use-any? use-any?])
(check-procedure val dom-len src-info pos orig-str) (with-syntax ([outer-lambda
(λ (dom-arg ...) (let* ([lst (syntax->list #'args)]
(val next-dom ...))))) [len (and lst (length lst))])
lifts-doms (syntax
superlifts-doms (lambda (chk dom-names ... rng-names ...)
partials-doms (lambda (val)
#f (chk val)
#f inner-lambda))))])
stronger-ribs-dom))) (values
(syntax (build--> '->
(syntax-case* stx (-> values any) module-or-top-identifier=? (list dom-ctcs ...)
[(-> dom ... (values rng ...)) #f
(opt/arrow-ctc (syntax->list (syntax (dom ...))) (list rng-ctcs ...)
(syntax->list (syntax (rng ...))))] use-any?
[(-> dom ... any) outer-lambda))
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))] inner-args/body
[(-> dom ... rng) (syntax (dom-names ... rng-names ...))))))))
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
(list #'rng))]))) (define (->-helper stx)
(syntax-case* stx (-> any values) module-or-top-identifier=?
[(-> doms ... any)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(ignored) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...))
(syntax (ignored))
(syntax (doms ...))
(syntax (any/c))
(syntax ((args ...) (val (dom-ctc args) ...)))
#t))]
[(-> doms ... (values rngs ...))
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))])
(values (syntax (dom-ctc ...))
(syntax (rng-ctc ...))
(syntax (doms ...))
(syntax (rngs ...))
(syntax ((args ...)
(let-values ([(rng-x ...) (val (dom-ctc args) ...)])
(values (rng-ctc rng-x) ...))))
#f))]
[(_ doms ... rng)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-ctc) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...))
(syntax (rng-ctc))
(syntax (doms ...))
(syntax (rng))
(syntax ((args ...) (rng-ctc (val (dom-ctc args) ...))))
#f))]))
(define (->*/proc stx)
(let-values ([(stx _1 _2) (->*/proc/main stx)])
stx))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define (->*/proc/main stx)
(syntax-case* stx (->* any) module-or-top-identifier=?
[(->* (doms ...) any)
(->/proc/main (syntax (-> doms ... any)))]
[(->* (doms ...) (rngs ...))
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
[(->* (doms ...) rst (rngs ...))
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(rst-x) (generate-temporaries (syntax (rst)))]
[(rest-arg) (generate-temporaries (syntax (rst)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
(let ([inner-args/body
(syntax ((args ... . rest-arg)
(let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))])
(values (rng-x rng-args) ...))))])
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x rng-x ...)
(lambda (val)
(chk val)
inner-lambda)))])
(values (syntax (build--> '->*
(list doms ...)
rst
(list rngs ...)
#f
outer-lambda))
inner-args/body
(syntax (dom-x ... rst-x rng-x ...)))))))]
[(->* (doms ...) rst any)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(rst-x) (generate-temporaries (syntax (rst)))]
[(rest-arg) (generate-temporaries (syntax (rst)))])
(let ([inner-args/body
(syntax ((args ... . rest-arg)
(apply val (dom-x args) ... (rst-x rest-arg))))])
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x ignored)
(lambda (val)
(chk val)
inner-lambda)))])
(values (syntax (build--> '->*
(list doms ...)
rst
(list any/c)
#t
outer-lambda))
inner-args/body
(syntax (dom-x ... rst-x)))))))])))
(define-for-syntax (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-syntax (->d stx) (make-/proc #f ->d/h stx))
(define-syntax (->d* stx) (make-/proc #f ->d*/h stx))
(define-syntax (->r stx) (make-/proc #f ->r/h stx))
(define-syntax (->pp stx) (make-/proc #f ->pp/h stx))
(define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx))
(define-syntax (case-> stx) (make-case->/proc #f stx stx select/h))
(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
;;
;; arrow opter
;;
(define/opter (-> opt/i opt/info stx)
(define (opt/arrow-ctc doms rngs)
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
(generate-temporaries rngs))]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
(let loop ([vars dom-vars]
[doms doms]
[next-doms null]
[lifts-doms null]
[superlifts-doms null]
[partials-doms null]
[stronger-ribs null])
(cond
[(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs)]
[else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs)
(opt/i (opt/info-swap-blame opt/info) (car doms))])
(loop (cdr vars)
(cdr doms)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-doms)
(append lifts-doms lift)
(append superlifts-doms superlift)
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))]
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng)
(let loop ([vars rng-vars]
[rngs rngs]
[next-rngs null]
[lifts-rngs null]
[superlifts-rngs null]
[partials-rngs null]
[stronger-ribs null])
(cond
[(null? rngs) (values (reverse next-rngs)
lifts-rngs
superlifts-rngs
partials-rngs
stronger-ribs)]
[else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs)
(opt/i opt/info (car rngs))])
(loop (cdr vars)
(cdr rngs)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-rngs)
(append lifts-rngs lift)
(append superlifts-rngs superlift)
(append partials-rngs partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values
(with-syntax ((pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
((dom-arg ...) dom-vars)
((rng-arg ...) rng-vars)
((next-dom ...) next-doms)
(dom-len (length dom-vars))
((next-rng ...) next-rngs))
(syntax (begin
(check-procedure val dom-len src-info pos orig-str)
(λ (dom-arg ...)
(let-values ([(rng-arg ...) (val next-dom ...)])
(values next-rng ...))))))
(append lifts-doms lifts-rngs)
(append superlifts-doms superlifts-rngs)
(append partials-doms partials-rngs)
#f
#f
(append stronger-ribs-dom stronger-ribs-rng))))
(define (opt/arrow-any-ctc doms)
(let*-values ([(dom-vars) (generate-temporaries doms)]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
(let loop ([vars dom-vars]
[doms doms]
[next-doms null]
[lifts-doms null]
[superlifts-doms null]
[partials-doms null]
[stronger-ribs null])
(cond
[(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs)]
[else
(let-values ([(next lift superlift partial flat _ this-stronger-ribs)
(opt/i (opt/info-swap-blame opt/info) (car doms))])
(loop (cdr vars)
(cdr doms)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-doms)
(append lifts-doms lift)
(append superlifts-doms superlift)
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values
(with-syntax ((pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
((dom-arg ...) dom-vars)
((next-dom ...) next-doms)
(dom-len (length dom-vars)))
(syntax (begin
(check-procedure val dom-len src-info pos orig-str)
(λ (dom-arg ...)
(val next-dom ...)))))
lifts-doms
superlifts-doms
partials-doms
#f
#f
stronger-ribs-dom)))
(syntax-case* stx (-> values any) module-or-top-identifier=?
[(-> dom ... (values rng ...))
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
(syntax->list (syntax (rng ...))))]
[(-> dom ... any)
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
[(-> dom ... rng)
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
(list #'rng))]))

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

@ -1,23 +1,22 @@
(module contract-object mzscheme #lang scheme/base
(require (lib "etc.ss") (require "contract-arrow.ss"
"contract-arrow.ss" "contract-guts.ss"
"contract-guts.ss" "class-internal.ss"
"class-internal.ss" "contract-arr-checks.ss")
"contract-arr-checks.ss")
(require (for-syntax scheme/base
(require-for-syntax "contract-helpers.ss" "contract-helpers.ss"
"contract-arr-obj-helpers.ss" "contract-arr-obj-helpers.ss"))
(lib "list.ss"))
(provide mixin-contract
(provide mixin-contract make-mixin-contract
make-mixin-contract is-a?/c
is-a?/c subclass?/c
subclass?/c implementation?/c
implementation?/c object-contract)
object-contract)
(define-syntax object-contract
(define-syntax-set (object-contract) (let ()
(define (obj->/proc stx) (make-/proc #t ->/h stx)) (define (obj->/proc stx) (make-/proc #t ->/h stx))
(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))
@ -41,11 +40,11 @@
[(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))] [(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)])) [_ (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 select/h #'case-> #'->))
(define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx select/h #'case-> #'->)) (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx select/h #'case-> #'->))
(define (object-contract/proc stx) (λ (stx)
;; name : syntax ;; name : syntax
;; ctc-stx : syntax[evals to a contract] ;; ctc-stx : syntax[evals to a contract]
@ -161,7 +160,7 @@
(syntax (syntax
(->d any/c doms ... (->d any/c doms ...
(let ([f rng-proc]) (let ([f rng-proc])
(check->* f arity-count) (check->* f arity-count)
(lambda (_this-var arg-vars ...) (lambda (_this-var arg-vars ...)
(f arg-vars ...)))))) (f arg-vars ...))))))
(with-syntax ([(args-vars ...) (generate-temporaries doms-val)]) (with-syntax ([(args-vars ...) (generate-temporaries doms-val)])
@ -174,7 +173,7 @@
[arity-count (length doms-val)]) [arity-count (length doms-val)])
(syntax (->d* (any/c doms ...) (syntax (->d* (any/c doms ...)
(let ([f rng-proc]) (let ([f rng-proc])
(check->* f arity-count) (check->* f arity-count)
(lambda (_this-var arg-vars ...) (lambda (_this-var arg-vars ...)
(f arg-vars ...))))))) (f arg-vars ...)))))))
(with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
@ -190,7 +189,7 @@
(syntax (->d* (any/c doms ...) (syntax (->d* (any/c doms ...)
rst-ctc rst-ctc
(let ([f rng-proc]) (let ([f rng-proc])
(check->*/more f arity-count) (check->*/more f arity-count)
(lambda (_this-var arg-vars ... . rest-var) (lambda (_this-var arg-vars ... . rest-var)
(apply f arg-vars ... rest-var)))))) (apply f arg-vars ... rest-var))))))
(with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
@ -204,7 +203,7 @@
(andmap identifier? (syntax->list (syntax (x ...)))) (andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->r/proc obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rng)) (syntax (->r ([this any/c] [x dom] ...) rng))
@ -214,7 +213,7 @@
(andmap identifier? (syntax->list (syntax (x ...)))) (andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->r/proc obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng)) (syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng))
@ -226,7 +225,7 @@
(andmap identifier? (syntax->list (syntax (x ...)))) (andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->pp/proc obj->pp/proc
(syntax (->pp ([this any/c] [x dom] ...) . other-stuff)) (syntax (->pp ([this any/c] [x dom] ...) . other-stuff))
@ -238,7 +237,7 @@
(andmap identifier? (syntax->list (syntax (x ...))))) (andmap identifier? (syntax->list (syntax (x ...)))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->pp-rest/proc obj->pp-rest/proc
(syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff)) (syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff))
@ -249,6 +248,12 @@
;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc] ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
(define (build-methods-stx mtds) (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)] (let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)]
[names (map mtd-name mtds)] [names (map mtd-name mtds)]
[i 0]) [i 0])
@ -279,7 +284,7 @@
rest-ids ... rest-ids ...
last-var)))))]))) last-var)))))])))
(syntax->list arg-spec-stxs))] (syntax->list arg-spec-stxs))]
[name (string->symbol (format "~a method" (syntax-object->datum (car names))))]) [name (string->symbol (format "~a method" (syntax->datum (car names))))])
(with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)]) (with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)])
(cons (syntax (lambda (field-ref) (let ([name proc]) name))) (cons (syntax (lambda (field-ref) (let ([name proc]) name)))
(loop (cdr arg-spec-stxss) (loop (cdr arg-spec-stxss)
@ -307,8 +312,8 @@
(syntax-case stx () (syntax-case stx ()
[(_ field/mtd-specs ...) [(_ field/mtd-specs ...)
(let* ([mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (field/mtd-specs ...))))] (let* ([mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (field/mtd-specs ...))))]
[mtds (filter mtd? mtd/flds)] [mtds (filter mtd? mtd/flds)]
[flds (filter fld? mtd/flds)]) [flds (filter fld? mtd/flds)])
(with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)] (with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)]
[(method-name ...) (map mtd-name mtds)] [(method-name ...) (map mtd-name mtds)]
[(method-ctc-var ...) (generate-temporaries mtds)] [(method-ctc-var ...) (generate-temporaries mtds)]
@ -334,105 +339,105 @@
'(method-name ...) '(method-name ...)
(list methods ...) (list methods ...)
'(field-name ...))]) '(field-name ...))])
(make-proj-contract (make-proj-contract
`(object-contract `(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ... ,(build-compound-type-name 'method-name method-ctc-var) ...
,(build-compound-type-name 'field 'field-name field-ctc-var) ...) ,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
(lambda (pos-blame neg-blame src-info orig-str) (lambda (pos-blame neg-blame src-info orig-str)
(let ([method/app-var (method-var 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)] [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)
...) ...)
(let ([field-names-list '(field-name ...)])
(unless (field-bound? field-name val) (lambda (val)
(field-error val 'field-name src-info pos-blame orig-str)) ... (check-object val src-info pos-blame orig-str)
(let ([val-mtd-names
(let ([vtable (extract-vtable val)] (interface->method-names
[method-ht (extract-method-ht val)]) (object-interface
(make-object cls val))])
val (void)
(method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ... (check-method val 'method-name val-mtd-names src-info pos-blame orig-str)
(field/app-var (get-field field-name val)) ... ...)
))))))
#f)))))))]))) (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)))))))]))))
(define (check-object val src-info blame orig-str) (define (check-object val src-info blame orig-str)
(unless (object? val) (unless (object? val)
(raise-contract-error val
src-info
blame
orig-str
"expected an object, got ~e"
val)))
(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)))
(define (field-error val field-name src-info blame orig-str)
(raise-contract-error val (raise-contract-error val
src-info src-info
blame blame
orig-str orig-str
"expected an object with field ~s" "expected an object, got ~e"
field-name)) val)))
(define (make-mixin-contract . %/<%>s)
((and/c (flat-contract class?)
(apply and/c (map sub/impl?/c %/<%>s)))
. ->d .
subclass?/c))
(define (subclass?/c %)
(unless (class? %)
(error 'subclass?/c "expected <class>, given: ~e" %))
(let ([name (object-name %)])
(flat-named-contract
`(subclass?/c ,(or name 'unknown%))
(lambda (x) (subclass? x %)))))
(define (implementation?/c <%>)
(unless (interface? <%>)
(error 'implementation?/c "expected <interface>, given: ~e" <%>))
(let ([name (object-name <%>)])
(flat-named-contract
`(implementation?/c ,(or name 'unknown<%>))
(lambda (x) (implementation? x <%>)))))
(define (sub/impl?/c %/<%>)
(cond
[(interface? %/<%>) (implementation?/c %/<%>)]
[(class? %/<%>) (subclass?/c %/<%>)]
[else (error 'make-mixin-contract "unknown input ~e" %/<%>)]))
(define (is-a?/c <%>) (define (check-method val method-name val-mtd-names src-info blame orig-str)
(unless (or (interface? <%>) (unless (memq method-name val-mtd-names)
(class? <%>)) (raise-contract-error val
(error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>)) src-info
(let ([name (object-name <%>)]) blame
(flat-named-contract orig-str
(cond "expected an object with method ~s"
[name method-name)))
`(is-a?/c ,name)]
[(class? <%>) (define (field-error val field-name src-info blame orig-str)
`(is-a?/c unknown%)] (raise-contract-error val
[else `(is-a?/c unknown<%>)]) src-info
(lambda (x) (is-a? x <%>))))) blame
orig-str
(define mixin-contract (class? . ->d . subclass?/c))) "expected an object with field ~s"
field-name))
(define (make-mixin-contract . %/<%>s)
((and/c (flat-contract class?)
(apply and/c (map sub/impl?/c %/<%>s)))
. ->d .
subclass?/c))
(define (subclass?/c %)
(unless (class? %)
(error 'subclass?/c "expected <class>, given: ~e" %))
(let ([name (object-name %)])
(flat-named-contract
`(subclass?/c ,(or name 'unknown%))
(lambda (x) (subclass? x %)))))
(define (implementation?/c <%>)
(unless (interface? <%>)
(error 'implementation?/c "expected <interface>, given: ~e" <%>))
(let ([name (object-name <%>)])
(flat-named-contract
`(implementation?/c ,(or name 'unknown<%>))
(lambda (x) (implementation? x <%>)))))
(define (sub/impl?/c %/<%>)
(cond
[(interface? %/<%>) (implementation?/c %/<%>)]
[(class? %/<%>) (subclass?/c %/<%>)]
[else (error 'make-mixin-contract "unknown input ~e" %/<%>)]))
(define (is-a?/c <%>)
(unless (or (interface? <%>)
(class? <%>))
(error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>))
(let ([name (object-name <%>)])
(flat-named-contract
(cond
[name
`(is-a?/c ,name)]
[(class? <%>)
`(is-a?/c unknown%)]
[else `(is-a?/c unknown<%>)])
(lambda (x) (is-a? x <%>)))))
(define mixin-contract (class? . ->d . subclass?/c))