diff --git a/c1.scm b/c1.scm index 6f0edbc..b4f25d3 100644 --- a/c1.scm +++ b/c1.scm @@ -9,54 +9,54 @@ (let ([r (read)]) (cond [(fixnum? r) r] - [else (error "invalid fixnum in input: " r)] - ))) + [else (error "invalid fixnum in input: " r)]))) + (define (interp-exp sexp) (match sexp [(? fixnum?) sexp] [`(read) (read-fixnum)] [`(- ,e) (fx- 0 (interp-exp e))] - [`(+ ,e1 ,e2) (fx+ (interp-exp e1) (interp-exp e2))] - )) + [`(+ ,e1 ,e2) (fx+ (interp-exp e1) (interp-exp e2))])) + (define (interp-R0 p) (match p - [`(program ,e) (interp-exp e)] - )) + [`(program ,e) (interp-exp e)])) + (define (pe-arith p) (match p - [`(program ,e) (pe-exp e)] - )) + [`(program ,e) (pe-exp e)])) + (define (pe-exp exp) - (pe-remove-node-labels (pe-fold-right-constants (pe-move-reads-left (pe-do-negate exp)))) - ) + (pe-remove-node-labels (pe-fold-right-constants (pe-move-reads-left (pe-do-negate exp))))) + ; removes R/C/S labels from a tree (define (pe-remove-node-labels tree) (match tree [`((+ ,e1 ,e2) ,_) `(+ ,(pe-remove-node-labels e1) ,(pe-remove-node-labels e2))] [`(,e C) e] - [`(,e R) e] - )) + [`(,e R) e])) + ; partially evaluates an S/R/C-tree (define (pe-fold-right-constants exp) (match exp [`(,_ S) (make-S-node (node-S-left exp) `(,(pe-fold-constants (node-S-right exp)) C))] [`(,_ C) `(,(pe-fold-constants exp) C)] - [`(,_ R) exp] - )) + [`(,_ R) exp])) + ; evaluates a C-tree and returns the integer result (define (pe-fold-constants c-tree) (match c-tree [`((+ ,e1 ,e2) C) (fx+ (pe-fold-constants e1) (pe-fold-constants e2))] - [`(,e C) e] - )) + [`(,e C) e])) + ; pushes down negation to literals, inside additions and elides multiple consecutive negations (define (pe-do-negate exp) @@ -65,8 +65,8 @@ [`(- (+ ,e1 ,e2)) (pe-do-negate `(+ (- ,e1) (- ,e2)))] [`(+ ,e1 ,e2) `(+ ,(pe-do-negate e1) ,(pe-do-negate e2))] [`(- ,e) (if (fixnum? e) (fx- 0 e) `(- ,(pe-do-negate e)))] - [_ exp] - )) + [_ exp])) + ; takes an exepression and transforms it in an equivalent form such that it is either ; - a tree of C nodes @@ -81,12 +81,12 @@ [(? fixnum?) `(,exp C)] [`(read) `(,exp R)] [`(- (read)) `(,exp R)] - [`(+ ,e1 ,e2) + [`(+ ,e1 ,e2) (let ([e1-rl (pe-move-reads-left e1)] [e2-rl (pe-move-reads-left e2)]) - (pe-join-subtrees e1-rl e2-rl) - )] - )) + (pe-join-subtrees e1-rl e2-rl))])) + + ; join two subtrees and forms either a new C-tree, a new R-tree or a new S-tree (define (pe-join-subtrees e1-rl e2-rl) @@ -96,50 +96,50 @@ [(and (node-is-R e1-rl) (node-is-C e2-rl)) (make-S-node e1-rl e2-rl)] [(and (node-is-C e1-rl) (node-is-R e2-rl)) (make-S-node e2-rl e1-rl)] [(node-is-S e1-rl) - (cond - [(node-is-C e2-rl) (make-S-node - (node-S-left e1-rl) - (make-C-node (node-S-right e1-rl) e2-rl))] - [(node-is-R e2-rl) (make-S-node - (make-R-node (node-S-left e1-rl) e2-rl) - (node-S-right e1-rl))] - [(node-is-S e2-rl) (make-S-node - (make-R-node (node-S-left e1-rl) (node-S-left e2-rl)) - (make-C-node (node-S-right e1-rl) (node-S-right e2-rl)))] - )] - [(node-is-S e2-rl) (pe-join-subtrees e2-rl e1-rl)] - ) - ) + (cond + [(node-is-C e2-rl) (make-S-node + (node-S-left e1-rl) + (make-C-node (node-S-right e1-rl) e2-rl))] + [(node-is-R e2-rl) (make-S-node + (make-R-node (node-S-left e1-rl) e2-rl) + (node-S-right e1-rl))] + [(node-is-S e2-rl) (make-S-node + (make-R-node (node-S-left e1-rl) (node-S-left e2-rl)) + (make-C-node (node-S-right e1-rl) (node-S-right e2-rl)))])] + + [(node-is-S e2-rl) (pe-join-subtrees e2-rl e1-rl)])) + + (define (node-is-C n) (match n [`(,_ C) #t] - [_ #f] - )) + [_ #f])) + (define (node-is-R n) (match n [`(,_ R) #t] - [_ #f] - )) + [_ #f])) + (define (node-is-S n) (match n [`(,_ S) #t] - [_ #f] - )) + [_ #f])) + (define (node-S-left n) (match n [`((+ ,e1 ,_) S) e1] - [_ (error "cannot be here! (S left)")] - )) + [_ (error "cannot be here! (S left)")])) + (define (node-S-right n) (match n [`((+ ,_ ,e2) S) e2] - [_ (error "cannot be here! (S right)")] - )) + [_ (error "cannot be here! (S right)")])) + (define (make-S-node r c) `((+ ,r ,c) S)) @@ -151,33 +151,32 @@ `((+ ,r1 ,r2) R)) (define (test-eq a b) - (if (equal? a b) #t (error "assert failed: " a " != " b) )) + (if (equal? a b) #t (error "assert failed: " a " != " b))) (define (test-pe-eq a b) (test-eq (pe-exp a) b)) -(define (ppn exp) (begin (print (pe-exp exp)) (newline) )) +(define (ppn exp) (begin (print (pe-exp exp)) (newline))) (test-eq (pe-do-negate `(- 3)) -3) -(test-eq (pe-do-negate `(- (+ 3 4)) ) `(+ -3 -4) ) -(test-eq (pe-do-negate `(- (+ 2 (- (read)))) ) `(+ -2 (read)) ) -(test-eq (pe-do-negate `(+ (- 1) (- (- 2))) ) `(+ -1 2) ) -(test-eq (pe-do-negate `(- (- (- (+ (read) 1)))) ) `(+ (- (read)) -1) ) +(test-eq (pe-do-negate `(- (+ 3 4)) ) `(+ -3 -4)) +(test-eq (pe-do-negate `(- (+ 2 (- (read)))) ) `(+ -2 (read))) +(test-eq (pe-do-negate `(+ (- 1) (- (- 2))) ) `(+ -1 2)) +(test-eq (pe-do-negate `(- (- (- (+ (read) 1)))) ) `(+ (- (read)) -1)) (test-eq (node-is-C `(1 C)) #t) (test-eq (pe-move-reads-left `1) `(1 C)) -(test-eq (pe-move-reads-left `(+ 1 1) ) `((+ (1 C) (1 C)) C) ) -(test-eq (pe-move-reads-left `(+ 1 (read)) ) `((+ ((read) R) (1 C)) S) ) -(test-eq (pe-move-reads-left `(+ (read) (read)) ) `((+ ((read) R) ((read) R)) R) ) -(test-eq (pe-move-reads-left `(+ (- (read)) -2) ) `((+ ((- (read)) R) (-2 C)) S) ) +(test-eq (pe-move-reads-left `(+ 1 1) ) `((+ (1 C) (1 C)) C)) +(test-eq (pe-move-reads-left `(+ 1 (read)) ) `((+ ((read) R) (1 C)) S)) +(test-eq (pe-move-reads-left `(+ (read) (read)) ) `((+ ((read) R) ((read) R)) R)) +(test-eq (pe-move-reads-left `(+ (- (read)) -2) ) `((+ ((- (read)) R) (-2 C)) S)) (test-eq (pe-fold-constants `((+ (1 C) (-3 C)) C) ) -2) (test-eq (pe-fold-right-constants `((+ (1 C) (-3 C)) C) ) `(-2 C)) -(test-eq (pe-fold-right-constants `((+ ((read) R) ((+ (1 C) (-3 C)) C)) S) ) - `((+ ((read) R) (-2 C)) S) ) +(test-eq (pe-fold-right-constants `((+ ((read) R) ((+ (1 C) (-3 C)) C)) S)) + `((+ ((read) R) (-2 C)) S)) -(test-eq (pe-remove-node-labels `((read) R) ) `(read) ) -(test-eq (pe-remove-node-labels `((+ ((read) R) ((read) R)) R) ) `(+ (read) (read)) ) -(test-eq (pe-remove-node-labels `((+ ((- (read)) R) (-2 C)) S) ) `(+ (- (read)) -2) ) - -(test-eq (pe-exp `(+ (- (+ (read) 9)) (+ (+ (read) 1) 5)) ) `(+ (+ (- (read)) (read)) -3) ) +(test-eq (pe-remove-node-labels `((read) R) ) `(read)) +(test-eq (pe-remove-node-labels `((+ ((read) R) ((read) R)) R) ) `(+ (read) (read))) +(test-eq (pe-remove-node-labels `((+ ((- (read)) R) (-2 C)) S) ) `(+ (- (read)) -2)) +(test-eq (pe-exp `(+ (- (+ (read) 9)) (+ (+ (read) 1) 5)) ) `(+ (+ (- (read)) (read)) -3)) diff --git a/remove-complex-oper.scm b/remove-complex-oper.scm index e30e1c9..b934fe0 100644 --- a/remove-complex-oper.scm +++ b/remove-complex-oper.scm @@ -16,7 +16,7 @@ (define (remove-complex-opera* p) (let ([uniq-res (uniquify p)]) (match (cadr uniq-res) - [`(program ,data ,exp) + [`(program ,data ,exp) (begin (define initial-tmpcount (hash-ref (car uniq-res) `tmp 0)) (define-values (new-exp bla) (rco-exp exp initial-tmpcount)) @@ -31,23 +31,22 @@ (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) + [`(- ,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 `-)) + [`(+ ,e1 ,e2) (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))] + `(+ ,new-exp1 ,new-exp2)) new-tmpcount))] [`(let ([,var ,e]) ,body) (begin (define-values (exp-tmp exp-tmpcount) (rco-exp e tmpcount)) diff --git a/uniquify.scm b/uniquify.scm index 70eb782..f40534f 100644 --- a/uniquify.scm +++ b/uniquify.scm @@ -4,14 +4,14 @@ (define (uniquify p) (match p - [`(program ,data ,exp) + [`(program ,data ,exp) (let ([res ((uniquify-exp (make-immutable-hash) (make-immutable-hash)) exp)]) - `(,(car res) + `(,(car res) (program ,data ,(cadr res))))])) (define (add-unique-assoc symtable varname) - (hash-update symtable varname + (hash-update symtable varname (lambda (ref) (+ ref 1)) 0)) @@ -19,7 +19,7 @@ (if (hash-has-key? symtable varname) (string->symbol (format "~a.~a" varname (hash-ref symtable varname))) varname)) - + (define (uniquify-exp symtable ctxtable) (lambda (sexp) (match sexp @@ -28,7 +28,7 @@ [(? symbol?) (list symtable (get-unique-assoc ctxtable sexp))] [`(let ([,var ,rexp]) ,body) - (begin + (begin (define cur-symtable (add-unique-assoc symtable var)) (define new-ctxtable (hash-set ctxtable var (hash-ref cur-symtable var))) (define uniquify-exp-result ((uniquify-exp cur-symtable ctxtable) rexp)) @@ -40,11 +40,11 @@ `(let ([,(get-unique-assoc new-ctxtable var) ,(cadr uniquify-exp-result)]) ,bodyexp))]))] - + ; handle (+ e...) and (- e...) - [`(,op ,es ...) + [`(,op ,es ...) (begin - (define-values (new-symtable res) + (define-values (new-symtable res) (for/fold ([cur-symtable symtable] [res (list op)]) ([exp es])