From 197ff0a08f97345e90fdf200df3f48a95b4ec19f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 30 Mar 2023 15:52:52 +0100 Subject: [PATCH] Complete (and much improved) reimplementation of the trace system. --- README.md | 4 +- resources/lisp1.5.lsp | 2 + src/beowulf/bootstrap.clj | 170 +++++++++++++++----------------------- src/beowulf/core.clj | 5 +- src/beowulf/host.clj | 2 +- src/beowulf/trace.clj | 24 ++++++ 6 files changed, 98 insertions(+), 109 deletions(-) create mode 100644 src/beowulf/trace.clj diff --git a/README.md b/README.md index 0bfbecb..ecdf752 100644 --- a/README.md +++ b/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 -interpreter. +provided by `beowulf.host`, to bootstrap the full Lisp 1.5 interpreter. In addition it contains the function `INTEROP`, which allows host language functions to be called from Lisp. diff --git a/resources/lisp1.5.lsp b/resources/lisp1.5.lsp index 94c3623..c881745 100644 --- a/resources/lisp1.5.lsp +++ b/resources/lisp1.5.lsp @@ -74,4 +74,6 @@ (SYSOUT) (TERPRI) (TIMES) + (TRACE) + (UNTRACE) (ZEROP LAMBDA (N) (EQ N 0))) diff --git a/src/beowulf/bootstrap.clj b/src/beowulf/bootstrap.clj index 770763b..f419944 100644 --- a/src/beowulf/bootstrap.clj +++ b/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 + [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] - (let [fn (try (EVAL function-symbol environment) + [^Symbol function-symbol ^ConsCell args ^ConsCell environment depth] + (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) @@ -438,7 +445,7 @@ RPLACA (apply RPLACA args) RPLACD (apply RPLACD args) SET (apply SET args) - SYSIN (when (lax? 'SYSIN) + SYSIN (when (lax? 'SYSIN) (apply SYSIN args)) SYSOUT (when (lax? 'SYSOUT) (if (empty? 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 - "Internal guts of both `APPLY` and `traced-apply`. Apply this `function` to - these `arguments` in this `environment` and return the result. +(defn 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] + [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)))) - -(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)))) + environment) + depth))) (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] - (let [test (EVAL (CAAR clauses) env)] + [clauses env depth] + (let [test (EVAL (CAAR clauses) env depth)] (if (and (not= test NIL) (not= test 'F)) - (EVAL (CADAR clauses) env) - (EVCON (CDR clauses) env)))) + (EVAL (CADAR clauses) env depth) + (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) - (EVLIS (CDR args) env)))) + (EVAL (CAR args) env depth) + (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` - based on the value of `:trace` in `*options*`. Evaluate this `expr` - 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] - (if - (:trace *options*) - (traced-eval expr env) - (eval-internal expr env)))) + "Evaluate this `expr` and return the result. If `environment` is not passed, + it defaults to the current value of the global object list. The `depth` + 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." + ([expr] + (EVAL expr @oblist 0)) + ([expr env depth] + (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 depth) + :else (APPLY + (CAR expr) + (EVLIS (CDR expr) env depth) + env + depth)) + :else (APPLY + (CAR expr) + (EVLIS (CDR expr) env depth) + env + depth)))) diff --git a/src/beowulf/core.clj b/src/beowulf/core.clj index d924795..5ffd477 100644 --- a/src/beowulf/core.clj +++ b/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."] - ["-t" "--trace" "Trace Lisp evaluation."]]) + ["-s" "--strict" "Strictly interpret the Lisp 1.5 language, without extensions."]]) (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 diff --git a/src/beowulf/host.clj b/src/beowulf/host.clj index b367ea2..44bbd31 100644 --- a/src/beowulf/host.clj +++ b/src/beowulf/host.clj @@ -135,4 +135,4 @@ (defn GREATERP [x y] - (> x y)) \ No newline at end of file + (> x y)) diff --git a/src/beowulf/trace.clj b/src/beowulf/trace.clj new file mode 100644 index 0000000..c3807e2 --- /dev/null +++ b/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)) %))))) \ No newline at end of file