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
|
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) =
BIT #1, (R0) ; test if e is cons or atom
BEQ not_atom ; branch if not atom(e)
JSR PC, #assoc ; return assoc(e)
; TODO assumes assoc puts result in R0
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
MOV R0, R4 ; save e
MOV @R4, R2 ; hd <- car(e)
BIT #1, (R2) ; test if hd is cons or atom
BNE head_is_atom ; branch if atom(hd)
;otherwise (if cons):
MOV @R2, R0 ; arg1 <- car(hd) = first
MOV "LABEL", R1 ; arg2 <- at"LABEL"
JSR PC, #eq ; test eq(first, at"LABEL")
BNE not_label ; branch if not label
; if is label
MOV 2(R2), R2 ; rest <- cdr(hd)
MOV 2(R2), R3 ; rest' <- cdr(rest)
; R2 = rest
; R3 = rest'
; push entry l[second, hd] onto symbol table a
; a <- cons(l[second, hd], a)
MOV @R2, (R5)+ ; push second (=car(rest)) onto symbol table column 0
MOV @R4, (R5)+ ; push hd onto symbol table column 1
; evaluate cons(third, tl) in extended environment
; R0 <- cons(third, tl)
MOV @R3, R0 ; arg1 <- third (=car(rest'))
MOV 2(R4), R1 ; arg2 <- tl = cdr(e)
JSR PC, #cons ; result in R0
JSR PC, #eval ; result <- eval(cons(third, tl))
SUB 4, R5 ; pop off symbol table entry
RTS PC ; return result in R0
not_label:
; R2 = hd
; first still in R0
MOV "LAMBDA", R1 ; arg2 <- at"LAMBDA"
JSR PC, #eq ; test eq(first, at"LAMBDA")
BNE error ; branch if not lambda
;if is lambda
; push onto a ; a <- append(pair(second, evlis(tl)), a)
MOV R5, -(SP) ; push old symbol table pointer to stack
MOV 2(R2), R1 ; rest <- cdr(hd)
MOV @R1, R2 ; symbols <- car(rest) = second
MOV 2(R4), R3 ; args <- tl = cdr(e)
; R1 = rest
; R2 = symbols
; R3 = args
evlis: (symbols, args)
BIT #1, (R2) ; test if symbols is cons or atom
BNE done ; if its atom jump to done
; if its cons:
BIT #1, (R3) ; test if args is cons or atom
BNE done ; if its atom jump to done
; if both are cons:
MOV @R3, R0 ; arg1 <- car(args)
JSR PC, #eval ; result <- eval (arg1)
; push (symbol, eval(arg))
MOV @R2, (R5)+ ; push symbol (=car(symbols)) to column 0
MOV R0, (R5)+ ; push result to column 1
MOV 2(R2), R2 ; args <- cdr(args)
MOV 2(R3), R3 ; symbols <- cdr(symbols)
BR -??? ; jump to evlis(symbols, args)
done:
MOV 2(R1), R1 ; rest' <- cdr(rest)
MOV @R1, R0 ; arg1 <- third = car(rest')
JSR PC, #eval ; result <- eval(third)
; pop off argument entries
MOV (SP)+, R5 ; restore symbol table pointer
RTS PC
error:
MOV R4, R0
BR -2 ; infinite loop
; this should never happen. ill-formed s-exp
; return bad ; maybe just return the original s-exp
RTS PC
head_is_atom: (hd, tl)
return cases
[ (eq(hd, at"QUOTE"), car(tl))
, (eq(hd, at"ATOM"), atom(eval(car(tl))))
, (eq(hd, at"EQ"), eq(eval(car(tl)), eval(cadr(tl))))
, (eq(hd, at"COND"), evcon(car(tl)))
, (eq(hd, at"CAR"), car(eval(car(tl))))
, (eq(hd, at"CDR"), cdr(eval(car(tl))))
, (eq(hd, at"CONS"), cons(eval(car(tl)), eval(cadr(tl))))
, (at"T", eval(cons(assoc(hd), tl)))
]
MOV R2, R0 ; arg1 <- hd
MOV "QUOTE", R1 ; arg2 <- at"QUOTE"
JSR PC, #eq ; test eq(hd, at"QUOTE")
BNE next ; skip if not quote
...
RTS PC
next:
MOV "ATOM", R1 ; arg2 <- at"ATOM"
JSR PC, #eq ; test eq(hd, at"ATOM")
BNE next ; skip if not atom
...
RTS PC
next:
MOV "EQ", R1 ; arg2 <- at"EQ"
JSR PC, #eq ; test eq(hd, at"EQ")
BNE next ; skip if not eq
...
RTS PC
next:
MOV "COND", R1 ; arg2 <- at"COND"
JSR PC, #eq ; test eq(hd, at"COND")
BNE next ; skip if not cond
...
RTS PC
next:
MOV "CAR", R1 ; arg2 <- at"CAR"
JSR PC, #eq ; test eq(hd, at"CAR")
BNE next ; skip if not car
...
RTS PC
next:
MOV "CDR", R1 ; arg2 <- at"CDR"
JSR PC, #eq ; test eq(hd, at"CDR")
BNE next ; skip if not cdr
...
RTS PC
next:
MOV "CONS", R1 ; arg2 <- at"CONS"
JSR PC, #eq ; test eq(hd, at"CONS")
BNE next ; skip if not cons
...
RTS PC
otherwise:
...
RTS PC
evcon(c) =
cases
[ (eval(caar(c)), eval(cadar(c)))
, (at"T", evcon(cdr(c)))
]
evlis(m) =
cases
[ (null(m), at"NIL")
, (at"T", cons(eval(car(m)), evlis(cdr(m))))
]
eq
assoc
cons
at"QUOTE"
at"ATOM"
at"EQ"
at"COND"
at"CAR"
at"CDR"
at"CONS"
at"LABEL"
at"LAMBDA"
|
