94 lines
3.3 KiB
Scheme
94 lines
3.3 KiB
Scheme
#lang racket
|
|
|
|
(require "uniquify.scm")
|
|
|
|
(provide remove-complex-opera*)
|
|
|
|
; 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)
|
|
[`(program ,data ,exp)
|
|
(begin
|
|
(define initial-tmpcount (hash-ref (car uniq-res) `tmp 0))
|
|
(define-values (new-exp bla) (rco-exp exp initial-tmpcount))
|
|
`(program ,data ,new-exp))])))
|
|
|
|
(define (let-binding var val exp)
|
|
`(let ([,var ,val]) ,exp))
|
|
|
|
(define (wrap-associations assoc-list exp)
|
|
(if (empty? assoc-list)
|
|
exp
|
|
(let ([binding (car assoc-list)])
|
|
(let-binding (car binding) (cadr binding)
|
|
(wrap-associations (cdr assoc-list) exp)))))
|
|
|
|
(define (rco-exp exp tmpcount)
|
|
(match exp
|
|
[(? fixnum?) (values exp tmpcount)]
|
|
[(? symbol?) (values exp tmpcount)]
|
|
[`(read) (values exp tmpcount)]
|
|
[`(- ,e)
|
|
(begin
|
|
(define-values (new-exp assoc-list new-tmpcount) (rco-arg e tmpcount))
|
|
(values (wrap-associations assoc-list `(- ,new-exp)) new-tmpcount))]
|
|
[`(,op ,e1 ,e2)
|
|
#:when (or (eq? op `+) (eq? op `-))
|
|
(begin
|
|
(define-values (new-exp1 assoc-list1 new-tmpcount1) (rco-arg e1 tmpcount))
|
|
(define-values (new-exp2 assoc-list2 new-tmpcount) (rco-arg e2 new-tmpcount1))
|
|
(values (wrap-associations (append assoc-list1 assoc-list2)
|
|
`(,op ,new-exp1 ,new-exp2)) new-tmpcount))]
|
|
[`(let ([,var ,e]) ,body)
|
|
(begin
|
|
(define-values (exp-tmp exp-tmpcount) (rco-exp e tmpcount))
|
|
(define-values (new-body new-tmpcount) (rco-exp body exp-tmpcount))
|
|
(values `(let ([,var ,exp-tmp]) ,new-body)
|
|
exp-tmpcount))]))
|
|
|
|
(define (get-unique-symbol tmpcount)
|
|
(string->symbol (format "tmp.~a" tmpcount)))
|
|
|
|
(define (rco-arg exp tmpcount)
|
|
(match exp
|
|
[(? fixnum?) (values exp '() tmpcount)]
|
|
[(? symbol?) (values exp '() tmpcount)]
|
|
[`(read) (values exp '() tmpcount)]
|
|
[`(- ,e)
|
|
(begin
|
|
(define-values (new-exp assoc-list exp-tmpcount) (rco-arg e tmpcount))
|
|
(define new-tmpcount (+ exp-tmpcount 1))
|
|
(define tmpname (get-unique-symbol new-tmpcount))
|
|
(set! assoc-list (append assoc-list (list `(,tmpname (- ,new-exp)))))
|
|
(values tmpname
|
|
assoc-list
|
|
new-tmpcount))]
|
|
[`(,op ,e1 ,e2)
|
|
#:when (or (eq? op `+) (eq? op `-))
|
|
(begin
|
|
(define-values (new-exp1 assoc-1 exp1-tmpcount) (rco-arg e1 tmpcount))
|
|
(define-values (new-exp2 assoc-2 exp2-tmpcount) (rco-arg e2 exp1-tmpcount))
|
|
(define assoc-list (append assoc-1 assoc-2))
|
|
(define new-tmpcount (+ exp2-tmpcount 1))
|
|
(define tmpname (get-unique-symbol new-tmpcount))
|
|
(set! assoc-list (append assoc-list (list `(,tmpname (,op ,new-exp1 ,new-exp2)))))
|
|
(values tmpname
|
|
assoc-list
|
|
new-tmpcount))]
|
|
[`(let ([,var ,rexp]) ,body)
|
|
(begin
|
|
(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))]))
|