diff --git a/remove-complex-oper.scm b/remove-complex-oper.scm index 76f87d1..b4ec6d3 100644 --- a/remove-complex-oper.scm +++ b/remove-complex-oper.scm @@ -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)