Huge amount of work, not much real progress.

.gitignore

@@ -12,3 +12,6 @@ pom.xml.asc
 .hg/
 .idea/
 *~
+.calva/
+.clj-kondo/
+.lsp/

beowulf.iml

@@ -0,0 +1,25 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<module cursive.leiningen.project.LeiningenProjectsManager.displayName="beowulf:0.2.1-SNAPSHOT" cursive.leiningen.project.LeiningenProjectsManager.isLeinModule="true" type="JAVA_MODULE" version="4">
+  <component name="NewModuleRootManager" LANGUAGE_LEVEL="JDK_1_5">
+    <output url="file://$MODULE_DIR$/target/default/classes" />
+    <output-test url="file://$MODULE_DIR$/target/default/classes" />
+    <content url="file://$MODULE_DIR$">
+      <sourceFolder url="file://$MODULE_DIR$/src" isTestSource="false" />
+      <sourceFolder url="file://$MODULE_DIR$/dev-resources" isTestSource="false" />
+      <sourceFolder url="file://$MODULE_DIR$/resources" isTestSource="false" />
+      <sourceFolder url="file://$MODULE_DIR$/test" isTestSource="true" />
+      <excludeFolder url="file://$MODULE_DIR$/target" />
+      <excludeFolder url="file://$MODULE_DIR$/target/default" />
+    </content>
+    <orderEntry type="inheritedJdk" />
+    <orderEntry type="sourceFolder" forTests="false" />
+    <orderEntry type="library" name="Leiningen: clojure-complete:0.2.5" level="project" />
+    <orderEntry type="library" name="Leiningen: environ:1.1.0" level="project" />
+    <orderEntry type="library" name="Leiningen: instaparse:1.4.10" level="project" />
+    <orderEntry type="library" name="Leiningen: nrepl:0.6.0" level="project" />
+    <orderEntry type="library" name="Leiningen: org.clojure/clojure:1.8.0" level="project" />
+    <orderEntry type="library" name="Leiningen: org.clojure/math.numeric-tower:0.0.4" level="project" />
+    <orderEntry type="library" name="Leiningen: org.clojure/tools.cli:0.4.2" level="project" />
+    <orderEntry type="library" name="Leiningen: org.clojure/tools.trace:0.7.10" level="project" />
+  </component>
+</module>

resources/apply-2.mexpr.lsp

@@ -0,0 +1,22 @@
+;; see page 70 of Lisp 1.5 Programmers Manual; this expands somewhat 
+;; on the accounts of eval and apply given on page 13. This is M-expr
+;; syntax, obviously. 
+
+;; apply
+;; NOTE THAT I suspect there is a typo in the printed manual in line
+;; 7 of this definition, namely a missing closing square bracket before
+;; the final semi-colon; that has been corrected here.
+
+apply[fn;args;a] = [
+    null[fn] -> NIL;
+    atom[fn] -> [get[fn;EXPR] -> apply[expr; args; a];
+                 get[fn;SUBR] -> {spread[args];
+                                  $ALIST := a;
+                                  TSX subr4, 4};
+                 T -> apply[cdr[sassoc[fn; a; λ[[]; error[A2]]]]; args a]];
+    eq[car[fn]; LABEL] -> apply[caddr[fn]; args; 
+                                cons[cons[cadr[fn];caddr[fn]]; a]];
+    eq[car[fn]; FUNARG] -> apply[cadr[fn]; args; caddr[fn]];
+    eq[car[fn]; LAMBDA] -> eval[caddr[fn]; nconc[pair[cadr[fn]; args]; a]];
+    T -> apply[eval[fn;a]; args; a]]
+

resources/cond-test.mexpr.lsp

@@ -0,0 +1,3 @@
+;; from page 5
+
+[eq[car[x];A]->cons[B;cdr[x]];T->x]

src/beowulf/bootstrap.clj

@@ -88,36 +88,36 @@
             \a (uaf (.first l) (butlast path))
             \d (uaf (.getCdr l) (butlast path)))))
 
-(defn CAAR [x] (uaf x (seq "aa")))
+(defmacro CAAR [x] `(uaf ~x '(\a \a)))
-(defn CADR [x] (uaf x (seq "ad")))
+(defmacro CADR [x] `(uaf ~x '(\a \d)))
-(defn CDDR [x] (uaf x (seq "dd")))
+(defmacro CDDR [x] `(uaf ~x '(\d \d)))
-(defn CDAR [x] (uaf x (seq "da")))
+(defmacro CDAR [x] `(uaf ~x '(\d \a)))
 
-(defn CAAAR [x] (uaf x (seq "aaa")))
+(defmacro CAAAR [x] `(uaf ~x '(\a \a \a)))
-(defn CAADR [x] (uaf x (seq "aad")))
+(defmacro CAADR [x] `(uaf ~x '(\a \a \d)))
-(defn CADAR [x] (uaf x (seq "ada")))
+(defmacro CADAR [x] `(uaf ~x '(\a \d \a)))
-(defn CADDR [x] (uaf x (seq "add")))
+(defmacro CADDR [x] `(uaf ~x '(\a \d \d)))
-(defn CDDAR [x] (uaf x (seq "dda")))
+(defmacro CDDAR [x] `(uaf ~x '(\d \d \a)))
-(defn CDDDR [x] (uaf x (seq "ddd")))
+(defmacro CDDDR [x] `(uaf ~x '(\d \d \d)))
-(defn CDAAR [x] (uaf x (seq "daa")))
+(defmacro CDAAR [x] `(uaf ~x '(\d \a \a)))
-(defn CDADR [x] (uaf x (seq "dad")))
+(defmacro CDADR [x] `(uaf ~x '(\d \a \d)))
 
-(defn CAAAAR [x] (uaf x (seq "aaaa")))
+(defmacro CAAAAR [x] `(uaf ~x '(\a \a \a \a)))
-(defn CAADAR [x] (uaf x (seq "aada")))
+(defmacro CAADAR [x] `(uaf ~x '(\a \a \d \a)))
-(defn CADAAR [x] (uaf x (seq "adaa")))
+(defmacro CADAAR [x] `(uaf ~x '(\a \d \a \a)))
-(defn CADDAR [x] (uaf x (seq "adda")))
+(defmacro CADDAR [x] `(uaf ~x '(\a \d \d \a)))
-(defn CDDAAR [x] (uaf x (seq "ddaa")))
+(defmacro CDDAAR [x] `(uaf ~x '(\d \d \a \a)))
-(defn CDDDAR [x] (uaf x (seq "ddda")))
+(defmacro CDDDAR [x] `(uaf ~x '(\d \d \d \a)))
-(defn CDAAAR [x] (uaf x (seq "daaa")))
+(defmacro CDAAAR [x] `(uaf ~x '(\d \a \a \a)))
-(defn CDADAR [x] (uaf x (seq "dada")))
+(defmacro CDADAR [x] `(uaf ~x '(\d \a \d \a)))
-(defn CAAADR [x] (uaf x (seq "aaad")))
+(defmacro CAAADR [x] `(uaf ~x '(\a \a \a \d)))
-(defn CAADDR [x] (uaf x (seq "aadd")))
+(defmacro CAADDR [x] `(uaf ~x '(\a \a \d \d)))
-(defn CADADR [x] (uaf x (seq "adad")))
+(defmacro CADADR [x] `(uaf ~x '(\a \d \a \d)))
-(defn CADDDR [x] (uaf x (seq "addd")))
+(defmacro CADDDR [x] `(uaf ~x '(\a \d \d \d)))
-(defn CDDADR [x] (uaf x (seq "ddad")))
+(defmacro CDDADR [x] `(uaf ~x '(\d \d \a \d)))
-(defn CDDDDR [x] (uaf x (seq "dddd")))
+(defmacro CDDDDR [x] `(uaf ~x '(\d \d \d \d)))
-(defn CDAADR [x] (uaf x (seq "daad")))
+(defmacro CDAADR [x] `(uaf ~x '(\d \a \a \d)))
-(defn CDADDR [x] (uaf x (seq "dadd")))
+(defmacro CDADDR [x] `(uaf ~x '(\d \a \d \d)))
 
 (defn EQ
   "Returns `T` if and only if both `x` and `y` are bound to the same atom,
@@ -318,8 +318,6 @@
     (=
       (ATOM? function)
       T)(cond
-           ;; TODO: doesn't check whether `function` is bound in the environment;
-           ;; we'll need that before we can bootstrap.
            (= function 'CAR) (CAAR args)
            (= function 'CDR) (CDAR args)
            (= function 'CONS) (make-cons-cell (CAR args) (CADR args))

src/beowulf/cons_cell.clj

@@ -195,15 +195,20 @@
   [this writer]
   (.write writer (to-string this)))
 
-(defmacro make-cons-cell
+(defn make-cons-cell
   "Construct a new instance of cons cell with this `car` and `cdr`."
   [car cdr]
-  `(ConsCell. ~car ~cdr))
+  (try
+     (ConsCell. car cdr)
+     (catch Exception any
+       (throw (ex-info "Cound not construct cons cell" {:car car
+                                                        :cdr cdr} any)))))
 
 (defn make-beowulf-list
   "Construct a linked list of cons cells with the same content as the
   sequence `x`."
   [x]
+  (try
     (cond
     (empty? x) NIL
     (coll? x) (ConsCell.
@@ -213,4 +218,8 @@
                   (first x))
                 (make-beowulf-list (rest x)))
     :else
-    NIL))
+    NIL)
+    (catch Exception any 
+      (throw (ex-info "Could not construct Beowulf list" 
+                      {:content x} 
+                      any)))))

src/beowulf/core.clj

@@ -55,13 +55,13 @@
     (println
       (str
         "\nHider wilcuman. Béowulf is mín nama.\n"
-        (if
+        (when
           (System/getProperty "beowulf.version")
           (str "Síðe " (System/getProperty "beowulf.version") "\n"))
-        (if
+        (when
           (:help (:options args))
           (:summary args))
-        (if (:errors args)
+        (when (:errors args)
           (apply str (interpose "; " (:errors args))))
         "\nSprecan 'quit' tó laéfan\n"))
     (binding [*options* (:options args)]

src/beowulf/read.clj

@@ -15,7 +15,8 @@
   switch."
   (:require [beowulf.bootstrap :refer [*options*]]
             [clojure.math.numeric-tower :refer [expt]]
-            [clojure.string :refer [starts-with? upper-case]]
+            [clojure.pprint :refer [pprint]]
+            [clojure.string :refer [join split starts-with? upper-case]]
             [instaparse.core :as i]
             [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]]))
 
@@ -35,10 +36,20 @@
   (i/parser
    (str
       ;; top level: we accept mexprs as well as sexprs.
-      "expr := mexpr | sexpr;"
+    "expr := mexpr | sexpr | opt-space expr opt-space;"
 
+      ;; comments. I'm pretty confident Lisp 1.5 did NOT have these.
+    "comment := opt-space <';;'> opt-space #'[^\\n\\r]*';"
+
+     ;; there's a notation comprising a left brace followed by mexprs
+     ;; followed by a right brace which doesn't seem to be documented 
+     ;; but I think must represent a prog(?)
+
+    ;; "prog := lbrace exprs rbrace;"
       ;; mexprs. I'm pretty clear that Lisp 1.5 could never read these,
       ;; but it's a convenience.
+
+    "exprs := expr | exprs;"
     "mexpr := λexpr | fncall | defn | cond | mvar | mexpr comment;
       λexpr := λ lsqb bindings semi-colon body rsqb;
       λ := 'λ';
@@ -47,6 +58,8 @@
       fncall := fn-name lsqb args rsqb;
       lsqb := '[';
       rsqb := ']';
+       lbrace := '{';
+       rbrace := '}';
       defn := mexpr opt-space '=' opt-space mexpr;
       cond := lsqb (cond-clause semi-colon opt-space)* cond-clause rsqb;
       cond-clause := expr opt-space arrow opt-space expr;
@@ -56,13 +69,10 @@
       mvar := #'[a-z]+';
       semi-colon := ';';"
 
-      ;; comments. I'm pretty confident Lisp 1.5 did NOT have these.
-      "comment := opt-space <';;'> #'[^\\n\\r]*';"
-
       ;; sexprs. Note it's not clear to me whether Lisp 1.5 had the quote macro,
       ;; but I've included it on the basis that it can do little harm.
     "sexpr := quoted-expr | atom | number | dotted-pair | list | sexpr comment;
-      list := lpar sexpr rpar | lpar (sexpr sep)* rpar | lpar (sexpr sep)* dot-terminal;
+      list := lpar sexpr rpar | lpar (sexpr sep)* rpar | lpar (sexpr sep)* dot-terminal | lbrace exprs rbrace;
       dotted-pair := lpar dot-terminal ;
       dot := '.';
       lpar := '(';
@@ -101,7 +111,7 @@
      (apply
       vector
       (remove
-        #(if (coll? %) (empty? %))
+       #(when (coll? %) (empty? %))
        (case (first p)
          (:arg :expr :coefficient :fn-name :number :sexpr) (simplify (second p) context)
          (:λexpr
@@ -113,7 +123,7 @@
                 (= context :mexpr)
                  [:quoted-expr p]
                  p)
-          :comment (if
+         :comment (when
                    (:strict *options*)
                     (throw
                      (ex-info "Cannot parse comments in strict mode"
@@ -139,7 +149,9 @@
                   [:args (apply vector (map simplify (rest p)))]]
                  (map #(simplify % context) p))
           ;;default
-          p)))
+         (if (coll? (first p))
+           (map #(simplify % context) p)
+           p))))
      p)))
 
 
@@ -197,30 +209,32 @@
   "Generate a cond clause from this simplified parse tree fragment `p`;
   returns `nil` if `p` does not represent a cond clause."
   [p]
-  (if
+  (when
    (and (coll? p) (= :cond-clause (first p)))
     (make-beowulf-list
-      (list (generate (nth p 1))
+     (list (if (= (nth p 1) [:quoted-expr [:atom "T"]])
+             'T
+             (generate (nth p 1)))
            (generate (nth p 2))))))
 
 (defn gen-cond
   "Generate a cond statement from this simplified parse tree fragment `p`;
   returns `nil` if `p` does not represent a (MEXPR) cond statement."
   [p]
-  (if
+  (when
    (and (coll? p) (= :cond (first p)))
     (make-beowulf-list
      (cons
       'COND
       (map
-          gen-cond-clause
+       generate
        (rest p))))))
 
 (defn gen-fn-call
   "Generate a function call from this simplified parse tree fragment `p`;
   returns `nil` if `p` does not represent a (MEXPR) function call."
   [p]
-  (if
+  (when
    (and (coll? p) (= :fncall (first p)) (= :mvar (first (second p))))
     (make-cons-cell
      (generate (second p))
@@ -264,6 +278,7 @@
   "Generate lisp structure from this parse tree `p`. It is assumed that
   `p` has been simplified."
   [p]
+  (try
     (if
      (coll? p)
       (case (first p)
@@ -272,17 +287,19 @@
                 (generate (nth p 1))
                 (make-cons-cell (generate (nth p 2))
                                 (generate (nth p 3))))
-      (:args :list) (gen-dot-terminated-list (rest p))
+        :args (make-beowulf-list (map generate (rest p)))
         :atom (symbol (second p))
         :bindings (generate (second p))
         :body (make-beowulf-list (map generate (rest p)))
         :cond (gen-cond p)
+        :cond-clause (gen-cond-clause p)
         (:decimal :integer) (read-string (strip-leading-zeros (second p)))
         :dotted-pair (make-cons-cell
                       (generate (nth p 1))
                       (generate (nth p 2)))
         :exponent (generate (second p))
         :fncall (gen-fn-call p)
+        :list (gen-dot-terminated-list (rest p))
         :mvar (symbol (upper-case (second p)))
         :octal (let [n (read-string (strip-leading-zeros (second p) "0"))
                      scale (generate (nth p 2))]
@@ -298,8 +315,13 @@
                       (* n (expt 10 exponent)))
 
       ;; default
-      (throw (Exception. (str "Cannot yet generate " (first p)))))
+        (throw (ex-info (str "Unrecognised head: " (first p))
-    p))
+                        {:generating p})))
+      p)
+    (catch Throwable any
+      (throw (ex-info "Could not generate"
+                      {:generating p}
+                      any)))))
 
 (defmacro gsp
   "Shortcut macro - the internals of read; or, if you like, read-string.

test/beowulf/bootstrap_test.clj

@@ -179,22 +179,22 @@
           actual (MEMBER
                    (gsp "ALBERT")
                    (gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
-      (= actual expected))
+      (is (= actual expected)))
     (let [expected 'T
           actual (MEMBER
                    (gsp "BELINDA")
                    (gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
-      (= actual expected))
+       (is (= actual expected)))
     (let [expected 'T
           actual (MEMBER
                    (gsp "ELFREDA")
                    (gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
-      (= actual expected))
+       (is (= actual expected)))
     (let [expected 'F
           actual (MEMBER
                    (gsp "BERTRAM")
                    (gsp "(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED)"))]
-      (= actual expected))))
+       (is (= actual expected)))))
 
 (deftest pairlis-tests
   (testing "pairlis"

test/beowulf/mexpr_test.clj

@@ -25,10 +25,10 @@
 (deftest variable-tests
   (testing "Variable translation"
     (let [expected "X"
-          actual (print-str (generate (simplify (parse "x"))))]
+          actual (print-str (gsp "x"))]
       (is (= actual expected)))
     (let [expected "CAR"
-          actual (print-str (generate (simplify (parse "car"))))]
+          actual (print-str (gsp "car"))]
       (is (= actual expected)))
     ))
 
@@ -39,28 +39,30 @@
     ;; Wrapping in a function call puts us into mexpr contest;
     ;; "T" would be interpreted as a sexpr, which would not be
     ;; quoted.
-    (let [expected "(ATOM (QUOTE T))"
+    (let [expected "(ATOM (QUOTE A))"
-          actual (print-str (generate (simplify (parse "atom[T]"))))]
+          actual (print-str (gsp "atom[A]"))]
-      (is (= actual expected)))
+      (is (= actual expected)
+          "Atoms should normally be quoted"))
     ;; I'm not clear how `car[(A B C)]` should be translated, but
     ;; I suspect as (CAR (LIST 'A 'B 'C)).
+
     ))
 
 (deftest fncall-tests
   (testing "Function calls"
     (let [expected "(CAR X)"
-          actual (print-str (generate (simplify (parse "car[x]"))))]
+          actual (print-str (gsp "car[x]"))]
       (is (= actual expected)))
     (let [expected "(FF (CAR X))"
-          actual (print-str (generate (simplify (parse "ff[car[x]]"))))]
+          actual (print-str (gsp "ff[car[x]]"))]
       (is (= actual expected)))))
 
 (deftest conditional-tests
   (testing "Conditional expressions"
-    (let [expected "(COND ((ATOM X) X) ((QUOTE T) (FF (CAR X))))"
+    (let [expected "(COND ((ATOM X) X) (T (FF (CAR X))))"
-          actual (print-str (generate (simplify (parse "[atom[x]->x; T->ff[car[x]]]"))))]
+          actual (print-str (gsp "[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))))))"
+    (let [expected "(LABEL FF (LAMBDA (X) (COND ((ATOM X) X) (T (FF (CAR X))))))"
           actual (print-str
                    (generate
                      (simplify

test/beowulf/sexpr_test.clj

@@ -10,19 +10,19 @@
 (deftest atom-tests
   (testing "Reading atoms"
     (let [expected 'A
-          actual (generate (simplify (parse (str expected))))]
+          actual (gsp(str expected))]
       (is (= actual expected)))
     (let [expected 'APPLE
-          actual (generate (simplify (parse (str expected))))]
+          actual (gsp(str expected))]
       (is (= actual expected)))
     (let [expected 'PART2
-          actual (generate (simplify (parse (str expected))))]
+          actual (gsp(str expected))]
       (is (= actual expected)))
     (let [expected 'EXTRALONGSTRINGOFLETTERS
-          actual (generate (simplify (parse (str expected))))]
+          actual (gsp(str expected))]
       (is (= actual expected)))
     (let [expected 'A4B66XYZ2
-          actual (generate (simplify (parse (str expected))))]
+          actual (gsp(str expected))]
       (is (= actual expected)))))
 
 (deftest comment-tests
@@ -54,67 +54,67 @@
 (deftest number-tests
   (testing "Reading octal numbers"
     (let [expected 1
-             actual (generate (simplify (parse "1Q")))]
+             actual (gsp "1Q")]
          (is (= actual expected)))
     (let [expected -1
-             actual (generate (simplify (parse "-1Q")))]
+             actual (gsp "-1Q")]
          (is (= actual expected)))
     (let [expected 8
-             actual (generate (simplify (parse "1Q1")))]
+             actual (gsp "1Q1")]
          (is (= actual expected)))
     (let [expected -8
-             actual (generate (simplify (parse "-1Q1")))]
+             actual (gsp "-1Q1")]
          (is (= actual expected)))
     (let [expected 128
-             actual (generate (simplify (parse "2Q2")))]
+             actual (gsp "2Q2")]
          (is (= actual expected)))
     (let [expected 2093056
-             actual (generate (simplify (parse "777Q4")))]
+             actual (gsp "777Q4")]
          (is (= actual expected))))
   (testing "Reading decimal numbers - broadly should be homiconic"
     (let [expected 7
-             actual (generate (simplify (parse "7")))]
+             actual (gsp "7")]
          (is (= actual expected)))
     (let [expected -7
-             actual (generate (simplify (parse "-7")))]
+             actual (gsp "-7")]
          (is (= actual expected)))
     (let [expected 3.141592
-             actual (generate (simplify (parse "3.141592")))]
+             actual (gsp "3.141592")]
          (is (= actual expected)))
     (let [expected 1234567890
-             actual (generate (simplify (parse "1234567890")))]
+             actual (gsp "1234567890")]
          (is (= actual expected)))
     (let [expected -45.23
-             actual (generate (simplify (parse "-45.23")))]
+             actual (gsp "-45.23")]
          (is (= actual expected))))
   (testing "Reading scientific notation")
     (let [expected 2/5
-             actual (generate (simplify (parse "4E-1")))]
+             actual (gsp "4E-1")]
          (is (< (abs (- actual expected)) 0.0001)))
     (let [expected 60
-             actual (generate (simplify (parse "6E1")))]
+             actual (gsp "6E1")]
          (is (< (abs (- actual expected)) 0.0001)))
     (let [expected 60
-             actual (generate (simplify (parse "600.00E-1")))]
+             actual (gsp "600.00E-1")]
          (is (< (abs (- actual expected)) 0.0001)))
     (let [expected 60
-             actual (generate (simplify (parse "0.6E2")))]
+             actual (gsp "0.6E2")]
          (is (< (abs (- actual expected)) 0.0001))))
 
 (deftest dotted-pair-tests
   (testing "Reading dotted pairs"
     (let [expected "(A . B)"
-          actual (print-str (generate (simplify (parse expected))))]
+          actual (print-str (gsp expected))]
       (is (= actual expected)))
     (let [expected "(A B C . D)"
-          actual (print-str (generate (simplify (parse expected))))]
+          actual (print-str (gsp expected))]
       (is (= actual expected)))
     (let [expected "(A B (C . D) E)"
-          actual (print-str (generate (simplify (parse expected))))]
+          actual (print-str (gsp 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 (print-str (generate (simplify (parse expected))))]
+          actual (print-str (gsp expected))]
       (is (= actual expected)))))