..
original commit: 2a8e7361dd02b4686dcc3e585498c89be63c1709
This commit is contained in:
Robby Findler
parent
9bd74b402d
commit
a0ce257501
|
|
@ -8,7 +8,7 @@
|
||||||
object% object?
|
object% object?
|
||||||
new make-object instantiate
|
new make-object instantiate
|
||||||
send send/apply send* class-field-accessor class-field-mutator with-method
|
send send/apply send* class-field-accessor class-field-mutator with-method
|
||||||
get-field
|
get-field field-bound?
|
||||||
private* public* public-final* override* override-final*
|
private* public* public-final* override* override-final*
|
||||||
define/private define/public define/public-final define/override define/override-final
|
define/private define/public define/public-final define/override define/override-final
|
||||||
define-local-member-name
|
define-local-member-name
|
||||||
|
|
|
||||||
|
|
@ -14,9 +14,7 @@ improve method arity mismatch contract violation error messages?
|
||||||
case->
|
case->
|
||||||
opt->
|
opt->
|
||||||
opt->*
|
opt->*
|
||||||
;class-contract
|
object-contract
|
||||||
;class-contract/prim
|
|
||||||
object-contract ;; not yet good enough
|
|
||||||
provide/contract
|
provide/contract
|
||||||
define/contract
|
define/contract
|
||||||
contract?
|
contract?
|
||||||
|
|
@ -613,30 +611,24 @@ improve method arity mismatch contract violation error messages?
|
||||||
;
|
;
|
||||||
|
|
||||||
|
|
||||||
(define-syntax-set (-> ->* ->d ->d* case-> object-contract
|
(define-syntax-set (-> ->* ->d ->d* case-> object-contract)
|
||||||
class-contract class-contract/prim)
|
|
||||||
|
|
||||||
;; ->/proc : syntax -> syntax
|
(define (->/proc stx) (make-/proc #t ->/h stx))
|
||||||
;; the transformer for the -> macro
|
(define (->*/proc stx) (make-/proc #t ->*/h stx))
|
||||||
(define (->/proc stx) (make-/proc ->/h stx))
|
(define (->d/proc stx) (make-/proc #t ->d/h stx))
|
||||||
|
(define (->d*/proc stx) (make-/proc #t ->d*/h stx))
|
||||||
|
|
||||||
;; ->*/proc : syntax -> syntax
|
(define (obj->/proc stx) (make-/proc #f ->/h stx))
|
||||||
;; the transformer for the ->* macro
|
(define (obj->*/proc stx) (make-/proc #f ->*/h stx))
|
||||||
(define (->*/proc stx) (make-/proc ->*/h stx))
|
(define (obj->d/proc stx) (make-/proc #f ->d/h stx))
|
||||||
|
(define (obj->d*/proc stx) (make-/proc #f ->d*/h stx))
|
||||||
|
|
||||||
;; ->d/proc : syntax -> syntax
|
;; make-/proc : boolean
|
||||||
;; the transformer for the ->d macro
|
;; (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
|
||||||
(define (->d/proc stx) (make-/proc ->d/h stx))
|
|
||||||
|
|
||||||
;; ->d*/proc : syntax -> syntax
|
|
||||||
;; the transformer for the ->d* macro
|
|
||||||
(define (->d*/proc stx) (make-/proc ->d*/h stx))
|
|
||||||
|
|
||||||
;; make-/proc : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
|
|
||||||
;; syntax
|
;; syntax
|
||||||
;; -> (syntax -> syntax)
|
;; -> (syntax -> syntax)
|
||||||
(define (make-/proc /h stx)
|
(define (make-/proc show-first? /h stx)
|
||||||
(let-values ([(arguments-check build-proj check-val wrapper) (/h stx)])
|
(let-values ([(arguments-check build-proj check-val wrapper) (/h show-first? stx)])
|
||||||
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
|
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
|
||||||
(with-syntax ([inner-check (check-val outer-args)]
|
(with-syntax ([inner-check (check-val outer-args)]
|
||||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
|
|
@ -663,11 +655,15 @@ improve method arity mismatch contract violation error messages?
|
||||||
|
|
||||||
;; case->/proc : syntax -> syntax
|
;; case->/proc : syntax -> syntax
|
||||||
;; the transformer for the case-> macro
|
;; the transformer for the case-> macro
|
||||||
(define (case->/proc stx)
|
(define (case->/proc stx) (make-case->/proc #t stx))
|
||||||
|
|
||||||
|
(define (obj-case->/proc stx) (make-case->/proc #f stx))
|
||||||
|
|
||||||
|
(define (make-case->/proc show-first? stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ cases ...)
|
[(_ cases ...)
|
||||||
(let-values ([(arguments-check build-projs check-val wrapper)
|
(let-values ([(arguments-check build-projs check-val wrapper)
|
||||||
(case->/h stx (syntax->list (syntax (cases ...))))])
|
(case->/h show-first? stx (syntax->list (syntax (cases ...))))])
|
||||||
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
|
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
|
||||||
(with-syntax ([(inner-check ...) (check-val outer-args)]
|
(with-syntax ([(inner-check ...) (check-val outer-args)]
|
||||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
|
|
@ -744,7 +740,8 @@ improve method arity mismatch contract violation error messages?
|
||||||
'more))))
|
'more))))
|
||||||
|
|
||||||
|
|
||||||
;; case->/h : syntax
|
;; case->/h : boolean
|
||||||
|
;; syntax
|
||||||
;; (listof syntax)
|
;; (listof syntax)
|
||||||
;; -> (values (syntax -> syntax)
|
;; -> (values (syntax -> syntax)
|
||||||
;; (syntax -> syntax)
|
;; (syntax -> syntax)
|
||||||
|
|
@ -752,7 +749,7 @@ improve method arity mismatch contract violation error messages?
|
||||||
;; (syntax -> syntax))
|
;; (syntax -> syntax))
|
||||||
;; like the other /h functions, but composes the wrapper functions
|
;; like the other /h functions, but composes the wrapper functions
|
||||||
;; together and combines the cases of the case-lambda into a single list.
|
;; together and combines the cases of the case-lambda into a single list.
|
||||||
(define (case->/h orig-stx cases)
|
(define (case->/h show-first? orig-stx cases)
|
||||||
(let loop ([cases cases]
|
(let loop ([cases cases]
|
||||||
[name-ids '()])
|
[name-ids '()])
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -772,7 +769,7 @@ improve method arity mismatch contract violation error messages?
|
||||||
(let-values ([(arguments-checks build-projs check-vals wrappers)
|
(let-values ([(arguments-checks build-projs check-vals wrappers)
|
||||||
(loop (cdr cases) (cons new-id name-ids))]
|
(loop (cdr cases) (cons new-id name-ids))]
|
||||||
[(arguments-check build-proj check-val wrapper)
|
[(arguments-check build-proj check-val wrapper)
|
||||||
(/h (car cases))])
|
(/h show-first? (car cases))])
|
||||||
(values
|
(values
|
||||||
(lambda (outer-args x)
|
(lambda (outer-args x)
|
||||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
|
|
@ -797,95 +794,6 @@ improve method arity mismatch contract violation error messages?
|
||||||
[cases (wrappers args)])
|
[cases (wrappers args)])
|
||||||
(syntax (case . cases)))))))])))
|
(syntax (case . cases)))))))])))
|
||||||
|
|
||||||
(define (class-contract/proc stx) (class-contract-mo? stx #f))
|
|
||||||
(define (class-contract/prim/proc stx) (class-contract-mo? stx #t))
|
|
||||||
|
|
||||||
(define (class-contract-mo? stx use-make-object?)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(form (method-specifier meth-name meth-contract) ...)
|
|
||||||
(and
|
|
||||||
(andmap method-specifier? (syntax->list (syntax (method-specifier ...))))
|
|
||||||
(andmap identifier? (syntax->list (syntax (meth-name ...)))))
|
|
||||||
(let* ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]
|
|
||||||
[val-meth-names (syntax->list (syntax (meth-name ...)))]
|
|
||||||
[super-meth-names (map prefix-super val-meth-names)]
|
|
||||||
[val-meth-contracts (syntax->list (syntax (meth-contract ...)))]
|
|
||||||
[val-meth-contract-vars (generate-temporaries val-meth-contracts)])
|
|
||||||
|
|
||||||
(ensure-no-duplicates stx 'class-contract val-meth-names)
|
|
||||||
|
|
||||||
(with-syntax ([outer-args outer-args]
|
|
||||||
[(super-meth-name ...) super-meth-names]
|
|
||||||
[(get-meth-contract ...) (map method-name->contract-method-name val-meth-names)]
|
|
||||||
[(method ...)
|
|
||||||
(map (lambda (meth-name meth-contract-var contract-stx)
|
|
||||||
(make-class-wrapper-method outer-args
|
|
||||||
meth-name
|
|
||||||
meth-contract-var
|
|
||||||
contract-stx))
|
|
||||||
val-meth-names
|
|
||||||
val-meth-contract-vars
|
|
||||||
val-meth-contracts)]
|
|
||||||
[(meth-contract-var ...) val-meth-contract-vars]
|
|
||||||
[this (datum->syntax-object (syntax form) 'this stx)]
|
|
||||||
[super-init (datum->syntax-object (syntax form) 'super-instantiate stx)]
|
|
||||||
[super-make (datum->syntax-object (syntax form) 'super-make-object stx)])
|
|
||||||
(with-syntax ([call-super-initializer
|
|
||||||
(if use-make-object?
|
|
||||||
(syntax/loc stx
|
|
||||||
(begin (init-rest args)
|
|
||||||
(apply super-make args)))
|
|
||||||
(syntax/loc stx
|
|
||||||
(super-init ())))])
|
|
||||||
(syntax/loc stx
|
|
||||||
(make-contract
|
|
||||||
"(object-contract ...)"
|
|
||||||
(lambda outer-args
|
|
||||||
(let ([super-contracts-ht
|
|
||||||
(let loop ([cls val])
|
|
||||||
(cond
|
|
||||||
[(sneaky-class? cls) (sneaky-class-contract-table cls)]
|
|
||||||
[else (let ([super (class-super-class cls)])
|
|
||||||
(and super
|
|
||||||
(loop super)))]))]
|
|
||||||
[meth-contract-var meth-contract] ...)
|
|
||||||
(unless (class? val)
|
|
||||||
(raise-contract-error src-info pos-blame neg-blame orig-str "expected a class, got: ~e" val))
|
|
||||||
(let ([class-i (class->interface val)])
|
|
||||||
(void)
|
|
||||||
(unless (method-in-interface? 'meth-name class-i)
|
|
||||||
(raise-contract-error src-info
|
|
||||||
pos-blame
|
|
||||||
neg-blame
|
|
||||||
orig-str
|
|
||||||
"expected class to have method ~a, got: ~e"
|
|
||||||
'meth-name
|
|
||||||
val)) ...)
|
|
||||||
(let ([c (class*/names-sneaky
|
|
||||||
(this super-init super-make) val ()
|
|
||||||
|
|
||||||
(rename [super-meth-name meth-name] ...)
|
|
||||||
method ...
|
|
||||||
call-super-initializer)]
|
|
||||||
[ht (make-hash-table)])
|
|
||||||
(set-sneaky-class-contract-table! c ht)
|
|
||||||
(hash-table-put! ht 'meth-name meth-contract-var) ...
|
|
||||||
c))))))))]
|
|
||||||
[(_ (meth-specifier meth-name meth-contract) ...)
|
|
||||||
(for-each (lambda (specifier name)
|
|
||||||
(unless (method-specifier? name)
|
|
||||||
(raise-syntax-error 'class-contract "expected either public or override" stx specifier))
|
|
||||||
(unless (identifier? name)
|
|
||||||
(raise-syntax-error 'class-contract "expected name" stx name)))
|
|
||||||
(syntax->list (syntax (meth-specifier ...)))
|
|
||||||
(syntax->list (syntax (meth-name ...))))]
|
|
||||||
[(_ clz ...)
|
|
||||||
(for-each (lambda (clz)
|
|
||||||
(syntax-case clz ()
|
|
||||||
[(a b c) (void)]
|
|
||||||
[else (raise-syntax-error 'class-contract "bad method/contract clause" stx clz)]))
|
|
||||||
(syntax->list (syntax (clz ...))))]))
|
|
||||||
|
|
||||||
(define (object-contract/proc stx)
|
(define (object-contract/proc stx)
|
||||||
|
|
||||||
;; name : syntax
|
;; name : syntax
|
||||||
|
|
@ -915,24 +823,39 @@ improve method arity mismatch contract violation error messages?
|
||||||
(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)]))
|
[_ (raise-syntax-error 'object-contract "expected field or method clause" stx f/m-stx)]))
|
||||||
|
|
||||||
;; expand-mtd-contract : syntax -> (values ctc-stx mtd-arg-stx)
|
;; expand-mtd-contract : syntax -> (values syntax[expanded ctc] syntax[mtd-arg])
|
||||||
(define (expand-mtd-contract mtd-stx)
|
(define (expand-mtd-contract mtd-stx)
|
||||||
(syntax-case stx (case-> opt->)
|
(syntax-case mtd-stx (case-> opt->)
|
||||||
#|
|
|
||||||
[(case-> cases ...)
|
[(case-> cases ...)
|
||||||
(with-syntax ([(cases ...) (map expand-mtd-arrow (syntax->list (syntax (cases ...))))])
|
(let loop ([cases (syntax->list (syntax (cases ...)))]
|
||||||
(syntax (case-> cases ...)))]
|
[ctc-stxs null]
|
||||||
|
[args-stxs null])
|
||||||
|
(cond
|
||||||
|
[(null? cases)
|
||||||
|
(values
|
||||||
|
(with-syntax ([(x ...) (reverse ctc-stxs)])
|
||||||
|
(obj-case->/proc (syntax (case-> x ...))))
|
||||||
|
(with-syntax ([(x ...) (apply append (map syntax->list (reverse args-stxs)))])
|
||||||
|
(syntax (x ...))))]
|
||||||
|
[else
|
||||||
|
(let-values ([(trans ctc-stx mtd-args) (expand-mtd-arrow (car cases))])
|
||||||
|
(loop (cdr cases)
|
||||||
|
(cons ctc-stx ctc-stxs)
|
||||||
|
(cons mtd-args args-stxs)))]))]
|
||||||
|
#|
|
||||||
[(opt-> opts ...) ...]
|
[(opt-> opts ...) ...]
|
||||||
|#
|
|#
|
||||||
[else (expand-mtd-arrow mtd-stx)]))
|
[else (let-values ([(x y z) (expand-mtd-arrow mtd-stx)])
|
||||||
|
(values (x y) z))]))
|
||||||
|
|
||||||
;; expand-mtd-arrow : stx -> (values ctc-stx mtd-arg-stx)
|
;; expand-mtd-arrow : stx -> (values (syntax[ctc] -> syntax[expanded ctc]) syntax[ctc] syntax[mtd-arg])
|
||||||
(define (expand-mtd-arrow mtd-stx)
|
(define (expand-mtd-arrow mtd-stx)
|
||||||
(syntax-case mtd-stx (-> ->* ->d ->d*)
|
(syntax-case mtd-stx (-> ->* ->d ->d*)
|
||||||
[(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)]
|
[(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)]
|
||||||
[(-> args ...)
|
[(-> args ...)
|
||||||
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))])
|
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))])
|
||||||
(values (->/proc (syntax (-> any? args ...)))
|
(values obj->/proc
|
||||||
|
(syntax (-> any? args ...))
|
||||||
(syntax ((arg-vars ...)))))]
|
(syntax ((arg-vars ...)))))]
|
||||||
#|
|
#|
|
||||||
[(->* (doms ...) (rngs ...))
|
[(->* (doms ...) (rngs ...))
|
||||||
|
|
@ -1021,116 +944,71 @@ improve method arity mismatch contract violation error messages?
|
||||||
[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-var ...) (generate-temporaries mtds)]
|
[(method-var ...) (generate-temporaries mtds)]
|
||||||
[(method/app-var ...) (generate-temporaries mtds)]
|
[(method/app-var ...) (generate-temporaries mtds)]
|
||||||
[(methods ...) (build-methods-stx (map mtd-mtd-arg-stx mtds))]
|
[(methods ...) (build-methods-stx (map mtd-mtd-arg-stx mtds))]
|
||||||
|
|
||||||
[(field-ctc-stx ...) (map fld-ctc-stx flds)]
|
[(field-ctc-stx ...) (map fld-ctc-stx flds)]
|
||||||
[(field-name ...) (map fld-name flds)]
|
[(field-name ...) (map fld-name flds)]
|
||||||
|
[(field-ctc-var ...) (generate-temporaries flds)]
|
||||||
[(field-var ...) (generate-temporaries flds)]
|
[(field-var ...) (generate-temporaries flds)]
|
||||||
[(field/app-var ...) (generate-temporaries flds)])
|
[(field/app-var ...) (generate-temporaries flds)])
|
||||||
(syntax
|
(syntax
|
||||||
(make-contract
|
(let ([method-ctc-var method-ctc-stx] ...
|
||||||
"class contract"
|
[field-ctc-var (coerce-contract object-contract field-ctc-stx)] ...)
|
||||||
(let ([method-var (contract-proc method-ctc-stx)] ...
|
(let ([method-var (contract-proc method-ctc-var)] ...
|
||||||
[field-var (contract-proc (coerce-contract object-contract field-ctc-stx))] ...)
|
[field-var (contract-proc field-ctc-var)] ...)
|
||||||
(lambda (pos-blame neg-blame src-info orig-str)
|
(make-contract
|
||||||
(let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)] ...
|
(build-compound-type-name
|
||||||
[field/app-var (field-var pos-blame neg-blame src-info orig-str)]...)
|
'object-contract
|
||||||
(let ([cls (make-wrapper-class 'wrapper-class
|
(build-compound-type-name #f 'method-name (contract-name method-ctc-var)) ...
|
||||||
'(method-name ...)
|
(build-compound-type-name 'field 'field-name (contract-name field-ctc-var)) ...)
|
||||||
(list methods ...)
|
(lambda (pos-blame neg-blame src-info orig-str)
|
||||||
'(field-name ...)
|
(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)]...)
|
||||||
(lambda (val)
|
(let ([cls (make-wrapper-class 'wrapper-class
|
||||||
(unless (object? val)
|
'(method-name ...)
|
||||||
(raise-contract-error src-info
|
(list methods ...)
|
||||||
pos-blame
|
'(field-name ...)
|
||||||
neg-blame
|
)])
|
||||||
orig-str
|
(lambda (val)
|
||||||
"expected an object, got ~e"
|
(unless (object? val)
|
||||||
val))
|
|
||||||
(let ([val-mtd-names
|
|
||||||
(interface->method-names
|
|
||||||
(object-interface
|
|
||||||
val))])
|
|
||||||
(void)
|
|
||||||
(unless (memq 'method-name val-mtd-names)
|
|
||||||
(raise-contract-error src-info
|
(raise-contract-error src-info
|
||||||
pos-blame
|
pos-blame
|
||||||
neg-blame
|
neg-blame
|
||||||
orig-str
|
orig-str
|
||||||
"expected an object with method ~s"
|
"expected an object, got ~e"
|
||||||
'method-name))
|
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))
|
||||||
|
...)
|
||||||
|
|
||||||
;; need to make sure all field names are there...
|
(unless (field-bound? field-name val)
|
||||||
|
(raise-contract-error src-info
|
||||||
|
pos-blame
|
||||||
|
neg-blame
|
||||||
|
orig-str
|
||||||
|
"expected an object with field ~s"
|
||||||
|
'field-name)) ...
|
||||||
|
|
||||||
(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)) ...
|
||||||
)))))))))))]))
|
))))))))))))]))
|
||||||
|
|
||||||
(define (object-contract/proc2 stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(form (meth-name meth-contract) ...)
|
|
||||||
(andmap identifier? (syntax->list (syntax (meth-name ...))))
|
|
||||||
(let* ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]
|
|
||||||
[val-meth-names (syntax->list (syntax (meth-name ...)))]
|
|
||||||
[val-meth-contracts (syntax->list (syntax (meth-contract ...)))]
|
|
||||||
[val-meth-contract-vars (generate-temporaries val-meth-contracts)])
|
|
||||||
|
|
||||||
(ensure-no-duplicates stx 'object/contract val-meth-names)
|
|
||||||
|
|
||||||
(with-syntax ([outer-args outer-args]
|
|
||||||
[(get-meth-contract ...) (map method-name->contract-method-name val-meth-names)]
|
|
||||||
[(method ...)
|
|
||||||
(map (lambda (x y z) (make-object-wrapper-method outer-args x y z))
|
|
||||||
val-meth-names
|
|
||||||
val-meth-contract-vars
|
|
||||||
val-meth-contracts)]
|
|
||||||
[(meth-contract-var ...) val-meth-contract-vars])
|
|
||||||
(syntax/loc stx
|
|
||||||
(make-contract
|
|
||||||
"object contract"
|
|
||||||
(lambda outer-args
|
|
||||||
(let ([meth-contract-var meth-contract] ...)
|
|
||||||
(unless (object? val)
|
|
||||||
(raise-contract-error src-info pos-blame neg-blame orig-str "expected an object, got: ~e" val))
|
|
||||||
(let ([obj-i (object-interface val)])
|
|
||||||
(void)
|
|
||||||
(unless (method-in-interface? 'meth-name obj-i)
|
|
||||||
(raise-contract-error src-info
|
|
||||||
pos-blame
|
|
||||||
neg-blame
|
|
||||||
orig-str
|
|
||||||
"expected class to have method ~a, got: ~e"
|
|
||||||
'meth-name
|
|
||||||
val))
|
|
||||||
...)
|
|
||||||
|
|
||||||
(make-object/sneaky
|
|
||||||
val
|
|
||||||
(class object%
|
|
||||||
method ...
|
|
||||||
(super-instantiate ())))))))))]
|
|
||||||
[(_ (meth-name meth-contract) ...)
|
|
||||||
(for-each (lambda (name)
|
|
||||||
(unless (identifier? name)
|
|
||||||
(raise-syntax-error 'object-contract "expected name" stx name)))
|
|
||||||
(syntax->list (syntax (meth-name ...))))]
|
|
||||||
[(_ clz ...)
|
|
||||||
(for-each (lambda (clz)
|
|
||||||
(syntax-case clz ()
|
|
||||||
[(b c) (void)]
|
|
||||||
[else (raise-syntax-error 'object-contract
|
|
||||||
"bad method/contract clause"
|
|
||||||
stx
|
|
||||||
clz)]))
|
|
||||||
(syntax->list (syntax (clz ...))))]))
|
|
||||||
|
|
||||||
;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void
|
;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void
|
||||||
(define (ensure-no-duplicates stx form-name names)
|
(define (ensure-no-duplicates stx form-name names)
|
||||||
|
|
@ -1261,173 +1139,164 @@ improve method arity mismatch contract violation error messages?
|
||||||
;; They are combined into a lambda for the -> ->* ->d ->d* macros,
|
;; They are combined into a lambda for the -> ->* ->d ->d* macros,
|
||||||
;; and combined into a case-lambda for the case-> macro.
|
;; and combined into a case-lambda for the case-> macro.
|
||||||
|
|
||||||
;; ->/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||||
(define (->/h stx)
|
(define (->/h show-first? stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_) (raise-syntax-error '-> "expected at least one argument" stx)]
|
[(_) (raise-syntax-error '-> "expected at least one argument" stx)]
|
||||||
[(_ arg ...)
|
[(_ arg ...)
|
||||||
(with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (arg ...))))]
|
(with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (arg ...))))]
|
||||||
[rng (car (last-pair (syntax->list (syntax (arg ...)))))])
|
[rng (car (last-pair (syntax->list (syntax (arg ...)))))])
|
||||||
(syntax-case* (syntax rng) (any values) module-or-top-identifier=?
|
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
|
[(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
|
[(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
|
[(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
|
||||||
|
[(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
|
[(arg-x ...) (generate-temporaries (syntax (dom ...)))])
|
||||||
|
(with-syntax ([(name-dom-contract-x ...)
|
||||||
|
(if show-first?
|
||||||
|
(syntax (dom-contract-x ...))
|
||||||
|
(cdr
|
||||||
|
(syntax->list
|
||||||
|
(syntax (dom-contract-x ...)))))])
|
||||||
|
(syntax-case* (syntax rng) (any values) module-or-top-identifier=?
|
||||||
|
[any
|
||||||
|
(values
|
||||||
|
(lambda (outer-args body)
|
||||||
|
(with-syntax ([body body]
|
||||||
|
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||||
|
(syntax
|
||||||
|
(let ([dom-contract-x (coerce-contract -> dom)] ...)
|
||||||
|
(let ([dom-x (contract-proc dom-contract-x)] ...)
|
||||||
|
(let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)])
|
||||||
|
body))))))
|
||||||
|
|
||||||
[any
|
(lambda (outer-args inner-lambda)
|
||||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
[(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
|
[inner-lambda inner-lambda])
|
||||||
[(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
|
(syntax
|
||||||
[(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
|
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
|
||||||
[(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
|
inner-lambda))))
|
||||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))])
|
|
||||||
(values
|
|
||||||
(lambda (outer-args body)
|
|
||||||
(with-syntax ([body body]
|
|
||||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
|
||||||
(syntax
|
|
||||||
(let ([dom-contract-x (coerce-contract -> dom)] ...)
|
|
||||||
(let ([dom-x (contract-proc dom-contract-x)] ...)
|
|
||||||
(let ([name-id (build-compound-type-name '-> dom-contract-x ... 'any)])
|
|
||||||
body))))))
|
|
||||||
|
|
||||||
(lambda (outer-args inner-lambda)
|
(lambda (outer-args)
|
||||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||||
[inner-lambda inner-lambda])
|
(syntax
|
||||||
(syntax
|
(unless (and (procedure? val)
|
||||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
|
(procedure-arity-includes? val dom-length))
|
||||||
inner-lambda))))
|
(raise-contract-error
|
||||||
|
src-info
|
||||||
|
pos-blame
|
||||||
|
neg-blame
|
||||||
|
orig-str
|
||||||
|
"expected a procedure that accepts ~a arguments, given: ~e"
|
||||||
|
dom-length
|
||||||
|
val)))))
|
||||||
|
|
||||||
(lambda (outer-args)
|
(lambda (outer-args)
|
||||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||||
(syntax
|
(syntax
|
||||||
(unless (and (procedure? val)
|
((arg-x ...)
|
||||||
(procedure-arity-includes? val dom-length))
|
(val (dom-projection-x arg-x) ...))))))]
|
||||||
(raise-contract-error
|
[(values rng ...)
|
||||||
src-info
|
(with-syntax ([(rng-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||||
pos-blame
|
[(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||||
neg-blame
|
[(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||||
orig-str
|
[(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))]
|
||||||
"expected a procedure that accepts ~a arguments, given: ~e"
|
[(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||||
dom-length
|
[(res-x ...) (generate-temporaries (syntax (rng ...)))])
|
||||||
val)))))
|
(values
|
||||||
|
(lambda (outer-args body)
|
||||||
|
(with-syntax ([body body]
|
||||||
|
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||||
|
(syntax
|
||||||
|
(let ([dom-contract-x (coerce-contract -> dom)] ...
|
||||||
|
[rng-contract-x (coerce-contract -> rng)] ...)
|
||||||
|
(let ([dom-x (contract-proc dom-contract-x)] ...
|
||||||
|
[rng-x (contract-proc rng-contract-x)] ...)
|
||||||
|
(let ([name-id (build-compound-type-name
|
||||||
|
'->
|
||||||
|
name-dom-contract-x ...
|
||||||
|
(build-compound-type-name 'values rng-contract-x ...))])
|
||||||
|
body))))))
|
||||||
|
|
||||||
(lambda (outer-args)
|
(lambda (outer-args inner-lambda)
|
||||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
(syntax
|
[inner-lambda inner-lambda])
|
||||||
((arg-x ...)
|
(syntax
|
||||||
(val (dom-projection-x arg-x) ...)))))))]
|
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...
|
||||||
[(values rng ...)
|
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...)
|
||||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
inner-lambda))))
|
||||||
[(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
|
|
||||||
[(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
|
|
||||||
[(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
|
|
||||||
[(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
|
|
||||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
|
||||||
|
|
||||||
[(rng-x ...) (generate-temporaries (syntax (rng ...)))]
|
(lambda (outer-args)
|
||||||
[(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))]
|
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||||
[(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))]
|
(syntax
|
||||||
[(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))]
|
(unless (and (procedure? val)
|
||||||
[(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))]
|
(procedure-arity-includes? val dom-length))
|
||||||
[(res-x ...) (generate-temporaries (syntax (rng ...)))])
|
(raise-contract-error
|
||||||
(values
|
src-info
|
||||||
(lambda (outer-args body)
|
pos-blame
|
||||||
(with-syntax ([body body]
|
neg-blame
|
||||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
orig-str
|
||||||
(syntax
|
"expected a procedure that accepts ~a arguments, given: ~e"
|
||||||
(let ([dom-contract-x (coerce-contract -> dom)] ...
|
dom-length
|
||||||
[rng-contract-x (coerce-contract -> rng)] ...)
|
val)))))
|
||||||
(let ([dom-x (contract-proc dom-contract-x)] ...
|
|
||||||
[rng-x (contract-proc rng-contract-x)] ...)
|
|
||||||
(let ([name-id (build-compound-type-name
|
|
||||||
'->
|
|
||||||
dom-contract-x ...
|
|
||||||
(build-compound-type-name 'values rng-contract-x ...))])
|
|
||||||
body))))))
|
|
||||||
|
|
||||||
(lambda (outer-args inner-lambda)
|
(lambda (outer-args)
|
||||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||||
[inner-lambda inner-lambda])
|
(syntax
|
||||||
(syntax
|
((arg-x ...)
|
||||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...
|
(let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)])
|
||||||
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...)
|
(values (rng-projection-x
|
||||||
inner-lambda))))
|
res-x)
|
||||||
|
...))))))))]
|
||||||
|
[rng
|
||||||
|
(with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))]
|
||||||
|
[(rng-contact-x) (generate-temporaries (syntax (rng)))]
|
||||||
|
[(rng-projection-x) (generate-temporaries (syntax (rng)))]
|
||||||
|
[(rng-ant-x) (generate-temporaries (syntax (rng)))]
|
||||||
|
[(res-x) (generate-temporaries (syntax (rng)))])
|
||||||
|
(values
|
||||||
|
(lambda (outer-args body)
|
||||||
|
(with-syntax ([body body]
|
||||||
|
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||||
|
(syntax
|
||||||
|
(let ([dom-contract-x (coerce-contract -> dom)] ...
|
||||||
|
[rng-contract-x (coerce-contract -> rng)])
|
||||||
|
(let ([dom-x (contract-proc dom-contract-x)] ...
|
||||||
|
[rng-x (contract-proc rng-contract-x)])
|
||||||
|
(let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)])
|
||||||
|
body))))))
|
||||||
|
|
||||||
(lambda (outer-args)
|
(lambda (outer-args inner-lambda)
|
||||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
(syntax
|
[inner-lambda inner-lambda])
|
||||||
(unless (and (procedure? val)
|
(syntax
|
||||||
(procedure-arity-includes? val dom-length))
|
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...
|
||||||
(raise-contract-error
|
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)])
|
||||||
src-info
|
inner-lambda))))
|
||||||
pos-blame
|
|
||||||
neg-blame
|
|
||||||
orig-str
|
|
||||||
"expected a procedure that accepts ~a arguments, given: ~e"
|
|
||||||
dom-length
|
|
||||||
val)))))
|
|
||||||
|
|
||||||
(lambda (outer-args)
|
(lambda (outer-args)
|
||||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||||
(syntax
|
(syntax
|
||||||
((arg-x ...)
|
(unless (and (procedure? val)
|
||||||
(let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)])
|
(procedure-arity-includes? val dom-length))
|
||||||
(values (rng-projection-x
|
(raise-contract-error
|
||||||
res-x)
|
src-info
|
||||||
...))))))))]
|
pos-blame
|
||||||
[rng
|
neg-blame
|
||||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
orig-str
|
||||||
[(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
|
"expected a procedure that accepts ~a arguments, given: ~e"
|
||||||
[(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
|
dom-length
|
||||||
[(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
|
val)))))
|
||||||
[(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
|
|
||||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
|
||||||
|
|
||||||
[(rng-x) (generate-temporaries (syntax (rng)))]
|
(lambda (outer-args)
|
||||||
[(rng-contact-x) (generate-temporaries (syntax (rng)))]
|
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||||
[(rng-projection-x) (generate-temporaries (syntax (rng)))]
|
(syntax
|
||||||
[(rng-ant-x) (generate-temporaries (syntax (rng)))]
|
((arg-x ...)
|
||||||
[(res-x) (generate-temporaries (syntax (rng)))])
|
(let ([res-x (val (dom-projection-x arg-x) ...)])
|
||||||
(values
|
(rng-projection-x res-x))))))))]))))]))
|
||||||
(lambda (outer-args body)
|
|
||||||
(with-syntax ([body body]
|
|
||||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
|
||||||
(syntax
|
|
||||||
(let ([dom-contract-x (coerce-contract -> dom)] ...
|
|
||||||
[rng-contract-x (coerce-contract -> rng)])
|
|
||||||
(let ([dom-x (contract-proc dom-contract-x)] ...
|
|
||||||
[rng-x (contract-proc rng-contract-x)])
|
|
||||||
(let ([name-id (build-compound-type-name '-> dom-contract-x ... rng-contract-x)])
|
|
||||||
body))))))
|
|
||||||
|
|
||||||
(lambda (outer-args inner-lambda)
|
;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
(define (->*/h show-first? stx)
|
||||||
[inner-lambda inner-lambda])
|
|
||||||
(syntax
|
|
||||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...
|
|
||||||
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)])
|
|
||||||
inner-lambda))))
|
|
||||||
|
|
||||||
(lambda (outer-args)
|
|
||||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
|
||||||
(syntax
|
|
||||||
(unless (and (procedure? val)
|
|
||||||
(procedure-arity-includes? val dom-length))
|
|
||||||
(raise-contract-error
|
|
||||||
src-info
|
|
||||||
pos-blame
|
|
||||||
neg-blame
|
|
||||||
orig-str
|
|
||||||
"expected a procedure that accepts ~a arguments, given: ~e"
|
|
||||||
dom-length
|
|
||||||
val)))))
|
|
||||||
|
|
||||||
(lambda (outer-args)
|
|
||||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
|
||||||
(syntax
|
|
||||||
((arg-x ...)
|
|
||||||
(let ([res-x (val (dom-projection-x arg-x) ...)])
|
|
||||||
(rng-projection-x res-x))))))))]))]))
|
|
||||||
|
|
||||||
;; ->*/h : stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
|
||||||
(define (->*/h stx)
|
|
||||||
(syntax-case stx (any)
|
(syntax-case stx (any)
|
||||||
[(_ (dom ...) (rng ...))
|
[(_ (dom ...) (rng ...))
|
||||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
|
|
@ -1446,14 +1315,20 @@ improve method arity mismatch contract violation error messages?
|
||||||
(values
|
(values
|
||||||
(lambda (outer-args body)
|
(lambda (outer-args body)
|
||||||
(with-syntax ([body body]
|
(with-syntax ([body body]
|
||||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
|
[(name-dom-contract-x ...)
|
||||||
|
(if show-first?
|
||||||
|
(syntax (dom-contract-x ...))
|
||||||
|
(cdr
|
||||||
|
(syntax->list
|
||||||
|
(syntax (dom-contract-x ...)))))])
|
||||||
(syntax
|
(syntax
|
||||||
(let ([dom-contract-x (coerce-contract ->* dom)] ...
|
(let ([dom-contract-x (coerce-contract ->* dom)] ...
|
||||||
[rng-contract-x (coerce-contract ->* rng)] ...)
|
[rng-contract-x (coerce-contract ->* rng)] ...)
|
||||||
(let ([dom-x (contract-proc dom-contract-x)] ...
|
(let ([dom-x (contract-proc dom-contract-x)] ...
|
||||||
[rng-x (contract-proc rng-contract-x)] ...)
|
[rng-x (contract-proc rng-contract-x)] ...)
|
||||||
(let ([name-id (string-append "(->* "
|
(let ([name-id (string-append "(->* "
|
||||||
(build-compound-type-name #f dom-contract-x ...)
|
(build-compound-type-name #f name-dom-contract-x ...)
|
||||||
" "
|
" "
|
||||||
(build-compound-type-name #f rng-contract-x ...)
|
(build-compound-type-name #f rng-contract-x ...)
|
||||||
")")])
|
")")])
|
||||||
|
|
@ -1499,12 +1374,18 @@ improve method arity mismatch contract violation error messages?
|
||||||
(values
|
(values
|
||||||
(lambda (outer-args body)
|
(lambda (outer-args body)
|
||||||
(with-syntax ([body body]
|
(with-syntax ([body body]
|
||||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
|
[(name-dom-contract-x ...)
|
||||||
|
(if show-first?
|
||||||
|
(syntax (dom-contract-x ...))
|
||||||
|
(cdr
|
||||||
|
(syntax->list
|
||||||
|
(syntax (dom-contract-x ...)))))])
|
||||||
(syntax
|
(syntax
|
||||||
(let ([dom-contract-x (coerce-contract ->* dom)] ...)
|
(let ([dom-contract-x (coerce-contract ->* dom)] ...)
|
||||||
(let ([dom-x (contract-proc dom-contract-x)] ...)
|
(let ([dom-x (contract-proc dom-contract-x)] ...)
|
||||||
(let ([name-id (string-append "(->* "
|
(let ([name-id (string-append "(->* "
|
||||||
(build-compound-type-name #f dom-contract-x ...)
|
(build-compound-type-name #f name-dom-contract-x ...)
|
||||||
" any)")])
|
" any)")])
|
||||||
body))))))
|
body))))))
|
||||||
|
|
||||||
|
|
@ -1556,7 +1437,13 @@ improve method arity mismatch contract violation error messages?
|
||||||
(values
|
(values
|
||||||
(lambda (outer-args body)
|
(lambda (outer-args body)
|
||||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
[body body])
|
[body body]
|
||||||
|
[(name-dom-contract-x ...)
|
||||||
|
(if show-first?
|
||||||
|
(syntax (dom-contract-x ...))
|
||||||
|
(cdr
|
||||||
|
(syntax->list
|
||||||
|
(syntax (dom-contract-x ...)))))])
|
||||||
(syntax
|
(syntax
|
||||||
(let ([dom-contract-x (coerce-contract ->* dom)] ...
|
(let ([dom-contract-x (coerce-contract ->* dom)] ...
|
||||||
[dom-rest-contract-x (coerce-contract ->* rest)]
|
[dom-rest-contract-x (coerce-contract ->* rest)]
|
||||||
|
|
@ -1619,14 +1506,20 @@ improve method arity mismatch contract violation error messages?
|
||||||
(values
|
(values
|
||||||
(lambda (outer-args body)
|
(lambda (outer-args body)
|
||||||
(with-syntax ([body body]
|
(with-syntax ([body body]
|
||||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
|
[(name-dom-contract-x ...)
|
||||||
|
(if show-first?
|
||||||
|
(syntax (dom-contract-x ...))
|
||||||
|
(cdr
|
||||||
|
(syntax->list
|
||||||
|
(syntax (dom-contract-x ...)))))])
|
||||||
(syntax
|
(syntax
|
||||||
(let ([dom-contract-x (coerce-contract ->* dom)] ...
|
(let ([dom-contract-x (coerce-contract ->* dom)] ...
|
||||||
[dom-rest-contract-x (coerce-contract ->* rest)])
|
[dom-rest-contract-x (coerce-contract ->* rest)])
|
||||||
(let ([dom-x (contract-proc dom-contract-x)] ...
|
(let ([dom-x (contract-proc dom-contract-x)] ...
|
||||||
[dom-rest-x (contract-proc dom-rest-contract-x)])
|
[dom-rest-x (contract-proc dom-rest-contract-x)])
|
||||||
(let ([name-id (string-append "(->* "
|
(let ([name-id (string-append "(->* "
|
||||||
(build-compound-type-name #f dom-contract-x ...)
|
(build-compound-type-name #f name-dom-contract-x ...)
|
||||||
" "
|
" "
|
||||||
(contract->type-name dom-rest-contract-x)
|
(contract->type-name dom-rest-contract-x)
|
||||||
" any)")])
|
" any)")])
|
||||||
|
|
@ -1660,8 +1553,8 @@ improve method arity mismatch contract violation error messages?
|
||||||
...
|
...
|
||||||
(dom-projection-rest-x arg-rest-x))))))))]))
|
(dom-projection-rest-x arg-rest-x))))))))]))
|
||||||
|
|
||||||
;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||||
(define (->d/h stx)
|
(define (->d/h show-first? stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_) (raise-syntax-error '->d "expected at least one argument" stx)]
|
[(_) (raise-syntax-error '->d "expected at least one argument" stx)]
|
||||||
[(_ ct ...)
|
[(_ ct ...)
|
||||||
|
|
@ -1675,7 +1568,13 @@ improve method arity mismatch contract violation error messages?
|
||||||
(values
|
(values
|
||||||
(lambda (outer-args body)
|
(lambda (outer-args body)
|
||||||
(with-syntax ([body body]
|
(with-syntax ([body body]
|
||||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
|
[(name-dom-contract-x ...)
|
||||||
|
(if show-first?
|
||||||
|
(syntax (dom-contract-x ...))
|
||||||
|
(cdr
|
||||||
|
(syntax->list
|
||||||
|
(syntax (dom-contract-x ...)))))])
|
||||||
(syntax
|
(syntax
|
||||||
(let ([dom-contract-x (coerce-contract ->d dom)] ...)
|
(let ([dom-contract-x (coerce-contract ->d dom)] ...)
|
||||||
(let ([dom-x (contract-proc dom-contract-x)] ...
|
(let ([dom-x (contract-proc dom-contract-x)] ...
|
||||||
|
|
@ -1685,7 +1584,7 @@ improve method arity mismatch contract violation error messages?
|
||||||
(error '->d "expected range portion to be a function that takes ~a arguments, given: ~e"
|
(error '->d "expected range portion to be a function that takes ~a arguments, given: ~e"
|
||||||
arity
|
arity
|
||||||
rng-x))
|
rng-x))
|
||||||
(let ([name-id (build-compound-type-name '->d dom-contract-x ... '(... ...))])
|
(let ([name-id (build-compound-type-name '->d name-dom-contract-x ... '(... ...))])
|
||||||
|
|
||||||
body))))))
|
body))))))
|
||||||
(lambda (outer-args inner-lambda)
|
(lambda (outer-args inner-lambda)
|
||||||
|
|
@ -1719,8 +1618,8 @@ improve method arity mismatch contract violation error messages?
|
||||||
orig-str)
|
orig-str)
|
||||||
(val (dom-projection-x arg-x) ...))))))))))]))
|
(val (dom-projection-x arg-x) ...))))))))))]))
|
||||||
|
|
||||||
;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||||
(define (->d*/h stx)
|
(define (->d*/h show-first? stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ (dom ...) rng-mk)
|
[(_ (dom ...) rng-mk)
|
||||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
|
|
@ -1732,7 +1631,13 @@ improve method arity mismatch contract violation error messages?
|
||||||
(values
|
(values
|
||||||
(lambda (outer-args body)
|
(lambda (outer-args body)
|
||||||
(with-syntax ([body body]
|
(with-syntax ([body body]
|
||||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
|
[(name-dom-contract-x ...)
|
||||||
|
(if show-first?
|
||||||
|
(syntax (dom-contract-x ...))
|
||||||
|
(cdr
|
||||||
|
(syntax->list
|
||||||
|
(syntax (dom-contract-x ...)))))])
|
||||||
(syntax
|
(syntax
|
||||||
(let ([dom-contract-x (coerce-contract ->d* dom)] ...)
|
(let ([dom-contract-x (coerce-contract ->d* dom)] ...)
|
||||||
(let ([dom-x (contract-proc dom-contract-x)] ...
|
(let ([dom-x (contract-proc dom-contract-x)] ...
|
||||||
|
|
@ -1742,7 +1647,7 @@ improve method arity mismatch contract violation error messages?
|
||||||
(error '->d* "expected range position to be a procedure that accepts ~a arguments, given: ~e"
|
(error '->d* "expected range position to be a procedure that accepts ~a arguments, given: ~e"
|
||||||
dom-length rng-mk-x))
|
dom-length rng-mk-x))
|
||||||
(let ([name-id (string-append "(->d* "
|
(let ([name-id (string-append "(->d* "
|
||||||
(build-compound-type-name #f dom-contract-x ...)
|
(build-compound-type-name #f name-dom-contract-x ...)
|
||||||
" ...)")])
|
" ...)")])
|
||||||
body))))))
|
body))))))
|
||||||
(lambda (outer-args inner-lambda)
|
(lambda (outer-args inner-lambda)
|
||||||
|
|
@ -1802,7 +1707,13 @@ improve method arity mismatch contract violation error messages?
|
||||||
(values
|
(values
|
||||||
(lambda (outer-args body)
|
(lambda (outer-args body)
|
||||||
(with-syntax ([body body]
|
(with-syntax ([body body]
|
||||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||||
|
[(name-dom-contract-x ...)
|
||||||
|
(if show-first?
|
||||||
|
(syntax (dom-contract-x ...))
|
||||||
|
(cdr
|
||||||
|
(syntax->list
|
||||||
|
(syntax (dom-contract-x ...)))))])
|
||||||
(syntax
|
(syntax
|
||||||
(let ([dom-contract-x (coerce-contract ->d* dom)] ...
|
(let ([dom-contract-x (coerce-contract ->d* dom)] ...
|
||||||
[dom-rest-contract-x (coerce-contract ->d* rest)])
|
[dom-rest-contract-x (coerce-contract ->d* rest)])
|
||||||
|
|
@ -1813,7 +1724,7 @@ improve method arity mismatch contract violation error messages?
|
||||||
(error '->d* "expected range position to be a procedure that accepts ~a arguments, given: ~e"
|
(error '->d* "expected range position to be a procedure that accepts ~a arguments, given: ~e"
|
||||||
arity rng-mk-x))
|
arity rng-mk-x))
|
||||||
(let ([name-id (string-append "(->d* "
|
(let ([name-id (string-append "(->d* "
|
||||||
(build-compound-type-name #f dom-contract-x ...)
|
(build-compound-type-name #f name-dom-contract-x ...)
|
||||||
" "
|
" "
|
||||||
(contract->type-name dom-rest-contract-x)
|
(contract->type-name dom-rest-contract-x)
|
||||||
" ...)")])
|
" ...)")])
|
||||||
|
|
|
||||||
|
|
@ -828,7 +828,7 @@
|
||||||
"pos")
|
"pos")
|
||||||
|
|
||||||
(test/spec-passed/result
|
(test/spec-passed/result
|
||||||
'object-contract1
|
'object-contract->1
|
||||||
'(send
|
'(send
|
||||||
(contract (object-contract (m (integer? . -> . integer?)))
|
(contract (object-contract (m (integer? . -> . integer?)))
|
||||||
(new (class object% (define/public (m x) x) (super-new)))
|
(new (class object% (define/public (m x) x) (super-new)))
|
||||||
|
|
@ -839,7 +839,7 @@
|
||||||
1)
|
1)
|
||||||
|
|
||||||
(test/spec-failed
|
(test/spec-failed
|
||||||
'object-contract2
|
'object-contract->2
|
||||||
'(contract (object-contract (m (integer? . -> . integer?)))
|
'(contract (object-contract (m (integer? . -> . integer?)))
|
||||||
(make-object object%)
|
(make-object object%)
|
||||||
'pos
|
'pos
|
||||||
|
|
@ -847,7 +847,7 @@
|
||||||
"pos")
|
"pos")
|
||||||
|
|
||||||
(test/spec-failed
|
(test/spec-failed
|
||||||
'object-contract3
|
'object-contract->3
|
||||||
'(send
|
'(send
|
||||||
(contract (object-contract (m (integer? . -> . integer?)))
|
(contract (object-contract (m (integer? . -> . integer?)))
|
||||||
(make-object (class object% (define/public (m x) x) (super-instantiate ())))
|
(make-object (class object% (define/public (m x) x) (super-instantiate ())))
|
||||||
|
|
@ -858,7 +858,7 @@
|
||||||
"neg")
|
"neg")
|
||||||
|
|
||||||
(test/spec-failed
|
(test/spec-failed
|
||||||
'object-contract4
|
'object-contract->4
|
||||||
'(send
|
'(send
|
||||||
(contract (object-contract (m (integer? . -> . integer?)))
|
(contract (object-contract (m (integer? . -> . integer?)))
|
||||||
(make-object (class object% (define/public (m x) 'x) (super-instantiate ())))
|
(make-object (class object% (define/public (m x) 'x) (super-instantiate ())))
|
||||||
|
|
@ -869,13 +869,86 @@
|
||||||
"pos")
|
"pos")
|
||||||
|
|
||||||
(test/spec-failed
|
(test/spec-failed
|
||||||
'object-contract5
|
'object-contract->5
|
||||||
'(contract (object-contract (m (integer? integer? . -> . integer?)))
|
'(contract (object-contract (m (integer? integer? . -> . integer?)))
|
||||||
(make-object (class object% (define/public (m x) 'x) (super-instantiate ())))
|
(make-object (class object% (define/public (m x) 'x) (super-instantiate ())))
|
||||||
'pos
|
'pos
|
||||||
'neg)
|
'neg)
|
||||||
"pos")
|
"pos")
|
||||||
|
|
||||||
|
(test/spec-failed
|
||||||
|
'object-contract-case->1
|
||||||
|
'(contract (object-contract (m (case-> (boolean? . -> . boolean?)
|
||||||
|
(integer? integer? . -> . integer?))))
|
||||||
|
(new object%)
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
"pos")
|
||||||
|
|
||||||
|
(test/spec-failed
|
||||||
|
'object-contract-case->2
|
||||||
|
'(contract (object-contract (m (case-> (boolean? . -> . boolean?)
|
||||||
|
(integer? integer? . -> . integer?))))
|
||||||
|
(new (class object% (define/public (m x) x) (super-new)))
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
"pos")
|
||||||
|
|
||||||
|
(test/spec-failed
|
||||||
|
'object-contract-case->3
|
||||||
|
'(contract (object-contract (m (case-> (boolean? . -> . boolean?)
|
||||||
|
(integer? integer? . -> . integer?))))
|
||||||
|
(new (class object% (define/public (m x y) x) (super-new)))
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
"pos")
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'object-contract-case->4
|
||||||
|
'(contract (object-contract (m (case-> (boolean? . -> . boolean?)
|
||||||
|
(integer? integer? . -> . integer?))))
|
||||||
|
(new (class object%
|
||||||
|
(define/public m
|
||||||
|
(case-lambda
|
||||||
|
[(b) (not b)]
|
||||||
|
[(x y) (+ x y)]))
|
||||||
|
(super-new)))
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'object-contract-case->5
|
||||||
|
'(send (contract (object-contract (m (case-> (boolean? . -> . boolean?)
|
||||||
|
(integer? integer? . -> . integer?))))
|
||||||
|
(new (class object%
|
||||||
|
(define/public m
|
||||||
|
(case-lambda
|
||||||
|
[(b) (not b)]
|
||||||
|
[(x y) (+ x y)]))
|
||||||
|
(super-new)))
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
m
|
||||||
|
#t)
|
||||||
|
#f)
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'object-contract-case->6
|
||||||
|
'(send (contract (object-contract (m (case-> (boolean? . -> . boolean?)
|
||||||
|
(integer? integer? . -> . integer?))))
|
||||||
|
(new (class object%
|
||||||
|
(define/public m
|
||||||
|
(case-lambda
|
||||||
|
[(b) (not b)]
|
||||||
|
[(x y) (+ x y)]))
|
||||||
|
(super-new)))
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
m
|
||||||
|
3
|
||||||
|
4)
|
||||||
|
7)
|
||||||
|
|
||||||
|
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
|
|
@ -1396,7 +1469,18 @@
|
||||||
(test-name "(box/p boolean?)" (box/p (flat-contract boolean?)))
|
(test-name "(box/p boolean?)" (box/p (flat-contract boolean?)))
|
||||||
(test-name "the-name" (flat-rec-contract the-name))
|
(test-name "the-name" (flat-rec-contract the-name))
|
||||||
|
|
||||||
(test-name "(object-contract (m (-> integer? integer?)))" (object-contract (m (-> integer? integer?))))
|
(test-name "(object-contract)" (object-contract))
|
||||||
|
(test-name "(object-contract (field x integer?))" (object-contract (field x integer?)))
|
||||||
|
(test-name "(object-contract (m (-> integer? integer?)))"
|
||||||
|
(object-contract (m (-> integer? integer?))))
|
||||||
|
(test-name "(object-contract (m (-> integer? any)))"
|
||||||
|
(object-contract (m (-> integer? any))))
|
||||||
|
(test-name "(object-contract (m (-> integer? (values integer? integer?))))"
|
||||||
|
(object-contract (m (-> integer? (values integer? integer?)))))
|
||||||
|
(test-name "(object-contract (m (case-> (-> integer? integer? integer?) (-> integer? (values integer? integer?)))))"
|
||||||
|
(object-contract (m (case->
|
||||||
|
(-> integer? integer? integer?)
|
||||||
|
(-> integer? (values integer? integer?))))))
|
||||||
|
|
||||||
))
|
))
|
||||||
(report-errs)
|
(report-errs)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user