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

321
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))))))
;; ---------------------------------------- (define empty-case-lambda/c
;; Checks and error functions used in macro expansions (flat-named-contract '(case->)
(λ (x) (and (procedure? x) (null? (procedure-arity x))))))
;; procedure-accepts-and-more? : procedure number -> boolean ;; ----------------------------------------
;; returns #t if val accepts dom-length arguments and ;; Checks and error functions used in macro expansions
;; 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) ;; procedure-accepts-and-more? : procedure number -> boolean
(unless (procedure? f) ;; returns #t if val accepts dom-length arguments and
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) ;; any number of arguments more than dom-length.
(unless (procedure-arity-includes? f arity-count) ;; returns #f otherwise.
(error 'object-contract (define (procedure-accepts-and-more? val dom-length)
"expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e" (let ([arity (procedure-arity val)])
arity-count (cond
f))) [(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->*/more f arity-count) (define (check->* f arity-count)
(unless (procedure? f) (unless (procedure? f)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
(unless (procedure-accepts-and-more? f arity-count) (unless (procedure-arity-includes? f arity-count)
(error 'object-contract (error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a argument~a and arbitrarily many more, got ~e" "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
arity-count arity-count
(if (= 1 arity-count) "" "s") f)))
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) (define (check-post-expr->pp/h val post-expr src-info blame orig-str)
(unless post-expr (unless post-expr
(raise-contract-error val (raise-contract-error val
src-info src-info
blame blame
orig-str orig-str
"post-condition expression failure"))) "post-condition expression failure")))
(define (check-procedure val dom-length src-info blame orig-str) (define (check-procedure val dom-length src-info blame orig-str)
(unless (and (procedure? val) (unless (and (procedure? val)
(procedure-arity-includes? val dom-length)) (procedure-arity-includes? val dom-length))
(raise-contract-error (raise-contract-error
val val
src-info src-info
blame blame
orig-str orig-str
"expected a procedure that accepts ~a arguments, given: ~e" "expected a procedure that accepts ~a arguments, given: ~e"
dom-length dom-length
val))) val)))
(define ((check-procedure? arity) val) (define ((check-procedure? arity) val)
(and (procedure? val) (and (procedure? val)
(procedure-arity-includes? val arity))) (procedure-arity-includes? val arity)))
(define ((check-procedure/more? arity) val) (define ((check-procedure/more? arity) val)
(and (procedure? val) (and (procedure? val)
(procedure-accepts-and-more? val arity))) (procedure-accepts-and-more? val arity)))
(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str) (define (check-procedure/kind val arity kind-of-thing src-info blame orig-str)
(unless (procedure? val) (unless (procedure? val)
(raise-contract-error val (raise-contract-error val
src-info src-info
blame blame
orig-str orig-str
"expected a procedure, got ~e" "expected a procedure, got ~e"
val)) val))
(unless (procedure-arity-includes? val arity) (unless (procedure-arity-includes? val arity)
(raise-contract-error val (raise-contract-error val
src-info src-info
blame blame
orig-str orig-str
"expected a ~a of arity ~a (not arity ~a), got ~e" "expected a ~a of arity ~a (not arity ~a), got ~e"
kind-of-thing kind-of-thing
arity arity
(procedure-arity val) (procedure-arity val)
val))) val)))
(define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str) (define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str)
(unless (procedure? val) (unless (procedure? val)
(raise-contract-error val (raise-contract-error val
src-info src-info
blame blame
orig-str orig-str
"expected a procedure, got ~e" "expected a procedure, got ~e"
val)) val))
(unless (procedure-accepts-and-more? val arity) (unless (procedure-accepts-and-more? val arity)
(raise-contract-error val (raise-contract-error val
src-info src-info
blame blame
orig-str orig-str
"expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e" "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e"
kind-of-thing kind-of-thing
arity arity
(procedure-arity val) (procedure-arity val)
val))) val)))
(define (check-procedure/more val dom-length src-info blame orig-str) (define (check-procedure/more val dom-length src-info blame orig-str)
(unless (and (procedure? val) (unless (and (procedure? val)
(procedure-accepts-and-more? val dom-length)) (procedure-accepts-and-more? val dom-length))
(raise-contract-error (raise-contract-error
val val
src-info src-info
blame blame
orig-str orig-str
"expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e" "expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e"
dom-length dom-length
dom-length dom-length
val))) 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)))
|# |#
)

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

File diff suppressed because it is too large Load Diff

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

235
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 "contract-helpers.ss" (require (for-syntax scheme/base
"contract-arr-obj-helpers.ss" "contract-helpers.ss"
(lib "list.ss")) "contract-arr-obj-helpers.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-set (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->*/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))
@ -45,7 +44,7 @@
(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 ...)])
(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) (unless (field-bound? field-name val)
(field-error val 'field-name src-info pos-blame orig-str)) ... (field-error val 'field-name src-info pos-blame orig-str)) ...
(let ([vtable (extract-vtable val)] (let ([vtable (extract-vtable val)]
[method-ht (extract-method-ht val)]) [method-ht (extract-method-ht val)])
(make-object cls (make-object cls
val val
(method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ... (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ... (field/app-var (get-field field-name val)) ...
)))))) ))))))
#f)))))))]))) #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) (define (check-method val method-name val-mtd-names src-info blame orig-str)
((and/c (flat-contract class?) (unless (memq method-name val-mtd-names)
(apply and/c (map sub/impl?/c %/<%>s))) (raise-contract-error val
. ->d . src-info
subclass?/c)) blame
orig-str
"expected an object with method ~s"
method-name)))
(define (subclass?/c %) (define (field-error val field-name src-info blame orig-str)
(unless (class? %) (raise-contract-error val
(error 'subclass?/c "expected <class>, given: ~e" %)) src-info
(let ([name (object-name %)]) blame
(flat-named-contract orig-str
`(subclass?/c ,(or name 'unknown%)) "expected an object with field ~s"
(lambda (x) (subclass? x %))))) field-name))
(define (implementation?/c <%>) (define (make-mixin-contract . %/<%>s)
(unless (interface? <%>) ((and/c (flat-contract class?)
(error 'implementation?/c "expected <interface>, given: ~e" <%>)) (apply and/c (map sub/impl?/c %/<%>s)))
(let ([name (object-name <%>)]) . ->d .
(flat-named-contract subclass?/c))
`(implementation?/c ,(or name 'unknown<%>))
(lambda (x) (implementation? x <%>)))))
(define (sub/impl?/c %/<%>) (define (subclass?/c %)
(cond (unless (class? %)
[(interface? %/<%>) (implementation?/c %/<%>)] (error 'subclass?/c "expected <class>, given: ~e" %))
[(class? %/<%>) (subclass?/c %/<%>)] (let ([name (object-name %)])
[else (error 'make-mixin-contract "unknown input ~e" %/<%>)])) (flat-named-contract
`(subclass?/c ,(or name 'unknown%))
(lambda (x) (subclass? x %)))))
(define (is-a?/c <%>) (define (implementation?/c <%>)
(unless (or (interface? <%>) (unless (interface? <%>)
(class? <%>)) (error 'implementation?/c "expected <interface>, given: ~e" <%>))
(error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>)) (let ([name (object-name <%>)])
(let ([name (object-name <%>)]) (flat-named-contract
(flat-named-contract `(implementation?/c ,(or name 'unknown<%>))
(cond (lambda (x) (implementation? x <%>)))))
[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))) (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))