enrico
/
eoc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Return to simpler implementation

This commit is contained in:
Enrico Lumetti 2021-04-30 20:20:07 +02:00
parent 8c1294a56e
commit d52c9eb875
1 changed files with 16 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
remove-complex-oper.scm
View File

@ -4,16 +4,15 @@
(provide remove-complex-opera*)
; remove complex SUB-expressions:
; of course complex expression are possible
; but their argument can only be either
; - number
; - symbol
; - `(read)
; temporary variables are introduced to make this possible
; with the caveat that a binding should never associate
; an existing symbol to a temporary
; (Invariant of rco-arg)
; remove complex sub-expression
; the resulting code is either
; - (read)
; - a number literal
; - a symbol
; the three above are called in the following "simple terms"
; - (- x) where x is a simple term
; - (+ x y) where x and y are simple terms
; - (let ([var y]) z) where y and z are expressions
(define (remove-complex-opera* p)
(let ([uniq-res (uniquify p)])
(match (cadr uniq-res)
@ -33,42 +32,6 @@
(let-binding (car binding) (cadr binding)
(wrap-associations (cdr assoc-list) exp)))))
(define (substitute-var old-var var expr)
(match expr
[(? fixnum?) expr]
[`(read) expr]
[(? symbol?)
(if (eq? old-var expr) var expr)]
[`(- ,e) `(- ,(substitute-var old-var var e))]
[`(+ ,e1 ,e2)
(begin
(define se1 (substitute-var old-var var e1))
(define se2 (substitute-var old-var var e2))
`(+ ,se1 ,se2))]
[`(let ([,v ,e]) ,body)
(begin
(define se (substitute-var old-var var e))
(define sbody (substitute-var old-var var body))
`(let ([,v ,se]) ,sbody))]))
(define (change-assoc-key assoc-list old-key new-key)
(if (empty? assoc-list)
`()
(let ([key (caar assoc-list)])
(let ([new-pair (if (eq? key old-key)
`(,new-key . ,(cdar assoc-list))
(car assoc-list))])
(cons new-pair (change-assoc-key (cdr assoc-list) old-key new-key))))))
(define (is-tmp exp tmpcount)
(if (and (symbol? exp) (string-prefix? (symbol->string exp) "tmp."))
(let ([tmpvalue (string->number (substring (symbol->string exp) 4))])
(if (and tmpvalue (> tmpvalue tmpcount))
#t
#f))
#f))
(define (rco-exp exp tmpcount)
(match exp
[(? fixnum?) (values exp tmpcount)]
@ -87,19 +50,10 @@
`(,op ,new-exp1 ,new-exp2)) new-tmpcount))]
[`(let ([,var ,e]) ,body)
(begin
(define-values (exp-tmp assoc-list exp-tmpcount) (rco-arg e tmpcount))
(define-values (exp-tmp exp-tmpcount) (rco-exp e tmpcount))
(define-values (new-body new-tmpcount) (rco-exp body exp-tmpcount))
(define elide-tmp (or (is-tmp exp-tmp tmpcount)))
(set! assoc-list
(if (or elide-tmp (fixnum? exp-tmp))
(change-assoc-key assoc-list exp-tmp var)
(append assoc-list (list `(,var ,exp-tmp)))))
(set! new-body
(if (symbol? exp-tmp)
new-body ;(substitute-var exp-tmp var new-body) new-body)
`(let ([,var ,exp-tmp]) ,new-body)))
(values (wrap-associations assoc-list new-body)
new-tmpcount))]))
(values `(let ([,var ,exp-tmp]) ,new-body)
exp-tmpcount))]))
(define (get-unique-symbol tmpcount)
(string->symbol (format "tmp.~a" tmpcount)))
@ -132,16 +86,8 @@
new-tmpcount))]
[`(let ([,var ,rexp]) ,body)
(begin
(define-values (new-exp assoc-list-1 exp-tmpcount) (rco-arg rexp tmpcount))
(define-values (body-tmp assoc-list new-tmpcount) (rco-arg body exp-tmpcount))
(define new-assoc-list
(if (not (is-tmp new-exp tmpcount))
(cons `(,var ,new-exp) (append assoc-list-1 assoc-list))
(change-assoc-key (append assoc-list-1 assoc-list) new-exp var)))
(values body-tmp
new-assoc-list
(define-values (new-exp exp-tmpcount) (rco-exp rexp tmpcount))
(define-values (new-body new-tmpcount) (rco-exp body exp-tmpcount))
(values `(let ([,var ,new-exp]) ,new-body)
`()
new-tmpcount))]))
;(require racket/trace)
;(trace rco-exp)
;(trace rco-arg)