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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;