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