From 209f2db61105a58fb6255a8b8511c8b15a57506f Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 30 Mar 2016 15:38:31 -0500
Subject: [PATCH] Don't use syntax parameters for method contracts.
Can be done with plain old functions.
---
.../racket/contract/private/arr-d.rkt | 98 ++++++++++---------
.../racket/contract/private/arr-i.rkt | 26 ++---
.../racket/contract/private/arrow-common.rkt | 10 +-
.../contract/private/arrow-val-first.rkt | 97 ++++++++----------
.../racket/contract/private/case-arrow.rkt | 79 ++++++++-------
.../racket/contract/private/object.rkt | 15 ++-
.../collects/racket/private/class-c-old.rkt | 33 +++++--
7 files changed, 180 insertions(+), 178 deletions(-)
diff --git a/racket/collects/racket/contract/private/arr-d.rkt b/racket/collects/racket/contract/private/arr-d.rkt
index 66546c09c8..4888bcfac1 100644
--- a/racket/collects/racket/contract/private/arr-d.rkt
+++ b/racket/collects/racket/contract/private/arr-d.rkt
@@ -12,6 +12,7 @@
"arrow-common.rkt")
(provide ->d
+ (for-syntax ->d-internal) ; for ->dm
base-->d? ->d-name) ; for object-contract
;
@@ -132,6 +133,11 @@
(datum->syntax sstx (cons #'this-arg #'args) sstx)])))))
(define-syntax (->d stx)
+ (syntax-case stx ()
+ [(_ . args)
+ (->d-internal (syntax/loc stx (->d . args)) #|method?|# #f)]))
+
+(define-for-syntax (->d-internal stx maybe-this-param) ; non-#f is creating an ->dm
(syntax-case stx ()
[(_ (raw-mandatory-doms ...)
.
@@ -148,9 +154,9 @@
#'((optional-kwd optional-kwd-id) ...
(mandatory-kwd mandatory-kwd-id) ...)))]
[(this-parameter ...)
- (make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
- (car (generate-temporaries '(this)))
- (datum->syntax stx 'this #f)))])
+ (if maybe-this-param
+ (generate-temporaries '(this))
+ null)])
(with-syntax ([(dom-params ...)
#`(this-parameter ...
mandatory-regular-id ...
@@ -167,8 +173,7 @@
[any #'(() #f)]
[[id ctc] #'((id) (ctc))]
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
- [mtd? (and (syntax-parameter-value #'making-a-method) #t)]
- [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)])
+ [mtd? (and maybe-this-param #t)])
(let ([rng-underscores?
(let ([is-underscore?
(λ (x)
@@ -195,7 +200,7 @@
(when dup
(raise-syntax-error #f "duplicate identifier" stx dup)))
#`(let-syntax ([parameterize-this
- (let ([old-param (syntax-parameter-value #'making-a-method)])
+ (let ([old-param #,maybe-this-param])
(λ (stx)
(syntax-case stx ()
[(_ body) #'body]
@@ -207,44 +212,42 @@
([param (make-this-transformer #'id)])
body)))
#'body)])))])
- (syntax-parameterize
- ((making-a-method #f))
- (build-->d mtd? ->m-ctc?
- (list (λ (dom-params ...)
- (parameterize-this this-parameter ... mandatory-doms)) ...)
- (list (λ (dom-params ...)
- (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
- (with-syntax ([(id rst-ctc) id/rest])
- #`(λ (dom-params ...)
- (parameterize-this this-parameter ... rst-ctc)))
- #f)
- #,(if pre-cond
- #`(λ (dom-params ...)
- (parameterize-this this-parameter ... #,pre-cond))
- #f)
- #,(syntax-case #'rng-ctcs ()
- [#f #f]
- [(ctc ...)
- (if rng-underscores?
- #'(box (list (λ (dom-params ...)
- (parameterize-this this-parameter ... ctc)) ...))
- #'(list (λ (rng-params ... dom-params ...)
- (parameterize-this this-parameter ... ctc)) ...))])
- #,(if post-cond
- #`(λ (rng-params ... dom-params ...)
- (parameterize-this this-parameter ... #,post-cond))
- #f)
- '(mandatory-kwd ...)
- '(optional-kwd ...)
- (λ (f)
- #,(add-name-prop
- (syntax-local-infer-name stx)
- #`(λ args (apply f args)))))))))))))]))
+ (build-->d mtd?
+ (list (λ (dom-params ...)
+ (parameterize-this this-parameter ... mandatory-doms)) ...)
+ (list (λ (dom-params ...)
+ (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
+ (with-syntax ([(id rst-ctc) id/rest])
+ #`(λ (dom-params ...)
+ (parameterize-this this-parameter ... rst-ctc)))
+ #f)
+ #,(if pre-cond
+ #`(λ (dom-params ...)
+ (parameterize-this this-parameter ... #,pre-cond))
+ #f)
+ #,(syntax-case #'rng-ctcs ()
+ [#f #f]
+ [(ctc ...)
+ (if rng-underscores?
+ #'(box (list (λ (dom-params ...)
+ (parameterize-this this-parameter ... ctc)) ...))
+ #'(list (λ (rng-params ... dom-params ...)
+ (parameterize-this this-parameter ... ctc)) ...))])
+ #,(if post-cond
+ #`(λ (rng-params ... dom-params ...)
+ (parameterize-this this-parameter ... #,post-cond))
+ #f)
+ '(mandatory-kwd ...)
+ '(optional-kwd ...)
+ (λ (f)
+ #,(add-name-prop
+ (syntax-local-infer-name stx)
+ #`(λ args (apply f args))))))))))))]))
(define ((late-neg-->d-proj wrap-procedure) ->d-stct)
(let* ([opt-count (length (base-->d-optional-dom-ctcs ->d-stct))]
@@ -462,7 +465,7 @@
(cons (car args) (loop (cdr all-kwds) (cdr kwds) (cdr args)))
(cons the-unsupplied-arg (loop (cdr all-kwds) kwds args))))]))))
-(define (build-->d mtd? mctc?
+(define (build-->d mtd?
mandatory-dom-ctcs optional-dom-ctcs
mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs
rest-ctc pre-cond range post-cond
@@ -473,7 +476,7 @@
(append mandatory-kwds optional-kwds)
(append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
(λ (x y) (keyword<? (car x) (car y))))])
- (make-impersonator-->d mtd? mctc?
+ (make-impersonator-->d mtd?
mandatory-dom-ctcs optional-dom-ctcs
(map cdr kwd/ctc-pairs)
rest-ctc pre-cond range post-cond
@@ -484,7 +487,7 @@
;; Re `print-as-method-if-method?`: See comment before `base->-name` in arrow-val-first.rkt
(define ((->d-name print-as-method-if-method?) ctc)
- (let* ([name (if (and (base-->d-mctc? ctc) print-as-method-if-method?) '->dm '->d)]
+ (let* ([name (if (and (base-->d-mtd? ctc) print-as-method-if-method?) '->dm '->d)]
[counting-id 'x]
[ids '(x y z w)]
[next-id
@@ -550,7 +553,6 @@
;; both the domain and the range from those that depend only on the domain (and thus, those
;; that can be applied early)
(define-struct base-->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
- mctc? ;; boolean; indicates if this contract was constructed with ->dm (from racket/class)
mandatory-dom-ctcs ;; (listof (-> d??? ctc))
optional-dom-ctcs ;; (listof (-> d??? ctc))
keyword-ctcs ;; (listof (-> d??? ctc))
diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt
index 702f4912a4..fdf4e7698b 100644
--- a/racket/collects/racket/contract/private/arr-i.rkt
+++ b/racket/collects/racket/contract/private/arr-i.rkt
@@ -25,7 +25,8 @@
[module-identifier-mapping-put! free-identifier-mapping-put!]
[module-identifier-mapping-for-each free-identifier-mapping-for-each])))
-(provide (rename-out [->i/m ->i]))
+(provide (rename-out [->i/m ->i])
+ (for-syntax ->i-internal)) ; for method version of ->i
(define (build-??-args c-or-i-procedure ctc blame)
(define arg-ctc-projs (map (λ (x) (get/build-late-neg-projection (->i-arg-contract x)))
@@ -841,7 +842,7 @@ evaluted left-to-right.)
body))]
[else stx]))
-(define-for-syntax (mk-wrapper-func/blame-id-info stx an-istx used-indy-vars)
+(define-for-syntax (mk-wrapper-func/blame-id-info stx an-istx used-indy-vars method?)
(define-values (wrapper-proc-arglist
blame-ids args+rst
@@ -864,8 +865,7 @@ evaluted left-to-right.)
(generate-temporaries (map arg/res-var ordered-ress)))
- (define this-param (and (syntax-parameter-value #'making-a-method)
- (car (generate-temporaries '(this)))))
+ (define this-param (and method? (car (generate-temporaries '(this)))))
(define wrapper-body
(add-wrapper-let
@@ -899,7 +899,7 @@ evaluted left-to-right.)
#`(λ #,wrapper-proc-arglist
(λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
- (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
+ (chk val #,method?)
(c-or-i-procedure
val
(let ([arg-checker
@@ -1026,7 +1026,7 @@ evaluted left-to-right.)
arg-proj-vars indy-arg-proj-vars
res-proj-vars indy-res-proj-vars))
-(define-for-syntax (mk-val-first-wrapper-func/blame-id-info an-istx used-indy-vars)
+(define-for-syntax (mk-val-first-wrapper-func/blame-id-info an-istx used-indy-vars method?)
(define-values (wrapper-proc-arglist
blame-ids args+rst
ordered-args arg-indices
@@ -1048,8 +1048,7 @@ evaluted left-to-right.)
(generate-temporaries (map arg/res-var ordered-ress)))
- (define this-param (and (syntax-parameter-value #'making-a-method)
- (car (generate-temporaries '(this)))))
+ (define this-param (and method? (car (generate-temporaries '(this)))))
#`(λ #,wrapper-proc-arglist
(λ (f)
@@ -1138,10 +1137,15 @@ evaluted left-to-right.)
vars))
(define-syntax (->i/m stx)
+ (syntax-case stx ()
+ [(_ . args)
+ (->i-internal (syntax/loc stx (->i . args)) #|method?|# #f)]))
+
+(define-for-syntax (->i-internal stx method?)
(define an-istx (parse-->i stx))
(define used-indy-vars (mk-used-indy-vars an-istx))
- (define-values (blame-ids wrapper-func) (mk-wrapper-func/blame-id-info stx an-istx used-indy-vars))
- (define val-first-wrapper-func (mk-val-first-wrapper-func/blame-id-info an-istx used-indy-vars))
+ (define-values (blame-ids wrapper-func) (mk-wrapper-func/blame-id-info stx an-istx used-indy-vars method?))
+ (define val-first-wrapper-func (mk-val-first-wrapper-func/blame-id-info an-istx used-indy-vars method?))
(define args+rst (append (istx-args an-istx)
(if (istx-rst an-istx)
(list (istx-rst an-istx))
@@ -1311,7 +1315,7 @@ evaluted left-to-right.)
(istx-args an-istx)))
keyword<?)
'#,(and (istx-rst an-istx) (arg/res-var (istx-rst an-istx)))
- #,(and (syntax-parameter-value #'making-a-method) #t)
+ #,method?
(quote-module-name)
#,wrapper-func
#,val-first-wrapper-func
diff --git a/racket/collects/racket/contract/private/arrow-common.rkt b/racket/collects/racket/contract/private/arrow-common.rkt
index e2788a012c..ba4975d77d 100644
--- a/racket/collects/racket/contract/private/arrow-common.rkt
+++ b/racket/collects/racket/contract/private/arrow-common.rkt
@@ -8,8 +8,7 @@
racket/stxparam)
(require (for-syntax racket/base))
-(provide making-a-method method-contract? (for-syntax make-this-parameters)
- blame-add-range-context
+(provide blame-add-range-context
blame-add-nth-arg-context
check-procedure check-procedure/more
procedure-accepts-and-more?
@@ -27,13 +26,6 @@
(define-struct unsupplied-arg ())
(define the-unsupplied-arg (make-unsupplied-arg))
-(define-syntax-parameter making-a-method #f)
-(define-syntax-parameter method-contract? #f)
-(define-for-syntax (make-this-parameters id)
- (if (syntax-parameter-value #'making-a-method)
- (list id)
- null))
-
(define (blame-add-range-context blame)
(blame-add-context blame "the range of"))
diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt
index 1a82ba4037..573059dd53 100644
--- a/racket/collects/racket/contract/private/arrow-val-first.rkt
+++ b/racket/collects/racket/contract/private/arrow-val-first.rkt
@@ -14,7 +14,7 @@
(prefix-in arrow: "arrow-common.rkt"))
(provide (rename-out [->/c ->]) ->*
- ->-internal ->*-internal ; for ->m and ->*m
+ (for-syntax ->-internal ->*-internal) ; for ->m and ->*m
base->? base->-name base->-rngs base->-doms
dynamic->*
arity-checking-wrapper
@@ -644,17 +644,12 @@
(define-syntax (->/c stx)
(syntax-case stx ()
[(_ . args)
- (let ()
- #`(syntax-parameterize
- ((arrow:making-a-method #f))
- #,(quasisyntax/loc stx
- (->-internal -> . args))))]))
+ (->-internal (syntax/loc stx (-> . args)) #|method?|# #f)]))
-(define-syntax (->-internal stx*)
- (syntax-case stx* ()
- [(_ orig-> args ... rng)
+(define-for-syntax (->-internal stx method?)
+ (syntax-case stx ()
+ [(_ args ... rng)
(let ()
- (define stx (syntax/loc stx* (orig-> args ... rng)))
(define this-> (gensym 'this->))
(define-values (regular-args kwds kwd-args let-bindings ellipsis-info)
(parse-arrow-args stx (syntax->list #'(args ...)) this->))
@@ -666,29 +661,26 @@
[any #f]
[(values rng ...) (add-pos-obligations (syntax->list #'(rng ...)))]
[rng (add-pos-obligations (list #'rng))]))
- (define method? (syntax-parameter-value #'arrow:making-a-method))
(define-values (plus-one-arity-function chaperone-constructor)
(build-plus-one-arity-function+chaperone-constructor
regular-args '() kwds '() #f #f (and ellipsis-info #t) rngs #f #f
method?))
(syntax-property
- #`(syntax-parameterize
- ([arrow:making-a-method #f]) ; subcontracts are not method contracts, even if we ourselves are one
- (let #,let-bindings
- #,(quasisyntax/loc stx
- (build-simple-->
- (list #,@regular-args)
- '(#,@kwds)
- (list #,@kwd-args)
- #,(if rngs
- #`(list #,@rngs)
- #'#f)
- #,plus-one-arity-function
- #,chaperone-constructor
- #,(if ellipsis-info
- #`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info)
- #'#f)
- #,method?))))
+ #`(let #,let-bindings
+ #,(quasisyntax/loc stx
+ (build-simple-->
+ (list #,@regular-args)
+ '(#,@kwds)
+ (list #,@kwd-args)
+ #,(if rngs
+ #`(list #,@rngs)
+ #'#f)
+ #,plus-one-arity-function
+ #,chaperone-constructor
+ #,(if ellipsis-info
+ #`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info)
+ #'#f)
+ #,method?)))
'racket/contract:contract
(vector this->
;; the -> in the original input to this guy
@@ -835,13 +827,9 @@
(define-syntax (->* stx)
(syntax-case stx ()
[(_ . args)
- #`(syntax-parameterize
- ((arrow:making-a-method #f))
- #,(quasisyntax/loc stx
- (->*-internal ->* . args)))]))
+ (->*-internal (syntax/loc stx (->* . args)) #|method?|# #f)]))
-(define-syntax (->*-internal stx*)
- (define stx (syntax-case stx* () [(_ orig->* . args) (syntax/loc stx* (orig->* . args))]))
+(define-for-syntax (->*-internal stx method?)
(define this->* (gensym 'this->*))
(define-values (man-dom man-dom-kwds man-lets
opt-dom opt-dom-kwds opt-lets
@@ -862,7 +850,6 @@
[(post-let-binding ...) (if (or post post/desc)
(list #`[post-x (λ () #,(or post post/desc))])
(list))])
- (define method? (syntax-parameter-value #'arrow:making-a-method))
(define-values (plus-one-arity-function chaperone-constructor)
(build-plus-one-arity-function+chaperone-constructor
(syntax->list #'(mandatory-dom ...))
@@ -881,27 +868,25 @@
optional-let-bindings ...
pre-let-binding ...
post-let-binding ...)
- (syntax-parameterize
- ([arrow:making-a-method #f]) ; subcontracts are not method contracts, even if we ourselves are one
- (build--> '->*
- (list mandatory-dom ...)
- (list optional-dom ...)
- '(mandatory-dom-kwd ...)
- (list mandatory-dom-kwd-ctc ...)
- '(optional-dom-kwd ...)
- (list optional-dom-kwd-ctc ...)
- #,rest-ctc
- #,(and pre #t)
- #,(if rng-ctcs
- #`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))])
- (syntax-property rng-ctc
- 'racket/contract:positive-position
- this->*)))
- #'#f)
- #,(and post #t)
- #,plus-one-arity-function
- #,chaperone-constructor
- #,method?)))
+ (build--> '->*
+ (list mandatory-dom ...)
+ (list optional-dom ...)
+ '(mandatory-dom-kwd ...)
+ (list mandatory-dom-kwd-ctc ...)
+ '(optional-dom-kwd ...)
+ (list optional-dom-kwd-ctc ...)
+ #,rest-ctc
+ #,(and pre #t)
+ #,(if rng-ctcs
+ #`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))])
+ (syntax-property rng-ctc
+ 'racket/contract:positive-position
+ this->*)))
+ #'#f)
+ #,(and post #t)
+ #,plus-one-arity-function
+ #,chaperone-constructor
+ #,method?))
'racket/contract:contract
(vector this->*
diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt
index bcb4917197..af78648f14 100644
--- a/racket/collects/racket/contract/private/case-arrow.rkt
+++ b/racket/collects/racket/contract/private/case-arrow.rkt
@@ -11,7 +11,9 @@
"arrow-common.rkt"
"arrow-val-first.rkt")
-(provide case->)
+(provide case->
+ (for-syntax case->-internal) ; for case->m
+ base-case->? case->-name) ; for object-contract
;
@@ -48,7 +50,7 @@
[_
(raise-syntax-error #f "expected ->" stx case)]))
-(define-for-syntax (parse-out-case stx neg-party blame-party-info case n)
+(define-for-syntax (parse-out-case stx neg-party blame-party-info case n method?)
(let-values ([(dom-ctc-exprs rst-ctc-expr rng-ctc-exprs) (separate-out-doms/rst/rng stx case)])
(with-syntax ([(dom-proj-x ...) (generate-temporaries dom-ctc-exprs)]
[(rst-proj-x) (generate-temporaries '(rest-proj-x))]
@@ -60,7 +62,9 @@
(generate-temporaries rng-ctc-exprs)
'())]
[(this-parameter ...)
- (make-this-parameters (car (generate-temporaries '(this))))])
+ (if method?
+ (generate-temporaries '(this))
+ null)])
#`(#,dom-ctc-exprs
#,rst-ctc-expr
#,(if rng-ctc-exprs #`(list #,@rng-ctc-exprs) #f)
@@ -104,6 +108,11 @@
(dom-proj-x dom-formals neg-party) ...)]))))))
(define-syntax (case-> stx)
+ (syntax-case stx ()
+ [(_ . args)
+ (case->-internal (syntax/loc stx (case-> . args)) #|method?|# #f)]))
+
+(define-for-syntax (case->-internal stx mctc?)
(syntax-case stx ()
[(_ cases ...)
(let ()
@@ -119,34 +128,31 @@
body) ...)
(for/list ([x (in-list (syntax->list #'(cases ...)))]
[n (in-naturals)])
- (parse-out-case stx #'neg-party #'blame-party-info x n))]
- [mctc? (and (syntax-parameter-value #'method-contract?) #t)])
- #`(syntax-parameterize
- ((making-a-method #f))
- (build-case->
- (list (list dom-ctc-expr ...) ...)
- (list rst-ctc-expr ...)
- (list rng-ctc-exprs ...)
- '(spec ...)
- mctc?
- (λ (chk
- wrapper
- blame
- blame-party-info
- ctc
- rng-ctcs-x ...
- #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
- #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
- (λ (f neg-party)
- (define blame+neg-party (cons blame neg-party))
- (put-it-together
- #,(let ([case-lam (syntax/loc stx
- (case-lambda [formals body] ...))])
- (if name
- #`(let ([#,name #,case-lam]) #,name)
- case-lam))
- f blame neg-party blame+neg-party blame-party-info wrapper ctc
- chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))]))
+ (parse-out-case stx #'neg-party #'blame-party-info x n mctc?))])
+ #`(build-case->
+ (list (list dom-ctc-expr ...) ...)
+ (list rst-ctc-expr ...)
+ (list rng-ctc-exprs ...)
+ '(spec ...)
+ #,mctc?
+ (λ (chk
+ wrapper
+ blame
+ blame-party-info
+ ctc
+ rng-ctcs-x ...
+ #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
+ #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
+ (λ (f neg-party)
+ (define blame+neg-party (cons blame neg-party))
+ (put-it-together
+ #,(let ([case-lam (syntax/loc stx
+ (case-lambda [formals body] ...))])
+ (if name
+ #`(let ([#,name #,case-lam]) #,name)
+ case-lam))
+ f blame neg-party blame+neg-party blame-party-info wrapper ctc
+ chk #,mctc?))))))]))
(define (put-it-together the-case-lam f blame neg-party blame+neg-party blame-party-info wrapper ctc chk mtd?)
(chk f mtd?)
@@ -183,7 +189,7 @@
;; rng-ctcs : (listof (listof contract))
;; specs : (listof (list boolean exact-positive-integer))
;; indicates the required arities of the input functions
-;; mctc? : was created with case->m
+;; mctc? : was created with case->m or object-contract
;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?))
;; generates a wrapper from projections
(define-struct base-case-> (dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper))
@@ -246,10 +252,11 @@
ctc
projs))))
-(define (case->-name ctc)
+;; Re `print-as-method-if-method?`: See comment before `base->-name` in arrow-val-first.rkt
+(define ((case->-name print-as-method-if-method?) ctc)
(apply
build-compound-type-name
- (if (base-case->-mctc? ctc) 'case->m 'case->)
+ (if (and (base-case->-mctc? ctc) print-as-method-if-method?) 'case->m 'case->)
(map (λ (dom rst range)
(apply
build-compound-type-name
@@ -277,7 +284,7 @@
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:late-neg-projection (case->-proj chaperone-procedure)
- #:name case->-name
+ #:name (case->-name #|print-as-method-if-method?|# #t)
#:first-order case->-first-order
#:stronger case->-stronger?))
@@ -286,7 +293,7 @@
#:property prop:contract
(build-contract-property
#:late-neg-projection (case->-proj impersonate-procedure)
- #:name case->-name
+ #:name (case->-name #|print-as-method-if-method?|# #t)
#:first-order case->-first-order
#:stronger case->-stronger?))
diff --git a/racket/collects/racket/contract/private/object.rkt b/racket/collects/racket/contract/private/object.rkt
index 83e87ee1d6..60efbb4195 100644
--- a/racket/collects/racket/contract/private/object.rkt
+++ b/racket/collects/racket/contract/private/object.rkt
@@ -45,9 +45,10 @@
;; similar to `build-compound-type-name`, but handles method contract names
(define (object-contract-sub-name . fs)
(for/list ([sub (in-list fs)])
- (cond [(base->? sub) ((base->-name #|print-as-method-if-method?|# #f) sub)] ; covers -> and ->*
- [(base-->d? sub) ((->d-name #|print-as-method-if-method?|# #f) sub)]
- ;; `->i` and `case->` will naturally print correctly, due to the way they handle methods
+ (cond [(base->? sub) ((base->-name #|print-as-method-if-method?|# #f) sub)] ; covers -> and ->*
+ [(base-->d? sub) ((->d-name #|print-as-method-if-method?|# #f) sub)]
+ [(base-case->? sub) ((case->-name #|print-as-method-if-method?|# #f) sub)]
+ ;; `->i` will naturally print correctly, due to the way it handles methods
[(contract-struct? sub) (contract-struct-name sub)]
[else sub])))
@@ -88,9 +89,7 @@
(map (λ (x) (string->symbol (format "~a method" (syntax-e x))))
(syntax->list #'(method-id ...)))])
#'(build-object-contract '(method-id ...)
- (syntax-parameterize
- ((making-a-method #t))
- (list (let ([method-name (fun->meth method-ctc)]) method-name) ...))
+ (list (let ([method-name (fun->meth method-ctc)]) method-name) ...)
'(field-id ...)
(list field-ctc ...))))]))
(define-syntax (fun->meth stx)
@@ -100,8 +99,8 @@
[(-> . args) #'(->m . args)]
[(->* . args) #'(->*m . args)]
[(->d . args) #'(->dm . args)]
- [(->i . args) #'ctc] ; ->i doesn't reset the `making-a-method` syntax parameter
- [(case-> case ...) #'ctc])])) ; neither does case->
+ [(case-> case ...) #'(case->m case ...)]
+ [(->i . args) (->i-internal #'ctc #|method?|# #t)])])) ; there's no ->im. could be, though, code is there
(define (build-object-contract methods method-ctcs fields field-ctcs)
(make-object-contract methods
diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt
index 7ff85f4129..30d6802023 100644
--- a/racket/collects/racket/private/class-c-old.rkt
+++ b/racket/collects/racket/private/class-c-old.rkt
@@ -8,8 +8,9 @@
"class-internal.rkt"
"../contract/base.rkt"
"../contract/combinator.rkt"
- (only-in "../contract/private/arrow-common.rkt" making-a-method method-contract?)
- (only-in "../contract/private/arrow-val-first.rkt" ->-internal ->*-internal))
+ (only-in "../contract/private/arrow-val-first.rkt" ->-internal ->*-internal)
+ (only-in "../contract/private/case-arrow.rkt" case->-internal)
+ (only-in "../contract/private/arr-d.rkt" ->d-internal))
(provide make-class/c class/c-late-neg-proj
blame-add-method-context blame-add-field-context blame-add-init-context
@@ -25,17 +26,29 @@
;; Shorthand contracts that treat the implicit object argument as if it were
;; contracted with any/c.
-(define-syntax-rule (->m . stx)
- (syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->-internal ->m . stx)))
+(define-syntax (->m stx)
+ (syntax-case stx ()
+ [(_ . args)
+ (->-internal (syntax/loc stx (->m . args))
+ #|method?|# #t)]))
-(define-syntax-rule (->*m . stx)
- (syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->*-internal ->*m . stx)))
+(define-syntax (->*m stx)
+ (syntax-case stx ()
+ [(_ . args)
+ (->*-internal (syntax/loc stx (->*m . args))
+ #|method?|# #t)]))
-(define-syntax-rule (case->m . stx)
- (syntax-parameterize ([making-a-method #t] [method-contract? #t]) (case-> . stx)))
+(define-syntax (case->m stx)
+ (syntax-case stx ()
+ [(_ . args)
+ (case->-internal (syntax/loc stx (case->m . args))
+ #|method?|# #t)]))
-(define-syntax-rule (->dm . stx)
- (syntax-parameterize ([making-a-method #'this-param] [method-contract? #t]) (->d . stx)))
+(define-syntax (->dm stx)
+ (syntax-case stx ()
+ [(_ . args)
+ (->d-internal (syntax/loc stx (->dm . args))
+ #|maybe-this-param|# #'#'this-param)]))
(define (class/c-check-first-order ctc cls fail)
(define opaque? (class/c-opaque? ctc))