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

fix 'inferred-name handling for keyword-supporting define

Browse Source 
Closes #3009
This commit is contained in:
Matthew Flatt 2020-01-20 10:27:07 -07:00
parent 848d2148b0
commit 17aae65664
8 changed files with 7227 additions and 7055 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14136
pkgs/racket-test-core/tests/racket/expobs-regression.rktd
View File

File diff suppressed because it is too large Load Diff

2
pkgs/racket-test-core/tests/racket/function.rktl
View File

@ -279,4 +279,6 @@
(define l (for/list ([i 100]) 0)) (define l (for/list ([i 100]) 0))
(test 0 apply @max l)) (test 0 apply @max l))
;; ----------------------------------------
(report-errs) (report-errs)

67
pkgs/racket-test-core/tests/racket/procs.rktl
View File

@ -689,6 +689,73 @@
(lambda () y))) (lambda () y)))
(test #f object-name (return-a-function-that-returns-y)) (test #f object-name (return-a-function-that-returns-y))
;; ----------------------------------------
;; Check 'inferred-name property on `lambda` that supports keywords
;; and optional arguments
(let ([mk
(lambda (mod-name proc)
(define e
`(module ,mod-name racket/base
(require (for-syntax racket/base))
(provide check-all)
(define-for-syntax (add-name stx)
(syntax-property stx 'inferred-name 'new-name))
(define-for-syntax fun
#',proc)
(define-syntax (go1 stx)
(syntax-case stx ()
[(_ id)
#`(define id #,fun)]))
(define-syntax (go2 stx)
(syntax-case stx ()
[(_ id)
#`(define id #,(add-name fun))]))
(define-syntax (go3 stx)
(syntax-case stx ()
[(_ id)
#`(define id (#%expression #,(add-name fun)))]))
(define-syntax (go4 stx)
(syntax-case stx ()
[(_ id)
#`(define id (let () #,(add-name fun)))]))
(go1 f1)
(go2 f2)
(go3 f3)
(go4 f4)
(define (check-all check)
(go1 g1)
(go2 g2)
(go3 g3)
(go4 g4)
(check f1 'f1)
(check f2 'new-name)
(check f3 'new-name)
(check f4 'new-name)
(check g1 'g1)
(check g2 'new-name)
(check g3 'new-name)
(check g4 'new-name))))
(eval e)
((dynamic-require `',mod-name 'check-all)
(lambda (proc name)
(test name mod-name (object-name proc)))))])
(mk 'checks-many-declared-inferred-names
'(lambda (x) x))
(mk 'checks-many-declared-inferred-names/opt
'(lambda (x [y 10]) x))
(mk 'checks-many-declared-inferred-names/keyword
'(lambda (x #:z z) x))
(mk 'checks-many-declared-inferred-names/opt-keyword
'(lambda (x #:z [z 11]) x)))
;; ---------------------------------------- ;; ----------------------------------------
(report-errs) (report-errs)

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

@ -676,8 +676,19 @@
[(null? kws) null] [(null? kws) null]
[else [else
(cons (cadar kws) (loop (cdr kws)))])))] (cons (cadar kws) (loop (cdr kws)))])))]
[local-name (or local-name [local-name (let ([name (simplify-inferred-name (syntax-property stx 'inferred-name))])
(syntax-local-infer-name stx))]) (cond
[(or (symbol? name) (identifier? name)) name]
[else (or local-name
(let ([name (syntax-local-infer-name stx)])
(and (or (symbol? name) (identifier? name))
name)))]))]
[add-local-name (lambda (stx)
(if local-name
;; Expecting always a `[case-]lambda form, so 'inferred-name
;; should work and is less invasive than `let`:
(syntax-property stx 'inferred-name local-name)
stx))])
(with-syntax ([(kw-arg ...) kw-args] (with-syntax ([(kw-arg ...) kw-args]
[kws-sorted sorted-kws] [kws-sorted sorted-kws]
[(opt-arg ...) opt-args] [(opt-arg ...) opt-args]
@ -761,14 +772,15 @@
[mk-no-kws [mk-no-kws
(lambda (kw-core?) (lambda (kw-core?)
;; entry point without keywords: ;; entry point without keywords:
(annotate-method (add-local-name
(quasisyntax/loc/always stx (annotate-method
(opt-cases #,(if kw-core? (quasisyntax/loc/always stx
#'(unpack null null) (opt-cases #,(if kw-core?
#'(core)) #'(unpack null null)
([opt-id opt-arg opt-not-supplied] ...) (plain-id ...) #'(core))
() () ([opt-id opt-arg opt-not-supplied] ...) (plain-id ...)
(rest-empty rest-id . rest) ()))))] () ()
(rest-empty rest-id . rest) ())))))]
[mk-with-kws [mk-with-kws
(lambda () (lambda ()
;; entry point with keywords: ;; entry point with keywords:
@ -808,11 +820,7 @@
(mk-core #t) (mk-core #t)
(mk-unpack) (mk-unpack)
(with-syntax ([kws (map car sorted-kws)] (with-syntax ([kws (map car sorted-kws)]
[no-kws (let ([p (mk-no-kws #t)] [no-kws (mk-no-kws #t)]
[n local-name])
(if n
#`(let ([#,n #,p]) #,n)
p))]
[with-kws (mk-with-kws)]) [with-kws (mk-with-kws)])
(quasisyntax/loc stx (quasisyntax/loc stx
(make-okp (make-okp
@ -1110,10 +1118,13 @@
(compile-enforce-module-constants)) (compile-enforce-module-constants))
(and (list? ctx) (and (list? ctx)
(andmap liberal-define-context? ctx))))))] (andmap liberal-define-context? ctx))))))]
[opt (lambda (rhs core-wrap plain) [opt (lambda (lam-id rhs core-wrap plain)
(parse-lambda rhs (parse-lambda rhs
id id
plain (lambda (new-rhs)
(plain (syntax-track-origin new-rhs
rhs
lam-id)))
(lambda (impl kwimpl wrap (lambda (impl kwimpl wrap
core-id unpack-id core-id unpack-id
n-req opt-not-supplieds rest? req-kws all-kws) n-req opt-not-supplieds rest? req-kws all-kws)
@ -1133,11 +1144,11 @@
#,(quasisyntax/loc stx #,(quasisyntax/loc stx
(define #,unpack-id #,kwimpl)) (define #,unpack-id #,kwimpl))
#,(quasisyntax/loc stx #,(quasisyntax/loc stx
(define proc #,wrap)))))))))]) (define proc #,(syntax-track-origin wrap rhs lam-id))))))))))])
(syntax-case rhs (begin quote) (syntax-case rhs (begin quote)
[(lam-id . _) [(lam-id . _)
(can-opt? #'lam-id) (can-opt? #'lam-id)
(opt rhs values plain)] (opt #'lam-id rhs values plain)]
[(begin (quote sym) (lam-id . _)) [(begin (quote sym) (lam-id . _))
;; looks like a compiler hint ;; looks like a compiler hint
(and (can-opt? #'lam-id) (and (can-opt? #'lam-id)
@ -1145,7 +1156,8 @@
(syntax-case rhs () (syntax-case rhs ()
[(_ _ sub-rhs) [(_ _ sub-rhs)
(let ([wrap (lambda (stx) #`(begin (quote sym) #,stx))]) (let ([wrap (lambda (stx) #`(begin (quote sym) #,stx))])
(opt #'sub-rhs (opt #'lam-id
#'sub-rhs
wrap wrap
(lambda (rhs) (plain (wrap rhs)))))])] (lambda (rhs) (plain (wrap rhs)))))])]
[_ (plain rhs)])))) [_ (plain rhs)]))))

3
racket/collects/racket/private/name.rkt
View File

@ -1,7 +1,8 @@
(module name '#%kernel (module name '#%kernel
(#%require "define.rkt" "qq-and-or.rkt" "cond.rkt") (#%require "define.rkt" "qq-and-or.rkt" "cond.rkt")
(#%provide syntax-local-infer-name) (#%provide syntax-local-infer-name
simplify-inferred-name)
(define syntax-local-infer-name (define syntax-local-infer-name
(case-lambda (case-lambda

3
racket/collects/racket/private/norm-define.rkt
View File

@ -6,8 +6,7 @@
(#%provide normalize-definition normalize-definition/mk-rhs) (#%provide normalize-definition normalize-definition/mk-rhs)
(define-values (normalize-definition/mk-rhs) (define-values (normalize-definition/mk-rhs)
(lambda (lambda (stx lambda-stx check-context? allow-key+opt? err-no-body?)
(stx lambda-stx check-context? allow-key+opt? err-no-body?)
(when (and check-context? (when (and check-context?
(memq (syntax-local-context) '(expression))) (memq (syntax-local-context) '(expression)))
(raise-syntax-error (raise-syntax-error

2
racket/src/expander/compile/expr.rkt
View File

@ -143,7 +143,7 @@
[else v])) [else v]))
;; Get either a declared 'inferred-name or one accumulated by the compiler ;; Get either a declared 'inferred-name or one accumulated by the compiler
(define name (or (let ([v (simplify-name (syntax-property orig-s 'inferred-name))]) (define name (or (let ([v (simplify-name (syntax-property orig-s 'inferred-name))])
(and (or (symbol? v) (syntax? v) (void? v)) (and (or (symbol? v) (and (syntax? v) (symbol? (syntax-e v))) (void? v))
v)) v))
inferred-name)) inferred-name))
(define named-s (if name (define named-s (if name

3
racket/src/racket/src/startup.inc
View File

@ -31276,7 +31276,8 @@ static const char *startup_source =
"(if(let-values(((or-part_0)(symbol? v_0)))" "(if(let-values(((or-part_0)(symbol? v_0)))"
"(if or-part_0" "(if or-part_0"
" or-part_0" " or-part_0"
"(let-values(((or-part_1)(syntax?$1 v_0)))" "(let-values(((or-part_1)"
"(if(syntax?$1 v_0)(symbol?(syntax-e$1 v_0)) #f)))"
"(if or-part_1 or-part_1(void? v_0)))))" "(if or-part_1 or-part_1(void? v_0)))))"
" v_0" " v_0"
" #f))))" " #f))))"