-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathcmgen.lisp
174 lines (160 loc) · 5.81 KB
/
cmgen.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
;; Generator for COMPLEX code. Should make some things easier,
;; especially line number shenanigans.
(defun find-labels (code)
(loop with labels = nil
for line-number upfrom 0
for line in code
when (eql (first line) 'label)
do (push (cons (second line) line-number) labels)
finally (return labels)))
(defun guard-negative (n)
(if (>= n 0)
(format nil "~A" n)
(format nil "0 - ~A" (- n))))
(defun compile-stmt (labels line-number line &key (use-line-number t))
(when use-line-number
(format t "~3D " line-number))
(ecase (first line)
(label (format t "SET VECTORX 1~%"))
(set (format t "SET ~A ~A~%" (second line) (compile-expr (third line))))
(print (format t "PRINT~{ ~A~}~%" (mapcar #'compile-expr (rest line))))
(if (format t "IF ~A " (compile-expr (second line)))
(compile-stmt labels line-number (third line) :use-line-number nil))
(goto (let ((value (cdr (assoc (second line) labels))))
(unless value
(error "No such label ~A" (second line)))
(format t "SET VECTORX ~A~%" (guard-negative (- value line-number)))))))
;; WARNING: The language seems to have no operator precedence rules.
;; Complicated nesting of expressions, or any nesting at all, is
;; discouraged.
(defun compile-expr (expr)
(etypecase expr
(list (ecase (first expr)
((eql +) (format nil "~A + ~A" (compile-expr (second expr)) (compile-expr (third expr))))
((eql -) (format nil "~A - ~A" (compile-expr (second expr)) (compile-expr (third expr))))))
(symbol (format nil "~A" expr))
(integer (format nil "~A" (guard-negative expr)))))
(defun compile-code (code)
(loop with labels = (find-labels code)
for line-number upfrom 0
for line in code
do (compile-stmt labels line-number line)))
(defmacro gensyms ((&rest names) &rest body)
`(let ,(loop for name in names collect (list name '(gensym))) ,@body))
;; Don't pass x=9. Always normalize to x=6 to avoid unusual behavior :)
(defun check-single (a b c d e f x &key success failure)
(gensyms (cont1 cont2 cont3 cont4 cont5 cont6)
`((if (- ,a ,x) (goto ,cont1))
(goto ,success)
(label ,cont1)
(if (- ,b ,x) (goto ,cont2))
(goto ,success)
(label ,cont2)
(if (- ,c ,x) (goto ,cont3))
(goto ,success)
(label ,cont3)
(if (- ,d ,x) (goto ,cont4))
(goto ,success)
(label ,cont4)
(if (- ,e ,x) (goto ,cont5))
(goto ,success)
(label ,cont5)
(if (- ,f ,x) (goto ,cont6))
(goto ,success)
(label ,cont6)
,@(if (= x 6)
(check-single a b c d e f 9 :success success :failure failure)
`((goto ,failure))))))
(defun check-vars (a b c d e f aa bb cc dd ee ff x y &key success failure)
(gensyms (success0 failure0 success1)
`(,@(check-single a b c d e f x :success success0 :failure failure0)
(label ,success0)
,@(check-single aa bb cc dd ee ff y :success success :failure failure0)
(label ,failure0)
,@(check-single aa bb cc dd ee ff x :success success1 :failure failure)
(label ,success1)
,@(check-single a b c d e f y :success success :failure failure))))
(defvar *code*
`((set total 0)
(set a 0)
(label next-a)
(set b (+ a 1))
(label next-b)
(set c (+ b 1))
(label next-c)
(set d (+ c 1))
(label next-d)
(set e (+ d 1))
(label next-e)
(set f (+ e 1))
(label next-f)
(set aa 0)
(label next-aa)
(set bb (+ aa 1))
(label next-bb)
(set cc (+ bb 1))
(label next-cc)
(set dd (+ cc 1))
(label next-dd)
(set ee (+ dd 1))
(label next-ee)
(set ff (+ ee 1))
(label next-ff)
;; Inside Loop
,@(check-vars 'a 'b 'c 'd 'e 'f 'aa 'bb 'cc 'dd 'ee 'ff 0 1 :success 'proceed1 :failure 'failure)
(label proceed1)
,@(check-vars 'a 'b 'c 'd 'e 'f 'aa 'bb 'cc 'dd 'ee 'ff 0 4 :success 'proceed2 :failure 'failure)
(label proceed2)
,@(check-vars 'a 'b 'c 'd 'e 'f 'aa 'bb 'cc 'dd 'ee 'ff 0 6 :success 'proceed3 :failure 'failure)
(label proceed3)
,@(check-vars 'a 'b 'c 'd 'e 'f 'aa 'bb 'cc 'dd 'ee 'ff 1 6 :success 'proceed4 :failure 'failure)
(label proceed4)
,@(check-vars 'a 'b 'c 'd 'e 'f 'aa 'bb 'cc 'dd 'ee 'ff 2 5 :success 'proceed5 :failure 'failure)
(label proceed5)
,@(check-vars 'a 'b 'c 'd 'e 'f 'aa 'bb 'cc 'dd 'ee 'ff 3 6 :success 'proceed6 :failure 'failure)
(label proceed6)
,@(check-vars 'a 'b 'c 'd 'e 'f 'aa 'bb 'cc 'dd 'ee 'ff 4 6 :success 'proceed7 :failure 'failure)
(label proceed7)
,@(check-vars 'a 'b 'c 'd 'e 'f 'aa 'bb 'cc 'dd 'ee 'ff 6 4 :success 'proceed8 :failure 'failure)
(label proceed8)
,@(check-vars 'a 'b 'c 'd 'e 'f 'aa 'bb 'cc 'dd 'ee 'ff 8 1 :success 'proceed9 :failure 'failure)
(label proceed9)
(set total (+ total 1))
(label failure)
;; End Inside Loop
(set ff (+ ff 1))
(if (- ff 10) (goto next-ff))
(set ee (+ ee 1))
(if (- ee 9) (goto next-ee))
(set dd (+ dd 1))
(if (- dd 8) (goto next-dd))
(set cc (+ cc 1))
(if (- cc 7) (goto next-cc))
(set bb (+ bb 1))
(if (- bb 6) (goto next-bb))
(set aa (+ aa 1))
(if (- aa 5) (goto next-aa))
(set f (+ f 1))
(if (- f 10) (goto next-f))
(set e (+ e 1))
(if (- e 9) (goto next-e))
(set d (+ d 1))
(if (- d 8) (goto next-d))
(set c (+ c 1))
(if (- c 7) (goto next-c))
(set b (+ b 1))
(if (- b 6) (goto next-b))
(set a (+ a 1))
(if (- a 5) (goto next-a))
;; We systematically overcounted. Let's divide by two in the most convoluted possible way.
(set answer 0)
(label keep-counting)
(if total (goto continue))
(print answer)
(goto end)
(label continue)
(set total (- total 2))
(set answer (+ answer 1))
(goto keep-counting)
(label end)))
(compile-code *code*)