There are regressions, tests are failing, but EVAL is beginning to work

resources/null.mexpr.lsp

@@ -0,0 +1 @@
+null[x] = [x = NIL -> T; T -> F]

src/beowulf/bootstrap.clj

@@ -13,11 +13,12 @@
             [clojure.tools.trace :refer [deftrace]]
             [beowulf.cons-cell :refer [CAR CDR CONS LIST make-beowulf-list make-cons-cell
                                        pretty-print T F]]
-            [beowulf.host :refer [ADD1 DIFFERENCE FIXP NUMBERP PLUS2 QUOTIENT
+            [beowulf.host :refer [ADD1 DIFFERENCE FIXP NUMBERP PLUS QUOTIENT
-                                  REMAINDER RPLACA RPLACD SUB1 TIMES2]]
+                                  REMAINDER RPLACA RPLACD SUB1 TIMES]]
             [beowulf.io :refer [SYSIN SYSOUT]]
             [beowulf.oblist :refer [*options* oblist NIL]])
-  (:import [beowulf.cons_cell ConsCell]))
+  (:import [beowulf.cons_cell ConsCell]
+           [clojure.lang Symbol]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -29,7 +30,7 @@
 ;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(declare EVAL)
+(declare APPLY EVAL)
 
 
 (defmacro NULL
@@ -379,42 +380,62 @@
     symbol val)
     NIL))
 
-(defn APPLY
+(defn- apply-symbolic
-  "For bootstrapping, at least, a version of APPLY written in Clojure.
+  "Apply this `funtion-symbol` to these `args` in this `environment` and 
+   return the result."
+  [^Symbol function-symbol ^ConsCell args ^ConsCell environment]
+  (let [fn (try (EVAL function-symbol environment)
+                (catch Throwable any (when (:trace *options*)
+                                       (println any))))]
+    (if (and fn (not= fn NIL))
+      (APPLY fn args environment)
+      (case function-symbol ;; there must be a better way of doing this!
+        ADD1 (apply ADD1 args)
+        APPEND (apply APPEND args)
+        APPLY (apply APPLY args)
+        ATOM (ATOM? (CAR args))
+        CAR (CAAR args)
+        CDR (CDAR args)
+        CONS (make-cons-cell (CAR args) (CADR args))
+        DEFINE (DEFINE (CAR args))
+        DIFFERENCE (DIFFERENCE (CAR args) (CADR args))
+        EQ (apply EQ args)
+        ;; think about EVAL. Getting the environment right is subtle
+        FIXP (apply FIXP args)
+        INTEROP (apply INTEROP args)
+        NUMBERP (apply NUMBERP args)
+        PLUS (apply PLUS args)
+        PRETTY (apply pretty-print args)
+        QUOTIENT (apply QUOTIENT args)
+        REMAINDER (apply REMAINDER args)
+        RPLACA (apply RPLACA args)
+        RPLACD (apply RPLACD args)
+        SET (apply SET args)
+        SYSIN (apply SYSIN args)
+        SYSOUT (apply SYSOUT args)
+        TIMES (apply TIMES args)
+        ;; else
+        (ex-info "No function found"
+                 {:context "APPLY"
+                  :function function-symbol
+                  :args args})))))
+
+(defn apply-internal
+  "Internal guts of both `APPLY` and `traced-apply`. Apply this `function` to 
+   these `arguments` in this `environment` and return the result.
+   
+   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
-    (= NIL function) (throw (ex-info "NIL is not a function" {:context "APPLY"
+    (= NIL function) (if (:strict *options*)
+                       NIL
+                       (throw (ex-info "NIL is not a function"
+                                       {:context "APPLY"
                                         :function "NIL"
-                                                              :args args}))
-    (=
-     (ATOM? function)
-     T) (cond
-          ;; (fn? (eval function)) (apply (eval function) args)
-          (not=
-           (ASSOC function environment)
-           NIL) (APPLY (CDR (ASSOC function environment)) args environment)
-          (= function 'ATOM) (if (ATOM? (CAR args)) T NIL)
-          (= function 'CAR) (CAAR args)
-          (= function 'CDR) (CDAR args)
-          (= function 'CONS) (make-cons-cell (CAR args) (CADR args))
-          (= function 'DEFINE) (DEFINE args)
-          (= function 'EQ) (apply EQ args)
-          (= function 'INTEROP) (INTEROP (CAR args) (CDR args))
-          (= function 'SET) (SET (CAR args) (CADR args))
-          (= function 'SYSIN) (SYSIN (CAR args))
-          (= function 'SYSOUT) (SYSOUT (CAR args))
-          (EVAL function environment) (APPLY
-                                       (EVAL function environment)
-                                       args
-                                       environment)
-          :else
-          (throw (ex-info "No function found" {:context "APPLY"
-                                               :function function
                                         :args args})))
-    (fn? function) ;; i.e., it's a Clojure function
+    (= (ATOM? function) T) (apply-symbolic function args environment)
-    (apply function (to-clojure args))
     (= (first function) 'LAMBDA) (EVAL
                                   (CADDR function)
                                   (PAIRLIS (CADR function) args environment))
@@ -427,8 +448,27 @@
                                    (CADDR function))
                                   environment))))
 
+(deftrace traced-apply
+  "Traced wrapper for `internal-apply`, q.v. Apply this `function` to 
+   these `arguments` in this `environment` and return the result."
+  [function args environment]
+  (apply-internal function args environment))
+
+(defn APPLY
+  "Despatcher for APPLY, selects beteen `traced-apply` and `apply-internal`
+   based on the value of `:trace` in `*options*`. Apply this `function` to 
+   these `arguments` and return the result. If `environment` is not passed,
+   if defaults to the current value of the global object list."
+  ([function args]
+   (APPLY function args @oblist))
+  ([function args environment]
+   (if
+    (:trace *options*)
+     (traced-apply function args environment)
+     (apply-internal function args environment))))
+
 (defn- EVCON
-  "Inner guts of primitive COND. All args are assumed to be
+  "Inner guts of primitive COND. All `clauses` are assumed to be
   `beowulf.cons-cell/ConsCell` objects.
   See page 13 of the Lisp 1.5 Programmers Manual."
   [clauses env]
@@ -449,20 +489,33 @@
      (EVAL (CAR args) env)
      (EVLIS (CDR args) env))))
 
-(defn eval-internal
+(defn- eval-symbolic [^Symbol s env]
-  "Common guts for both EVAL and traced-eval"
+  (let [binding (CDR (ASSOC s env))]
+    (if (= binding NIL)
+      (throw (ex-info (format "No binding for symbol `%s`" s)
+                      {:phase :eval
+                       :symbol s}))
+      binding)))
+
+(defn- eval-internal
+  "Common guts for both EVAL and traced-eval. Evaluate this `expr`
+   and return the result. 
+   
+   For bootstrapping, at least, this is 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
     (= (NUMBERP expr) T) expr
+    (symbol? expr) (eval-symbolic expr env)
     (string? expr) (if (:strict *options*)
                      (throw
                       (ex-info
                        (str "EVAL: strings not allowed in strict mode: \"" expr "\"")
-                       {:cause  :eval
+                       {:phase  :eval
                         :detail :strict
                         :expr   expr}))
                      (symbol expr))
-    (= (ATOM? expr) T) (CDR (ASSOC expr env))
     (=
      (ATOM? (CAR expr))
      T) (cond
@@ -494,9 +547,11 @@
 
 
 (defn EVAL
-  "For bootstrapping, at least, a version of EVAL written in Clojure.
+  "Despatcher for EVAL, selects beteen `traced-eval` and `eval-internal`
-  All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
+   based on the value of `:trace` in `*options*`. Evaluate this `expr`
-  See page 13 of the Lisp 1.5 Programmers Manual."
+   and return the result. If `environment` is not passed,
+   if defaults to the current value of the global object list.
+   All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects."
   ([expr]
    (EVAL expr @oblist))
   ([expr env]

src/beowulf/host.clj

@@ -63,17 +63,14 @@
              {:cause :bad-value
               :detail :rplaca}))));; PLUS
 
-(defn PLUS2
+(defn PLUS
-  "Lisp 1.5 `PLUS` is varargs, and implementing varargs functions in Clojure is
+  [& args]
-   not an added complexity I want. So this is a two arg `PLUS`, on which a
+  (let [s (apply + args)]
-  varargs `PLUS` can be built in the Lisp 1.5 layer using `REDUCE`."
-  [x y]
-  (let [s (+ x y)]
     (if (integer? s) s (float s))))
 
-(defn TIMES2
+(defn TIMES
-  [x y]
+  [& args]
-  (let [p (* x y)]
+  (let [p (apply * args)]
     (if (integer? p) p (float p))))
 
 (defn DIFFERENCE

src/beowulf/io.clj

@@ -48,7 +48,7 @@
          (with-out-str
            (println (apply str (repeat 79 ";")))
            (println (format ";; Beowulf %s Sysout file generated at %s"
-                            (System/getProperty "beowulf.version")
+                            (or (System/getProperty "beowulf.version") "")
                             (local-date-time)))
            (when (System/getenv "USER")
              (println (format ";; generated by %s" (System/getenv "USER"))))

src/beowulf/reader/generate.clj

@@ -130,7 +130,7 @@
 
 (defn gen-iexpr
   [tree]
-  (let [bundle (reduce #(assoc %1 (first %2) (nth %2 1)) 
+  (let [bundle (reduce #(assoc %1 (first %2) %2) 
                        {} 
                        (rest tree))]
     (list (generate (:iop bundle))
@@ -194,9 +194,22 @@
          :exponent (generate (second p))
          :fncall (gen-fn-call p)
          :iexpr (gen-iexpr p)
+         :iop (case (second p)
+                "/" 'DIFFERENCE
+                "=" 'EQUAL
+                ">" 'GREATERP
+                "<" 'LESSP
+                "+" 'PLUS
+                "*" 'TIMES
+                ;; else
+                (throw (ex-info "Unrecognised infix operator symbol"
+                                {:phase :generate
+                                 :fragment p})))
          :list (gen-dot-terminated-list (rest p))
          (:lhs :rhs) (generate (second p))
          :mexpr (generate (second p))
+         :mconst (make-beowulf-list 
+                  (list 'QUOTE (symbol (upper-case (second p)))))
          :mvar (symbol (upper-case (second p)))
          :octal (let [n (read-string (strip-leading-zeros (second p) "0"))
                       scale (generate (nth p 2))]

src/beowulf/reader/parser.clj

@@ -24,11 +24,11 @@
       ;; but it's a convenience.
 
     "exprs := expr | exprs;"
-    "mexpr := λexpr | fncall | defn | cond | mvar | iexpr | mexpr comment;
+    "mexpr := λexpr | fncall | defn | cond | mvar | mconst | iexpr | mexpr comment;
       λexpr := λ lsqb bindings semi-colon body rsqb;
       λ := 'λ';
       bindings := lsqb args rsqb;
-      body := (expr semi-colon opt-space)* expr;
+      body := (mexpr semi-colon opt-space)* mexpr;
       fncall := fn-name lsqb args rsqb;
       lsqb := '[';
       rsqb := ']';
@@ -36,18 +36,21 @@
        rbrace := '}';
       defn := mexpr opt-space '=' opt-space mexpr;
       cond := lsqb (opt-space cond-clause semi-colon opt-space)* cond-clause rsqb;
-      cond-clause := expr opt-space arrow opt-space expr opt-space;
+      cond-clause := mexpr opt-space arrow opt-space mexpr opt-space;
       arrow := '->';
-      args := (opt-space expr semi-colon opt-space)* expr;
+      args := (opt-space mexpr semi-colon opt-space)* mexpr;
       fn-name := mvar;
       mvar := #'[a-z]+';
+      mconst := #'[A-Z]+';
       semi-colon := ';';"
 
     ;; Infix operators appear in mexprs, e.g. on page 7. Ooops!
     ;; I do not know what infix operators are considered legal.
+    ;; In particular I do not know what symbol was used for
+    ;; multiply
     "iexpr := iexp iop iexp;
      iexp := mexpr | number | opt-space iexp opt-space;
-    iop := '>' | '<' | '+' | '-' | '/' | '=' ;"
+    iop := '>' | '<' | '+' | '-' | '*' '/' | '=' ;"
 
       ;; comments. I'm pretty confident Lisp 1.5 did NOT have these.
     "opt-comment := opt-space | comment;"

src/beowulf/reader/simplify.clj

@@ -35,7 +35,10 @@
 
 (defn simplify
   "Simplify this parse tree `p`. If `p` is an instaparse failure object, throw
-  an `ex-info`, with `p` as the value of its `:failure` key."
+   an `ex-info`, with `p` as the value of its `:failure` key.
+   
+   **NOTE THAT** it is assumed that `remove-optional-space` has been run on the
+   parse tree **BEFORE** it is passed to `simplify`."
   ([p]
    (if
     (instance? Failure p)
@@ -55,7 +58,7 @@
                  (case (first p)
                    (:λexpr
                     :args :bindings :body :cond :cond-clause :defn :dot-terminal
-                    :fncall :lhs :octal :quoted-expr :rhs :scientific) (map #(simplify % context) p)
+                    :fncall :lhs :quoted-expr :rhs ) (map #(simplify % context) p)
                    (:arg :expr :coefficient :fn-name :number) (simplify (second p) context)
                    (:arrow :dot :e :lpar :lsqb  :opt-comment :opt-space :q :quote :rpar :rsqb
                            :semi-colon :sep :space) nil
@@ -68,7 +71,7 @@
                               (throw
                                (ex-info "Cannot parse comments in strict mode"
                                         {:cause :strict})))
-                   :decimal p
+                   (:decimal :integer :mconst :octal :scientific) p
                    :dotted-pair (if
                                  (= context :mexpr)
                                   [:fncall

test/beowulf/host_test.clj

@@ -1,7 +1,7 @@
 (ns beowulf.host-test
   (:require [clojure.test :refer [deftest is testing]]
             [beowulf.cons-cell :refer [CDR F make-beowulf-list T]] 
-            [beowulf.host :refer [DIFFERENCE NUMBERP PLUS2 RPLACA RPLACD TIMES2]]
+            [beowulf.host :refer [DIFFERENCE NUMBERP PLUS RPLACA RPLACD TIMES]]
             [beowulf.oblist :refer [NIL]]
             [beowulf.read :refer [gsp]]))
 
@@ -51,18 +51,18 @@
 
 (deftest arithmetic-test
   ;; These are just sanity-test tests; they're by no means exhaustive.
-  (testing "PLUS2"
+  (testing "PLUS"
     (let [expected 3
-          actual (PLUS2 1 2)]
+          actual (PLUS 1 2)]
       (is (= actual expected))
       (is (integer? actual)))
     (let [expected 3.5
-          actual (PLUS2 1.25 9/4)]
+          actual (PLUS 1.25 9/4)]
       (is (= actual expected))
       (is (float? actual))))
-  (testing "TIMES2"
+  (testing "TIMES"
     (let [expected 6
-          actual (TIMES2 2 3)]
+          actual (TIMES 2 3)]
       (is (= actual expected))))
   (testing DIFFERENCE
     (let [expected -1