My monster, it lives!

I'm not confident this is yet tidy, so I'm not yet closing the feature branch - but it's working.

src/beowulf/bootstrap.clj

@@ -9,10 +9,9 @@
   ALLUPPERCASE are Lisp 1.5 functions (although written in Clojure) and that
   therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell`
   objects."
-  (:require [beowulf.cons-cell :refer [make-cons-cell T]]
+  (:require [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell T]]
-            [beowulf.host :refer [ATOM CAAR CADAR CADDR CADR CAR CDR GET LIST
+            [beowulf.host :refer [ASSOC ATOM CAAR CADAR CADDR CADR CAR CDR GET
-                                  NUMBERP PAIRLIS traced?]]
+                                  LIST NUMBERP PAIRLIS traced?]]
-            [beowulf.interop :refer [to-clojure]]
             [beowulf.oblist :refer [*options* NIL oblist]])
   (:import [beowulf.cons_cell ConsCell]
            [clojure.lang Symbol]))
@@ -39,51 +38,67 @@
 
 (declare APPLY EVAL)
 
-(defmacro QUOTE
+(defn try-resolve-subroutine
-  "Quote, but in upper case for LISP 1.5"
+  "Attempt to resolve this `subr` with these `arg`."
-  [f]
+  [subr args]
-  `(quote ~f))
+  (when (and subr (not= subr NIL))
+    (try @(resolve subr)
+         (catch Throwable any
+           (throw (ex-info "Failed to resolve subroutine"
+                           {:phase :apply
+                            :function subr
+                            :args args
+                            :type :beowulf}
+                           any))))))
 
-(defn- traced-apply
+(defn- trace-call
-  "Like `APPLY`, but with trace output to console."
+  "Show a trace of a call to the function named by this `function-symbol` 
-  [function-symbol args lisp-fn environment depth]
+  with these `args` at this depth."
+  [function-symbol args depth]
+  (when (traced? function-symbol)
     (let [indent (apply str (repeat depth "-"))]
-    (println (str indent "> " function-symbol " " args))
+      (println (str indent "> " function-symbol " " args)))))
-    (let [r (APPLY lisp-fn args environment depth)]
-      (println (str "<" indent " " r))
-      r)))
 
-(defn- safe-apply
+(defn- trace-response
-  "We've a real problem with varargs functions when `args` is `NIL`, because
+  "Show a trace of this `response` from the function named by this
-   Clojure does not see `NIL` as an empty sequence."
+   `function-symbol` at this depth."
-  [clj-fn args]
+  [function-symbol response depth]
-  (let [args' (when (instance? ConsCell args) args)]
+  (when (traced? function-symbol)
-    (apply clj-fn args')))
+    (let [indent (apply str (repeat depth "-"))]
+      (println (str "<" indent " " function-symbol " " response))))
+  response)
+
+(defn- value
+  "Seek a value for this symbol `s` by checking each of these indicators in
+   turn."
+  ([s]
+   (value s (list 'APVAL 'EXPR 'FEXPR 'SUBR 'FSUBR)))
+  ([s indicators]
+   (when (symbol? s)
+     (first (remove #(= % NIL) (map #(GET s %)
+                                    indicators))))))
 
 (defn- apply-symbolic
   "Apply this `funtion-symbol` to these `args` in this `environment` and 
    return the result."
   [^Symbol function-symbol args ^ConsCell environment depth]
-  (let [lisp-fn (try (EVAL function-symbol environment depth)
+  (trace-call function-symbol args depth)
-                     (catch Throwable any (when (:trace *options*)
+  (let [lisp-fn ;; (try 
-                                            (println any))))]
+        (value function-symbol '(EXPR FEXPR))
-    (if (and lisp-fn
+                    ;; (catch Exception any (when (traced? function-symbol)
-             (not= lisp-fn NIL)) (if (traced? function-symbol)
+                    ;;                        (println any))))
-                                   (traced-apply function-symbol
+        subr (value function-symbol '(SUBR FSUBR))
-                                                 args
+        host-fn (try-resolve-subroutine subr args)
-                                                 lisp-fn
+        result (cond (and lisp-fn
-                                                 environment
+                          (not= lisp-fn NIL)) (APPLY lisp-fn args environment depth)
-                                                 depth)
+                     host-fn (apply host-fn (when (instance? ConsCell args) args))
-                                   (APPLY lisp-fn args environment depth))
+                     :else (ex-info "No function found"
-        (if function-symbol
+                                    {:phase :apply
-          (let [f (GET function-symbol 'SUBR)]
-            (when f
-              (apply @(resolve f) (to-clojure args))))
-        ;; else
-          (ex-info "No function found"
-                   {:context "APPLY"
                                      :function function-symbol
-                    :args args})))))
+                                     :args args
+                                     :type :beowulf}))]
+    (trace-response function-symbol result depth)
+    result))
 
 (defn APPLY
   "Apply this `function` to these `arguments` in this `environment` and return
@@ -93,13 +108,15 @@
    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 depth]
-  (cond
+  (trace-call 'APPLY (list function args environment) depth)
+  (let [result (cond
                  (= NIL function) (if (:strict *options*)
                                     NIL
                                     (throw (ex-info "NIL is not a function"
-                                       {:context "APPLY"
+                                                    {:phase :apply
                                                      :function "NIL"
-                                        :args args})))
+                                                     :args args
+                                                     :type :beowulf})))
                  (= (ATOM function) T) (apply-symbolic function args environment (inc depth))
                  :else (case (first function)
                          LABEL (APPLY
@@ -119,7 +136,9 @@
                                          {:phase :apply
                                           :function function
                                           :args args
-                             :type :beowulf})))))
+                                          :type :beowulf}))))]
+    (trace-response 'APPLY result depth)
+    result))
 
 (defn- EVCON
   "Inner guts of primitive COND. All `clauses` are assumed to be
@@ -146,13 +165,25 @@
      (EVAL (CAR args) env depth)
      (EVLIS (CDR args) env depth))))
 
-;; (defn- eval-symbolic [^Symbol s env]
+(defn- eval-symbolic
-;;   (let [binding (ASSOC s env)]
+  [expr env depth]
-;;     (if (= binding NIL)
+  (let [v (value expr (list 'APVAL))
-;;       (throw (ex-info (format "No binding for symbol `%s`" s)
+        indent (apply str (repeat depth "-"))]
-;;                       {:phase :eval
+    (when (traced? 'EVAL)
-;;                        :symbol s}))
+      (println (str indent ": EVAL: deep binding (" expr " . " (or v "nil") ")")))
-;;       (CDR binding))))
+    (if (and v (not= v NIL))
+      v
+      (let [v' (ASSOC expr env)]
+        (when (traced? 'EVAL)
+          (println (str indent ": EVAL: shallow binding: " (or v' "nil"))))
+        (if (and v' (not= v' NIL))
+          (.getCdr v')
+          (throw (ex-info "No binding for symbol found"
+                          {:phase :eval
+                           :function 'EVAL
+                           :args (list expr env depth)
+                           :type :lisp
+                           :code :A8})))))))
 
 (defn EVAL
   "Evaluate this `expr` and return the result. If `environment` is not passed,
@@ -160,13 +191,18 @@
    argument is part of the tracing system and should not be set by user code.
 
    All args are assumed to be numbers, symbols or `beowulf.cons-cell/ConsCell` 
-   objects."
+   objects. However, if called with just a single arg, `expr`, I'll assume it's
+   being called from the Clojure REPL and will coerce the `expr` to `ConsCell`."
   ([expr]
-   (EVAL expr @oblist 0))
+   (let [expr' (if (and (coll? expr) (not (instance? ConsCell expr)))
+                 (make-beowulf-list expr)
+                 expr)]
+     (EVAL expr' @oblist 0)))
   ([expr env depth]
-   (cond
+   (trace-call 'EVAL (list expr env depth) depth)
+   (let [result (cond
                   (= (NUMBERP expr) T) expr
-     (symbol? expr) (GET expr 'APVAL)
+                  (symbol? expr) (eval-symbolic expr env depth)
                   (string? expr) (if (:strict *options*)
                                    (throw
                                     (ex-info
@@ -189,5 +225,7 @@
                          (CAR expr)
                          (EVLIS (CDR expr) env depth)
                          env
-            depth))))
+                         depth))]
+     (trace-response 'EVAL result depth)
+     result)))
 

src/beowulf/core.clj

@@ -2,8 +2,8 @@
   "Essentially, the `-main` function and the bootstrap read-eval-print loop."
   (:require [beowulf.bootstrap :refer [EVAL]]
             [beowulf.io :refer [default-sysout SYSIN]]
+            [beowulf.oblist :refer [*options* NIL]]
             [beowulf.read :refer [READ read-from-console]]
-            [beowulf.oblist :refer [*options* oblist]]
             [clojure.java.io :as io]
             [clojure.pprint :refer [pprint]]
             [clojure.string :refer [trim]]
@@ -55,7 +55,7 @@
 (defn- re 
   "Like REPL, but it isn't a loop and doesn't print."
   [input]
-  (EVAL (READ input) @oblist 0))
+  (EVAL (READ input) NIL 0))
 
 (defn repl
   "Read/eval/print loop."

src/beowulf/host.clj

@@ -2,14 +2,12 @@
   "provides Lisp 1.5 functions which can't be (or can't efficiently
    be) implemented in Lisp 1.5, which therefore need to be implemented in the
    host language, in this case Clojure."
-  (:require [clojure.string :refer [upper-case]]
+  (:require [beowulf.cons-cell :refer [F make-beowulf-list make-cons-cell T]] ;; note hyphen - this is Clojure...
-            [beowulf.cons-cell :refer [F make-cons-cell make-beowulf-list
-                                       pretty-print T]]
-            ;; note hyphen - this is Clojure...
             [beowulf.gendoc :refer [open-doc]]
-            [beowulf.oblist :refer [*options* oblist NIL]])
+            [beowulf.oblist :refer [*options* NIL oblist]]
-  (:import [beowulf.cons_cell ConsCell]
+            [clojure.set :refer [union]]
-           ;; note underscore - same namespace, but Java.
+            [clojure.string :refer [upper-case]])
+  (:import [beowulf.cons_cell ConsCell] ;; note underscore - same namespace, but Java.
            ))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -290,9 +288,20 @@
    In `beowulf.host` principally because I don't yet feel confident to define
    varargs functions in Lisp."
   [& args]
-  (if (empty? (filter #(or (= 'F %) (= NIL %) (nil? %)) args))
+  (cond (= NIL args) T
-    'T
+        (not (#{NIL F} (.getCar args))) (AND (.getCdr args))
-    'F))
+        :else T))
+
+(defn OR
+  "`T` if and only if at least one of my `args` evaluates to something other
+  than either `F` or `NIL`, else `F`.
+   
+   In `beowulf.host` principally because I don't yet feel confident to define
+   varargs functions in Lisp."
+  [& args]
+  (cond (= NIL args) F
+        (not (#{NIL F} (.getCar args))) T
+        :else (OR (.getCdr args))))
 
 ;;;; Operations on lists ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -516,19 +525,26 @@
   "Return `true` iff `s` is a symbol currently being traced, else `nil`."
   [s]
   (try (contains? @traced-symbols s)
-       (catch Throwable _)))
+       (catch Throwable _ nil)))
 
 (defn TRACE
-  "Add this symbol `s` to the set of symbols currently being traced. If `s`
+  "Add this `s` to the set of symbols currently being traced. If `s`
-   is not a symbol, does nothing."
+   is not a symbol or sequence of symbols, does nothing."
   [s]
-  (when (symbol? s)
+  (swap! traced-symbols
-    (swap! traced-symbols #(conj % s))))
+         #(cond
+            (symbol? s) (conj % s)
+            (and (seq? s) (every? symbol? s)) (union % (set s))
+            :else %)))
 
 (defn UNTRACE
+  "Remove this `s` from the set of symbols currently being traced. If `s`
+   is not a symbol or sequence of symbols, does nothing."
   [s]
-  (when (symbol? s)
+  (cond
-    (swap! traced-symbols #(set (remove (fn [x] (= s x)) %)))))
+    (symbol? s) (swap! traced-symbols #(set (remove (fn [x] (= s x)) %)))
+    (and (seq? s) (every? symbol? s)) (map UNTRACE s))
+  @traced-symbols)
 
 ;;;; Extensions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;