Remove trailing space and (- x x) matching

This commit is contained in:
Enrico Lumetti 2021-05-01 00:11:54 +02:00
parent 866af9c2b5
commit 4c67b0f18d
3 changed files with 75 additions and 77 deletions

73
c1.scm
View File

@ -9,54 +9,54 @@
(let ([r (read)]) (let ([r (read)])
(cond (cond
[(fixnum? r) r] [(fixnum? r) r]
[else (error "invalid fixnum in input: " r)] [else (error "invalid fixnum in input: " r)])))
)))
(define (interp-exp sexp) (define (interp-exp sexp)
(match sexp (match sexp
[(? fixnum?) sexp] [(? fixnum?) sexp]
[`(read) (read-fixnum)] [`(read) (read-fixnum)]
[`(- ,e) (fx- 0 (interp-exp e))] [`(- ,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) (define (interp-R0 p)
(match p (match p
[`(program ,e) (interp-exp e)] [`(program ,e) (interp-exp e)]))
))
(define (pe-arith p) (define (pe-arith p)
(match p (match p
[`(program ,e) (pe-exp e)] [`(program ,e) (pe-exp e)]))
))
(define (pe-exp exp) (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 ; removes R/C/S labels from a tree
(define (pe-remove-node-labels tree) (define (pe-remove-node-labels tree)
(match tree (match tree
[`((+ ,e1 ,e2) ,_) `(+ ,(pe-remove-node-labels e1) ,(pe-remove-node-labels e2))] [`((+ ,e1 ,e2) ,_) `(+ ,(pe-remove-node-labels e1) ,(pe-remove-node-labels e2))]
[`(,e C) e] [`(,e C) e]
[`(,e R) e] [`(,e R) e]))
))
; partially evaluates an S/R/C-tree ; partially evaluates an S/R/C-tree
(define (pe-fold-right-constants exp) (define (pe-fold-right-constants exp)
(match exp (match exp
[`(,_ S) (make-S-node (node-S-left exp) `(,(pe-fold-constants (node-S-right exp)) C))] [`(,_ S) (make-S-node (node-S-left exp) `(,(pe-fold-constants (node-S-right exp)) C))]
[`(,_ C) `(,(pe-fold-constants exp) C)] [`(,_ C) `(,(pe-fold-constants exp) C)]
[`(,_ R) exp] [`(,_ R) exp]))
))
; evaluates a C-tree and returns the integer result ; evaluates a C-tree and returns the integer result
(define (pe-fold-constants c-tree) (define (pe-fold-constants c-tree)
(match c-tree (match c-tree
[`((+ ,e1 ,e2) C) (fx+ (pe-fold-constants e1) (pe-fold-constants e2))] [`((+ ,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 ; pushes down negation to literals, inside additions and elides multiple consecutive negations
(define (pe-do-negate exp) (define (pe-do-negate exp)
@ -65,8 +65,8 @@
[`(- (+ ,e1 ,e2)) (pe-do-negate `(+ (- ,e1) (- ,e2)))] [`(- (+ ,e1 ,e2)) (pe-do-negate `(+ (- ,e1) (- ,e2)))]
[`(+ ,e1 ,e2) `(+ ,(pe-do-negate e1) ,(pe-do-negate e2))] [`(+ ,e1 ,e2) `(+ ,(pe-do-negate e1) ,(pe-do-negate e2))]
[`(- ,e) (if (fixnum? e) (fx- 0 e) `(- ,(pe-do-negate e)))] [`(- ,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 ; takes an exepression and transforms it in an equivalent form such that it is either
; - a tree of C nodes ; - a tree of C nodes
@ -84,9 +84,9 @@
[`(+ ,e1 ,e2) [`(+ ,e1 ,e2)
(let ([e1-rl (pe-move-reads-left e1)] (let ([e1-rl (pe-move-reads-left e1)]
[e2-rl (pe-move-reads-left e2)]) [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 ; 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) (define (pe-join-subtrees e1-rl e2-rl)
@ -105,41 +105,41 @@
(node-S-right e1-rl))] (node-S-right e1-rl))]
[(node-is-S e2-rl) (make-S-node [(node-is-S e2-rl) (make-S-node
(make-R-node (node-S-left e1-rl) (node-S-left e2-rl)) (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)))] (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)] [(node-is-S e2-rl) (pe-join-subtrees e2-rl e1-rl)]))
)
)
(define (node-is-C n) (define (node-is-C n)
(match n (match n
[`(,_ C) #t] [`(,_ C) #t]
[_ #f] [_ #f]))
))
(define (node-is-R n) (define (node-is-R n)
(match n (match n
[`(,_ R) #t] [`(,_ R) #t]
[_ #f] [_ #f]))
))
(define (node-is-S n) (define (node-is-S n)
(match n (match n
[`(,_ S) #t] [`(,_ S) #t]
[_ #f] [_ #f]))
))
(define (node-S-left n) (define (node-S-left n)
(match n (match n
[`((+ ,e1 ,_) S) e1] [`((+ ,e1 ,_) S) e1]
[_ (error "cannot be here! (S left)")] [_ (error "cannot be here! (S left)")]))
))
(define (node-S-right n) (define (node-S-right n)
(match n (match n
[`((+ ,_ ,e2) S) e2] [`((+ ,_ ,e2) S) e2]
[_ (error "cannot be here! (S right)")] [_ (error "cannot be here! (S right)")]))
))
(define (make-S-node r c) (define (make-S-node r c)
`((+ ,r ,c) S)) `((+ ,r ,c) S))
@ -180,4 +180,3 @@
(test-eq (pe-remove-node-labels `((+ ((- (read)) R) (-2 C)) S) ) `(+ (- (read)) -2)) (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-exp `(+ (- (+ (read) 9)) (+ (+ (read) 1) 5)) ) `(+ (+ (- (read)) (read)) -3))

View File

@ -41,13 +41,12 @@
(begin (begin
(define-values (new-exp assoc-list new-tmpcount) (rco-arg e tmpcount)) (define-values (new-exp assoc-list new-tmpcount) (rco-arg e tmpcount))
(values (wrap-associations assoc-list `(- ,new-exp)) new-tmpcount))] (values (wrap-associations assoc-list `(- ,new-exp)) new-tmpcount))]
[`(,op ,e1 ,e2) [`(+ ,e1 ,e2)
#:when (or (eq? op `+) (eq? op `-))
(begin (begin
(define-values (new-exp1 assoc-list1 new-tmpcount1) (rco-arg e1 tmpcount)) (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)) (define-values (new-exp2 assoc-list2 new-tmpcount) (rco-arg e2 new-tmpcount1))
(values (wrap-associations (append assoc-list1 assoc-list2) (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) [`(let ([,var ,e]) ,body)
(begin (begin
(define-values (exp-tmp exp-tmpcount) (rco-exp e tmpcount)) (define-values (exp-tmp exp-tmpcount) (rco-exp e tmpcount))