Return to simpler implementation

remove-complex-oper.scm

@@ -4,16 +4,15 @@
 
 (provide remove-complex-opera*)
 
-; remove complex SUB-expressions:
+; remove complex sub-expression
-; of course complex expression are possible
+; the resulting code is either
-; but their argument can only be either
+; - (read)
-; - number
+; - a number literal
-; - symbol
+; - a symbol
-; - `(read)
+; the three above are called in the following "simple terms"
-; temporary variables are introduced to make this possible
+; - (- x) where x is a simple term
-; with the caveat that a binding should never associate
+; - (+ x y) where x and y are simple terms
-; an existing symbol to a temporary
+; - (let ([var y]) z) where y and z are expressions
-; (Invariant of rco-arg)
 (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)))
+      (values `(let ([,var ,exp-tmp]) ,new-body)
-      (set! assoc-list
+              exp-tmpcount))]))
-        (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))]))
 
 (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 (new-exp exp-tmpcount) (rco-exp rexp tmpcount))
-     (define-values (body-tmp assoc-list new-tmpcount) (rco-arg body exp-tmpcount))
+     (define-values (new-body new-tmpcount) (rco-exp body exp-tmpcount))
-     (define new-assoc-list
+     (values `(let ([,var ,new-exp]) ,new-body)
-        (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
              new-tmpcount))]))
-
-;(require racket/trace)
-;(trace rco-exp)
-;(trace rco-arg)