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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
|
R0 has e (s-exp to be evaluated)
a (the environment / symbol table) at a known location
; e to be evaluated in R0
; result of evaluation in R0
eval: (e) =
003000 032710 BIT #1, (R0) ; test if e is cons or atom
003002 000001
003004 001403 BEQ not_atom ; branch if not atom(e)
003006 004737 JSR PC, #assoc ; return assoc(e)
003010 004500
003012 000207 RTS PC
not_atom:
; R7 = PC
; R6 = SP
; R5 = a (symbol table)
; R4 = e (original sexp)
; R3 = args = tl = cdr(e)
; R2 = hd, symbols = second = car(cdr(hd))
; R1 = arg2
; R0 = arg1, result
003014 010004 MOV R0, R4 ; save e
003016 011402 MOV @R4, R2 ; hd <- car(e)
003020 032712 BIT #1, (R2) ; test if hd is cons or atom
003022 000001
003024 001402 BEQ 4 ; branch if cons
003026 000137 JMP head_is_atom ; jump if atom(hd)
003030 003300
; otherwise (if cons):
003032 011200 MOV @R2, R0 ; arg1 <- car(hd) = first
003034 012701 MOV "LABEL", R1 ; arg2 <- at"LABEL"
003036 005100
003040 004737 JSR PC, #eq ; test eq(first, at"LABEL")
003042 004600
003044 001020 BNE not_label ; branch if not label
; if is label
003046 016202 MOV 2(R2), R2 ; rest <- cdr(hd)
003050 000002
003052 016203 MOV 2(R2), R3 ; rest' <- cdr(rest)
003054 000002
; R2 = rest
; R3 = rest'
; push entry l[second, third] onto symbol table a
003056 011225 MOV @R2, (R5)+ ; push second (=car(rest)) onto symbol table column 0
003060 011325 MOV @R3, (R5)+ ; push third (=car(rest')) onto symbol table column 1
; evaluate cons(third, tl) in extended environment
; R0 <- cons(third, tl)
003062 011300 MOV @R3, R0 ; arg1 <- third (=car(rest'))
003064 016401 MOV 2(R4), R1 ; arg2 <- tl = cdr(e)
003066 000002
003070 004737 JSR PC, #cons ; result in R0
003072 004400
003074 004737 JSR PC, #eval ; result <- eval(cons(third, tl))
003076 003000
003100 162705 SUB 4, R5 ; pop off symbol table entry
003102 000004
003104 000207 RTS PC ; return result in R0
not_label:
; R2 = hd
003106 011200 MOV @R2, R0 ; arg1 <- car(hd) = first
003110 012701 MOV "LAMBDA", R1 ; arg2 <- at"LAMBDA"
003112 005110
003114 004737 JSR PC, #eq ; test eq(first, at"LAMBDA")
003116 004600
003120 001043 BNE not_lambda ; branch if not lambda
; if is lambda
; push onto a ; a <- append(pair(second, evlis(tl)), a)
003122 010546 MOV R5, -(SP) ; push old symbol table pointer to stack
003124 016201 MOV 2(R2), R1 ; rest <- cdr(hd)
003126 000002
003130 011102 MOV @R1, R2 ; symbols <- car(rest) = second
003132 016403 MOV 2(R4), R3 ; args <- tl = cdr(e)
003134 000002
003136 010146 MOV R1, -(SP) ; save rest
; R2 = symbols
; R3 = args
evlis: (symbols, args)
003140 032712 BIT #1, (R2) ; test if symbols is cons or atom
003142 000001
003144 001021 BNE done ; if its atom jump to done
; if its cons:
003146 032713 BIT #1, (R3) ; test if args is cons or atom
003150 000001
003152 001016 BNE done ; if its atom jump to done
; if both are cons:
003154 011300 MOV @R3, R0 ; arg1 <- car(args)
003156 010246 MOV R2, -(SP) ; save symbos
003160 010346 MOV R3, -(SP) ; save args
003162 004737 JSR PC, #eval ; result <- eval (arg1)
003164 003000
003166 012603 MOV (SP)+, R3 ; restore args
003170 012602 MOV (SP)+, R2 ; restore symbols
; push (symbol, eval(arg))
003172 011225 MOV @R2, (R5)+ ; push symbol (=car(symbols)) to column 0
003174 010025 MOV R0, (R5)+ ; push result to column 1
003176 016202 MOV 2(R2), R2 ; args <- cdr(args)
003200 000002
003202 016303 MOV 2(R3), R3 ; symbols <- cdr(symbols)
003204 000002
003206 000754 BR evlis ; jump to evlis(symbols, args)
done:
003210 012601 MOV (SP)+, R1 ; restore rest
; R1 = rest
003212 016101 MOV 2(R1), R1 ; rest' <- cdr(rest)
003214 000002
003216 011100 MOV @R1, R0 ; arg1 <- third = car(rest')
003220 004737 JSR PC, #eval ; result <- eval(third)
003222 003000
; pop off argument entries
003224 012605 MOV (SP)+, R5 ; restore symbol table pointer
003226 000207 RTS PC
not_lambda:
; R2 = hd
003230 011200 MOV @R2, R0 ; arg1 <- car(hd) = first
003232 012701 MOV "DEFINE", R1 ; arg2 <- at"DEFINE"
003234 005122
003236 004737 JSR PC, #eq ; test eq(first, at"DEFINE")
003240 004600
003242 001377 BNE error ; infinite loop if not define
; if is define
; push entry l[cp(second), cp(third)] onto symbol table
003244 016203 MOV 2(R2), R3 ; rest <- cdr(hd)
003246 000002
003250 011300 MOV @R3, R0 ; arg1 <- second (=car(rest))
003252 004737 JSR PC, @copy ; copy second to big heap
003254 005400
003256 010025 MOV R0, (R5)+ ; push cp(second) onto symbol table column 0
003260 017300 MOV @2(R3), R0 ; arg1 <- third (=car(cdr(rest)))
003262 000002
003264 004737 JSR PC, @copy ; copy third to big heap
003266 005400
003270 010025 MOV R0, (R5)+ ; push cp(third) onto symbol table column 1
003272 012700 MOV "NIL", R0 ; result <- at"NIL"
003274 005000
003276 000207 RTS PC ; return result
head_is_atom:
; R2 = hd
; R3 = tl
; R4 = e
003300 016403 MOV 2(R4), R3 ; tl <- cdr(e)
003302 000002
003304 010200 MOV R2, R0 ; arg1 <- hd
003306 012701 MOV "QUOTE", R1 ; arg2 <- at"QUOTE"
003310 005016
003312 004737 JSR PC, #eq ; test eq(hd, at"QUOTE")
003314 004600
003316 001002 BNE next ; skip if not quote
; return car(tl)
003320 011300 MOV @R3, R0
003322 000207 RTS PC
next:
003324 010200 MOV R2, R0 ; arg1 <- hd
003326 012701 MOV "ATOM", R1 ; arg2 <- at"ATOM"
003330 005026
003332 004737 JSR PC, #eq ; test eq(hd, at"ATOM")
003334 004600
003336 001014 BNE next ; skip if not atom
; return atom(eval(car(tl)))
003340 011300 MOV @R3, R0 ; arg1 <- car(tl)
003342 004737 JSR PC, #eval ; result <- eval(car(tl))
003344 003000
003346 032710 BIT #1, (R0) ; test if e is cons or atom
003350 000001
003352 001403 BEQ not_atom ; branch if not atom
; is atom
003354 012700 MOV "T" R0
003356 005006
003360 000207 RTS PC
; not_atom
003362 012700 MOV "F" R0
003364 005012
003366 000207 RTS PC
next:
003370 010200 MOV R2, R0 ; arg1 <- hd
003372 012701 MOV "EQ", R1 ; arg2 <- at"EQ"
003374 005036
003376 004737 JSR PC, #eq ; test eq(hd, at"EQ")
003400 004600
003402 001026 BNE next ; skip if not eq
; return eq(eval(car(tl)), eval(cadr(tl)))
003404 011300 MOV @R3, R0 ; arg1 <- car(tl)
003406 010346 MOV R3, -(SP) ; save tl
003410 004737 JSR PC, #eval ; result <- eval(car(tl))
003412 003000
003414 012603 MOV (SP)+, R3 ; restore tl
003416 010046 MOV R0, -(SP) ; push eq arg1 = result
003420 016300 MOV 2(R3), R0 ; rest <- cdr(tl)
003422 000002
003424 011000 MOV @R0, R0 ; arg1 <- car(rest)
003426 004737 JSR PC, #eval ; result <- eval(cadr(tl))
003430 003000
003432 010001 MOV R0, R1 ; arg2 <- result
003134 012600 MOV (SP)+, R0 ; pop arg1
003436 004737 JSR PC, #eq ; test if equal
003440 004600
003442 001003 BNE not_eq
; eq
003444 012700 MOV "T" R0
003446 005006
003450 000207 RTS PC
; not_eq
003452 012700 MOV "F" R0
003454 005012
003456 000207 RTS PC
next:
003460 010200 MOV R2, R0 ; arg1 <- hd
003462 012701 MOV "COND", R1 ; arg2 <- at"COND"
003464 005044
003466 004737 JSR PC, #eq ; test eq(hd, at"COND")
003470 004600
003472 001026 BNE next ; skip if not cond
; return evcon(tl)
00474 010302 MOV R3, R2 ; c <- tl
evcon:
; R1 = arg1 = at"T"
; R2 = c
003476 011200 MOV @R2, R0 ; car(c)
003500 011000 MOV @R0, R0 ; arg1 <- caar(c)
003502 010246 MOV R2, -(SP) ; save c
003504 004737 JSR PC, #eval ; arg1 <- eval(caar(c))
003506 003000
003510 012602 MOV (SP)+, R2 ; restore c
003512 012701 MOV "T" R1 ; arg2 <- at"T"
003514 005006
003516 004737 JSR PC, #eq ; check if it's at"T"
003520 004600
003522 001403 BEQ is_true
; if not true
003524 016202 MOV 2(R2), R2 ; c <- cdr(c)
003526 000002
003530 000762 BR evcon ; evcon(c)
; if true
003532 011200 MOV @R2, R0 ; car(c)
003534 016000 MOV 2(R0), R0 ; cdar(c)
003536 000002
003540 011000 MOV @R0, R0 ; arg1 <- cadar(c)
003542 004737 JSR PC, #eval ; result <- eval(cadar(c))
003544 003000
003546 000207 RTS PC
next:
003550 010200 MOV R2, R0 ; arg1 <- hd
003552 012701 MOV "CAR", R1 ; arg2 <- at"CAR"
003554 005054
003556 004737 JSR PC, #eq ; test eq(hd, at"CAR")
003560 004600
003562 001005 BNE next ; skip if not car
; return car(eval(car(tl)))
003564 011300 MOV @R3, R0 ; arg1 <- car(tl)
003566 004737 JSR PC, #eval ; result <- eval(car(tl))
003570 003000
003572 011000 MOV @R0, R0 ; result <- car(result)
003574 000207 RTS PC
next:
003576 010200 MOV R2, R0 ; arg1 <- hd
003600 012701 MOV "CDR", R1 ; arg2 <- at"CDR"
003602 005062
003604 004737 JSR PC, #eq ; test eq(hd, at"CDR")
003606 004600
003610 001006 BNE next ; skip if not cdr
; return cdr(eval(car(tl)))
003612 011300 MOV @R3, R0 ; arg1 <- car(tl)
003614 004737 JSR PC, #eval ; result <- eval(car(tl))
003616 003000
003620 016000 MOV 2(R0), R0 ; result <- cdr(result)
003622 000002
003624 000207 RTS PC
next:
003626 010200 MOV R2, R0 ; arg1 <- hd
003630 012701 MOV "CONS", R1 ; arg2 <- at"CONS"
003632 005070
003634 004737 JSR PC, #eq ; test eq(hd, at"CONS")
003636 004600
003640 001020 BNE otherwise ; skip if not cons
; return cons(eval(car(tl)), eval(cadr(tl)))
003642 011300 MOV @R3, R0 ; arg1 <- car(tl)
003644 010346 MOV R3, -(SP) ; save tl
003646 004737 JSR PC, #eval ; result <- eval(car(tl))
003650 003000
003652 012603 MOV (SP)+, R3 ; restore tl
003654 010046 MOV R0, -(SP) ; push cons arg1
003656 016300 MOV 2(R3), R0 ; rest <- cdr(tl)
003660 000002
003662 011000 MOV @R0, R0 ; arg1 <- car(rest)
003664 004737 JSR PC, #eval ; result <- eval(cadr(tl))
003666 003000
003670 010001 MOV R0, R1 ; arg2 <- result
003672 012600 MOV (SP)+, R0 ; pop arg1
003674 004737 JSR PC, #cons
003676 004400
003700 000207 RTS PC
otherwise:
; return eval(cons(assoc(hd), tl))
003702 010200 MOV R2, R0 ; arg <- hd
003704 004737 JSR PC, #assoc ; arg1 <- assoc(hd)
003706 004500
003710 010301 MOV R3, R1 ; arg2 <- tl
003712 004737 JSR PC, #cons ; arg <- cons(assoc(hd), tl)
003714 004400
003716 004737 JSR PC, #eval ; result <- eval(arg)
003720 003000
003722 000207 RTS PC
; This one touches R0, R1
eq:
; R0 = arg1
; R1 = arg2
004600 032710 BIT #1, (R0) ; test if arg1 is cons or atom
004602 000001
004604 001420 BEQ bad ; if its cons jump to error
; otherwise its atom
004606 032711 BIT #1, (R1) ; test if arg2 is cons or atom
004610 000001
004612 001415 BEQ bad ; if its cons jump to error
; get the string pointers out of atoms arg1 and arg2
004614 011000 MOV @(R0), R0
004616 005300 DEC R0
004620 011101 MOV @(R1), R1
004622 005301 DEC R1
loop:
004624 121021 CMPB (R0), (R1)+ ; compare a byte from each string
; advance R1 pointer
004626 001003 BNE not_equal
; if they are equal:
004630 105720 TSTB (R0)+ ; check if null byte
; advance R0 pointer
004632 001403 BEQ done ; if null byte, strings are equal
; otherwise, not done yet:
004634 000773 BR loop
not_equal:
; the strings are not equal
004636 000244 CLZ ; clear zero flag
004640 000207 RTS PC
done:
; the strings are equal
004642 000264 SEZ ; set zero flag
004644 000207 RTS PC
bad:
004646 000777 BR -2 ; infinite loop
; THIS ONE TOUCHES R0, R2
cons:
; R0 = arg1
; R1 = arg2
; heap at 10000
; no garbage collection
; pretend heap is infinite
004400 013702 MOV @#10000, R2 ; get free pointer
004402 010000
004404 010012 MOV R0, @R2 ; move arg1 to car of new cons cell
004406 010162 MOV R1, 2(R2) ; move arg2 to cdr of new cons cell
004410 000002
004412 010200 MOV R2, R0 ; result <- new cons cell
004414 062702 ADD 4, R2 ; advance free pointer
004416 000004
004420 010237 MOV R2, @#10000 ; store new free pointer
004422 010000
004424 000207 RTS PC
; This one touches R0, R1, R2, R4
assoc:
004500 010504 MOV R5, R4
004502 010002 MOV R0, R2
; R1 = key
; R2 = symbol
; R4 = symbol table pointer
loop:
004504 020427 CMP R4, #6000 ; beginning of symbol table
004506 006000
004510 101411 BLOS bad ; symbol not found
; otherwise check next row
004512 005744 TST -(R4) ; skip column 1
004514 014401 MOV -(R4), R1 ; key <- column 0
004516 010200 MOV R2, R0 ; arg1 <- symbol
004520 004737 JSR PC, #eq ; check if symbol equals key
004522 004600
004524 001367 BNE loop
; otherwise they are equal
004526 016400 MOV 2(R4), R0 ; result <- value
004530 000002
004532 000207 RTS PC
bad:
004534 000777 BR -2 ; infinite loop
|
