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.
This commit is contained in:
parent
5b5ddb9444
commit
20b8f45db1
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue