Complete (and much improved) reimplementation of the trace system.

README.md

@@ -37,7 +37,6 @@ Command line arguments as follows:
   -p PROMPT, --prompt PROMPT    Sprecan::  Set the REPL prompt to PROMPT
   -r INITFILE, --read INITFILE             Read Lisp functions from the file INITFILE
   -s, --strict                             Strictly interpret the Lisp 1.5 language, without extensions.
-  -t, --trace                              Trace Lisp evaluation.
 ```
 
 ### Architectural plan
@@ -66,8 +65,7 @@ implementations.
 This file is essentially Lisp as defined in Chapter 1 (pages 1-14) of the
 Lisp 1.5 Programmer's Manual; that is to say, a very simple Lisp language,
 which should, I believe, be sufficient in conjunction with the functions
-provided by `beowulf.host`, be sufficient to bootstrap the full Lisp 1.5
+provided by `beowulf.host`, to bootstrap the full Lisp 1.5 interpreter.
-interpreter.
 
 In addition it contains the function `INTEROP`, which allows host language
 functions to be called from Lisp.

resources/lisp1.5.lsp

@@ -74,4 +74,6 @@
   (SYSOUT) 
   (TERPRI)
   (TIMES)
+  (TRACE)
+  (UNTRACE)
   (ZEROP LAMBDA (N) (EQ N 0)))

src/beowulf/bootstrap.clj

@@ -10,15 +10,15 @@
   therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell`
   objects."
   (:require [clojure.string :as s]
-            [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 [AND ADD1 DIFFERENCE ERROR FIXP GENSYM GREATERP LESSP
                                   NUMBERP PLUS QUOTIENT
-                                  REMAINDER RPLACA RPLACD SUB1 TIMES]]
+                                  REMAINDER RPLACA RPLACD TIMES]]
             [beowulf.io :refer [SYSIN SYSOUT]]
             [beowulf.oblist :refer [*options* oblist NIL]]
-            [beowulf.read :refer [READ]])
+            [beowulf.read :refer [READ]]
+            [beowulf.trace :refer [TRACE traced? UNTRACE]])
   (:import [beowulf.cons_cell ConsCell]
            [clojure.lang Symbol]))
 
@@ -399,12 +399,19 @@
 (defn- apply-symbolic
   "Apply this `funtion-symbol` to these `args` in this `environment` and 
    return the result."
-  [^Symbol function-symbol ^ConsCell args ^ConsCell environment]
+  [^Symbol function-symbol ^ConsCell args ^ConsCell environment depth]
-  (let [fn (try (EVAL function-symbol environment)
+  (let [fn (try (EVAL function-symbol environment depth)
                 (catch Throwable any (when (:trace *options*)
-                                       (println any))))]
+                                       (println any))))
+        indent (apply str (repeat depth "-"))]
     (if (and fn (not= fn NIL))
-      (APPLY fn args environment)
+      (if (traced? function-symbol)
+        (do
+         (println (str indent "> " function-symbol " " args))
+         (let [r (APPLY fn args environment depth)]
+           (println (str "<" indent " " r))
+           r))
+        (APPLY fn args environment depth))
       (case function-symbol ;; there must be a better way of doing this!
         ADD1 (apply ADD1 args)
         AND (apply AND args)
@@ -446,20 +453,22 @@
                    (apply SYSOUT args)))
         TERPRI (println)
         TIMES (apply TIMES args)
+        TRACE (apply TRACE args)
+        UNTRACE (apply UNTRACE args)
         ;; else
         (ex-info "No function found"
                  {:context "APPLY"
                   :function function-symbol
                   :args args})))))
 
-(defn apply-internal
+(defn APPLY
-  "Internal guts of both `APPLY` and `traced-apply`. Apply this `function` to 
+  "Apply this `function` to these `arguments` in this `environment` and return
-   these `arguments` in this `environment` and return the result.
+   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]
+  [function args environment depth]
   (cond
     (= NIL function) (if (:strict *options*)
                        NIL
@@ -467,10 +476,10 @@
                                        {:context "APPLY"
                                         :function "NIL"
                                         :args args})))
-    (= (ATOM? function) T) (apply-symbolic function args environment)
+    (= (ATOM? function) T) (apply-symbolic function args environment (inc depth))
     (= (first function) 'LAMBDA) (EVAL
                                   (CADDR function)
-                                  (PAIRLIS (CADR function) args environment))
+                                  (PAIRLIS (CADR function) args environment) depth)
     (= (first function) 'LABEL) (APPLY
                                  (CADDR function)
                                  args
@@ -478,26 +487,8 @@
                                   (make-cons-cell
                                    (CADR function)
                                    (CADDR function))
-                                  environment))))
+                                  environment)
-
+                                 depth)))
-(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 `clauses` are assumed to be
@@ -505,24 +496,24 @@
    often return `F`, not `NIL`, on failure.
 
    See page 13 of the Lisp 1.5 Programmers Manual."
-  [clauses env]
+  [clauses env depth]
-  (let [test (EVAL (CAAR clauses) env)]
+  (let [test (EVAL (CAAR clauses) env depth)]
     (if
      (and (not= test NIL) (not= test 'F))
-      (EVAL (CADAR clauses) env)
+      (EVAL (CADAR clauses) env depth)
-      (EVCON (CDR clauses) env))))
+      (EVCON (CDR clauses) env depth))))
 
 (defn- EVLIS
   "Map `EVAL` across this list of `args` in the context of this
   `env`ironment.All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
   See page 13 of the Lisp 1.5 Programmers Manual."
-  [args env]
+  [args env depth]
   (cond
     (= NIL args) NIL
     :else
     (make-cons-cell
-     (EVAL (CAR args) env)
+     (EVAL (CAR args) env depth)
-     (EVLIS (CDR args) env))))
+     (EVLIS (CDR args) env depth))))
 
 (defn- eval-symbolic [^Symbol s env]
   (let [binding (ASSOC s env)]
@@ -532,66 +523,41 @@
                        :symbol s}))
       (CDR 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 "\"")
-                       {:phase  :eval
-                        :detail :strict
-                        :expr   expr}))
-                     (symbol expr))
-    (=
-     (ATOM? (CAR expr))
-     T) (cond
-          (= (CAR expr) 'QUOTE) (CADR expr)
-          (= (CAR expr) 'COND) (EVCON (CDR expr) env)
-          :else (APPLY
-                 (CAR expr)
-                 (EVLIS (CDR expr) env)
-                 env))
-    :else (APPLY
-           (CAR expr)
-           (EVLIS (CDR expr) env)
-           env)))
-
-(deftrace traced-eval
-  "Essentially, identical to EVAL except traced."
-  [expr env]
-  (eval-internal expr env))
-
-;; (defmacro EVAL
-;;   "For bootstrapping, at least, 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]
-;;   `(if
-;;    (:trace *options*)
-;;     (traced-eval ~expr ~env)
-;;     (eval-internal ~expr ~env)))
-
 
 (defn EVAL
-  "Despatcher for EVAL, selects beteen `traced-eval` and `eval-internal`
+  "Evaluate this `expr` and return the result. If `environment` is not passed,
-   based on the value of `:trace` in `*options*`. Evaluate this `expr`
+   it defaults to the current value of the global object list. The `depth`
-   and return the result. If `environment` is not passed,
+   argument is part of the tracing system and should not be set by user code.
-   if defaults to the current value of the global object list.
+
-   All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects."
+   All args are assumed to be numbers, symbols or `beowulf.cons-cell/ConsCell` 
-  ([expr]
+   objects."
-   (EVAL expr @oblist))
+  ([expr]
-  ([expr env]
+   (EVAL expr @oblist 0))
-   (if
+  ([expr env depth]
-    (:trace *options*)
+   (cond
-     (traced-eval expr env)
+     (= (NUMBERP expr) T) expr
-     (eval-internal expr env))))
+     (symbol? expr) (eval-symbolic expr env)
+     (string? expr) (if (:strict *options*)
+                      (throw
+                       (ex-info
+                        (str "EVAL: strings not allowed in strict mode: \"" expr "\"")
+                        {:phase  :eval
+                         :detail :strict
+                         :expr   expr}))
+                      (symbol expr))
+     (=
+      (ATOM? (CAR expr))
+      T) (cond
+           (= (CAR expr) 'QUOTE) (CADR expr)
+           (= (CAR expr) 'COND) (EVCON (CDR expr) env depth)
+           :else (APPLY
+                  (CAR expr)
+                  (EVLIS (CDR expr) env depth)
+                  env
+                  depth))
+     :else (APPLY
+            (CAR expr)
+            (EVLIS (CDR expr) env depth)
+            env
+            depth))))
 

src/beowulf/core.clj

@@ -29,8 +29,7 @@
                  (.exists (io/file %))
                  (.canRead (io/file %)))
                "Could not find initfile"]]
-   ["-s" "--strict" "Strictly interpret the Lisp 1.5 language, without extensions."]
+   ["-s" "--strict" "Strictly interpret the Lisp 1.5 language, without extensions."]])
-   ["-t" "--trace" "Trace Lisp evaluation."]])
 
 (defn repl
   "Read/eval/print loop."
@@ -42,7 +41,7 @@
       (let [input (trim (read-from-console))]
         (cond
           (= input stop-word) (throw (ex-info "\nFærwell!" {:cause :quit}))
-          input (println (str ">  " (print-str (EVAL (READ input) @oblist))))
+          input (println (str ">  " (print-str (EVAL (READ input) @oblist 0))))
           :else (println)))
       (catch
        Exception

src/beowulf/trace.clj

@@ -0,0 +1,24 @@
+(ns beowulf.trace
+  "Tracing of function execution")
+
+(def traced-symbols
+  "Symbols currently being traced."
+  (atom #{}))
+
+(defn traced?
+  "Return `true` iff `s` is a symbol currently being traced, else `nil`."
+  [s]
+  (try (contains? @traced-symbols s)
+       (catch Throwable _)))
+
+(defn TRACE
+  "Add this symbol `s` to the set of symbols currently being traced. If `s`
+   is not a symbol, does nothing."
+  [s]
+  (when (symbol? s)
+    (swap! traced-symbols #(conj % s))))
+
+(defn UNTRACE
+  [s]
+  (when (symbol? s)
+    (swap! traced-symbols #(set (remove (fn [x] (= s x)) %)))))