Added unit tests for about half the bootstrap functions

src/beowulf/cons_cell.clj

@@ -67,6 +67,42 @@
           ss))
       (str c))))
 
+(defn pretty-print
+  "This isn't the world's best pretty printer but it sort of works."
+  ([^beowulf.cons_cell.ConsCell cell]
+   (println (pretty-print cell 80 0)))
+  ([^beowulf.cons_cell.ConsCell cell width level]
+   (loop [c cell
+          n (inc level)
+          s "("]
+     (if
+       (instance? beowulf.cons_cell.ConsCell c)
+       (let [car (.CAR c)
+             cdr (.CDR c)
+             cons? (instance? beowulf.cons_cell.ConsCell cdr)
+             print-width (count (print-str c))
+             indent (apply str (repeat n "  "))
+             ss (str
+                  s
+                  (pretty-print car width n)
+                  (cond
+                    cons?
+                    (if
+                      (< (+ (count indent) print-width) width)
+                      " "
+                      (str "\n" indent))
+                    (or (nil? cdr) (= cdr 'NIL))
+                    ")"
+                    :else
+                    (str " . " (pretty-print cdr width n) ")")))]
+         (if
+           cons?
+           (recur cdr n ss)
+           ss))
+       (str c)))))
+
+
+
 (defmethod clojure.core/print-method beowulf.cons_cell.ConsCell
   [this writer]
   (.write writer (to-string this)))

src/beowulf/eval.clj

@@ -11,7 +11,7 @@
 
 (defn null
   [x]
-  (= x NIL))
+  (if (= x NIL) 'T 'F))
 
 (defn primitive-atom
   "It is not clear to me from the documentation whether `(ATOM 7)` should return
@@ -50,7 +50,7 @@
   all those fiddly `#'c[ad]+r'` functions a bit easier"
   [l path]
   (cond
-    (null l) NIL
+    (= l NIL) NIL
     (empty? path) l
     :else (case (last path)
             \a (uaf (car l) (butlast path))
@@ -87,30 +87,23 @@
 (defn cdaadr [x] (uaf x (seq "daad")))
 (defn cdaddr [x] (uaf x (seq "dadd")))
 
-;; (defn eq
+(defn eq
-;;   "`eq` is only defined for atoms (symbols); it is NOT pointer identity, as
+  ;; For some reason providing a doc string for this function breaks the
-;;   it is in later Lisps. Returns `'T` on success (identical atoms), `'F`
+  ;; Clojure parser!
-;;   (NOT `NIL`) on failure. The behaviour if either argument is not an atom is
+  [x y]
-;;   stated to be 'undefined', but I shall return `'F` for consistency."I
+  (if (and (= (primitive-atom x) 'T) (= x y)) 'T 'F))
-;;   [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."
+  an example of a conditional expression inside a conditional expression.
+
+  NOTE: returns F on failure, not NIL"
   [x y]
   (cond
-    (primitive-atom? x) (cond
+    (= (primitive-atom x) 'T) (eq x y)
-                  (primitive-atom? y) (eq x y)
+    (= (equal (car x) (car y)) 'T) (equal (cdr x) (cdr y))
-                  :else 'F) ;; NOTE: returns F on failure, not NIL
-    (equal (car x) (car y)) (equal (cdr x) (cdr y))
     :else 'F))
 
 (defn subst
@@ -118,8 +111,8 @@
   all occurrences of the atomic symbol `y` in the S-expression `z`."
   [x y z]
   (cond
-    (equal y z) x
+    (= (equal y z) 'T) x
-    (primitive-atom? z) z ;; NIL is a symbol
+    (= (primitive-atom? z) 'T) z ;; NIL is a symbol
     :else
     (make-cons-cell (subst x y (car z)) (subst x y (cdr z)))))
 
@@ -130,9 +123,9 @@
   See page 11 of the Lisp 1.5 Programmers Manual."
   [x y]
   (cond
-   (null x) y
+    (= x NIL) y
     :else
-    (cons (car x) (append (cdr x) y))))
+    (make-cons-cell (car x) (append (cdr x) y))))
 
 
 (defn member
@@ -144,7 +137,7 @@
   [x y]
   (cond
     (= y NIL) F ;; NOTE: returns F on falsity, not NIL
-    (equal x (car y)) T
+    (= (equal x (car y)) 'T) 'T
     :else (member x (cdr y))))
 
 (defn pairlis
@@ -162,7 +155,7 @@
   (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
+    (or (= NIL x) (= NIL y)) a
     :else (make-cons-cell
             (make-cons-cell (car x) (car y))
             (pairlis (cdr x) (cdr y) a))))
@@ -176,9 +169,9 @@
   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
+    (= NIL a) NIL ;; this clause is not present in the original but is added for
     ;; robustness.
-    (equal (caar a) x) (car a)
+    (= (equal (caar a) x) 'T) (car a)
     :else
     (primitive-assoc x (cdr a))))
 
@@ -187,8 +180,8 @@
   ? I think this is doing variable binding in the stack frame?"
   [a z]
   (cond
-    (null a) z
+    (= NIL a) z
-    (= (caar a) z) (cdar a)
+    (= (caar a) z) (cdar a) ;; TODO: this looks definitely wrong
     :else
     (sub2 (cdr a) z)))
 
@@ -243,10 +236,9 @@
   `beowulf.cons-cell/ConsCell` objects.
   See page 13 of the Lisp 1.5 Programmers Manual."
   [clauses env]
-  (cond
+  (if
     (not= (primitive-eval (caar clauses) env) NIL)
     (primitive-eval (cadar clauses) env)
-    :else
     (evcon (cdr clauses) env)))
 
 (defn- evlis

src/beowulf/read.clj

@@ -269,3 +269,10 @@
 (defn primitive-read
   []
   (generate (simplify (parse (read-line)))))
+
+(defmacro gsp
+  "Shortcut macro - the internals of read; or, if you like, read-string.
+  Argument `s` should be a string representation of a valid Lisp
+  expression."
+  [s]
+  `(generate (simplify (parse ~s))))

test/beowulf/bootstrap_test.clj

@@ -3,7 +3,7 @@
             [clojure.test :refer :all]
             [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]
             [beowulf.eval :refer :all]
-            [beowulf.read :refer [parse simplify generate]]))
+            [beowulf.read :refer [gsp]]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -19,7 +19,7 @@
           actual (primitive-atom T)]
       (is (= actual expected) "T is an atom (symbol)"))
     (let [expected T
-          actual (primitive-atom (generate (simplify (parse "HELLO"))))]
+          actual (primitive-atom (gsp "HELLO"))]
       (is (= actual expected) "HELLO is an atom (symbol)"))
     (let [expected T
           actual (primitive-atom 7)]
@@ -30,14 +30,14 @@
           actual (primitive-atom (make-cons-cell 'A 'B))]
       (is (= actual expected) "A dotted pair is explicitly not an atom."))
     (let [expected F
-          actual (primitive-atom (generate (simplify (parse "(A B C D)"))))]
+          actual (primitive-atom (gsp "(A B C D)"))]
       (is (= actual expected) "A list is explicitly not an atom")))
   (testing "primitive-atom?"
     (let [expected T
           actual (primitive-atom? T)]
       (is (= actual expected) "T is an atom (symbol)"))
     (let [expected T
-          actual (primitive-atom? (generate (simplify (parse "HELLO"))))]
+          actual (primitive-atom? (gsp "HELLO"))]
       (is (= actual expected) "HELLO is an atom (symbol)"))
     (let [expected T
           actual (primitive-atom? 7)]
@@ -48,7 +48,7 @@
           actual (primitive-atom? (make-cons-cell 'A 'B))]
       (is (= actual expected) "A dotted pair is explicitly not an atom."))
     (let [expected NIL
-          actual (primitive-atom? (generate (simplify (parse "(A B C D)"))))]
+          actual (primitive-atom? (gsp "(A B C D)"))]
       (is (= actual expected) "A list is explicitly not an atom"))
 
     ))
@@ -59,7 +59,7 @@
           actual (car (make-cons-cell 'A 'B))]
       (is (= actual expected) "A is car of (A . B)"))
     (let [expected 'A
-          actual (car (generate (simplify (parse "(A B C D)"))))]
+          actual (car (gsp "(A B C D)"))]
       (is (= actual expected) "A is car of (A B C D)"))
     (is (thrown-with-msg?
           Exception
@@ -76,7 +76,7 @@
           actual (cdr (make-cons-cell 'A 'B))]
       (is (= actual expected) "B is cdr of (A . B)"))
     (let [expected 'B
-          actual (cdr (generate (simplify (parse "(A B C D)"))))]
+          actual (cdr (gsp "(A B C D)"))]
       (is (instance? beowulf.cons_cell.ConsCell actual)
           "cdr of (A B C D) is a cons cell")
       (is (= (car actual) expected) "the car of that cons-cell is B"))
@@ -90,22 +90,23 @@
           #"Cannot take CDR of `.*"
           (cdr 7))
         "Can't take the cdr of a number"))
-  (let [s (generate
+  (let [s (gsp "((((1 . 2) 3)(4 5) 6)(7 (8 9) (10 11 12) 13) 14 (15 16) 17)")]
-            (simplify
-              (parse
-                "((((1 . 2) 3)(4 5) 6)(7 (8 9) (10 11 12) 13) 14 (15 16) 17)")))]
     ;; structure for testing access functions
     (testing "cadr"
       (let [expected 'B
-            actual (cadr (generate (simplify (parse "(A B C D)"))))]
+            actual (cadr (gsp "(A B C D)"))]
         (is (= actual expected))))
     (testing "caddr"
       (let [expected 'C
-            actual (caddr (generate (simplify (parse "(A B C D)"))))]
+            actual (caddr (gsp "(A B C D)"))]
-        (is (= actual expected))))
+        (is (= actual expected)))
+      (let [expected 14
+            actual (caddr s)]
+        (is (= actual expected)))
+      )
     (testing "cadddr"
       (let [expected 'D
-            actual (cadddr (generate (simplify (parse "(A B C D)"))))]
+            actual (cadddr (gsp "(A B C D)"))]
         (is (= actual expected))))
     (testing "caaaar"
       (let [expected "1"
@@ -114,3 +115,74 @@
     ))
 
 
+(deftest equality-tests
+  (testing "eq"
+    (let [expected 'T
+          actual (eq 'FRED 'FRED)]
+      (is (= actual expected) "identical symbols"))
+    (let [expected 'F
+          actual (eq 'FRED 'ELFREDA)]
+      (is (= actual expected) "different symbols"))
+    (let [expected 'F
+          l (gsp "(NOT AN ATOM)")
+          actual (eq l l)]
+      (is (= actual expected) "identical lists (eq is not defined for lists)")))
+  (testing "equal"
+    (let [expected 'T
+          actual (equal 'FRED 'FRED)]
+      (is (= actual expected) "identical symbols"))
+    (let [expected 'F
+          actual (equal 'FRED 'ELFREDA)]
+      (is (= actual expected) "different symbols"))
+    (let [expected 'T
+          l (gsp "(NOT AN ATOM)")
+          actual (equal l l)]
+      (is (= actual expected) "same list, same content"))
+    (let [expected 'T
+          l (gsp "(NOT AN ATOM)")
+          m (gsp "(NOT AN ATOM)")
+          actual (equal l m)]
+      (is (= actual expected) "different lists, same content"))
+    (let [expected 'F
+          l (gsp "(NOT AN ATOM)")
+          m (gsp "(NOT REALLY AN ATOM)")
+          actual (equal l m)]
+      (is (= actual expected) "different lists, different content"))))
+
+(deftest substitution-tests
+  (testing "subst"
+    (let [expected "((A X . A) . C)"
+          ;; differs from example in book only because of how the function
+          ;; `beowulf.cons-cell/to-string` formats lists.
+          actual (print-str
+                   (subst
+                     (gsp "(X . A)")
+                     (gsp "B")
+                     (gsp "((A . B) . C)")))]
+      (is (= actual expected)))))
+
+(deftest append-tests
+  (testing "append"
+    (let [expected "(A B C D E)"
+          actual (print-str
+                   (append
+                     (gsp "(A B)")
+                     (gsp "(C D E)")))]
+      (is (= actual expected)))))
+
+(deftest member-tests
+  (testing "member"
+    (let [expected 'T
+          actual (member (gsp "ALBERT") (gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
+      (= actual expected))
+    (let [expected 'T
+          actual (member (gsp "BELINDA") (gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
+      (= actual expected))
+    (let [expected 'T
+          actual (member (gsp "ELFREDA") (gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
+      (= actual expected))
+    (let [expected 'F
+          actual (member (gsp "BERTRAM") (gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
+      (= actual expected))))
+
+