defend against strage inferred-name property call with keyword args
This commit is contained in:
parent
79bb6531df
commit
50ff92b784
|
@ -1854,6 +1854,25 @@
|
||||||
(read i)))
|
(read i)))
|
||||||
(test (syntax->datum (eval v)) syntax->datum (eval e)))
|
(test (syntax->datum (eval v)) syntax->datum (eval e)))
|
||||||
|
|
||||||
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; Check that expansion of `apply` into the keyword `apply`
|
||||||
|
;; doesn't create a confusing inferred name:
|
||||||
|
|
||||||
|
(define proc-that-accepts-anything (make-keyword-procedure void))
|
||||||
|
(proc-that-accepts-anything #:contract
|
||||||
|
(apply proc-that-accepts-anything
|
||||||
|
null
|
||||||
|
#:flat? #t))
|
||||||
|
(let-syntax ([x (lambda (stx)
|
||||||
|
(syntax-property
|
||||||
|
(datum->syntax stx
|
||||||
|
(cons #'proc-that-accepts-anything
|
||||||
|
(cdr (syntax-e stx))))
|
||||||
|
'inferred-name
|
||||||
|
"non-symbol"))])
|
||||||
|
(proc-that-accepts-anything #:contract
|
||||||
|
(x #:flag? #t)))
|
||||||
|
|
||||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(report-errs)
|
(report-errs)
|
||||||
|
|
|
@ -954,7 +954,7 @@
|
||||||
[else
|
[else
|
||||||
(cons (car l) (loop (cdr l)))])))])
|
(cons (car l) (loop (cdr l)))])))])
|
||||||
(let* ([name (syntax-local-infer-name stx #f)]
|
(let* ([name (syntax-local-infer-name stx #f)]
|
||||||
[ids (cons (if name
|
[ids (cons (if (and name (or (identifier? name) (symbol? name)))
|
||||||
(if (syntax? name) name (datum->syntax #f name))
|
(if (syntax? name) name (datum->syntax #f name))
|
||||||
(datum->syntax #f 'procedure))
|
(datum->syntax #f 'procedure))
|
||||||
(generate-temporaries exprs))])
|
(generate-temporaries exprs))])
|
||||||
|
|
Loading…
Reference in New Issue
Block a user