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

cs: fix procedure names in startup code

Browse Source 
Commit 7d725ab48b interferred with the way that procedure names are
recorded for the code that is built into the Racket executable.
This commit is contained in:
Matthew Flatt 2019-10-07 15:18:46 -06:00
parent 0c4fbda8ba
commit e72f954e85
2 changed files with 45 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -13,6 +13,8 @@
(test #f object-name 'hello)
(test #f object-name "hi")
(test 'eval object-name eval)
(define (src-name? s)
(and (symbol? s)
(regexp-match ":[0-9]+.[0-9]+$" (symbol->string s))

79
racket/src/cs/convert.rkt
View File

@ -99,6 +99,45 @@
(unless for-cify?
(lift l))
;; Startup code as an S-expression uses the pattern
;; (lambda <formals> (begin '<id> <expr>))
;; or
;; (case-lambda [<formals> (begin '<id> <expr>)] <clause> ...)
;; to record a name for a function. Detect that pattern and
;; convert back to an 'inferred-name property. We rely on the fact
;; that the names `lambda`, `case-lambda`, and `quote` are
;; never shadowed, so we don't have to parse expression forms
;; in general.
(define (recognize-inferred-names e)
(cond
[(not (pair? e)) e]
[else
(define (begin-name e)
(and (pair? e)
(eq? (car e) 'begin)
(pair? (cdr e))
(pair? (cddr e))
(pair? (cadr e))
(eq? 'quote (caadr e))
(cadadr e)))
(case (car e)
[(quote) e]
[(lambda)
(define new-e (map recognize-inferred-names e))
(define name (begin-name (caddr e)))
(if name
(wrap-property-set new-e 'inferred-name name)
new-e)]
[(case-lambda)
(define new-e (map recognize-inferred-names e))
(define name (and (pair? (cdr e))
(begin-name (cadadr e))))
(if name
(wrap-property-set new-e 'inferred-name name)
new-e)]
[else (cons (recognize-inferred-names (car e))
(recognize-inferred-names (cdr e)))])]))
(define prim-knowns
(let ([knowns (hasheq)])
(define-syntax-rule (define-primitive-table id [prim known] ...)
@ -142,7 +181,7 @@
(begin
(printf "Serializable...\n")
(time (convert-for-serialize l for-cify?)))
(values l null)))
(values (recognize-inferred-names l) null)))
(printf "Schemify...\n")
(define body
(time
@ -219,15 +258,7 @@
;; ----------------------------------------
;; Startup code as an S-expression uses the pattern
;; (lambda <formals> (begin '<id> <expr>))
;; or
;; (case-lambda [<formals> (begin '<id> <expr>)] <clause> ...)
;; to record a name for a function. Detect that pattern and
;; create a `#%name` form. We rely on the fact
;; that the names `lambda`, `case-lambda`, and `quote` are
;; never shadowed, so we don't have to parse expression forms
;; in general.
;; Convert 'inferred-name properties to `#%name` forms
(define (rename-functions e)
(cond
[(wrap? e)
@ -238,32 +269,8 @@
[else
(rename-functions (unwrap e))])]
[(not (pair? e)) e]
[else
(define (begin-name e)
(and (pair? e)
(eq? (car e) 'begin)
(pair? (cdr e))
(pair? (cddr e))
(pair? (cadr e))
(eq? 'quote (caadr e))
(cadadr e)))
(case (car e)
[(quote) e]
[(lambda)
(define new-e (map rename-functions e))
(define name (begin-name (caddr e)))
(if name
`(#%name ,name ,new-e)
new-e)]
[(case-lambda)
(define new-e (map rename-functions e))
(define name (and (pair? (cdr e))
(begin-name (cadadr e))))
(if name
`(#%name ,name ,new-e)
new-e)]
[else (cons (rename-functions (car e))
(rename-functions (cdr e)))])]))
[else (cons (rename-functions (car e))
(rename-functions (cdr e)))]))
;; ----------------------------------------