Read works, print works, eval is horribly broken.

project.clj

@@ -5,6 +5,7 @@
             :url "https://www.eclipse.org/legal/epl-2.0/"}
   :dependencies [[org.clojure/clojure "1.10.0"]
                  [org.clojure/math.numeric-tower "0.0.4"]
+                 [org.clojure/tools.trace "0.7.10"]
                  [instaparse "1.4.10"]]
   :main ^:skip-aot beowulf.core
   :target-path "target/%s"

resources/bootstrap.lsp

@@ -0,0 +1,2 @@
+(COMMENT '(THIS FILE WILL CONTAIN FUNCTION DEFINITIONS TO BOOTSTRAP LISP FULLSTOP
+  AT PRESENT WE HAVE NO COMMENT SYNTAX))

src/beowulf/cons_cell.clj

@@ -3,7 +3,9 @@
 
 (def NIL (symbol "NIL"))
 
-(def NIL (symbol "NIL"))
+(def T (symbol "T")) ;; true.
+
+(def F (symbol "F")) ;; false as distinct from nil
 
 (deftype ConsCell [CAR CDR]
   clojure.lang.ISeq

src/beowulf/core.clj

@@ -1,7 +1,17 @@
 (ns beowulf.core
+  (:require [beowulf.eval :refer [primitive-eval oblist]]
+            [beowulf.read :refer [primitive-read]]
+            [beowulf.print :refer [primitive-print prin]])
   (:gen-class))
 
 (defn -main
   "I don't do a whole lot ... yet."
   [& args]
-  (println "Hello, World!"))
+  (println "Hello, World!")
+  (loop []
+    (print ":: ")
+    (flush)
+    (let [input (primitive-read)]
+      (println (str "\tI read: " (prin input)))
+      (println (str ">  "(prin (primitive-eval input @oblist))))
+      (recur))))

src/beowulf/eval.clj

@@ -1,25 +1,283 @@
 (ns beowulf.eval
-  (:require [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]]))
+  (:require [clojure.tools.trace :refer :all]
+            [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]))
 
-(declare *oblist* primitive-eval)
+(declare primitive-eval)
 
+(def oblist
+  "The default environment; modified certainly be `LABEL` (which seems to
+  be Lisp 1.5's equivalent of `SETQ`), possibly by other things."
+  (atom NIL))
 
-
-(defn primitive-eval
+(defn null
   [x]
+  (= x NIL))
+
+(defn primitive-atom
+  "It is not clear to me from the documentation whether `(ATOM 7)` should return
+  `'T` or `'F`. I'm going to assume `'T`."
+  [x]
+  (if (or (symbol? x) (number? x)) 'T 'F))
+
+(defn primitive-atom?
+  "The convention of returning `'F` from predicates, rather than `NIL`, is going
+  to tie me in knots. This is a variant of `primitive-atom` which returns `NIL`
+  on failure."
+  [x]
+  (if (or (symbol? x) (number? x)) 'T NIL))
+
+(defn car
+  [x]
+  (if
+    (instance? beowulf.cons_cell.ConsCell x)
+    (.CAR x)
+    NIL))
+
+(defn cdr
+  [x]
+  (if
+    (instance? beowulf.cons_cell.ConsCell x)
+    (.CDR x)
+    NIL))
+
+(defn uaf
+  "Universal access function; `l` is expected to be an arbitrary list, `path`
+  a (clojure) list of the characters `a` and `d`. Intended to make declaring
+  all those fiddly `#'c[ad]+r'` functions a bit easier"
+  [l path]
   (cond
-    (number? x) x
-    (symbol? x) (@*oblist* x)
-    (instance? x beowulf.cons_cell.ConsCell)
-    (apply (primitive-eval (.CAR x)) (map primitive-eval (.CDR x)))
+    (null l) NIL
+    (not (instance? beowulf.cons_cell.ConsCell l))
+    (throw (Exception. (str "Unexpected list argument to uaf: `" l "`")))
+    (empty? (rest path))(case (first path)
+                          \a (car l)
+                          \d (cdr l))
+    :else (case (first path)
+            \a (uaf (car l) (rest path))
+            \d (uaf (cdr l) (rest path)))))
+
+(defn caar [x] (uaf x (seq "aa")))
+(defn cadr [x] (uaf x (seq "ad")))
+(defn cddr [x] (uaf x (seq "dd")))
+(defn cdar [x] (uaf x (seq "da")))
+
+(defn caaar [x] (uaf x (seq "aaa")))
+(defn caadr [x] (uaf x (seq "aad")))
+(defn cadar [x] (uaf x (seq "ada")))
+(defn caddr [x] (uaf x (seq "add")))
+(defn cddar [x] (uaf x (seq "dda")))
+(defn cdddr [x] (uaf x (seq "ddd")))
+(defn cdaar [x] (uaf x (seq "daa")))
+(defn cdadr [x] (uaf x (seq "dad")))
+
+(defn caaaar [x] (uaf x (seq "aaaa")))
+(defn caadar [x] (uaf x (seq "aada")))
+(defn cadaar [x] (uaf x (seq "adaa")))
+(defn caddar [x] (uaf x (seq "adda")))
+(defn cddaar [x] (uaf x (seq "ddaa")))
+(defn cdddar [x] (uaf x (seq "ddda")))
+(defn cdaaar [x] (uaf x (seq "daaa")))
+(defn cdadar [x] (uaf x (seq "dada")))
+(defn caaadr [x] (uaf x (seq "aaad")))
+(defn caaddr [x] (uaf x (seq "aadd")))
+(defn cadadr [x] (uaf x (seq "adad")))
+(defn cadddr [x] (uaf x (seq "addd")))
+(defn cddadr [x] (uaf x (seq "ddad")))
+(defn cddddr [x] (uaf x (seq "dddd")))
+(defn cdaadr [x] (uaf x (seq "daad")))
+(defn cdaddr [x] (uaf x (seq "dadd")))
+
+;; (defn eq
+;;   "`eq` is only defined for atoms (symbols); it is NOT pointer identity, as
+;;   it is in later Lisps. Returns `'T` on success (identical atoms), `'F`
+;;   (NOT `NIL`) on failure. The behaviour if either argument is not an atom is
+;;   stated to be 'undefined', but I shall return `'F` for consistency."I
+;;   [x y]
+;;   (cond
+;;     (and (primitive-atom? x) (= x y)) 'T
+;;     :else
+;;     'F))
+
+(defn eq [x y] (if (and (primitive-atom? x) (= x y)) T F))
+
+(defn equal
+  "This is a predicate that is true if its two arguments are identical
+  S-expressions, and false if they are different. (The elementary predicate
+  `eq` is defined only for atomic arguments.) The definition of `equal` is
+  an example of a conditional expression inside a conditional expression."
+  [x y]
+  (cond
+    (primitive-atom? x) (cond
+                  (primitive-atom? y) (eq x y)
+                  :else 'F) ;; NOTE: returns F on failure, not NIL
+    (equal (car x) (car y)) (equal (cdr x) (cdr y))
+    :else 'F))
+
+(defn subst
+  "This function gives the result of substituting the S-expression `x` for
+  all occurrences of the atomic symbol `y` in the S-expression `z`."
+  [x y z]
+  (cond
+    (equal y z) x
+    (primitive-atom? z) z ;; NIL is a symbol
     :else
-    (throw (Exception. (str "Don't know how to eval `" x "`")))))
+    (make-cons-cell (subst x y (car z)) (subst x y (cdr z)))))
+
+(defn append
+  "Append the the elements of `y` to the elements of `x`.
+
+  All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
+  See page 11 of the Lisp 1.5 Programmers Manual."
+  [x y]
+  (cond
+   (null x) y
+    :else
+    (cons (car x) (append (cdr x) y))))
 
 
-(def ^:dynamic *oblist*
-  "The base environment."
-  (atom {'NIL NIL
-         'F NIL
-         'T 'T
-         'eval primitive-eval}))
+(defn member
+  "This predicate is true if the S-expression `x` occurs among the elements
+  of the list `y`.
+
+  All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
+  See page 11 of the Lisp 1.5 Programmers Manual."
+  [x y]
+  (cond
+    (= y NIL) F ;; NOTE: returns F on falsity, not NIL
+    (equal x (car y)) T
+    :else (member x (cdr y))))
+
+(defn pairlis
+  "This function gives the list of pairs of corresponding elements of the
+  lists `x` and `y`, and appends this to the list `a`. The resultant list
+  of pairs, which is like a table with two columns, is called an
+  association list.
+
+  Eessentially, it builds the environment on the stack, implementing shallow
+  binding.
+
+  All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
+  See page 12 of the Lisp 1.5 Programmers Manual."
+  [x y a]
+  (cond
+    ;; the original tests only x; testing y as well will be a little more
+    ;; robust if `x` and `y` are not the same length.
+    (or (null x) (null y)) a
+    :else (make-cons-cell
+            (make-cons-cell (car x) (car y))
+            (pairlis (cdr x) (cdr y) a))))
+
+(defn primitive-assoc
+  "If a is an association list such as the one formed by pairlis in the above
+  example, then assoc will produce the first pair whose first term is x. Thus
+  it is a table searching function.
+
+  All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
+  See page 12 of the Lisp 1.5 Programmers Manual."
+  [x a]
+  (cond
+    (null a) NIL ;; this clause is not present in the original but is added for
+    ;; robustness.
+    (equal (caar a) x) (car a)
+    :else
+    (primitive-assoc x (cdr a))))
+
+(defn- sub2
+  "Internal to `sublis`, q.v., which substitutes into a list from a store.
+  ? I think this is doing variable binding in the stack frame?"
+  [a z]
+  (cond
+    (null a) z
+    (= (caar a) z) (cdar a)
+    :else
+    (sub2 (cdr a) z)))
+
+(defn sublis
+  "Here `a` is assumed to be an association list of the form
+  `((ul . vl)...(un . vn))`, where the `u`s are atomic, and `y` is any
+  S-expression. What `sublis` does, is to treat the `u`s as variables when
+  they occur in `y`, and to substitute the corresponding `v`s from the pair
+  list.
+
+  My interpretation is that this is variable binding in the stack frame.
+
+  All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
+  See page 12 of the Lisp 1.5 Programmers Manual."
+  [a y]
+  (cond
+    (primitive-atom? y) (sub2 a y)
+    :else
+    (make-cons-cell (sublis a (car y)) (sublis a (cdr y)))))
+
+(deftrace primitive-apply
+  "For bootstrapping, at least, a version of APPLY written in Clojure.
+  All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
+  See page 13 of the Lisp 1.5 Programmers Manual."
+  [function args environment]
+  (cond
+    (primitive-atom? function)(cond
+                        (= function 'CAR) (caar args)
+                        (= function 'CDR) (cdar args)
+                        (= function 'CONS) (make-cons-cell (car args) (cadr args))
+                        (= function 'ATOM) (if (primitive-atom? (car args)) T NIL)
+                        (= function 'EQ) (if (= (car args) (cadr args)) T NIL)
+                        :else
+                        (primitive-apply
+                          (primitive-eval function environment)
+                          args
+                          environment))
+    (= (first function) 'LAMBDA) (primitive-eval
+                                   (caddr function)
+                                   (pairlis (cadr function) args environment))
+    (= (first function) 'LABEL) (primitive-apply
+                                  (caddr function)
+                                  args
+                                  (make-cons-cell
+                                    (make-cons-cell
+                                      (cadr function)
+                                      (caddr function))
+                                    environment))))
+
+(defn- evcon
+  "Inner guts of primitive COND. All args are assumed to be
+  `beowulf.cons-cell/ConsCell` objects.
+  See page 13 of the Lisp 1.5 Programmers Manual."
+  [clauses env]
+  (cond
+    (not= (primitive-eval (caar clauses) env) NIL)
+    (primitive-eval (cadar clauses) env)
+    :else
+    (evcon (cdr clauses) env)))
+
+(defn- evlis
+  "Map `primitive-eval` across this list of `args` in the context of this
+  `env`ironment.All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
+  See page 13 of the Lisp 1.5 Programmers Manual."
+  [args env]
+  (cond
+    (null args) NIL
+    :else
+    (make-cons-cell
+      (primitive-eval (car args) env)
+      (evlis (cdr args) env))))
+
+
+(deftrace primitive-eval
+  "For bootstrapping, at least, a version of EVAL written in Clojure.
+  All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
+  See page 13 of the Lisp 1.5 Programmers Manual."
+  [expr env]
+  (cond
+    (primitive-atom? expr) (cdr (primitive-assoc expr env))
+    (primitive-atom? (car expr))(cond
+                          (eq (car expr) 'QUOTE) (cadr expr)
+                          (eq (car expr) 'COND) (evcon (cdr expr) env)
+                          :else (primitive-apply
+                                  (car expr)
+                                  (evlis (cdr expr) env)
+                                  env))
+    :else (primitive-apply
+            (car expr)
+            (evlis (cdr expr) env)
+            env)))
 

src/beowulf/functions.clj

@@ -1,32 +0,0 @@
-(ns beowulf.functions
-  (:require [beowulf.read :as r]
-            [beowulf.print :as p])
-  )
-
-(defn car
-  [sexpr]
-  (if
-    (list? sexpr)
-    (first sexpr)
-    (throw (Exception. "Undefined: car[" (p/prin sexpr) "]"))))
-
-(defn cdr
-  [sexpr]
-  (if
-    (list? sexpr)
-    (rest sexpr)
-    (throw (Exception. "Undefined: cdr[" (p/prin sexpr) "]"))))
-
-(defn eq
-  "eq, in LISP 1.5, is equality of atoms, only."
-  [a b]
-  (if
-    (and (symbol? a)(symbol? b))
-    (= a b)
-    (throw (Exception. "Undefined: eq[" (p/prn a) ";" (p/prn b) "]"))))
-
-(defn atom
-  [sexpr]
-  (symbol? sexpr))
-
-

src/beowulf/print.clj

@@ -51,3 +51,9 @@
     [x]
     (str x)))
 
+(defn primitive-print
+  [x]
+  (if
+    (satisfies? beowulf.print.Printable x) (prin x)
+    (str x)))
+

src/beowulf/read.clj

@@ -266,3 +266,6 @@
       (throw (Exception. (str "Cannot yet generate " (first p)))))
     p))
 
+(defn primitive-read
+  []
+  (generate (simplify (parse (read-line)))))