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