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