diff --git a/src/beowulf/cons_cell.clj b/src/beowulf/cons_cell.clj index 2a299d5..46affd2 100644 --- a/src/beowulf/cons_cell.clj +++ b/src/beowulf/cons_cell.clj @@ -14,13 +14,19 @@ ;; next and more must return ISeq: ;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java (more [this] (if - (= (.CDR this) NIL) - clojure.lang.PersistentList/EMPTY - (.CDR this))) + (seq? this) + (if + (= (.CDR this) NIL) + clojure.lang.PersistentList/EMPTY + (.CDR this)) + NIL)) (next [this] (if - (= (.CDR this) NIL) - nil ;; next returns nil when empty - (.CDR this))) + (seq? this) + (if + (= (.CDR this) NIL) + nil ;; next returns nil when empty + (.CDR this)) + NIL)) clojure.lang.Seqable (seq [this] this) @@ -31,12 +37,50 @@ clojure.lang.IPersistentCollection (count [this] (if - (= (.CDR this) NIL) - 0 - (inc (count (.CDR this))))) + (seq? this) + (if + (= (.CDR this) NIL) + 0 + (inc (count (.CDR this)))) + 0)) (empty [this] false) (equiv [this other] false)) +(defn- to-string + "Printing ConsCells gave me a *lot* of trouble. This is an internal function + used by the print-method override (below) in order that the standard Clojure + `print` and `str` functions will print ConsCells correctly. The argument + `cell` must, obviously, be an instance of `ConsCell`." + [cell] + (loop [c cell + n 0 + s "("] + (if + (instance? beowulf.cons_cell.ConsCell c) + (let [car (.CAR c) + cdr (.CDR c) + cons? (instance? beowulf.cons_cell.ConsCell cdr) + ss (str + s + (to-string car) + (cond + cons? + " " + (or (nil? cdr) (= cdr 'NIL)) + ")" + :else + (str " . " (to-string cdr) ")")))] + (if + cons? + (recur cdr (inc n) ss) + ss)) + (str c)))) + +(defmethod clojure.core/print-method beowulf.cons_cell.ConsCell + [this writer] + (.write writer (to-string this))) + + (defn make-cons-cell [a d] (ConsCell. a d)) diff --git a/src/beowulf/core.clj b/src/beowulf/core.clj index a0644df..ea0fc91 100644 --- a/src/beowulf/core.clj +++ b/src/beowulf/core.clj @@ -1,7 +1,6 @@ (ns beowulf.core (:require [beowulf.eval :refer [primitive-eval oblist]] - [beowulf.read :refer [primitive-read]] - [beowulf.print :refer [primitive-print prin]]) + [beowulf.read :refer [primitive-read]]) (:gen-class)) (defn -main @@ -12,6 +11,6 @@ (print ":: ") (flush) (let [input (primitive-read)] - (println (str "\tI read: " (prin input))) - (println (str "> "(prin (primitive-eval input @oblist)))) + (println (str "\tI read: " input)) + (println (str "> " (primitive-eval input @oblist))) (recur)))) diff --git a/src/beowulf/eval.clj b/src/beowulf/eval.clj index 97fbf1a..394e4ff 100644 --- a/src/beowulf/eval.clj +++ b/src/beowulf/eval.clj @@ -31,14 +31,18 @@ (if (instance? beowulf.cons_cell.ConsCell x) (.CAR x) - NIL)) + (throw + (Exception. + (str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")"))))) (defn cdr [x] (if (instance? beowulf.cons_cell.ConsCell x) (.CDR x) - NIL)) + (throw + (Exception. + (str "Cannot take CDR of `" x "` (" (.getName (.getClass x)) ")"))))) (defn uaf "Universal access function; `l` is expected to be an arbitrary list, `path` @@ -47,14 +51,10 @@ [l path] (cond (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))))) + (empty? path) l + :else (case (last path) + \a (uaf (car l) (butlast path)) + \d (uaf (cdr l) (butlast path))))) (defn caar [x] (uaf x (seq "aa"))) (defn cadr [x] (uaf x (seq "ad"))) diff --git a/src/beowulf/print.clj b/src/beowulf/print.clj deleted file mode 100644 index e9b1835..0000000 --- a/src/beowulf/print.clj +++ /dev/null @@ -1,59 +0,0 @@ -(ns beowulf.print - ) - -(defprotocol Printable - (prin [x])) - -(extend-type - clojure.lang.Symbol - Printable - (prin [x] (str x))) - -(extend-protocol - Printable - nil - (prin [x] "NIL")) - -(extend-protocol - Printable - - clojure.lang.Symbol - (prin [x] (str x)) - - java.lang.Number - (prin [x] (str x)) - - beowulf.cons_cell.ConsCell - (prin [x] - (loop [c x - n 0 - s "("] - (let [car (.CAR c) - cdr (.CDR c) - cons? (instance? beowulf.cons_cell.ConsCell cdr) - ss (str - s - (prin car) - (cond - cons? - " " - (or (nil? cdr) (= cdr 'NIL)) - ")" - :else - (str " . " (prin cdr) ")")))] - (if - cons? - (recur cdr (inc n) ss) - ss)))) - - java.lang.Object - (prin - [x] - (str x))) - -(defn primitive-print - [x] - (if - (satisfies? beowulf.print.Printable x) (prin x) - (str x))) - diff --git a/test/beowulf/bootstrap_test.clj b/test/beowulf/bootstrap_test.clj new file mode 100644 index 0000000..7f5e1c4 --- /dev/null +++ b/test/beowulf/bootstrap_test.clj @@ -0,0 +1,116 @@ +(ns beowulf.bootstrap-test + (:require [clojure.math.numeric-tower :refer [abs]] + [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]])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; This file is primarily tests of the functions in `beowulf.eval` - which +;;; are Clojure functions, but aim to provide sufficient functionality that +;;; Beowulf can get up to the level of running its own code. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest atom-tests + (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"))))] + (is (= actual expected) "HELLO is an atom (symbol)")) + (let [expected T + actual (primitive-atom 7)] + (is (= actual expected) + "I'm not actually certain whether a number should be treated as an + atom, but I'm guessing so")) + (let [expected F + 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)"))))] + (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"))))] + (is (= actual expected) "HELLO is an atom (symbol)")) + (let [expected T + actual (primitive-atom? 7)] + (is (= actual expected) + "I'm not actually certain whether a number should be treated as an + atom, but I'm guessing so")) + (let [expected NIL + 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)"))))] + (is (= actual expected) "A list is explicitly not an atom")) + + )) + +(deftest access-function-tests + (testing "car" + (let [expected 'A + 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)"))))] + (is (= actual expected) "A is car of (A B C D)")) + (is (thrown-with-msg? + Exception + #"Cannot take CAR of `.*" + (car 'T)) + "Can't take the car of an atom") + (is (thrown-with-msg? + Exception + #"Cannot take CAR of `.*" + (car 7)) + "Can't take the car of a number")) + (testing "cdr" + (let [expected 'B + 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)"))))] + (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")) + (is (thrown-with-msg? + Exception + #"Cannot take CDR of `.*" + (cdr 'T)) + "Can't take the cdr of an atom") + (is (thrown-with-msg? + Exception + #"Cannot take CDR of `.*" + (cdr 7)) + "Can't take the cdr of a number")) + (let [s (generate + (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)"))))] + (is (= actual expected)))) + (testing "caddr" + (let [expected 'C + actual (caddr (generate (simplify (parse "(A B C D)"))))] + (is (= actual expected)))) + (testing "cadddr" + (let [expected 'D + actual (cadddr (generate (simplify (parse "(A B C D)"))))] + (is (= actual expected)))) + (testing "caaaar" + (let [expected "1" + actual (print-str (caaaar s))] + (is (= actual expected)))) + )) + + diff --git a/test/beowulf/mexpr_test.clj b/test/beowulf/mexpr_test.clj index f8022e5..3500875 100644 --- a/test/beowulf/mexpr_test.clj +++ b/test/beowulf/mexpr_test.clj @@ -1,7 +1,6 @@ (ns beowulf.mexpr-test (:require [clojure.test :refer :all] - [beowulf.read :refer [parse simplify generate]] - [beowulf.print :refer :all])) + [beowulf.read :refer [parse simplify generate]])) ;; These tests are taken generally from the examples on page 10 of ;; Lisp 1.5 Programmers Manual: @@ -23,10 +22,10 @@ (deftest variable-tests (testing "Variable translation" (let [expected "X" - actual (prin (generate (simplify (parse "x"))))] + actual (print-str (generate (simplify (parse "x"))))] (is (= actual expected))) (let [expected "CAR" - actual (prin (generate (simplify (parse "car"))))] + actual (print-str (generate (simplify (parse "car"))))] (is (= actual expected))) )) @@ -38,7 +37,7 @@ ;; "T" would be interpreted as a sexpr, which would not be ;; quoted. (let [expected "(ATOM (QUOTE T))" - actual (prin (generate (simplify (parse "atom[T]"))))] + actual (print-str (generate (simplify (parse "atom[T]"))))] (is (= actual expected))) ;; I'm not clear how `car[(A B C)]` should be translated, but ;; I suspect as (CAR (LIST 'A 'B 'C)). @@ -47,19 +46,19 @@ (deftest fncall-tests (testing "Function calls" (let [expected "(CAR X)" - actual (prin (generate (simplify (parse "car[x]"))))] + actual (print-str (generate (simplify (parse "car[x]"))))] (is (= actual expected))) (let [expected "(FF (CAR X))" - actual (prin (generate (simplify (parse "ff[car[x]]"))))] + actual (print-str (generate (simplify (parse "ff[car[x]]"))))] (is (= actual expected))))) (deftest conditional-tests (testing "Conditional expressions" (let [expected "(COND ((ATOM X) X) ((QUOTE T) (FF (CAR X))))" - actual (prin (generate (simplify (parse "[atom[x]->x; T->ff[car[x]]]"))))] + actual (print-str (generate (simplify (parse "[atom[x]->x; T->ff[car[x]]]"))))] (is (= actual expected))) (let [expected "(LABEL FF (LAMBDA (X) (COND ((ATOM X) X) ((QUOTE T) (FF (CAR X))))))" - actual (prin + actual (print-str (generate (simplify (parse "label[ff;λ[[x];[atom[x]->x; T->ff[car[x]]]]]"))))] diff --git a/test/beowulf/read_test.clj b/test/beowulf/read_test.clj deleted file mode 100644 index 1fe206a..0000000 --- a/test/beowulf/read_test.clj +++ /dev/null @@ -1,8 +0,0 @@ -(ns beowulf.read-test - (:require [clojure.test :refer :all] - [beowulf.core :refer :all])) - -;; (deftest a-test -;; (testing "FIXME, I fail." -;; (is (= 0 1)))) - diff --git a/test/beowulf/sexpr_test.clj b/test/beowulf/sexpr_test.clj index 77463da..98d3358 100644 --- a/test/beowulf/sexpr_test.clj +++ b/test/beowulf/sexpr_test.clj @@ -2,8 +2,7 @@ (:require [clojure.math.numeric-tower :refer [abs]] [clojure.test :refer :all] [beowulf.cons-cell :refer :all] - [beowulf.read :refer [parse simplify generate]] - [beowulf.print :refer :all])) + [beowulf.read :refer [parse simplify generate]])) ;; broadly, sexprs should be homoiconic @@ -78,17 +77,17 @@ (deftest dotted-pair-tests (testing "Reading dotted pairs" (let [expected "(A . B)" - actual (prin (generate (simplify (parse expected))))] + actual (print-str (generate (simplify (parse expected))))] (is (= actual expected))) (let [expected "(A B C . D)" - actual (prin (generate (simplify (parse expected))))] + actual (print-str (generate (simplify (parse expected))))] (is (= actual expected))) (let [expected "(A B (C . D) E)" - actual (prin (generate (simplify (parse expected))))] + actual (print-str (generate (simplify (parse expected))))] (is (= actual expected))))) (deftest list-tests (testing "Reading arbitrarily structured lists" (let [expected "(DEFUN FACT (X) (COND ((ZEROP X) 1) (T (TIMES X (FACT (SUB1 X))))))" - actual (prin (generate (simplify (parse expected))))] + actual (print-str (generate (simplify (parse expected))))] (is (= actual expected)))))