..
original commit: 45e8ea4e36c875d12881ceafee62585402845053
This commit is contained in:
Robby Findler
parent
57ec955307
commit
aab6330a0a
|
|
@ -1,3 +1,9 @@
|
|||
#|
|
||||
|
||||
improve method arity mismatch contract violation error messages?
|
||||
(abstract out -> and friends even more?)
|
||||
|
||||
|#
|
||||
|
||||
(module contract mzscheme
|
||||
(provide (rename -contract contract)
|
||||
|
|
@ -10,7 +16,7 @@
|
|||
opt->*
|
||||
;class-contract
|
||||
;class-contract/prim
|
||||
;object-contract ;; not yet good enough
|
||||
object-contract ;; not yet good enough
|
||||
provide/contract
|
||||
define/contract
|
||||
contract?
|
||||
|
|
@ -833,7 +839,7 @@
|
|||
(super-init ())))])
|
||||
(syntax/loc stx
|
||||
(make-contract
|
||||
"class contract"
|
||||
"(object-contract ...)"
|
||||
(lambda outer-args
|
||||
(let ([super-contracts-ht
|
||||
(let loop ([cls val])
|
||||
|
|
@ -854,8 +860,7 @@
|
|||
orig-str
|
||||
"expected class to have method ~a, got: ~e"
|
||||
'meth-name
|
||||
val))
|
||||
...)
|
||||
val)) ...)
|
||||
(let ([c (class*/names-sneaky
|
||||
(this super-init super-make) val ()
|
||||
|
||||
|
|
@ -888,17 +893,18 @@
|
|||
;; mtd-arg-stx : syntax[list of arg-specs] (ie, for use in a case-lambda)
|
||||
(define-struct mtd (name ctc-stx mtd-arg-stx))
|
||||
|
||||
;; name : syntax
|
||||
;; ctc-stx : syntax[evals to a contract]
|
||||
(define-struct fld (name ctc-stx))
|
||||
|
||||
;; expand-field/mtd-spec : stx -> (union mtd fld)
|
||||
(define (expand-field/mtd-spec f/m-stx)
|
||||
(printf "expand-field/mtd-spec: ~s\n" f/m-stx)
|
||||
(syntax-case f/m-stx (field)
|
||||
#|
|
||||
[(field field-name ctc)
|
||||
(identifier? (syntax field-name))
|
||||
(make-field (syntax field-name) (syntax ctc))]
|
||||
(make-fld (syntax field-name) (syntax ctc))]
|
||||
[(field field-name ctc)
|
||||
(raise-syntax-error 'object-contract "expected name of field" stx (syntax field-name))]
|
||||
|#
|
||||
[(mtd-name ctc)
|
||||
(identifier? (syntax mtd-name))
|
||||
(let-values ([(ctc-stx proc-stx) (expand-mtd-contract (syntax ctc))])
|
||||
|
|
@ -906,11 +912,11 @@
|
|||
ctc-stx
|
||||
proc-stx))]
|
||||
[(mtd-name ctc)
|
||||
(raise-syntax-error 'object-contract "expected name of method" stx (syntax mtd-name))]))
|
||||
(raise-syntax-error 'object-contract "expected name of method" stx (syntax mtd-name))]
|
||||
[_ (raise-syntax-error 'object-contract "expected field or method clause" stx f/m-stx)]))
|
||||
|
||||
;; expand-mtd-contract : syntax -> (values ctc-stx mtd-arg-stx)
|
||||
(define (expand-mtd-contract mtd-stx)
|
||||
(printf "mtd-stx: ~s\n" mtd-stx)
|
||||
(syntax-case stx (case-> opt->)
|
||||
#|
|
||||
[(case-> cases ...)
|
||||
|
|
@ -922,12 +928,11 @@
|
|||
|
||||
;; expand-mtd-arrow : stx -> (values ctc-stx mtd-arg-stx)
|
||||
(define (expand-mtd-arrow mtd-stx)
|
||||
(printf "mtd-stx: ~s\n" mtd-stx)
|
||||
(syntax-case mtd-stx (-> ->* ->d ->d*)
|
||||
[(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)]
|
||||
[(-> args ...)
|
||||
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))])
|
||||
(values (->/proc (syntax (-> this-ctc args ...)))
|
||||
(values (->/proc (syntax (-> any? args ...)))
|
||||
(syntax ((arg-vars ...)))))]
|
||||
#|
|
||||
[(->* (doms ...) (rngs ...))
|
||||
|
|
@ -991,6 +996,7 @@
|
|||
[else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)]))
|
||||
|
||||
|
||||
;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
|
||||
(define (build-methods-stx arg-spec-stxss)
|
||||
(let loop ([arg-spec-stxss arg-spec-stxss]
|
||||
[i 0])
|
||||
|
|
@ -1000,71 +1006,79 @@
|
|||
(with-syntax ([(cases ...)
|
||||
(map (lambda (arg-spec-stx)
|
||||
(with-syntax ([(this rest-ids ...) arg-spec-stx]
|
||||
[mi (+ i 1)])
|
||||
(syntax ((field-ref this mi) (field-ref this 0) rest-ids ...))))
|
||||
arg-spec-stxs)])
|
||||
[i i])
|
||||
(syntax ((this rest-ids ...)
|
||||
((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))))
|
||||
(syntax->list arg-spec-stxs))])
|
||||
(cons (syntax (lambda (field-ref) (case-lambda cases ...)))
|
||||
(loop (cdr arg-spec-stxss)
|
||||
(+ i 1)))))])))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(_ (name mtd) ...)
|
||||
(andmap identifier? (syntax->list (syntax (name ...))))
|
||||
(let* ([_ (printf "1\n")]
|
||||
[mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (mtd ...))))]
|
||||
[(_ field/mtd-specs ...)
|
||||
(let* ([mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (field/mtd-specs ...))))]
|
||||
[mtds (filter mtd? mtd/flds)]
|
||||
;[flds (filter fld? mtd/flds)]
|
||||
)
|
||||
(printf "2\n")
|
||||
(with-syntax ([(method-var ...) (generate-temporaries mtds)]
|
||||
[(method/app-var ...) (generate-temporaries mtds)]
|
||||
[(method-ctc-stx ...) (map mtd-ctc-stx mtds)]
|
||||
[flds (filter fld? mtd/flds)])
|
||||
(with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)]
|
||||
[(method-name ...) (map mtd-name mtds)]
|
||||
[(methods ...) (build-methods-stx mtds)])
|
||||
[(method-var ...) (generate-temporaries mtds)]
|
||||
[(method/app-var ...) (generate-temporaries mtds)]
|
||||
[(methods ...) (build-methods-stx (map mtd-mtd-arg-stx mtds))]
|
||||
|
||||
[(field-ctc-stx ...) (map mtd-ctc-stx flds)]
|
||||
[(field-name ...) (map fld-name flds)]
|
||||
[(field-var ...) (generate-temporaries flds)]
|
||||
[(field/app-var ...) (generate-temporaries flds)])
|
||||
(syntax
|
||||
(make-contract
|
||||
"class contract"
|
||||
(let ([method-var (contract-proc method-ctc-stx)] ...)
|
||||
(let ([mtd-names '(method-name ...)])
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([method/app-var (method-var pos neg src-info orig-str)] ...)
|
||||
(let ([cls (make-wrapper-class 'wrapper-class
|
||||
'(method-name ...)
|
||||
(list methods ...)
|
||||
'();; fields
|
||||
)])
|
||||
(lambda (val)
|
||||
(let ([val-mtd-names
|
||||
(interface->method-names
|
||||
(class->interface
|
||||
(object-class
|
||||
val)))])
|
||||
(for-each (lambda (val-mtd-name)
|
||||
(unless (memq val-mtd-name mtd-names)
|
||||
(raise-contract-error src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
orig-str
|
||||
"expected an object with method ~s"
|
||||
val-mtd-name)))
|
||||
val-mtd-names))
|
||||
(create-proxy cls
|
||||
val
|
||||
(list method/app-var ...))))))))))))]
|
||||
[(_ (name mtd) ...)
|
||||
(for-each (lambda (name)
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error 'object-contract "expected method name" stx name)))
|
||||
(syntax->list (syntax (name ...))))]
|
||||
[(_ x ...)
|
||||
(for-each (lambda (pr)
|
||||
(syntax-case pr ()
|
||||
[(a b) (void)]
|
||||
[else (raise-syntax-error 'object-contract
|
||||
"expected method name and method contract"
|
||||
stx
|
||||
pr)]))
|
||||
(syntax->list (syntax (x ...))))]))
|
||||
(let ([method-var (contract-proc method-ctc-stx)] ...
|
||||
[field-ctc-var field-ctc-stx] ...)
|
||||
(begin
|
||||
(void)
|
||||
(unless (contract? field-ctc-var)
|
||||
(error 'object-contract
|
||||
"expected contract for field ~a, got ~e"
|
||||
'field-name
|
||||
field-ctc-var)) ...)
|
||||
(let ([field-var (contract-proc field-ctc-var)] ...)
|
||||
(lambda (pos-blame neg-blame src-info orig-str)
|
||||
(let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)] ...
|
||||
[field/app-var (field-var pos-blame neg-blame src-info orig-str)]...)
|
||||
(let ([cls (make-wrapper-class 'wrapper-class
|
||||
'(method-name ...)
|
||||
(list methods ...)
|
||||
'() ; '(field-name ...)
|
||||
)])
|
||||
(lambda (val)
|
||||
(unless (object? val)
|
||||
(raise-contract-error src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
orig-str
|
||||
"expected an object, got ~e"
|
||||
val))
|
||||
(let ([val-mtd-names
|
||||
(interface->method-names
|
||||
(object-interface
|
||||
val))])
|
||||
(void)
|
||||
(unless (memq 'method-name val-mtd-names)
|
||||
(raise-contract-error src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
orig-str
|
||||
"expected an object with method ~s"
|
||||
'method-name))
|
||||
...)
|
||||
|
||||
(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 (field-res val 'field-name))
|
||||
))))))))))))]))
|
||||
|
||||
(define (object-contract/proc2 stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -759,66 +759,18 @@
|
|||
(eval '(require contract-test-suite6))
|
||||
(eval '(define-struct (t s) ()))))
|
||||
|
||||
#|
|
||||
(test/spec-passed/result
|
||||
'class-contract1
|
||||
'(send
|
||||
(make-object (contract (class-contract (public m (integer? . -> . integer?)))
|
||||
(class object% (define/public (m x) x) (super-instantiate ()))
|
||||
'pos
|
||||
'neg))
|
||||
m
|
||||
1)
|
||||
1)
|
||||
|
||||
(test/spec-failed
|
||||
'class-contract2
|
||||
'(contract (class-contract (public m (integer? . -> . integer?)))
|
||||
object%
|
||||
(test/spec-passed
|
||||
'object-contract0
|
||||
'(contract (object-contract)
|
||||
(new object%)
|
||||
'pos
|
||||
'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'class-contract3
|
||||
'(send
|
||||
(make-object (contract (class-contract (public m (integer? . -> . integer?)))
|
||||
(class object% (define/public (m x) x) (super-instantiate ()))
|
||||
'pos
|
||||
'neg))
|
||||
m
|
||||
'x)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'class-contract4
|
||||
'(send
|
||||
(make-object (contract (class-contract (public m (integer? . -> . integer?)))
|
||||
(class object% (define/public (m x) 'x) (super-instantiate ()))
|
||||
'pos
|
||||
'neg))
|
||||
m
|
||||
1)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'class-contract/prim
|
||||
'(make-object
|
||||
(class (contract (class-contract/prim)
|
||||
(class object% (init x) (init y) (init z) (super-make-object))
|
||||
'pos-c
|
||||
'neg-c)
|
||||
(init-rest x)
|
||||
(apply super-make-object x))
|
||||
1 2 3))
|
||||
|
||||
|#
|
||||
'neg))
|
||||
|
||||
(test/spec-passed/result
|
||||
'object-contract1
|
||||
'(send
|
||||
(contract (object-contract (m (integer? . -> . integer?)))
|
||||
(make-object (class object% (define/public (m x) x) (super-instantiate ())))
|
||||
(new (class object% (define/public (m x) x) (super-new)))
|
||||
'pos
|
||||
'neg)
|
||||
m
|
||||
|
|
@ -854,76 +806,14 @@
|
|||
m
|
||||
1)
|
||||
"pos")
|
||||
|
||||
|#
|
||||
|
||||
(test/spec-passed/result
|
||||
'object-contract=>1
|
||||
'(let* ([c% (class object% (super-instantiate ()))]
|
||||
[c (make-object c%)]
|
||||
[wc (contract (object-contract) c 'pos-c 'neg-c)]
|
||||
[d% (class c% (super-instantiate ()))]
|
||||
[d (make-object d%)]
|
||||
[wd (contract (object-contract) d 'pos-d 'neg-d)])
|
||||
(list (is-a? c c%)
|
||||
(is-a? wc c%)
|
||||
(is-a? d c%)
|
||||
(is-a? wd c%)
|
||||
(interface-extension? (object-interface d) (object-interface c))))
|
||||
(list #t #t #t #t #t))
|
||||
|
||||
(test/spec-passed
|
||||
'recursive-object1
|
||||
'(letrec ([cc (object-contract (m (-> dd dd)))]
|
||||
[dd (object-contract (m (-> cc cc)))]
|
||||
[% (class object% (define/public (m x) x) (super-instantiate ()))]
|
||||
[c (contract cc (make-object %) 'c-pos 'c-neg)]
|
||||
[d (contract dd (make-object %) 'd-pos 'd-neg)])
|
||||
(send c m d)
|
||||
(send d m c)))
|
||||
|
||||
(test/spec-failed
|
||||
'recursive-object2
|
||||
'(letrec ([cc (object-contract (m (-> dd dd)))]
|
||||
[dd (object-contract (n (-> cc cc)))]
|
||||
[% (class object% (define/public (m x) x) (define/public (n x) x) (super-instantiate ()))]
|
||||
[c (contract cc (make-object %) 'c-pos 'c-neg)]
|
||||
[d (contract dd (make-object %) 'd-pos 'd-neg)])
|
||||
(send c m c))
|
||||
"c-neg")
|
||||
|
||||
(test/spec-passed/result
|
||||
'class-contract=>3
|
||||
'(let* ([c% (class object% (super-instantiate ()))]
|
||||
[wc% (contract (class-contract) c% 'pos-c 'neg-c)]
|
||||
[d% (class c% (super-instantiate ()))]
|
||||
[wd% (contract (class-contract) d% 'pos-d 'neg-d)])
|
||||
(list (subclass? wd% wc%)
|
||||
(implementation? wd% (class->interface wc%))
|
||||
(is-a? (make-object wd%) wc%)
|
||||
(is-a? (make-object wd%) (class->interface wc%))
|
||||
(is-a? (instantiate wd% ()) wc%)
|
||||
(is-a? (instantiate wd% ()) (class->interface wc%))))
|
||||
(list #t #t #t #t #t #t))
|
||||
|
||||
(test/spec-passed
|
||||
'recursive-class1
|
||||
'(letrec ([cc (class-contract (public m (-> dd dd)))]
|
||||
[dd (class-contract (public n (-> cc cc)))]
|
||||
[c% (contract cc (class object% (define/public (m x) x) (super-instantiate ())) 'c-pos 'c-neg)]
|
||||
[d% (contract dd (class object% (define/public (n x) x) (super-instantiate ())) 'd-pos 'd-neg)])
|
||||
(send (make-object c%) m d%)
|
||||
(send (make-object d%) n c%)))
|
||||
|
||||
(test/spec-failed
|
||||
'recursive-class1
|
||||
'(letrec ([cc (class-contract (public m (-> dd dd)))]
|
||||
[dd (class-contract (public n (-> cc cc)))]
|
||||
[c% (contract cc (class object% (define/public (m x) x) (super-instantiate ())) 'c-pos 'c-neg)]
|
||||
[d% (contract dd (class object% (define/public (n x) x) (super-instantiate ())) 'd-pos 'd-neg)])
|
||||
(send (make-object c%) m c%))
|
||||
"c-neg")
|
||||
|#
|
||||
'object-contract5
|
||||
'(contract (object-contract (m (integer? integer? . -> . integer?)))
|
||||
(make-object (class object% (define/public (m x) 'x) (super-instantiate ())))
|
||||
'pos
|
||||
'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'immutable1
|
||||
|
|
@ -1425,6 +1315,8 @@
|
|||
(test-name "(box/p boolean?)" (box/p boolean?))
|
||||
(test-name "(box/p boolean?)" (box/p (flat-contract boolean?)))
|
||||
(test-name "the-name" (flat-rec-contract the-name))
|
||||
|
||||
(test-name "(object-contract (m (-> integer? integer?)))" (object-contract (m (-> integer? integer?))))
|
||||
|
||||
))
|
||||
(report-errs)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user