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

Add ->dm and case->m, which are the implicit method versions of ->d and

Browse Source 
case->.

This should be included in the release.

svn: r18579
This commit is contained in:
Stevie Strickland 2010-03-18 21:28:41 +00:00
parent dedb261ea8
commit dde2011ec7
4 changed files with 221 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
collects/scheme/contract/private/arrow.ss
View File

@ -39,6 +39,10 @@ v4 todo:
check-procedure/more) check-procedure/more)
(define-syntax-parameter making-a-method #f) (define-syntax-parameter making-a-method #f)
(define-for-syntax (make-this-parameters id)
(if (syntax-parameter-value #'making-a-method)
(list id)
null))
(define-struct contracted-function (proc ctc) (define-struct contracted-function (proc ctc)
#:property prop:procedure 0 #:property prop:procedure 0
@ -301,9 +305,7 @@ v4 todo:
[(args ...) (generate-temporaries (syntax (doms ...)))] [(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(this-parameter ...) [(this-parameter ...)
(if (syntax-parameter-value #'making-a-method) (make-this-parameters (car (generate-temporaries '(this))))])
(generate-temporaries '(this))
'())])
(syntax-case* #'last-one (-> any values) module-or-top-identifier=? (syntax-case* #'last-one (-> any values) module-or-top-identifier=?
[any [any
(with-syntax ([(ignored) (generate-temporaries (syntax (rng)))]) (with-syntax ([(ignored) (generate-temporaries (syntax (rng)))])
@ -369,7 +371,7 @@ v4 todo:
(with-syntax ([outer-lambda (with-syntax ([outer-lambda
#`(lambda (chk ctc dom-names ... kwd-names ... rng-names ...) #`(lambda (chk ctc dom-names ... kwd-names ... rng-names ...)
(lambda (val) (lambda (val)
(chk val #,(syntax-parameter-value #'making-a-method)) (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
(make-contracted-function inner-lambda ctc)))]) (make-contracted-function inner-lambda ctc)))])
(values (values
(syntax (syntax
@ -607,9 +609,7 @@ v4 todo:
(with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))] (with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
[(rng ...) (generate-temporaries (or rng-ctc '()))] [(rng ...) (generate-temporaries (or rng-ctc '()))]
[(this-parameter ...) [(this-parameter ...)
(if (syntax-parameter-value #'making-a-method) (make-this-parameters (car (generate-temporaries '(this))))])
(generate-temporaries '(this))
'())])
#`(build--> #`(build-->
'->* '->*
(list mandatory-dom ...) (list mandatory-dom ...)
@ -634,7 +634,7 @@ v4 todo:
optional-dom-kwd-proj ... optional-dom-kwd-proj ...
rng-proj ...) rng-proj ...)
(λ (f) (λ (f)
(chk f #,(syntax-parameter-value #'making-a-method)) (chk f #,(and (syntax-parameter-value #'making-a-method) #t))
(make-contracted-function (make-contracted-function
#,(maybe-a-method/name #,(maybe-a-method/name
(add-name-prop (add-name-prop
@ -756,6 +756,21 @@ v4 todo:
(syntax->list #'(kwd ...))))]) (syntax->list #'(kwd ...))))])
doms) doms)
(define-for-syntax (make-this-transformer this-arg)
(with-syntax ([this-arg this-arg])
(make-set!-transformer
(λ (sstx)
(syntax-case sstx (set!)
[(set! id arg)
(raise-syntax-error #f
"can't mutate this"
sstx)]
[id
(identifier? #'id)
(syntax/loc sstx this-arg)]
[(id . args)
(datum->syntax sstx (cons #'this-arg #'args) sstx)])))))
(define-syntax (->d stx) (define-syntax (->d stx)
(syntax-case stx () (syntax-case stx ()
[(_ (raw-mandatory-doms ...) [(_ (raw-mandatory-doms ...)
@ -773,9 +788,9 @@ v4 todo:
#'((optional-kwd optional-kwd-id) ... #'((optional-kwd optional-kwd-id) ...
(mandatory-kwd mandatory-kwd-id) ...)))] (mandatory-kwd mandatory-kwd-id) ...)))]
[(this-parameter ...) [(this-parameter ...)
(if (syntax-parameter-value #'making-a-method) (make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
(list (datum->syntax stx 'this #f)) (car (generate-temporaries '(this)))
'())]) (datum->syntax stx 'this #f)))])
(let-values ([(id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)]) (let-values ([(id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)])
(with-syntax ([(dom-params ...) (with-syntax ([(dom-params ...)
#`(this-parameter ... #`(this-parameter ...
@ -793,7 +808,7 @@ v4 todo:
[any #'(() #f)] [any #'(() #f)]
[[id ctc] #'((id) (ctc))] [[id ctc] #'((id) (ctc))]
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])] [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
[mtd? (syntax-parameter-value #'making-a-method)]) [mtd? (and (syntax-parameter-value #'making-a-method) #t)])
(let ([rng-underscores? (let ([rng-underscores?
(let ([is-underscore? (let ([is-underscore?
(λ (x) (λ (x)
@ -819,35 +834,57 @@ v4 todo:
(syntax->list #'(dom-params ...))))]) (syntax->list #'(dom-params ...))))])
(when dup (when dup
(raise-syntax-error #f "duplicate identifier" stx dup))) (raise-syntax-error #f "duplicate identifier" stx dup)))
#`(syntax-parameterize #`(let-syntax ([parameterize-this
(let ([old-param (syntax-parameter-value #'making-a-method)])
(λ (stx)
(syntax-case stx ()
[(_ body) #'body]
[(_ id body)
(if (syntax? old-param)
(with-syntax ([param old-param])
(syntax/loc stx
(syntax-parameterize
([param (make-this-transformer #'id)])
body)))
#'body)])))])
(syntax-parameterize
((making-a-method #f)) ((making-a-method #f))
(build-->d mtd? (build-->d mtd?
(list (λ (dom-params ...) mandatory-doms) ...) (list (λ (dom-params ...)
(list (λ (dom-params ...) optional-doms) ...) (parameterize-this this-parameter ... mandatory-doms)) ...)
(list (λ (dom-params ...) mandatory-kwd-dom) ...) (list (λ (dom-params ...)
(list (λ (dom-params ...) optional-kwd-dom) ...) (parameterize-this this-parameter ... optional-doms)) ...)
(list (λ (dom-params ...)
(parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
(list (λ (dom-params ...)
(parameterize-this this-parameter ... optional-kwd-dom)) ...)
#,(if id/rest #,(if id/rest
(with-syntax ([(id rst-ctc) id/rest]) (with-syntax ([(id rst-ctc) id/rest])
#`(λ (dom-params ...) rst-ctc)) #`(λ (dom-params ...)
(parameterize-this this-parameter ... rst-ctc)))
#f) #f)
#,(if pre-cond #,(if pre-cond
#`(λ (dom-params ...) #,pre-cond) #`(λ (dom-params ...)
(parameterize-this this-parameter ... #,pre-cond))
#f) #f)
#,(syntax-case #'rng-ctcs () #,(syntax-case #'rng-ctcs ()
[#f #f] [#f #f]
[(ctc ...) [(ctc ...)
(if rng-underscores? (if rng-underscores?
#'(box (list (λ (dom-params ...) ctc) ...)) #'(box (list (λ (dom-params ...)
#'(list (λ (rng-params ... dom-params ...) ctc) ...))]) (parameterize-this this-parameter ... ctc)) ...))
#'(list (λ (rng-params ... dom-params ...)
(parameterize-this this-parameter ... ctc)) ...))])
#,(if post-cond #,(if post-cond
#`(λ (rng-params ... dom-params ...) #,post-cond) #`(λ (rng-params ... dom-params ...)
(parameterize-this this-parameter ... #,post-cond))
#f) #f)
'(mandatory-kwd ...) '(mandatory-kwd ...)
'(optional-kwd ...) '(optional-kwd ...)
(λ (f) (λ (f)
#,(add-name-prop #,(add-name-prop
(syntax-local-infer-name stx) (syntax-local-infer-name stx)
#`(λ args (apply f args))))))))))))])) #`(λ args (apply f args)))))))))))))]))
(define ->d-tail-key (gensym '->d-tail-key)) (define ->d-tail-key (gensym '->d-tail-key))
@ -1200,9 +1237,7 @@ v4 todo:
(generate-temporaries rng) (generate-temporaries rng)
'())] '())]
[(this-parameter ...) [(this-parameter ...)
(if (syntax-parameter-value #'making-a-method) (make-this-parameters (car (generate-temporaries '(this))))])
(generate-temporaries '(this))
'())])
#`(#,doms #`(#,doms
#,rst #,rst
#,(if rng #`(list #,@rng) #f) #,(if rng #`(list #,@rng) #f)
@ -1250,7 +1285,7 @@ v4 todo:
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
(λ (f) (λ (f)
(chk f #,(syntax-parameter-value #'making-a-method)) (chk f #,(and (syntax-parameter-value #'making-a-method) #t))
(make-contracted-function (make-contracted-function
(case-lambda (case-lambda
[formals body] ...) [formals body] ...)

10
collects/scheme/private/class-internal.ss
View File

@ -56,7 +56,7 @@
method-in-interface? interface->method-names class->interface class-info method-in-interface? interface->method-names class->interface class-info
(struct-out exn:fail:object) (struct-out exn:fail:object)
make-primitive-class make-primitive-class
class/c ->m ->*m object/c class/c ->m ->*m ->dm case->m object/c
;; "keywords": ;; "keywords":
private public override augment private public override augment
@ -2503,6 +2503,12 @@
(define-syntax-rule (->*m . stx) (define-syntax-rule (->*m . stx)
(syntax-parameterize ([making-a-method #t]) (->* . stx))) (syntax-parameterize ([making-a-method #t]) (->* . stx)))
(define-syntax-rule (case->m . stx)
(syntax-parameterize ([making-a-method #t]) (case-> . stx)))
(define-syntax-rule (->dm . stx)
(syntax-parameterize ([making-a-method #'this-param]) (->d . stx)))
(define (class/c-check-first-order ctc cls blame) (define (class/c-check-first-order ctc cls blame)
(let/ec return (let/ec return
(define (failed str . args) (define (failed str . args)
@ -4737,5 +4743,5 @@
method-in-interface? interface->method-names class->interface class-info method-in-interface? interface->method-names class->interface class-info
(struct-out exn:fail:object) (struct-out exn:fail:object)
make-primitive-class make-primitive-class
class/c ->m ->*m object/c) class/c ->m ->*m ->dm case->m object/c)

21
collects/scribblings/reference/class.scrbl
View File

@ -1512,8 +1512,8 @@ contracts for subclasses.
Method contracts must contain an additional initial argument which corresponds Method contracts must contain an additional initial argument which corresponds
to the implicit @scheme[this] parameter of the method. This allows for to the implicit @scheme[this] parameter of the method. This allows for
contracts which discuss the state of the object when the method is called contracts which discuss the state of the object when the method is called
(or, for dependent contracts, in other parts of the contract). Two alternative (or, for dependent contracts, in other parts of the contract). Alternative
contract forms, @scheme[->m] and @scheme[->*m], are provided as a shorthand contract forms, such as @scheme[->m], are provided as a shorthand
for writing method contracts. for writing method contracts.
The external contracts are as follows: The external contracts are as follows:
@ -1583,6 +1583,23 @@ more element than the stated domain, where the first (implicit) argument is cont
@scheme[any/c]. This contract is useful for writing simpler method contracts when no properties @scheme[any/c]. This contract is useful for writing simpler method contracts when no properties
of @scheme[this] need to be checked.} of @scheme[this] need to be checked.}
@defform[(case->m (-> dom ... rest range) ...)]{
Similar to @scheme[case->], except that the mandatory domain of each case of the resulting contract
contains one more element than the stated domain, where the first (implicit) argument is contracted
with @scheme[any/c]. This contract is useful for writing simpler method contracts when no properties
of @scheme[this] need to be checked.}
@defform[(->dm (mandatory-dependent-dom ...)
(optional-dependent-dom ...)
dependent-rest
pre-cond
dep-range)]{
Similar to @scheme[->d], except that the mandatory domain of the resulting contract
contains one more element than the stated domain, where the first (implicit) argument is contracted
with @scheme[any/c]. In addition, @scheme[this] is appropriately bound in the body of the contract.
This contract is useful for writing simpler method contracts when no properties
of @scheme[this] need to be checked.}
@defform/subs[ @defform/subs[
#:literals (field) #:literals (field)

114
collects/tests/mzscheme/contract-test.ss
View File

@ -5280,6 +5280,120 @@
'pos 'pos
'neg)) 'neg))
(test/spec-passed
'->dm-first-order-1
'(contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])]
[push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))]
[empty? (->m boolean?)])
(class object% (super-new)
(define stack null)
(define/public (empty?) (null? stack))
(define/public (push v) (set! stack (cons v stack)))
(define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
'pos
'neg))
(test/pos-blame
'->dm-first-order-1
'(contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])]
[push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))]
[empty? (->m boolean?)])
(class object% (super-new)
(define stack null)
(define/public (empty?) (null? stack))
(define/public (push v) (set! stack (cons v stack)))
(define/public (pop v) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
'pos
'neg))
(test/spec-passed
'->dm-higher-order-1
'(let* ([stack% (contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])]
[push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))]
[empty? (->m boolean?)])
(class object% (super-new)
(define stack null)
(define/public (empty?) (null? stack))
(define/public (push v) (set! stack (cons v stack)))
(define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
'pos
'neg)]
[o (new stack%)])
(send o push 4)
(send o empty?)
(send o pop)))
(test/pos-blame
'->dm-higher-order-2
'(let* ([stack% (contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])]
[push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))]
[empty? (->m boolean?)])
(class object% (super-new)
(define stack null)
(define/public (empty?) (null? stack))
(define/public (push v) (void))
(define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
'pos
'neg)]
[o (new stack%)])
(send o push 4)
(send o empty?)
(send o pop)))
(test/neg-blame
'->dm-higher-order-3
'(let* ([stack% (contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])]
[push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))]
[empty? (->m boolean?)])
(class object% (super-new)
(define stack null)
(define/public (empty?) (null? stack))
(define/public (push v) (set! stack (cons v stack)))
(define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
'pos
'neg)]
[o (new stack%)])
(send o pop)))
(test/spec-passed
'case->m-first-order-1
'(contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))])
(class object% (super-new) (define/public (m x [y 3]) (+ x y)))
'pos
'neg))
(test/pos-blame
'case->m-first-order-2
'(contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))])
(class object% (super-new) (define/public (m x) (+ x y)))
'pos
'neg))
(test/spec-passed
'case->m-higher-order-1
'(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))])
(class object% (super-new) (define/public (m x [y 3]) (+ x y)))
'pos
'neg)])
(send (new cls%) m 3)
(send (new cls%) m 3 4)))
(test/neg-blame
'case->m-higher-order-2
'(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))])
(class object% (super-new) (define/public (m x [y 3]) (+ x y)))
'pos
'neg)])
(send (new cls%) m #t)))
(test/neg-blame
'case->m-higher-order-3
'(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))])
(class object% (super-new) (define/public (m x [y 3]) (+ x y)))
'pos
'neg)])
(send (new cls%) m 3 #t)))
; ;
; ;
; ;; ;; ; ;; ; ;; ;; ; ;;