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