From 20b8f45db1570ec9bd1b207d41e66fed8ad5735f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 6 Apr 2023 14:25:12 +0100 Subject: [PATCH] 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 | 244 ++++++++++++++++++++++---------------- src/beowulf/core.clj | 4 +- src/beowulf/host.clj | 50 +++++--- 3 files changed, 176 insertions(+), 122 deletions(-) diff --git a/src/beowulf/bootstrap.clj b/src/beowulf/bootstrap.clj index ad6aae7..9637a69 100644 --- a/src/beowulf/bootstrap.clj +++ b/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]] - [beowulf.host :refer [ATOM CAAR CADAR CADDR CADR CAR CDR GET LIST - NUMBERP PAIRLIS traced?]] - [beowulf.interop :refer [to-clojure]] + (:require [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell T]] + [beowulf.host :refer [ASSOC ATOM CAAR CADAR CADDR CADR CAR CDR GET + LIST NUMBERP PAIRLIS traced?]] [beowulf.oblist :refer [*options* NIL oblist]]) (:import [beowulf.cons_cell ConsCell] [clojure.lang Symbol])) @@ -39,51 +38,67 @@ (declare APPLY EVAL) -(defmacro QUOTE - "Quote, but in upper case for LISP 1.5" - [f] - `(quote ~f)) +(defn try-resolve-subroutine + "Attempt to resolve this `subr` with these `arg`." + [subr args] + (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 - "Like `APPLY`, but with trace output to console." - [function-symbol args lisp-fn environment depth] - (let [indent (apply str (repeat depth "-"))] - (println (str indent "> " function-symbol " " args)) - (let [r (APPLY lisp-fn args environment depth)] - (println (str "<" indent " " r)) - r))) +(defn- trace-call + "Show a trace of a call to the function named by this `function-symbol` + 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))))) -(defn- safe-apply - "We've a real problem with varargs functions when `args` is `NIL`, because - Clojure does not see `NIL` as an empty sequence." - [clj-fn args] - (let [args' (when (instance? ConsCell args) args)] - (apply clj-fn args'))) +(defn- trace-response + "Show a trace of this `response` from the function named by this + `function-symbol` at this depth." + [function-symbol response depth] + (when (traced? function-symbol) + (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) - (catch Throwable any (when (:trace *options*) - (println any))))] - (if (and lisp-fn - (not= lisp-fn NIL)) (if (traced? function-symbol) - (traced-apply function-symbol - args - lisp-fn - environment - depth) - (APPLY lisp-fn args environment depth)) - (if function-symbol - (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}))))) + (trace-call function-symbol args depth) + (let [lisp-fn ;; (try + (value function-symbol '(EXPR FEXPR)) + ;; (catch Exception any (when (traced? function-symbol) + ;; (println any)))) + subr (value function-symbol '(SUBR FSUBR)) + host-fn (try-resolve-subroutine subr args) + result (cond (and lisp-fn + (not= lisp-fn NIL)) (APPLY lisp-fn args environment depth) + host-fn (apply host-fn (when (instance? ConsCell args) args)) + :else (ex-info "No function found" + {:phase :apply + :function function-symbol + :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,33 +108,37 @@ 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 - (= NIL function) (if (:strict *options*) - NIL - (throw (ex-info "NIL is not a function" - {:context "APPLY" - :function "NIL" - :args args}))) - (= (ATOM function) T) (apply-symbolic function args environment (inc depth)) - :else (case (first function) - LABEL (APPLY - (CADDR function) - args - (make-cons-cell - (make-cons-cell - (CADR function) - (CADDR function)) - environment) - depth) - FUNARG (APPLY (CADR function) args (CADDR function) depth) - LAMBDA (EVAL - (CADDR function) - (PAIRLIS (CADR function) args environment) depth) - (throw (ex-info "Unrecognised value in function position" - {:phase :apply - :function function - :args args - :type :beowulf}))))) + (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" + {:phase :apply + :function "NIL" + :args args + :type :beowulf}))) + (= (ATOM function) T) (apply-symbolic function args environment (inc depth)) + :else (case (first function) + LABEL (APPLY + (CADDR function) + args + (make-cons-cell + (make-cons-cell + (CADR function) + (CADDR function)) + environment) + depth) + FUNARG (APPLY (CADR function) args (CADDR function) depth) + LAMBDA (EVAL + (CADDR function) + (PAIRLIS (CADR function) args environment) depth) + (throw (ex-info "Unrecognised value in function position" + {:phase :apply + :function function + :args args + :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] -;; (let [binding (ASSOC s env)] -;; (if (= binding NIL) -;; (throw (ex-info (format "No binding for symbol `%s`" s) -;; {:phase :eval -;; :symbol s})) -;; (CDR binding)))) +(defn- eval-symbolic + [expr env depth] + (let [v (value expr (list 'APVAL)) + indent (apply str (repeat depth "-"))] + (when (traced? 'EVAL) + (println (str indent ": EVAL: deep binding (" expr " . " (or v "nil") ")"))) + (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,34 +191,41 @@ 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 - (= (NUMBERP expr) T) expr - (symbol? expr) (GET expr 'APVAL) - (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) (case (CAR expr) - QUOTE (CADR expr) - FUNCTION (LIST 'FUNARG (CADR expr)) - COND (EVCON (CDR expr) env depth) + (trace-call 'EVAL (list expr env depth) depth) + (let [result (cond + (= (NUMBERP expr) T) expr + (symbol? expr) (eval-symbolic expr env depth) + (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) (case (CAR expr) + QUOTE (CADR expr) + FUNCTION (LIST 'FUNARG (CADR 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)))) + (APPLY + (CAR expr) + (EVLIS (CDR expr) env depth) + env + depth)) + :else (APPLY + (CAR expr) + (EVLIS (CDR expr) env depth) + env + depth))] + (trace-response 'EVAL result depth) + result))) diff --git a/src/beowulf/core.clj b/src/beowulf/core.clj index 42e3e16..99b5a59 100644 --- a/src/beowulf/core.clj +++ b/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." diff --git a/src/beowulf/host.clj b/src/beowulf/host.clj index 738d806..82821ce 100644 --- a/src/beowulf/host.clj +++ b/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]] - [beowulf.cons-cell :refer [F make-cons-cell make-beowulf-list - pretty-print T]] - ;; note hyphen - this is Clojure... + (:require [beowulf.cons-cell :refer [F make-beowulf-list make-cons-cell T]] ;; note hyphen - this is Clojure... [beowulf.gendoc :refer [open-doc]] - [beowulf.oblist :refer [*options* oblist NIL]]) - (:import [beowulf.cons_cell ConsCell] - ;; note underscore - same namespace, but Java. + [beowulf.oblist :refer [*options* NIL oblist]] + [clojure.set :refer [union]] + [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)) - 'T - 'F)) + (cond (= NIL args) T + (not (#{NIL F} (.getCar args))) (AND (.getCdr args)) + :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` - is not a symbol, does nothing." + "Add this `s` to the set of symbols currently being traced. If `s` + is not a symbol or sequence of symbols, does nothing." [s] - (when (symbol? s) - (swap! traced-symbols #(conj % s)))) + (swap! traced-symbols + #(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) - (swap! traced-symbols #(set (remove (fn [x] (= s x)) %))))) + (cond + (symbol? s) (swap! traced-symbols #(set (remove (fn [x] (= s x)) %))) + (and (seq? s) (every? symbol? s)) (map UNTRACE s)) + @traced-symbols) ;;;; Extensions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;