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

fix procedure-name inference for keyword procedures

Browse Source 
Closes PR 12111
This commit is contained in:
Matthew Flatt 2011-08-13 08:19:02 -06:00
parent e286898f8b
commit 5be429dc99
2 changed files with 17 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/racket/private/kw.rkt
View File

@ -358,7 +358,7 @@
#f "bad argument sequence" stx (syntax args))]))))
;; The new `lambda' form:
(define-for-syntax (parse-lambda stx non-kw-k kw-k)
(define-for-syntax (parse-lambda stx local-name non-kw-k kw-k)
(syntax-case stx ()
[(_ args body1 body ...)
(if (simple-args? #'args)
@ -531,7 +531,8 @@
(mk-unpack)
(with-syntax ([kws (map car sorted-kws)]
[no-kws (let ([p (mk-no-kws #t)]
[n (syntax-local-infer-name stx)])
[n (or local-name
(syntax-local-infer-name stx))])
(if n
#`(let ([#,n #,p]) #,n)
p))]
@ -555,7 +556,8 @@
[needed-kws needed-kws]
[no-kws (mk-no-kws #t)]
[with-kws (mk-with-kws)]
[mk-id (with-syntax ([n (syntax-local-infer-name stx)]
[mk-id (with-syntax ([n (or local-name
(syntax-local-infer-name stx))]
[call-fail (mk-kw-arity-stub)])
(syntax-local-lift-expression
#'(make-required 'n call-fail method? #F)))])
@ -574,6 +576,7 @@
(if (eq? (syntax-local-context) 'expression)
(parse-lambda
stx
#f
(lambda (e) e)
(lambda (impl kwimpl wrap core-id unpack-id n-req n-opt rest? req-kws all-kws)
(syntax-protect
@ -796,6 +799,7 @@
(or (free-identifier=? #'lam-id #'new-lambda)
(free-identifier=? #'lam-id #'new-λ)))
(parse-lambda rhs
id
plain
(lambda (impl kwimpl wrap
core-id unpack-id

10
collects/tests/racket/procs.rktl
View File

@ -283,6 +283,16 @@
(test 7 (lambda () (f #:x 7)))
(set! f #f))
;; ----------------------------------------
;; Check mutation of direct-called keyword procedure
(let ()
(define (f1 #:x x) (list x))
(test 'f1 object-name f1))
(let ()
(define (f2 #:x [x 8]) (list x))
(test 'f2 object-name f2))
;; ----------------------------------------
(report-errs)