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

fall back to the slow path when application expression looks wrong

Browse Source 
closes PR 14279
This commit is contained in:
Robby Findler 2014-01-12 23:14:50 -06:00
parent 04628e3516
commit 4d123bb26d
7 changed files with 333 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
pkgs/racket-pkgs/racket-test/tests/racket/contract-helpers.rkt
View File

@ -1,6 +1,11 @@
#lang racket #lang racket
(require rackunit (require rackunit
racket/contract/private/arrow) racket/contract/private/arrow
(for-template racket/contract/private/arrow-val-first)
racket/contract/private/application-arity-checking
racket/contract/private/arr-i-parse)
(check-equal? (matches-arity-exactly? (λ () 1) 0 0 '() '()) #t) (check-equal? (matches-arity-exactly? (λ () 1) 0 0 '() '()) #t)
(check-equal? (matches-arity-exactly? (λ () 1) 1 1 '() '()) #f) (check-equal? (matches-arity-exactly? (λ () 1) 1 1 '() '()) #f)
(check-equal? (matches-arity-exactly? (λ () 1) 0 1 '() '()) #f) (check-equal? (matches-arity-exactly? (λ () 1) 0 1 '() '()) #f)
@ -65,3 +70,41 @@
(check-equal? (matches-arity-exactly? (lambda (x #:y y #:z [z 1]) y) (check-equal? (matches-arity-exactly? (lambda (x #:y y #:z [z 1]) y)
1 1 '() '(#:y #:z)) 1 1 '() '(#:y #:z))
#f) #f)
(check-equal? (->-valid-app-shapes #'(-> integer? integer?))
(valid-app-shapes '(1) '() '()))
(check-equal? (->-valid-app-shapes #'(-> integer? boolean? integer?))
(valid-app-shapes '(2) '() '()))
(check-equal? (->-valid-app-shapes #'(-> integer? #:x any/c integer?))
(valid-app-shapes '(1) '(#:x) '()))
(check-equal? (->-valid-app-shapes #'(-> integer? #:x any/c #:y any/c integer?))
(valid-app-shapes '(1) '(#:x #:y) '()))
(check-equal? (->*-valid-app-shapes #'(->* (integer? #:x any/c #:y any/c) integer?))
(valid-app-shapes '(1) '(#:x #:y) '()))
(check-equal? (->*-valid-app-shapes #'(->* () (integer? #:x any/c #:y any/c) integer?))
(valid-app-shapes '(0 1) '() '(#:x #:y)))
(check-equal? (->*-valid-app-shapes #'(->* (any/c) (any/c) #:rest any/c integer?))
(valid-app-shapes '(1 2 . 3) '() '()))
(check-equal? (->i-valid-app-shapes #'(->i () () [r any/c]))
(valid-app-shapes '(0) '() '()))
(check-equal? (->*-valid-app-shapes #'(->i ([p integer?] #:x [x any/c] #:y [y any/c]) [r any/c]))
(valid-app-shapes '(1) '(#:x #:y) '()))
(check-equal? (->*-valid-app-shapes #'(->i () ([p integer?] #:x [x any/c] #:y [y any/c]) [r any/c]))
(valid-app-shapes '(0 1) '() '(#:x #:y)))
(check-equal? (->*-valid-app-shapes #'(->i ([m any/c]) ([o any/c]) #:rest [r any/c] [r any/c]))
(valid-app-shapes '(1 2 . 3) '() '()))
(check-true (valid-argument-list? #'(f x) (valid-app-shapes '(1 2 . 3) '() '())))
(check-true (valid-argument-list? #'(f x y) (valid-app-shapes '(1 2 . 3) '() '())))
(check-true (valid-argument-list? #'(f x y a b c d) (valid-app-shapes '(1 2 . 3) '() '())))
(check-false (valid-argument-list? #'(f) (valid-app-shapes '(1 2 . 3) '() '()) #f))
(check-true (valid-argument-list? #'(f #:x x) (valid-app-shapes '(0) '(#:x) '())))
(check-true (valid-argument-list? #'(f #:x x) (valid-app-shapes '(0) '() '(#:x))))
(check-true (valid-argument-list? #'(f) (valid-app-shapes '(0) '() '(#:x))))
(check-false (valid-argument-list? #'(f) (valid-app-shapes '(0) '(#:x) '()) #f))
(check-false (valid-argument-list? #'(f #:y y) (valid-app-shapes '(0) '(#:x) '()) #f))
(check-false (valid-argument-list? #'(f #:x) (valid-app-shapes '(0) '(#:x) '()) #f))

21
pkgs/racket-pkgs/racket-test/tests/racket/contract/contract-out.rkt
View File

@ -938,6 +938,27 @@
(eval '(require 'provide/contract48-m1))) (eval '(require 'provide/contract48-m1)))
"provide/contract48-m1") "provide/contract48-m1")
;; test to make sure that arity errors have the
;; right name at the beginning of the message
(test/spec-passed/result
'provide/contract49
'(let ()
(eval '(module provide/contract49-m1 racket/base
(require racket/contract/base)
(define (f x) x)
(provide (contract-out [f (-> any/c any)]))))
(eval '(module provide/contract49-m2 racket/base
(require 'provide/contract48-m1)
(f 1 2)))
(with-handlers ([exn:fail? (λ (x)
(define m (regexp-match #rx"([^:]*:)" (exn-message x)))
(if m
(cadr m)
(list "regexp failed to match"
(exn-message x))))])
(eval '(require 'provide/contract49-m2))))
"f:")
(contract-error-test (contract-error-test
'contract-error-test8 'contract-error-test8
#'(begin #'(begin

72
racket/collects/racket/contract/private/application-arity-checking.rkt Normal file
View File

@ -0,0 +1,72 @@
#lang racket/base
#|
Used to check an application site of a well-known
contract function to see if the shape is okay.
That is, each contract builds a valid-app-shapes struct
describing what application expression shapes are okay
and valid-argument-list? checks an application against
a valid-app-shape.
|#
(provide (struct-out valid-app-shapes)
valid-argument-list?)
;; valid-arities : (or/c (listof nat) (improper-listof nat))
;; -- if improper, then the last nat indicates that any number
;; of args equal to or later than that last nat are okay
;; mandatory-kwds : (listof keyword?)
;; optional-kwds : (or/c (listof keyword?) 'any)
;; 'any indicates that any keyword is allowed
(struct valid-app-shapes (valid-arities mandatory-kwds optional-kwds)
#:prefab)
(define (valid-argument-list? app-stx the-valid-app-shape [log-problems? #t])
(cond
[the-valid-app-shape
(define-values (kwds arg-count)
(let loop ([stx (syntax-case app-stx ()
[(function . args) #'args])]
[kwds '()]
[arg-count 0])
(syntax-case stx ()
[(kwd kwd-arg . rest)
(keyword? (syntax-e #'kwd))
(loop #'rest (cons (syntax-e #'kwd) kwds) arg-count)]
[(arg . rest)
(loop #'rest kwds (+ arg-count 1))]
[()
(values kwds arg-count)])))
(define good-arg-count?
(let loop ([allowed-counts (valid-app-shapes-valid-arities the-valid-app-shape)])
(cond
[(null? allowed-counts) #f]
[(number? allowed-counts) (arg-count . >= . allowed-counts)]
[else (or (= arg-count (car allowed-counts))
(loop (cdr allowed-counts)))])))
(define ans?
(and good-arg-count?
(for/and ([kwd (in-list (valid-app-shapes-mandatory-kwds the-valid-app-shape))])
(member kwd kwds))
(for/and ([kwd (in-list kwds)])
(or (member kwd (valid-app-shapes-mandatory-kwds the-valid-app-shape))
(member kwd (valid-app-shapes-optional-kwds the-valid-app-shape))))
#t))
(when log-problems?
(unless ans?
(log-problem app-stx)))
ans?]
[else #t]))
(define-logger optimizer)
(define (log-problem stx)
(log-optimizer-warning
"warning in ~a:~a:~a: contract system detects procedure incorrectly applied"
(syntax-source stx)
(syntax-line stx)
(syntax-column stx)))

27
racket/collects/racket/contract/private/arr-i-parse.rkt
View File

@ -6,6 +6,8 @@
[make-module-identifier-mapping make-free-identifier-mapping] [make-module-identifier-mapping make-free-identifier-mapping]
[module-identifier-mapping-get free-identifier-mapping-get] [module-identifier-mapping-get free-identifier-mapping-get]
[module-identifier-mapping-put! free-identifier-mapping-put!]) [module-identifier-mapping-put! free-identifier-mapping-put!])
"application-arity-checking.rkt"
"arr-util.rkt"
(for-template racket/base (for-template racket/base
"misc.rkt")) "misc.rkt"))
@ -498,8 +500,33 @@ code does the parsing and validation of the syntax.
[_ [_
(raise-syntax-error #f "bad syntax" stx)]))) (raise-syntax-error #f "bad syntax" stx)])))
(define (->i-valid-app-shapes stx)
(define an-istx (parse-->i stx))
(define mans 0)
(define opts 0)
(define man-kwds '())
(define opt-kwds '())
(for ([arg (in-list (istx-args an-istx))])
(define kwd (arg-kwd arg))
(define opt? (arg-optional? arg))
(cond
[(and kwd opt?)
(set! opt-kwds (cons kwd opt-kwds))]
[(and kwd (not opt?))
(set! man-kwds (cons kwd man-kwds))]
[(and (not kwd) opt?)
(set! opts (+ opts 1))]
[(and (not kwd) (not opt?))
(set! mans (+ mans 1))]))
(valid-app-shapes-from-man/opts mans
opts
(istx-rst an-istx)
man-kwds
opt-kwds))
(provide (provide
parse-->i parse-->i
->i-valid-app-shapes
(struct-out istx) (struct-out istx)
(struct-out arg/res) (struct-out arg/res)
(struct-out arg) (struct-out arg)

20
racket/collects/racket/contract/private/arr-util.rkt
View File

@ -1,7 +1,9 @@
#lang racket/base #lang racket/base
(require "application-arity-checking.rkt")
(provide split-doms (provide split-doms
sort-keywords) sort-keywords
valid-app-shapes-from-man/opts)
;; split-doms : syntax identifier syntax -> syntax ;; split-doms : syntax identifier syntax -> syntax
;; given a sequence of keywords interpersed with other ;; given a sequence of keywords interpersed with other
@ -59,3 +61,19 @@
(cond (cond
[(null? pairs) null] [(null? pairs) null]
[else (insert (car pairs) (loop (cdr pairs)))]))) [else (insert (car pairs) (loop (cdr pairs)))])))
(define (valid-app-shapes-from-man/opts min-arg-length num-of-opts rest? man-kwds opt-kwds)
(define opt+man-dom-lengths
(for/list ([i (in-range (+ num-of-opts 1))])
(+ i min-arg-length)))
(valid-app-shapes (if rest?
(append opt+man-dom-lengths
(+ min-arg-length num-of-opts 1))
opt+man-dom-lengths)
man-kwds
opt-kwds))

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

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base (require (for-syntax racket/base
"application-arity-checking.rkt"
"arr-util.rkt") "arr-util.rkt")
"kwd-info-struct.rkt" "kwd-info-struct.rkt"
"arity-checking.rkt" "arity-checking.rkt"
@ -14,7 +15,9 @@
(provide ->2 ->*2 (provide ->2 ->*2
(for-syntax ->2-handled? (for-syntax ->2-handled?
->*2-handled?)) ->*2-handled?
->-valid-app-shapes
->*-valid-app-shapes))
(define-for-syntax (->2-handled? stx) (define-for-syntax (->2-handled? stx)
(syntax-case stx (any values any/c) (syntax-case stx (any values any/c)
@ -444,6 +447,17 @@
this->)] this->)]
let-bindings))]))]))) let-bindings))]))])))
(define-for-syntax (->-valid-app-shapes stx)
(syntax-case stx ()
[(_ args ...)
(let ()
(define this-> (gensym 'this->))
(define-values (regular-args kwds kwd-args let-bindings)
(parse-arrow-args stx (syntax->list #'(args ...)) this->))
(valid-app-shapes (list (- (length regular-args) 1))
(map syntax->datum kwds)
'()))]))
(define-syntax (->2 stx) (define-syntax (->2 stx)
(syntax-case stx () (syntax-case stx ()
[(_ args ...) [(_ args ...)
@ -521,61 +535,94 @@
kwd-doms kwd-doms
(cons #`[t x] let-bindings)))]))) (cons #`[t x] let-bindings)))])))
(define-for-syntax (parse->*2 stx)
(syntax-case stx ()
[(_ (raw-mandatory-dom ...) . other)
(let ()
(define-values (raw-optional-doms rest-ctc pre rng-ctcs post)
(arrow:parse-leftover->* stx #'other))
(with-syntax ([(man-dom
man-dom-kwds
man-lets)
(:split-doms stx '->* #'(raw-mandatory-dom ...))]
[(opt-dom
opt-dom-kwds
opt-lets)
(:split-doms stx '->* raw-optional-doms)])
(values
#'man-dom
#'man-dom-kwds
#'man-lets
#'opt-dom
#'opt-dom-kwds
#'opt-lets
rest-ctc pre rng-ctcs post)))]))
(define-for-syntax (->*-valid-app-shapes stx)
(define-values (man-dom man-dom-kwds man-lets
opt-dom opt-dom-kwds opt-lets
rest-ctc pre rng-ctcs post)
(parse->*2 stx))
(with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
[((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds])
(valid-app-shapes-from-man/opts (length (syntax->list man-dom))
(length (syntax->list opt-dom))
rest-ctc
(syntax->datum #'(mandatory-dom-kwd ...))
(syntax->datum #'(optional-dom-kwd ...)))))
(define-syntax (->*2 stx) (define-syntax (->*2 stx)
(cond (cond
[(->*2-handled? stx) [(->*2-handled? stx)
(syntax-case stx () (define-values (man-dom man-dom-kwds man-lets
[(_ (raw-mandatory-dom ...) . other) opt-dom opt-dom-kwds opt-lets
(let () rest-ctc pre rng-ctcs post)
(define-values (raw-optional-doms rest-ctc pre rng-ctcs post) (parse->*2 stx))
(arrow:parse-leftover->* stx #'other)) (with-syntax ([(mandatory-dom ...) man-dom]
(with-syntax ([((mandatory-dom ...) [((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) [(mandatory-let-bindings ...) man-lets]
(mandatory-let-bindings ...)) [(optional-dom ...) opt-dom]
(:split-doms stx '->* #'(raw-mandatory-dom ...))] [((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds]
[((optional-dom ...) [(optional-let-bindings ...) opt-lets]
((optional-dom-kwd optional-dom-kwd-ctc) ...) [(pre-x post-x) (generate-temporaries '(pre-cond post-cond))])
(optional-let-bindings ...)) (with-syntax ([((kwd dom opt?) ...) #'((mandatory-dom-kwd mandatory-dom-kwd-ctc #f) ...
(:split-doms stx '->* raw-optional-doms)] (optional-dom-kwd optional-dom-kwd-ctc #t) ...)]
[(pre-x post-x) (generate-temporaries '(pre-cond post-cond))]) [(pre-let-binding ...) (if pre
(with-syntax ([((kwd dom opt?) ...) #'((mandatory-dom-kwd mandatory-dom-kwd-ctc #f) ... (list #`[pre-x (λ () #,pre)])
(optional-dom-kwd optional-dom-kwd-ctc #t) ...)] (list))]
[(pre-let-binding ...) (if pre [(post-let-binding ...) (if post
(list #`[pre-x (λ () #,pre)]) (list #`[post-x (λ () #,post)])
(list))] (list))])
[(post-let-binding ...) (if post (define-values (plus-one-arity-function chaperone-constructor)
(list #`[post-x (λ () #,post)]) (build-plus-one-arity-function+chaperone-constructor
(list))]) stx
(define-values (plus-one-arity-function chaperone-constructor) (syntax->list #'(mandatory-dom ...))
(build-plus-one-arity-function+chaperone-constructor (syntax->list #'(optional-dom ...))
stx (syntax->list #'(mandatory-dom-kwd ...))
(syntax->list #'(mandatory-dom ...)) (syntax->list #'(optional-dom-kwd ...))
(syntax->list #'(optional-dom ...)) (and pre #'pre-x)
(syntax->list #'(mandatory-dom-kwd ...)) rest-ctc
(syntax->list #'(optional-dom-kwd ...)) rng-ctcs
(and pre #'pre-x) (and post #'post-x)))
rest-ctc #`(let (mandatory-let-bindings ...
rng-ctcs optional-let-bindings ...
(and post #'post-x))) pre-let-binding ...
#`(let (mandatory-let-bindings ... post-let-binding ...)
optional-let-bindings ... (build--> '->*
pre-let-binding ... (list mandatory-dom ...)
post-let-binding ...) (list optional-dom ...)
(build--> '->* '(mandatory-dom-kwd ...)
(list mandatory-dom ...) (list mandatory-dom-kwd-ctc ...)
(list optional-dom ...) '(optional-dom-kwd ...)
'(mandatory-dom-kwd ...) (list optional-dom-kwd-ctc ...)
(list mandatory-dom-kwd-ctc ...) #,rest-ctc
'(optional-dom-kwd ...) #,(and pre #t)
(list optional-dom-kwd-ctc ...) #,(if rng-ctcs
#,rest-ctc #`(list #,@rng-ctcs)
#,(and pre #t) #'#f)
#,(if rng-ctcs #,(and post #t)
#`(list #,@rng-ctcs) #,plus-one-arity-function
#'#f) #,chaperone-constructor))))]
#,(and post #t)
#,plus-one-arity-function
#,chaperone-constructor)))))])]
[else [else
(syntax-case stx () (syntax-case stx ()
[(_ args ...) [(_ args ...)

84
racket/collects/racket/contract/private/provide.rkt
View File

@ -13,6 +13,8 @@
racket/list racket/list
racket/struct-info racket/struct-info
setup/path-to-relative setup/path-to-relative
"application-arity-checking.rkt"
"arr-i-parse.rkt"
(prefix-in a: "helpers.rkt") (prefix-in a: "helpers.rkt")
(rename-in syntax/private/boundmap (rename-in syntax/private/boundmap
;; the private version of the library ;; the private version of the library
@ -56,11 +58,13 @@
(struct provide/contract-info (contract-id original-id)) (struct provide/contract-info (contract-id original-id))
(struct provide/contract-arrow-transformer provide/contract-info (struct provide/contract-arrow-transformer provide/contract-info
(saved-id-table (saved-id-table
saved-ho-id-table saved-ho-id-table
partially-applied-id partially-applied-id
extra-neg-party-argument-fn) extra-neg-party-argument-fn
valid-argument-lists)
#:property #:property
prop:set!-transformer prop:set!-transformer
(λ (self stx) (λ (self stx)
@ -68,7 +72,8 @@
[saved-id-table (provide/contract-arrow-transformer-saved-id-table self)] [saved-id-table (provide/contract-arrow-transformer-saved-id-table self)]
[saved-ho-id-table (provide/contract-arrow-transformer-saved-ho-id-table self)] [saved-ho-id-table (provide/contract-arrow-transformer-saved-ho-id-table self)]
[extra-neg-party-argument-fn [extra-neg-party-argument-fn
(provide/contract-arrow-transformer-extra-neg-party-argument-fn self)]) (provide/contract-arrow-transformer-extra-neg-party-argument-fn self)]
[valid-arg-lists (provide/contract-arrow-transformer-valid-argument-lists self)])
(with-syntax ([partially-applied-id partially-applied-id] (with-syntax ([partially-applied-id partially-applied-id]
[extra-neg-party-argument-fn extra-neg-party-argument-fn]) [extra-neg-party-argument-fn extra-neg-party-argument-fn])
(if (eq? 'expression (syntax-local-context)) (if (eq? 'expression (syntax-local-context))
@ -85,34 +90,40 @@
;; Expand to a use of the lifted expression: ;; Expand to a use of the lifted expression:
(define (adjust-location new-stx) (define (adjust-location new-stx)
(datum->syntax new-stx (syntax-e new-stx) stx new-stx)) (datum->syntax new-stx (syntax-e new-stx) stx new-stx))
(with-syntax ([lifted-neg-party (syntax-local-introduce lifted-neg-party)]) (define (gen-slow-path-code)
(syntax-case stx (set!) (define lifted-ctc-val
[name (or (hash-ref saved-ho-id-table key #f)
(identifier? #'name) ;; No: lift the neg name creation
(let ([lifted-ctc-val (with-syntax ([lifted-neg-party (syntax-local-introduce lifted-neg-party)])
(or (hash-ref saved-ho-id-table key #f) (syntax-local-introduce
;; No: lift the neg name creation (syntax-local-lift-expression
(syntax-local-introduce #'(partially-applied-id lifted-neg-party))))))
(syntax-local-lift-expression (when key (hash-set! saved-ho-id-table key lifted-ctc-val))
#'(partially-applied-id lifted-neg-party))))]) (adjust-location (syntax-local-introduce lifted-ctc-val)))
(when key (hash-set! saved-ho-id-table key lifted-ctc-val)) (syntax-case stx (set!)
(adjust-location (syntax-local-introduce lifted-ctc-val)))] [name
[(set! id arg) (identifier? #'name)
(raise-syntax-error (gen-slow-path-code)]
'contract/out [(set! id arg)
"cannot set! a contract/out variable" (raise-syntax-error
stx #'id)] 'contract/out
[(name more ...) "cannot set! a contract/out variable"
(with-syntax ([app (datum->syntax stx '#%app)]) stx #'id)]
(adjust-location [(name more ...)
#'(app extra-neg-party-argument-fn (with-syntax ([app (datum->syntax stx '#%app)])
lifted-neg-party (if (valid-argument-list? stx valid-arg-lists)
more ...)))]))) (with-syntax ([lifted-neg-party (syntax-local-introduce lifted-neg-party)])
(adjust-location
#'(app extra-neg-party-argument-fn
lifted-neg-party
more ...)))
#`(app #,(gen-slow-path-code) more ...)))]))
;; In case of partial expansion for module-level and internal-defn ;; In case of partial expansion for module-level and internal-defn
;; contexts, delay expansion until it's a good time to lift ;; contexts, delay expansion until it's a good time to lift
;; expressions: ;; expressions:
(quasisyntax/loc stx (#%expression #,stx))))))) (quasisyntax/loc stx (#%expression #,stx)))))))
(struct provide/contract-transformer provide/contract-info (saved-id-table partially-applied-id) (struct provide/contract-transformer provide/contract-info (saved-id-table partially-applied-id)
#:property #:property
prop:set!-transformer prop:set!-transformer
@ -167,10 +178,10 @@
#`(app #,id args ...))] #`(app #,id args ...))]
[x (identifier? #'x) id]))))) [x (identifier? #'x) id])))))
(define (make-provide/contract-arrow-transformer contract-id id pai enpfn) (define (make-provide/contract-arrow-transformer contract-id id pai enpfn val)
(provide/contract-arrow-transformer contract-id id (provide/contract-arrow-transformer contract-id id
(make-hasheq) (make-hasheq) (make-hasheq) (make-hasheq)
pai enpfn))) pai enpfn val)))
;; tl-code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax) ;; tl-code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax)
@ -234,12 +245,16 @@
srcloc-expr srcloc-expr
contract-error-name contract-error-name
pos-module-source) pos-module-source)
(define arrow? (define-values (arrow? the-valid-app-shapes)
(syntax-case ctrct (->2 ->*2 ->i) (syntax-case ctrct (->2 ->*2 ->i)
[(->2 . _) (->2-handled? ctrct)] [(->2 . _)
[(->*2 . _) (->*2-handled? ctrct)] (->2-handled? ctrct)
[(->i . _) #t] (values #t (->-valid-app-shapes ctrct))]
[_ #f])) [(->*2 . _)
(values (->*2-handled? ctrct)
(->*-valid-app-shapes ctrct))]
[(->i . _) (values #t (->i-valid-app-shapes ctrct))]
[_ (values #f #f)]))
(with-syntax ([id id] (with-syntax ([id id]
[(partially-applied-id extra-neg-party-argument-fn contract-id) [(partially-applied-id extra-neg-party-argument-fn contract-id)
(generate-temporaries (list 'idX 'idY 'idZ))] (generate-temporaries (list 'idX 'idY 'idZ))]
@ -267,10 +282,11 @@
(define-syntax #,id-rename (define-syntax #,id-rename
#,(if arrow? #,(if arrow?
#'(make-provide/contract-arrow-transformer #`(make-provide/contract-arrow-transformer
(quote-syntax contract-id) (quote-syntax id) (quote-syntax contract-id) (quote-syntax id)
(quote-syntax partially-applied-id) (quote-syntax partially-applied-id)
(quote-syntax extra-neg-party-argument-fn)) (quote-syntax extra-neg-party-argument-fn)
#,the-valid-app-shapes)
#'(make-provide/contract-transformer #'(make-provide/contract-transformer
(quote-syntax contract-id) (quote-syntax id) (quote-syntax contract-id) (quote-syntax id)
#f #f #f #f