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

add #:pre/desc to ->*

Browse Source
This commit is contained in:
Robby Findler 2014-12-22 14:48:44 -06:00
parent 3d48ef78f6
commit 9d58a067e3
5 changed files with 224 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -976,9 +976,13 @@ each value must match its respective contract.}
[optional-doms (code:line) (optional-dom ...)] [optional-doms (code:line) (optional-dom ...)]
[optional-dom dom-expr (code:line keyword dom-expr)] [optional-dom dom-expr (code:line keyword dom-expr)]
[rest (code:line) (code:line #:rest rest-expr)] [rest (code:line) (code:line #:rest rest-expr)]
[pre (code:line) (code:line #:pre pre-cond-expr)] [pre (code:line)
(code:line #:pre pre-cond-expr)
(code:line #:pre/desc pre-cond-expr)]
[range range-expr (values range-expr ...) any] [range range-expr (values range-expr ...) any]
[post (code:line) (code:line #:post post-cond-expr)])]{ [post (code:line)
(code:line #:post post-cond-expr)
(code:line #:post/desc post-cond-expr)])]{
The @racket[->*] contract combinator produces contracts for functions The @racket[->*] contract combinator produces contracts for functions
that accept optional arguments (either keyword or positional) and/or that accept optional arguments (either keyword or positional) and/or
@ -1005,14 +1009,24 @@ going to end up disallowing empty argument lists.
The @racket[pre-cond-expr] and @racket[post-cond-expr] The @racket[pre-cond-expr] and @racket[post-cond-expr]
expressions are checked as the function is called and returns, expressions are checked as the function is called and returns,
respectively, and allow checking of the environment without an respectively, and allow checking of the environment without an
explicit connection to an argument (or a result). explicit connection to an argument (or a result). If the @racket[#:pre]
or @racket[#:post] keywords are used, then a @racket[#f] result is
treated as a failure and any other result is treated as success.
If the @racket[#:pre/desc] or @racket[#:post/desc] keyword is used,
the result of the expression must be either a boolean, a string, or a
list of strings, where @racket[#t] means success and any of the other
results mean failure. If the result is a string or a list of strings,
the strings are expected to have at exactly one space after each
newline and multiple are used as lines in the error message; the contract
itself adds single space of indentation to each of the strings in that case.
The formatting requirements are not checked but they
match the recommendations in @secref["err-msg-conventions"].
As an example, the contract As an example, the contract
@racketblock[(->* () (boolean? #:x integer?) #:rest (listof symbol?) symbol?)] @racketblock[(->* () (boolean? #:x integer?) #:rest (listof symbol?) symbol?)]
matches functions that optionally accept a boolean, an matches functions that optionally accept a boolean, an
integer keyword argument @racket[#:x] and arbitrarily more integer keyword argument @racket[#:x] and arbitrarily more
symbols, and that return a symbol. symbols, and that return a symbol.
} }
@defform*/subs[#:literals (any values) @defform*/subs[#:literals (any values)

79
pkgs/racket-test/tests/racket/contract/arrow-star.rkt
View File

@ -14,6 +14,7 @@
(values (flat-contract integer?) (flat-contract boolean?)))) (values (flat-contract integer?) (flat-contract boolean?))))
(test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) any)) (test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) any))
(test/no-error '(->* ((flat-contract integer?)) () #:pre #t (flat-contract integer?) #:post #t)) (test/no-error '(->* ((flat-contract integer?)) () #:pre #t (flat-contract integer?) #:post #t))
(test/no-error '(->* (any/c) () #:pre/desc #t (flat-contract integer?) #:post/desc #t))
@ -602,6 +603,84 @@
'pos 'pos
'neg))) 'neg)))
(test/neg-blame
'->*pre/post-8
'((contract (->* () () #:pre/desc #f integer? #:post/desc #f)
(λ () 1)
'pos
'neg)))
(test/neg-blame
'->*pre/post-9
'((contract (->* () () #:pre/desc "" integer? #:post/desc #f)
(λ () 1)
'pos
'neg)))
(test/neg-blame
'->*pre/post-10
'((contract (->* () () #:pre/desc '("qqq") integer? #:post/desc #f)
(λ () 1)
'pos
'neg)))
(test/pos-blame
'->*pre/post-11
'((contract (->* () () #:pre/desc #t integer? #:post/desc #f)
(λ () 1)
'pos
'neg)))
(test/pos-blame
'->*pre/post-12
'((contract (->* () () #:pre/desc #t integer? #:post/desc "")
(λ () 1)
'pos
'neg)))
(test/pos-blame
'->*pre/post-13
'((contract (->* () () #:pre/desc #t integer? #:post/desc '("qqc"))
(λ () 1)
'pos
'neg)))
(test/pos-blame
'->*pre/post-14
'((contract (->* () () #:pre/desc #t integer? #:post/desc '("qqc"))
(λ () 1)
'pos
'neg)))
(test/neg-blame
'->*pre/post-15
'((contract (->* (integer?) #:pre/desc '("something" "not so great" "happened") any)
(λ (x) 1)
'pos 'neg)
1))
(contract-error-test
'->*pre/post-16
'((contract (->* () () #:pre/desc '("something wonderful") integer? #:post/desc '("qqc"))
(λ () 1)
'pos
'neg))
(λ (x)
(and (exn:fail:contract? x)
(regexp-match #rx"\n *something wonderful\n"
(exn-message x)))))
(contract-error-test
'->*pre/post-17
'((contract (->* () () integer? #:post/desc "something horrible")
(λ () 1)
'pos
'neg))
(λ (x)
(and (exn:fail:contract? x)
(regexp-match #rx"\n *something horrible\n"
(exn-message x)))))
(test/spec-passed (test/spec-passed
'->*-opt-optional1 '->*-opt-optional1
'((contract (->* () integer?) (lambda () 1) 'pos 'neg))) '((contract (->* () integer?) (lambda () 1) 'pos 'neg)))

73
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -12,17 +12,19 @@
(prefix-in arrow: "arrow.rkt")) (prefix-in arrow: "arrow.rkt"))
(provide (for-syntax build-chaperone-constructor/real) (provide (for-syntax build-chaperone-constructor/real)
->-proj) ->-proj
check-pre-cond
check-post-cond)
(define-for-syntax (build-chaperone-constructor/real this-args (define-for-syntax (build-chaperone-constructor/real this-args
mandatory-dom-projs mandatory-dom-projs
optional-dom-projs optional-dom-projs
mandatory-dom-kwds mandatory-dom-kwds
optional-dom-kwds optional-dom-kwds
pre pre pre/desc
rest rest
rngs rngs
post) post post/desc)
(define (nvars n sym) (generate-temporaries (for/list ([i (in-range n)]) sym))) (define (nvars n sym) (generate-temporaries (for/list ([i (in-range n)]) sym)))
(with-syntax ([(mandatory-dom-proj ...) (generate-temporaries mandatory-dom-projs)] (with-syntax ([(mandatory-dom-proj ...) (generate-temporaries mandatory-dom-projs)]
[(optional-dom-proj ...) (generate-temporaries optional-dom-projs)] [(optional-dom-proj ...) (generate-temporaries optional-dom-projs)]
@ -48,10 +50,11 @@
(map list (map list
optional-dom-kwds optional-dom-kwds
(syntax->list #'(optional-dom-kwd-proj ...))) (syntax->list #'(optional-dom-kwd-proj ...)))
pre pre pre/desc
(if rest (car (syntax->list #'(rest-proj ...))) #f) (if rest (car (syntax->list #'(rest-proj ...))) #f)
(if rngs (syntax->list #'(rng-proj ...)) #f) (if rngs (syntax->list #'(rng-proj ...)) #f)
post)))) post post/desc))))
(define (check-pre-cond pre blame neg-party val) (define (check-pre-cond pre blame neg-party val)
(unless (pre) (unless (pre)
@ -65,24 +68,68 @@
#:missing-party neg-party #:missing-party neg-party
val "#:post condition"))) val "#:post condition")))
(define (check-pre-cond/desc post blame neg-party val)
(handle-pre-post/desc-string #t post blame neg-party val))
(define (check-post-cond/desc post blame neg-party val)
(handle-pre-post/desc-string #f post blame neg-party val))
(define (handle-pre-post/desc-string pre? thunk blame neg-party val)
(define condition-result (thunk))
(cond
[(equal? condition-result #t)
(void)]
[else
(define msg
(cond
[(equal? condition-result #f)
(if pre?
"#:pre condition"
"#:post condition")]
[(string? condition-result) condition-result]
[(and (list? condition-result)
(andmap string? condition-result))
(apply
string-append
(let loop ([s condition-result])
(cond
[(null? s) '()]
[(null? (cdr s)) s]
[else (list* (car s)
"\n "
(loop (cdr s)))])))]
[else
(error
'->*
"expected #:~a/desc to produce (or/c boolean? string? (listof string?)), got ~e"
(if pre? "pre" "post")
condition-result)]))
(raise-blame-error (if pre? (blame-swap blame) blame)
#:missing-party neg-party
val "~a" msg)]))
(define-for-syntax (create-chaperone blame val (define-for-syntax (create-chaperone blame val
this-args this-args
doms opt-doms doms opt-doms
req-kwds opt-kwds req-kwds opt-kwds
pre pre pre/desc
dom-rest dom-rest
rngs rngs
post) post post/desc)
(with-syntax ([blame blame] (with-syntax ([blame blame]
[val val]) [val val])
(with-syntax ([(pre ...) (with-syntax ([(pre ...)
(if pre (cond
(list #`(check-pre-cond #,pre blame neg-party val)) [pre
null)] (list #`(check-pre-cond #,pre blame neg-party val))]
[pre/desc
(list #`(check-pre-cond/desc #,pre/desc blame neg-party val))]
[else null])]
[(post ...) [(post ...)
(if post (cond
(list #`(check-post-cond #,post blame neg-party val)) [post
null)]) (list #`(check-post-cond #,post blame neg-party val))]
[post/desc
(list #`(check-post-cond/desc #,post/desc blame neg-party val))]
[else null])])
(with-syntax ([(this-param ...) this-args] (with-syntax ([(this-param ...) this-args]
[(dom-ctc ...) doms] [(dom-ctc ...) doms]
[(dom-x ...) (generate-temporaries doms)] [(dom-x ...) (generate-temporaries doms)]

67
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -73,12 +73,12 @@
optional-args optional-args
mandatory-kwds mandatory-kwds
optional-kwds optional-kwds
pre pre pre/desc
rest rest
rngs rngs
post) post post/desc)
(define key (and (not pre) (define key (and (not pre) (not pre/desc)
(not post) (not post) (not post/desc)
(list (length regular-args) (list (length regular-args)
(length optional-args) (length optional-args)
(map syntax-e mandatory-kwds) (map syntax-e mandatory-kwds)
@ -100,20 +100,20 @@
optional-args optional-args
mandatory-kwds mandatory-kwds
optional-kwds optional-kwds
pre pre pre/desc
rest rest
rngs rngs
post) post post/desc)
(build-chaperone-constructor/real (build-chaperone-constructor/real
'() ;; this-args '() ;; this-args
regular-args regular-args
optional-args optional-args
mandatory-kwds mandatory-kwds
optional-kwds optional-kwds
pre pre pre/desc
rest rest
rngs rngs
post))])) post post/desc))]))
(define-syntax (build-populars stx) (define-syntax (build-populars stx)
(syntax-case stx () (syntax-case stx ()
@ -142,20 +142,20 @@
mans opts mans opts
mandatory-kwds mandatory-kwds
optional-kwds optional-kwds
#f #f #f
rest rest
rng-vars rng-vars
#f)) #f #f))
(define #,(syntax-local-introduce chaperone-id) (define #,(syntax-local-introduce chaperone-id)
#,(build-chaperone-constructor/real #,(build-chaperone-constructor/real
'() ;; this arg '() ;; this arg
mans opts mans opts
mandatory-kwds mandatory-kwds
optional-kwds optional-kwds
#f #f #f
rest rest
rng-vars rng-vars
#f)))) #f #f))))
(define popular-chaperone-key-table (define popular-chaperone-key-table
(make-hash (make-hash
(list #,@(for/list ([id (in-list popular-key-ids)] (list #,@(for/list ([id (in-list popular-key-ids)]
@ -167,10 +167,10 @@
optional-args optional-args
mandatory-kwds mandatory-kwds
optional-kwds optional-kwds
pre pre pre/desc
rest rest
rngs rngs
post) post post/desc)
(with-syntax ([(regb ...) (generate-temporaries regular-args)] (with-syntax ([(regb ...) (generate-temporaries regular-args)]
[(optb ...) (generate-temporaries optional-args)] [(optb ...) (generate-temporaries optional-args)]
[(kb ...) (generate-temporaries mandatory-kwds)] [(kb ...) (generate-temporaries mandatory-kwds)]
@ -194,11 +194,11 @@
[(the-call ...) #'(f ((regb arg-x) neg-party) ... kwd-arg-exps ...)] [(the-call ...) #'(f ((regb arg-x) neg-party) ... kwd-arg-exps ...)]
[(pre-check ...) [(pre-check ...)
(if pre (if pre
(list #`(check-pre-condition blame neg-party f #,pre)) (list #`(check-pre-cond #,pre blame neg-party f))
(list))] (list))]
[(post-check ...) [(post-check ...)
(if post (if post
(list #`(check-post-condition blame neg-party f #,post)) (list #`(check-post-cond #,post blame neg-party f))
(list))] (list))]
[(restb) (generate-temporaries '(rest-args))]) [(restb) (generate-temporaries '(rest-args))])
(define body-proc (define body-proc
@ -412,19 +412,6 @@
[(keyword<? opt-kwd kwd) [(keyword<? opt-kwd kwd)
(loop mandatory-kwds (cdr optional-kwds) kwds)])])]))) (loop mandatory-kwds (cdr optional-kwds) kwds)])])])))
(define (check-pre-condition blame neg-party val thunk)
(unless (thunk)
(raise-blame-error
(blame-swap blame) #:missing-party neg-party val
"#:pre condition failure")))
(define (check-post-condition blame neg-party val thunk)
(unless (thunk)
(raise-blame-error
blame #:missing-party neg-party val
"#:post condition failure")))
(define-for-syntax (parse-arrow-args stx args this->) (define-for-syntax (parse-arrow-args stx args this->)
(let loop ([args args] (let loop ([args args]
[regular-args '()] [regular-args '()]
@ -501,7 +488,7 @@
[rng (add-pos-obligations (list #'rng))])) [rng (add-pos-obligations (list #'rng))]))
(define-values (plus-one-arity-function chaperone-constructor) (define-values (plus-one-arity-function chaperone-constructor)
(build-plus-one-arity-function+chaperone-constructor (build-plus-one-arity-function+chaperone-constructor
stx regular-args '() kwds '() #f #f rngs #f)) stx regular-args '() kwds '() #f #f #f rngs #f #f))
(syntax-property (syntax-property
#`(let #,let-bindings #`(let #,let-bindings
#,(quasisyntax/loc stx #,(quasisyntax/loc stx
@ -568,7 +555,7 @@
(syntax-case stx () (syntax-case stx ()
[(_ (raw-mandatory-dom ...) . other) [(_ (raw-mandatory-dom ...) . other)
(let () (let ()
(define-values (raw-optional-doms rest-ctc pre rng-ctcs post) (define-values (raw-optional-doms rest-ctc pre pre/desc rng-ctcs post post/desc)
(arrow:parse-leftover->* stx #'other)) (arrow:parse-leftover->* stx #'other))
(with-syntax ([(man-dom (with-syntax ([(man-dom
man-dom-kwds man-dom-kwds
@ -585,13 +572,13 @@
#'opt-dom #'opt-dom
#'opt-dom-kwds #'opt-dom-kwds
#'opt-lets #'opt-lets
rest-ctc pre rng-ctcs post)))])) rest-ctc pre pre/desc rng-ctcs post post/desc)))]))
(define-for-syntax (->*-valid-app-shapes stx) (define-for-syntax (->*-valid-app-shapes stx)
(define this->* (gensym 'this->*)) (define this->* (gensym 'this->*))
(define-values (man-dom man-dom-kwds man-lets (define-values (man-dom man-dom-kwds man-lets
opt-dom opt-dom-kwds opt-lets opt-dom opt-dom-kwds opt-lets
rest-ctc pre rng-ctcs post) rest-ctc pre pre/desc rng-ctcs post post/desc)
(parse->*2 stx this->*)) (parse->*2 stx this->*))
(with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds] (with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
[((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds]) [((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds])
@ -607,7 +594,7 @@
(define this->* (gensym 'this->*)) (define this->* (gensym 'this->*))
(define-values (man-dom man-dom-kwds man-lets (define-values (man-dom man-dom-kwds man-lets
opt-dom opt-dom-kwds opt-lets opt-dom opt-dom-kwds opt-lets
rest-ctc pre rng-ctcs post) rest-ctc pre pre/desc rng-ctcs post post/desc)
(parse->*2 stx this->*)) (parse->*2 stx this->*))
(with-syntax ([(mandatory-dom ...) man-dom] (with-syntax ([(mandatory-dom ...) man-dom]
[((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds] [((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
@ -618,11 +605,11 @@
[(pre-x post-x) (generate-temporaries '(pre-cond post-cond))]) [(pre-x post-x) (generate-temporaries '(pre-cond post-cond))])
(with-syntax ([((kwd dom opt?) ...) #'((mandatory-dom-kwd mandatory-dom-kwd-ctc #f) ... (with-syntax ([((kwd dom opt?) ...) #'((mandatory-dom-kwd mandatory-dom-kwd-ctc #f) ...
(optional-dom-kwd optional-dom-kwd-ctc #t) ...)] (optional-dom-kwd optional-dom-kwd-ctc #t) ...)]
[(pre-let-binding ...) (if pre [(pre-let-binding ...) (if (or pre pre/desc)
(list #`[pre-x (λ () #,pre)]) (list #`[pre-x (λ () #,(or pre pre/desc))])
(list))] (list))]
[(post-let-binding ...) (if post [(post-let-binding ...) (if (or post post/desc)
(list #`[post-x (λ () #,post)]) (list #`[post-x (λ () #,(or post post/desc))])
(list))]) (list))])
(define-values (plus-one-arity-function chaperone-constructor) (define-values (plus-one-arity-function chaperone-constructor)
(build-plus-one-arity-function+chaperone-constructor (build-plus-one-arity-function+chaperone-constructor
@ -632,9 +619,11 @@
(syntax->list #'(mandatory-dom-kwd ...)) (syntax->list #'(mandatory-dom-kwd ...))
(syntax->list #'(optional-dom-kwd ...)) (syntax->list #'(optional-dom-kwd ...))
(and pre #'pre-x) (and pre #'pre-x)
(and pre/desc #'pre-x)
rest-ctc rest-ctc
rng-ctcs rng-ctcs
(and post #'post-x))) (and post #'post-x)
(and post/desc #'post-x)))
(syntax-property (syntax-property
#`(let (mandatory-let-bindings ... #`(let (mandatory-let-bindings ...
optional-let-bindings ... optional-let-bindings ...

46
racket/collects/racket/contract/private/arrow.rkt
View File

@ -836,6 +836,8 @@
(values #'() leftover)] (values #'() leftover)]
[(rng #:post . rst) [(rng #:post . rst)
(values #'() leftover)] (values #'() leftover)]
[(rng #:post/desc . rst)
(values #'() leftover)]
[(rng) [(rng)
(values #'() leftover)] (values #'() leftover)]
[((raw-optional-dom ...) . leftover) [((raw-optional-dom ...) . leftover)
@ -847,11 +849,13 @@
[(#:rest rest-expr . leftover) [(#:rest rest-expr . leftover)
(values #'rest-expr #'leftover)] (values #'rest-expr #'leftover)]
[_ (values #f leftover)])] [_ (values #f leftover)])]
[(pre leftover) [(pre pre/desc leftover)
(syntax-case leftover () (syntax-case leftover ()
[(#:pre pre-expr . leftover) [(#:pre pre-expr . leftover)
(values #'pre-expr #'leftover)] (values #'pre-expr #f #'leftover)]
[_ (values #f leftover)])] [(#:pre/desc pre-expr . leftover)
(values #f #'pre-expr #'leftover)]
[_ (values #f #f leftover)])]
[(rng leftover) [(rng leftover)
(syntax-case leftover (any values) (syntax-case leftover (any values)
[(any) (values #f #'())] [(any) (values #f #'())]
@ -865,22 +869,33 @@
(values #'(rng) #'leftover))] (values #'(rng) #'leftover))]
[_ [_
(raise-syntax-error #f "expected a range contract" stx leftover)])] (raise-syntax-error #f "expected a range contract" stx leftover)])]
[(post leftover) [(post post/desc leftover)
(syntax-case leftover () (syntax-case leftover ()
[(#:post post-expr . leftover) [(#:post post-expr . leftover)
(values #'post-expr #'leftover)] (values #'post-expr #f #'leftover)]
[(#:post/desc post-expr . leftover)
(values #f #'post-expr #'leftover)]
[else [else
(values #f leftover)])]) (values #f #f leftover)])])
(syntax-case leftover () (syntax-case leftover ()
[() (values raw-optional-doms rst pre rng post)] [() (values raw-optional-doms rst pre pre/desc rng post post/desc)]
[x (raise-syntax-error #f "expected the end of the contract" stx #'x)]))) [x (raise-syntax-error #f "expected the end of the contract" stx #'x)])))
;; ->*/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) ;; ->*/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define-for-syntax (->*/proc/main stx) (define-for-syntax (->*/proc/main stx)
(syntax-case* stx (->* any) module-or-top-identifier=? (syntax-case* stx (->* any) module-or-top-identifier=?
[(->* (raw-mandatory-dom ...) . rst) [(->* (raw-mandatory-dom ...) . rst)
(let-values ([(raw-optional-doms rest-ctc pre rng-ctc post) (let-values ([(raw-optional-doms rest-ctc raw-pre pre/desc rng-ctc raw-post post/desc)
(parse-leftover->* stx #'rst)]) (parse-leftover->* stx #'rst)])
(define pre (cond
[raw-pre raw-pre]
[pre/desc
#`(convert-pre-post/desc-to-boolean #t #,pre/desc)]
[else #f]))
(define post (cond
[raw-post raw-post]
[post/desc #`(convert-pre-post/desc-to-boolean #f #,post/desc)]
[else #f]))
(with-syntax ([((mandatory-dom ...) ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...)) (with-syntax ([((mandatory-dom ...) ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...))
(split-doms stx '->* #'(raw-mandatory-dom ...))] (split-doms stx '->* #'(raw-mandatory-dom ...))]
[((optional-dom ...) ((optional-dom-kwd optional-dom-kwd-ctc) ...)) [((optional-dom ...) ((optional-dom-kwd optional-dom-kwd-ctc) ...))
@ -962,6 +977,21 @@
(syntax->list #'(optional-dom-kwd-proj ...))) (syntax->list #'(optional-dom-kwd-proj ...)))
(if rng-ctc (syntax->list #'(rng-proj ...)) #f)))))))))))])) (if rng-ctc (syntax->list #'(rng-proj ...)) #f)))))))))))]))
(define (convert-pre-post/desc-to-boolean pre? b)
(cond
[(not b) #f]
[(or (not b)
(string? b)
(and (list? b)
(andmap string? b)))
#f]
[(equal? b #t) #t]
[else
(error '->* "expected #:~a to return (or/c boolean? string? (listof string?)), got ~e"
(if pre? "pre" "post")
b)]))
(define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx))) (define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx)))