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

cify: fix procedure names

Browse Source 
Extend the repair in e72f954e85 for cify.
This commit is contained in:
Matthew Flatt 2019-10-07 17:06:30 -06:00
parent e72f954e85
commit 5f3ab00351
3 changed files with 71 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -12,6 +12,7 @@
"../schemify/serialize.rkt"
"../schemify/known.rkt"
"../schemify/lift.rkt"
"../schemify/reinfer-name.rkt"
"../schemify/wrap.rkt")
(define skip-export? #f)
@ -99,45 +100,6 @@
(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] ...)

28
racket/src/racket/src/cify-startup.rkt
View File

@ -7,6 +7,9 @@
"../../schemify/serialize.rkt"
"../../schemify/known.rkt"
"../../schemify/lift.rkt"
"../../schemify/reinfer-name.rkt"
"../../schemify/wrap.rkt"
"../../schemify/match.rkt"
"../../cify/main.rkt"
"help-startup.rkt")
@ -74,7 +77,7 @@
(printf "Schemify...\n")
(define body
(time
(schemify-body bodys/re-uniqued prim-knowns #hasheq() #hasheq() #hasheq()
(schemify-body (recognize-inferred-names bodys/re-uniqued) prim-knowns #hasheq() #hasheq() #hasheq()
;; for cify:
#t
;; unsafe mode:
@ -92,7 +95,28 @@
(cons 'define p))
lifted-body))
(cify dest (caddr content) `(begin . ,converted-body) prim-knowns
;; Convert 'inferred-name properties back to `(lambda <formals> (begin 'name <expr>))` form
(define (restore-inferred-names e)
(cond
[(wrap? e)
(cond
[(wrap-property e 'inferred-name)
=> (lambda (name)
(match e
[`(lambda ,formals ,expr)
`(lambda ,formals (begin ',name ,(restore-inferred-names expr)))]
[`(case-lambda [,formals ,expr] . ,rest)
`(case-lambda [,formals (begin ',name ,(restore-inferred-names expr))]
. ,(restore-inferred-names rest))]
[`,_
(restore-inferred-names (unwrap e))]))]
[else
(restore-inferred-names (unwrap e))])]
[(not (pair? e)) e]
[else (cons (restore-inferred-names (car e))
(restore-inferred-names (cdr e)))]))
(cify dest (caddr content) `(begin . ,(restore-inferred-names converted-body)) prim-knowns
#:debug? debug?
#:preamble (append (list version-line
(format "#if 0 ~a" version-comparisons)

44
racket/src/schemify/reinfer-name.rkt Normal file
View File

@ -0,0 +1,44 @@
#lang racket/base
(require "wrap.rkt")
(provide recognize-inferred-names)
;; 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)))])]))