001 (ns beowulf.bootstrap
002 "Lisp as defined in Chapter 1 (pages 1-14) of the
003 `Lisp 1.5 Programmer's Manual`; that is to say, a very simple Lisp language,
004 which should, I believe, be sufficient in conjunction with the functions
005 provided by `beowulf.host`, be sufficient to bootstrap the full Lisp 1.5
006 interpreter..
007
008 The convention is adopted that functions in this file with names in
009 ALLUPPERCASE are Lisp 1.5 functions (although written in Clojure) and that
010 therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell`
011 objects."
012 (:require [clojure.tools.trace :refer :all]
013 [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]))
014
015 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
016 ;;;
017 ;;; This file is essentially Lisp as defined in Chapter 1 (pages 1-14) of the
018 ;;; Lisp 1.5 Programmer's Manual; that is to say, a very simple Lisp language,
019 ;;; which should, I believe, be sufficient in conjunction with the functions
020 ;;; provided by `beowulf.host`, be sufficient to bootstrap the full Lisp 1.5
021 ;;; interpreter.
022 ;;;
023 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
024
025 (declare EVAL)
026
027 (def oblist
028 "The default environment."
029 (atom NIL))
030
031 (def ^:dynamic *options*
032 "Command line options from invocation."
033 {})
034
035 (defmacro NULL
036 "Returns `T` if and only if the argument `x` is bound to `NIL`; else `F`."
037 [x]
038 `(if (= ~x NIL) T F))
039
040 (defmacro ATOM
041 "Returns `T` if and only is the argument `x` is bound to and atom; else `F`.
042 It is not clear to me from the documentation whether `(ATOM 7)` should return
043 `T` or `F`. I'm going to assume `T`."
044 [x]
045 `(if (or (symbol? ~x) (number? ~x)) T F))
046
047 (defmacro ATOM?
048 "The convention of returning `F` from predicates, rather than `NIL`, is going
049 to tie me in knots. This is a variant of `ATOM` which returns `NIL`
050 on failure."
051 [x]
052 `(if (or (symbol? ~x) (number? ~x)) T NIL))
053
054 (defn CAR
055 "Return the item indicated by the first pointer of a pair. NIL is treated
056 specially: the CAR of NIL is NIL."
057 [x]
058 (cond
059 (= x NIL) NIL
060 (instance? beowulf.cons_cell.ConsCell x) (.CAR x)
061 :else
062 (throw
063 (Exception.
064 (str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")")))))
065
066 (defn CDR
067 "Return the item indicated by the second pointer of a pair. NIL is treated
068 specially: the CDR of NIL is NIL."
069 [x]
070 (cond
071 (= x NIL) NIL
072 (instance? beowulf.cons_cell.ConsCell x) (.CDR x)
073 :else
074 (throw
075 (Exception.
076 (str "Cannot take CDR of `" x "` (" (.getName (.getClass x)) ")")))))
077
078 (defn uaf
079 "Universal access function; `l` is expected to be an arbitrary list, `path`
080 a (clojure) list of the characters `a` and `d`. Intended to make declaring
081 all those fiddly `#'c[ad]+r'` functions a bit easier"
082 [l path]
083 (cond
084 (= l NIL) NIL
085 (empty? path) l
086 :else (case (last path)
087 \a (uaf (CAR l) (butlast path))
088 \d (uaf (CDR l) (butlast path)))))
089
090 (defn CAAR [x] (uaf x (seq "aa")))
091 (defn CADR [x] (uaf x (seq "ad")))
092 (defn CDDR [x] (uaf x (seq "dd")))
093 (defn CDAR [x] (uaf x (seq "da")))
094
095 (defn CAAAR [x] (uaf x (seq "aaa")))
096 (defn CAADR [x] (uaf x (seq "aad")))
097 (defn CADAR [x] (uaf x (seq "ada")))
098 (defn CADDR [x] (uaf x (seq "add")))
099 (defn CDDAR [x] (uaf x (seq "dda")))
100 (defn CDDDR [x] (uaf x (seq "ddd")))
101 (defn CDAAR [x] (uaf x (seq "daa")))
102 (defn CDADR [x] (uaf x (seq "dad")))
103
104 (defn CAAAAR [x] (uaf x (seq "aaaa")))
105 (defn CAADAR [x] (uaf x (seq "aada")))
106 (defn CADAAR [x] (uaf x (seq "adaa")))
107 (defn CADDAR [x] (uaf x (seq "adda")))
108 (defn CDDAAR [x] (uaf x (seq "ddaa")))
109 (defn CDDDAR [x] (uaf x (seq "ddda")))
110 (defn CDAAAR [x] (uaf x (seq "daaa")))
111 (defn CDADAR [x] (uaf x (seq "dada")))
112 (defn CAAADR [x] (uaf x (seq "aaad")))
113 (defn CAADDR [x] (uaf x (seq "aadd")))
114 (defn CADADR [x] (uaf x (seq "adad")))
115 (defn CADDDR [x] (uaf x (seq "addd")))
116 (defn CDDADR [x] (uaf x (seq "ddad")))
117 (defn CDDDDR [x] (uaf x (seq "dddd")))
118 (defn CDAADR [x] (uaf x (seq "daad")))
119 (defn CDADDR [x] (uaf x (seq "dadd")))
120
121 (defn EQ
122 "Returns `T` if and only if both `x` and `y` are bound to the same atom,
123 else `F`."
124 [x y]
125 (if (and (= (ATOM x) T) (= x y)) T F))
126
127 (defn EQUAL
128 "This is a predicate that is true if its two arguments are identical
129 S-expressions, and false if they are different. (The elementary predicate
130 `EQ` is defined only for atomic arguments.) The definition of `EQUAL` is
131 an example of a conditional expression inside a conditional expression.
132
133 NOTE: returns `F` on failure, not `NIL`"
134 [x y]
135 (cond
136 (= (ATOM x) T) (EQ x y)
137 (= (EQUAL (CAR x) (CAR y)) T) (EQUAL (CDR x) (CDR y))
138 :else F))
139
140 (defn SUBST
141 "This function gives the result of substituting the S-expression `x` for
142 all occurrences of the atomic symbol `y` in the S-expression `z`."
143 [x y z]
144 (cond
145 (= (EQUAL y z) T) x
146 (= (ATOM? z) T) z ;; NIL is a symbol
147 :else
148 (make-cons-cell (SUBST x y (CAR z)) (SUBST x y (CDR z)))))
149
150 (defn APPEND
151 "Append the the elements of `y` to the elements of `x`.
152
153 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
154 See page 11 of the Lisp 1.5 Programmers Manual."
155 [x y]
156 (cond
157 (= x NIL) y
158 :else
159 (make-cons-cell (CAR x) (APPEND (CDR x) y))))
160
161
162 (defn MEMBER
163 "This predicate is true if the S-expression `x` occurs among the elements
164 of the list `y`.
165
166 All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
167 See page 11 of the Lisp 1.5 Programmers Manual."
168 [x y]
169 (cond
170 (= y NIL) F ;; NOTE: returns F on falsity, not NIL
171 (= (EQUAL x (CAR y)) T) T
172 :else (MEMBER x (CDR y))))
173
174 (defn PAIRLIS
175 "This function gives the list of pairs of corresponding elements of the
176 lists `x` and `y`, and APPENDs this to the list `a`. The resultant list
177 of pairs, which is like a table with two columns, is called an
178 association list.
179
180 Eessentially, it builds the environment on the stack, implementing shallow
181 binding.
182
183 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
184 See page 12 of the Lisp 1.5 Programmers Manual."
185 [x y a]
186 (cond
187 ;; the original tests only x; testing y as well will be a little more
188 ;; robust if `x` and `y` are not the same length.
189 (or (= NIL x) (= NIL y)) a
190 :else (make-cons-cell
191 (make-cons-cell (CAR x) (CAR y))
192 (PAIRLIS (CDR x) (CDR y) a))))
193
194 (defn ASSOC
195 "If a is an association list such as the one formed by PAIRLIS in the above
196 example, then assoc will produce the first pair whose first term is x. Thus
197 it is a table searching function.
198
199 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
200 See page 12 of the Lisp 1.5 Programmers Manual."
201 [x a]
202 (cond
203 (= NIL a) NIL ;; this clause is not present in the original but is added for
204 ;; robustness.
205 (= (EQUAL (CAAR a) x) T) (CAR a)
206 :else
207 (ASSOC x (CDR a))))
208
209 (defn- SUB2
210 "Internal to `SUBLIS`, q.v., which SUBSTitutes into a list from a store.
211 ? I think this is doing variable binding in the stack frame?"
212 [a z]
213 (cond
214 (= NIL a) z
215 (= (CAAR a) z) (CDAR a) ;; TODO: this looks definitely wrong
216 :else
217 (SUB2 (CDR a) z)))
218
219 (defn SUBLIS
220 "Here `a` is assumed to be an association list of the form
221 `((ul . vl)...(un . vn))`, where the `u`s are atomic, and `y` is any
222 S-expression. What `SUBLIS` does, is to treat the `u`s as variables when
223 they occur in `y`, and to SUBSTitute the corresponding `v`s from the pair
224 list.
225
226 My interpretation is that this is variable binding in the stack frame.
227
228 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
229 See page 12 of the Lisp 1.5 Programmers Manual."
230 [a y]
231 (cond
232 (= (ATOM? y) T) (SUB2 a y)
233 :else
234 (make-cons-cell (SUBLIS a (CAR y)) (SUBLIS a (CDR y)))))
235
236 (defn APPLY
237 "For bootstrapping, at least, a version of APPLY written in Clojure.
238 All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
239 See page 13 of the Lisp 1.5 Programmers Manual."
240 [function args environment]
241 (cond
242 (=
243 (ATOM? function)
244 T)(cond
245 ;; TODO: doesn't check whether `function` is bound in the environment;
246 ;; we'll need that before we can bootstrap.
247 (= function 'CAR) (CAAR args)
248 (= function 'CDR) (CDAR args)
249 (= function 'CONS) (make-cons-cell (CAR args) (CADR args))
250 (= function 'ATOM) (if (ATOM? (CAR args)) T NIL)
251 (= function 'EQ) (if (= (CAR args) (CADR args)) T NIL)
252 :else
253 (APPLY
254 (EVAL function environment)
255 args
256 environment))
257 (= (first function) 'LAMBDA) (EVAL
258 (CADDR function)
259 (PAIRLIS (CADR function) args environment))
260 (= (first function) 'LABEL) (APPLY
261 (CADDR function)
262 args
263 (make-cons-cell
264 (make-cons-cell
265 (CADR function)
266 (CADDR function))
267 environment))))
268
269 (defn- EVCON
270 "Inner guts of primitive COND. All args are assumed to be
271 `beowulf.cons-cell/ConsCell` objects.
272 See page 13 of the Lisp 1.5 Programmers Manual."
273 [clauses env]
274 (if
275 (not= (EVAL (CAAR clauses) env) NIL)
276 (EVAL (CADAR clauses) env)
277 (EVCON (CDR clauses) env)))
278
279 (defn- EVLIS
280 "Map `EVAL` across this list of `args` in the context of this
281 `env`ironment.All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
282 See page 13 of the Lisp 1.5 Programmers Manual."
283 [args env]
284 (cond
285 (= NIL args) NIL
286 :else
287 (make-cons-cell
288 (EVAL (CAR args) env)
289 (EVLIS (CDR args) env))))
290
291 (deftrace traced-eval
292 "Essentially, identical to EVAL except traced."
293 [expr env]
294 (cond
295 (=
296 (ATOM? expr) T)
297 (CDR (ASSOC expr env))
298 (=
299 (ATOM? (CAR expr))
300 T)(cond
301 (= (CAR expr) 'QUOTE) (CADR expr)
302 (= (CAR expr) 'COND) (EVCON (CDR expr) env)
303 :else (APPLY
304 (CAR expr)
305 (EVLIS (CDR expr) env)
306 env))
307 :else (APPLY
308 (CAR expr)
309 (EVLIS (CDR expr) env)
310 env)))
311
312 (defn EVAL
313 "For bootstrapping, at least, a version of EVAL written in Clojure.
314 All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
315 See page 13 of the Lisp 1.5 Programmers Manual."
316 [expr env]
317 (cond
318 (true? (:trace *options*))
319 (traced-eval expr env)
320 (=
321 (ATOM? expr) T)
322 (CDR (ASSOC expr env))
323 (=
324 (ATOM? (CAR expr))
325 T)(cond
326 (= (CAR expr) 'QUOTE) (CADR expr)
327 (= (CAR expr) 'COND) (EVCON (CDR expr) env)
328 :else (APPLY
329 (CAR expr)
330 (EVLIS (CDR expr) env)
331 env))
332 :else (APPLY
333 (CAR expr)
334 (EVLIS (CDR expr) env)
335 env)))
336
337
338