diff --git a/docs/cloverage/beowulf/bootstrap.clj.html b/docs/cloverage/beowulf/bootstrap.clj.html
index 20afabb..c45387d 100644
--- a/docs/cloverage/beowulf/bootstrap.clj.html
+++ b/docs/cloverage/beowulf/bootstrap.clj.html
@@ -38,1213 +38,1237 @@
011 objects."
- 012 (:require [clojure.string :as s]
+ 012 (:require [beowulf.cons-cell :refer [F make-beowulf-list make-cons-cell
- 013 [clojure.tools.trace :refer :all]
+ 013 pretty-print T]]
- 014 [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]))
+ 014 [beowulf.host :refer [ASSOC ATOM CAAR CADAR CADDR CADR CAR CDR GET
+
+
+ 015 LIST NUMBERP PAIRLIS traced?]]
+
+
+ 016 [beowulf.oblist :refer [*options* NIL oblist]])
+
+
+ 017 (:import [beowulf.cons_cell ConsCell]
+
+
+ 018 [clojure.lang Symbol]))
- 015
+ 019
- 016 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 020 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- 017 ;;;
+ 021 ;;;
- 018 ;;; This file is essentially Lisp as defined in Chapter 1 (pages 1-14) of the
-
-
- 019 ;;; Lisp 1.5 Programmer's Manual; that is to say, a very simple Lisp language,
-
-
- 020 ;;; which should, I believe, be sufficient in conjunction with the functions
-
-
- 021 ;;; provided by `beowulf.host`, be sufficient to bootstrap the full Lisp 1.5
-
-
- 022 ;;; interpreter.
+ 022 ;;; Copyright (C) 2022-2023 Simon Brooke
023 ;;;
- 024 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 024 ;;; This program is free software; you can redistribute it and/or
+
+
+ 025 ;;; modify it under the terms of the GNU General Public License
+
+
+ 026 ;;; as published by the Free Software Foundation; either version 2
+
+
+ 027 ;;; of the License, or (at your option) any later version.
+
+
+ 028 ;;;
+
+
+ 029 ;;; This program is distributed in the hope that it will be useful,
+
+
+ 030 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+
+
+ 031 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+
+
+ 032 ;;; GNU General Public License for more details.
+
+
+ 033 ;;;
+
+
+ 034 ;;; You should have received a copy of the GNU General Public License
+
+
+ 035 ;;; along with this program; if not, write to the Free Software
+
+
+ 036 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+
+ 037 ;;;
+
+
+ 038 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- 025
-
-
- 026 (declare EVAL)
-
-
- 027
-
-
- 028 (def oblist
-
-
- 029 "The default environment."
-
-
- 030 (atom NIL))
-
-
- 031
-
-
- 032 (def ^:dynamic *options*
-
-
- 033 "Command line options from invocation."
-
-
- 034 {})
-
-
- 035
-
-
- 036 (defmacro NULL
-
-
- 037 "Returns `T` if and only if the argument `x` is bound to `NIL`; else `F`."
-
-
- 038 [x]
-
-
- 039 `(if (= ~x NIL) T F))
-
-
- 040
-
-
- 041 (defmacro ATOM
-
-
- 042 "Returns `T` if and only is the argument `x` is bound to and atom; else `F`.
-
-
- 043 It is not clear to me from the documentation whether `(ATOM 7)` should return
-
-
- 044 `T` or `F`. I'm going to assume `T`."
-
-
- 045 [x]
-
-
- 046 `(if (or (symbol? ~x) (number? ~x)) T F))
-
-
- 047
-
-
- 048 (defmacro ATOM?
-
-
- 049 "The convention of returning `F` from predicates, rather than `NIL`, is going
-
-
- 050 to tie me in knots. This is a variant of `ATOM` which returns `NIL`
-
-
- 051 on failure."
-
-
- 052 [x]
-
-
- 053 `(if (or (symbol? ~x) (number? ~x)) T NIL))
-
-
- 054
-
-
- 055 (defn CAR
-
-
- 056 "Return the item indicated by the first pointer of a pair. NIL is treated
-
-
- 057 specially: the CAR of NIL is NIL."
-
-
- 058 [x]
-
-
- 059 (cond
-
-
- 060 (= x NIL) NIL
-
-
- 061 (instance? beowulf.cons_cell.ConsCell x) (.CAR x)
-
-
- 062 :else
-
-
- 063 (throw
-
-
- 064 (Exception.
-
-
- 065 (str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")")))))
-
-
- 066
-
-
- 067 (defn CDR
-
-
- 068 "Return the item indicated by the second pointer of a pair. NIL is treated
-
-
- 069 specially: the CDR of NIL is NIL."
-
-
- 070 [x]
-
-
- 071 (cond
-
-
- 072 (= x NIL) NIL
-
-
- 073 (instance? beowulf.cons_cell.ConsCell x) (.CDR x)
-
-
- 074 :else
-
-
- 075 (throw
-
-
- 076 (Exception.
-
-
- 077 (str "Cannot take CDR of `" x "` (" (.getName (.getClass x)) ")")))))
-
-
- 078
-
-
- 079 (defn uaf
-
-
- 080 "Universal access function; `l` is expected to be an arbitrary list, `path`
-
-
- 081 a (clojure) list of the characters `a` and `d`. Intended to make declaring
-
-
- 082 all those fiddly `#'c[ad]+r'` functions a bit easier"
-
-
- 083 [l path]
-
-
- 084 (cond
-
-
- 085 (= l NIL) NIL
+ 039
- 086 (empty? path) l
-
-
- 087 :else (case (last path)
-
-
- 088 \a (uaf (CAR l) (butlast path))
-
-
- 089 \d (uaf (CDR l) (butlast path)))))
+ 040 (declare APPLY EVAL prog-eval)
- 090
+ 041
-
- 091 (defn CAAR [x] (uaf x (seq "aa")))
-
-
- 092 (defn CADR [x] (uaf x (seq "ad")))
-
-
- 093 (defn CDDR [x] (uaf x (seq "dd")))
-
-
- 094 (defn CDAR [x] (uaf x (seq "da")))
+
+ 042 ;;;; The PROGram feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- 095
-
-
- 096 (defn CAAAR [x] (uaf x (seq "aaa")))
-
-
- 097 (defn CAADR [x] (uaf x (seq "aad")))
-
-
- 098 (defn CADAR [x] (uaf x (seq "ada")))
-
-
- 099 (defn CADDR [x] (uaf x (seq "add")))
-
-
- 100 (defn CDDAR [x] (uaf x (seq "dda")))
-
-
- 101 (defn CDDDR [x] (uaf x (seq "ddd")))
-
-
- 102 (defn CDAAR [x] (uaf x (seq "daa")))
-
-
- 103 (defn CDADR [x] (uaf x (seq "dad")))
-
-
- 104
-
-
- 105 (defn CAAAAR [x] (uaf x (seq "aaaa")))
-
-
- 106 (defn CAADAR [x] (uaf x (seq "aada")))
-
-
- 107 (defn CADAAR [x] (uaf x (seq "adaa")))
-
-
- 108 (defn CADDAR [x] (uaf x (seq "adda")))
-
-
- 109 (defn CDDAAR [x] (uaf x (seq "ddaa")))
-
-
- 110 (defn CDDDAR [x] (uaf x (seq "ddda")))
-
-
- 111 (defn CDAAAR [x] (uaf x (seq "daaa")))
-
-
- 112 (defn CDADAR [x] (uaf x (seq "dada")))
-
-
- 113 (defn CAAADR [x] (uaf x (seq "aaad")))
-
-
- 114 (defn CAADDR [x] (uaf x (seq "aadd")))
-
-
- 115 (defn CADADR [x] (uaf x (seq "adad")))
-
-
- 116 (defn CADDDR [x] (uaf x (seq "addd")))
-
-
- 117 (defn CDDADR [x] (uaf x (seq "ddad")))
-
-
- 118 (defn CDDDDR [x] (uaf x (seq "dddd")))
-
-
- 119 (defn CDAADR [x] (uaf x (seq "daad")))
-
-
- 120 (defn CDADDR [x] (uaf x (seq "dadd")))
-
-
- 121
+ 043
- 122 (defn EQ
+ 044 (def find-target
-
- 123 "Returns `T` if and only if both `x` and `y` are bound to the same atom,
-
-
- 124 else `F`."
-
-
- 125 [x y]
-
-
- 126 (if (and (= (ATOM x) T) (= x y)) T F))
-
-
- 127
+
+ 045 (memoize
- 128 (defn EQUAL
+ 046 (fn [target body]
-
- 129 "This is a predicate that is true if its two arguments are identical
-
-
- 130 S-expressions, and false if they are different. (The elementary predicate
-
-
- 131 `EQ` is defined only for atomic arguments.) The definition of `EQUAL` is
-
-
- 132 an example of a conditional expression inside a conditional expression.
-
-
- 133
-
-
- 134 NOTE: returns `F` on failure, not `NIL`"
-
-
- 135 [x y]
+
+ 047 (loop [body' body]
- 136 (cond
+ 048 (cond
-
- 137 (= (ATOM x) T) (EQ x y)
+
+ 049 (= body' NIL) (throw (ex-info (str "Mislar GO miercels: `" target "`")
-
- 138 (= (EQUAL (CAR x) (CAR y)) T) (EQUAL (CDR x) (CDR y))
-
-
- 139 :else F))
-
-
- 140
-
-
- 141 (defn SUBST
+
+ 050 {:phase :lisp
- 142 "This function gives the result of substituting the S-expression `x` for
+ 051 :function 'PROG
- 143 all occurrences of the atomic symbol `y` in the S-expression `z`."
+ 052 :type :lisp
- 144 [x y z]
-
-
- 145 (cond
-
-
- 146 (= (EQUAL y z) T) x
-
-
- 147 (= (ATOM? z) T) z ;; NIL is a symbol
-
-
- 148 :else
-
-
- 149 (make-cons-cell (SUBST x y (CAR z)) (SUBST x y (CDR z)))))
-
-
- 150
-
-
- 151 (defn APPEND
-
-
- 152 "Append the the elements of `y` to the elements of `x`.
-
-
- 153
-
-
- 154 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
-
-
- 155 See page 11 of the Lisp 1.5 Programmers Manual."
-
-
- 156 [x y]
-
-
- 157 (cond
-
-
- 158 (= x NIL) y
-
-
- 159 :else
-
-
- 160 (make-cons-cell (CAR x) (APPEND (CDR x) y))))
-
-
- 161
-
-
- 162
-
-
- 163 (defn MEMBER
-
-
- 164 "This predicate is true if the S-expression `x` occurs among the elements
-
-
- 165 of the list `y`.
-
-
- 166
-
-
- 167 All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
-
-
- 168 See page 11 of the Lisp 1.5 Programmers Manual."
-
-
- 169 [x y]
-
-
- 170 (cond
-
-
- 171 (= y NIL) F ;; NOTE: returns F on falsity, not NIL
-
-
- 172 (= (EQUAL x (CAR y)) T) T
-
-
- 173 :else (MEMBER x (CDR y))))
-
-
- 174
-
-
- 175 (defn PAIRLIS
-
-
- 176 "This function gives the list of pairs of corresponding elements of the
-
-
- 177 lists `x` and `y`, and APPENDs this to the list `a`. The resultant list
-
-
- 178 of pairs, which is like a table with two columns, is called an
-
-
- 179 association list.
-
-
- 180
-
-
- 181 Eessentially, it builds the environment on the stack, implementing shallow
-
-
- 182 binding.
-
-
- 183
-
-
- 184 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
-
-
- 185 See page 12 of the Lisp 1.5 Programmers Manual."
-
-
- 186 [x y a]
-
-
- 187 (cond
-
-
- 188 ;; the original tests only x; testing y as well will be a little more
-
-
- 189 ;; robust if `x` and `y` are not the same length.
-
-
- 190 (or (= NIL x) (= NIL y)) a
-
-
- 191 :else (make-cons-cell
-
-
- 192 (make-cons-cell (CAR x) (CAR y))
-
-
- 193 (PAIRLIS (CDR x) (CDR y) a))))
-
-
- 194
-
-
- 195 (defn ASSOC
-
-
- 196 "If a is an association list such as the one formed by PAIRLIS in the above
-
-
- 197 example, then assoc will produce the first pair whose first term is x. Thus
-
-
- 198 it is a table searching function.
-
-
- 199
-
-
- 200 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
-
-
- 201 See page 12 of the Lisp 1.5 Programmers Manual."
-
-
- 202 [x a]
-
-
- 203 (cond
-
-
- 204 (= NIL a) NIL ;; this clause is not present in the original but is added for
-
-
- 205 ;; robustness.
-
-
- 206 (= (EQUAL (CAAR a) x) T) (CAR a)
-
-
- 207 :else
-
-
- 208 (ASSOC x (CDR a))))
-
-
- 209
-
-
- 210 (defn- SUB2
-
-
- 211 "Internal to `SUBLIS`, q.v., which SUBSTitutes into a list from a store.
-
-
- 212 ? I think this is doing variable binding in the stack frame?"
-
-
- 213 [a z]
-
-
- 214 (cond
-
-
- 215 (= NIL a) z
-
-
- 216 (= (CAAR a) z) (CDAR a) ;; TODO: this looks definitely wrong
-
-
- 217 :else
-
-
- 218 (SUB2 (CDR a) z)))
-
-
- 219
-
-
- 220 (defn SUBLIS
-
-
- 221 "Here `a` is assumed to be an association list of the form
-
-
- 222 `((ul . vl)...(un . vn))`, where the `u`s are atomic, and `y` is any
-
-
- 223 S-expression. What `SUBLIS` does, is to treat the `u`s as variables when
-
-
- 224 they occur in `y`, and to SUBSTitute the corresponding `v`s from the pair
-
-
- 225 list.
-
-
- 226
-
-
- 227 My interpretation is that this is variable binding in the stack frame.
-
-
- 228
-
-
- 229 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
-
-
- 230 See page 12 of the Lisp 1.5 Programmers Manual."
-
-
- 231 [a y]
-
-
- 232 (cond
-
-
- 233 (= (ATOM? y) T) (SUB2 a y)
-
-
- 234 :else
-
-
- 235 (make-cons-cell (SUBLIS a (CAR y)) (SUBLIS a (CDR y)))))
-
-
- 236
-
-
- 237 (defn interop-interpret-q-name
-
-
- 238 "For interoperation with Clojure, it will often be necessary to pass
-
-
- 239 qualified names that are not representable in Lisp 1.5. This function
-
-
- 240 takes a sequence in the form `(PART PART PART... NAME)` and returns
-
-
- 241 a symbol in the form `PART.PART.PART/NAME`. This symbol will then be
-
-
- 242 tried in both that form and lower-cased. Names with hyphens or
-
-
- 243 underscores cannot be represented with this scheme."
-
-
- 244 [l]
+ 053 :code :A6
- 245 (if
-
-
- 246 (seq? l)
-
-
- 247 (symbol
-
-
- 248 (s/reverse
-
-
- 249 (s/replace-first
-
-
- 250 (s/reverse
-
-
- 251 (s/join "." (map str l)))
-
-
- 252 "."
-
-
- 253 "/")))
-
-
- 254 l))
-
-
- 255
-
-
- 256 (deftrace INTEROP
-
-
- 257 "Clojure (or other host environment) interoperation API. `fn-symbol` is expected
-
-
- 258 to be either
-
-
- 259
-
-
- 260 1. a symbol bound in the host environment to a function; or
-
-
- 261 2. a sequence (list) of symbols forming a qualified path name bound to a
-
-
- 262 function.
-
-
- 263
-
-
- 264 Lower case characters cannot normally be represented in Lisp 1.5, so both the
-
-
- 265 upper case and lower case variants of `fn-symbol` will be tried. If the
-
-
- 266 function you're looking for has a mixed case name, that is not currently
-
-
- 267 accessible.
-
-
- 268
-
-
- 269 `args` is expected to be a Lisp 1.5 list of arguments to be passed to that
-
-
- 270 function. Return value must be something acceptable to Lisp 1.5, so either
-
-
- 271 a symbol, a number, or a Lisp 1.5 list.
-
-
- 272
-
-
- 273 If `fn-symbol` is not found (even when cast to lower case), or is not a function,
-
-
- 274 or the value returned cannot be represented in Lisp 1.5, an exception is thrown
-
-
- 275 with `:cause` bound to `:interop` and `:detail` set to a value representing the
-
-
- 276 actual problem."
-
-
- 277 [fn-symbol args]
-
-
- 278 (let
-
-
- 279 [q-name (if
-
-
- 280 (seq? fn-symbol)
-
-
- 281 (interop-interpret-q-name fn-symbol)
-
-
- 282 fn-symbol)
-
-
- 283 l-name (symbol (s/lower-case q-name))
-
-
- 284 f (cond
-
-
- 285 (try
-
-
- 286 (fn? (eval l-name))
-
-
- 287 (catch java.lang.ClassNotFoundException e nil)) (eval l-name)
-
-
- 288 (try
-
-
- 289 (fn? (eval q-name))
-
-
- 290 (catch java.lang.ClassNotFoundException e nil)) (eval q-name)
-
-
- 291 :else (throw
-
-
- 292 (ex-info
-
-
- 293 (str "INTEROP: unknown function `" fn-symbol "`")
-
-
- 294 {:cause :interop
-
-
- 295 :detail :not-found
-
-
- 296 :name fn-symbol
-
-
- 297 :also-tried l-name})))
-
-
- 298 result (eval (cons f args))]
-
-
- 299 (cond
-
-
- 300 (instance? beowulf.cons_cell.ConsCell result) result
-
-
- 301 (seq? result) (make-beowulf-list result)
-
-
- 302 (symbol? result) result
-
-
- 303 (string? result) (symbol result)
-
-
- 304 (number? result) result
-
-
- 305 :else (throw
-
-
- 306 (ex-info
-
-
- 307 (str "INTEROP: Cannot return `" result "` to Lisp 1.5.")
-
-
- 308 {:cause :interop
-
-
- 309 :detail :not-representable
-
-
- 310 :result result})))))
-
-
- 311
-
-
- 312 (defn APPLY
-
-
- 313 "For bootstrapping, at least, a version of APPLY written in Clojure.
-
-
- 314 All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
-
-
- 315 See page 13 of the Lisp 1.5 Programmers Manual."
-
-
- 316 [function args environment]
-
-
- 317 (cond
-
-
- 318 (=
-
-
- 319 (ATOM? function)
-
-
- 320 T)(cond
-
-
- 321 ;; TODO: doesn't check whether `function` is bound in the environment;
-
-
- 322 ;; we'll need that before we can bootstrap.
-
-
- 323 (= function 'CAR) (CAAR args)
-
-
- 324 (= function 'CDR) (CDAR args)
-
-
- 325 (= function 'CONS) (make-cons-cell (CAR args) (CADR args))
-
-
- 326 (= function 'ATOM) (if (ATOM? (CAR args)) T NIL)
-
-
- 327 (= function 'EQ) (if (= (CAR args) (CADR args)) T NIL)
-
-
- 328 :else
-
-
- 329 (APPLY
-
-
- 330 (EVAL function environment)
-
-
- 331 args
-
-
- 332 environment))
-
-
- 333 (= (first function) 'LAMBDA) (EVAL
-
-
- 334 (CADDR function)
-
-
- 335 (PAIRLIS (CADR function) args environment))
-
-
- 336 (= (first function) 'LABEL) (APPLY
-
-
- 337 (CADDR function)
-
-
- 338 args
-
-
- 339 (make-cons-cell
-
-
- 340 (make-cons-cell
-
-
- 341 (CADR function)
-
-
- 342 (CADDR function))
-
-
- 343 environment))))
-
-
- 344
-
-
- 345 (defn- EVCON
-
-
- 346 "Inner guts of primitive COND. All args are assumed to be
-
-
- 347 `beowulf.cons-cell/ConsCell` objects.
-
-
- 348 See page 13 of the Lisp 1.5 Programmers Manual."
-
-
- 349 [clauses env]
-
-
- 350 (if
-
-
- 351 (not= (EVAL (CAAR clauses) env) NIL)
-
-
- 352 (EVAL (CADAR clauses) env)
-
-
- 353 (EVCON (CDR clauses) env)))
-
-
- 354
-
-
- 355 (defn- EVLIS
-
-
- 356 "Map `EVAL` across this list of `args` in the context of this
-
-
- 357 `env`ironment.All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
-
-
- 358 See page 13 of the Lisp 1.5 Programmers Manual."
-
-
- 359 [args env]
-
-
- 360 (cond
-
-
- 361 (= NIL args) NIL
-
-
- 362 :else
-
-
- 363 (make-cons-cell
-
-
- 364 (EVAL (CAR args) env)
-
-
- 365 (EVLIS (CDR args) env))))
-
-
- 366
-
-
- 367 (deftrace traced-eval
-
-
- 368 "Essentially, identical to EVAL except traced."
-
-
- 369 [expr env]
-
-
- 370 (cond
-
-
- 371 (=
-
-
- 372 (ATOM? expr) T)
-
-
- 373 (CDR (ASSOC expr env))
-
-
- 374 (=
-
-
- 375 (ATOM? (CAR expr))
+ 054 :target target}))
- 376 T)(cond
-
-
- 377 (= (CAR expr) 'QUOTE) (CADR expr)
-
-
- 378 (= (CAR expr) 'COND) (EVCON (CDR expr) env)
-
-
- 379 :else (APPLY
-
-
- 380 (CAR expr)
-
-
- 381 (EVLIS (CDR expr) env)
+ 055 (= (.getCar body') target) body'
- 382 env))
-
-
- 383 :else (APPLY
-
-
- 384 (CAR expr)
-
-
- 385 (EVLIS (CDR expr) env)
-
-
- 386 env)))
+ 056 :else (recur (.getCdr body')))))))
- 387
+ 057
- 388 (defn EVAL
+ 058 (defn- prog-cond
- 389 "For bootstrapping, at least, a version of EVAL written in Clojure.
+ 059 "Like `EVCON`, q.v. except using `prog-eval` instead of `EVAL` and not
- 390 All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
+ 060 throwing an error if no clause matches."
- 391 See page 13 of the Lisp 1.5 Programmers Manual."
+ 061 [clauses vars env depth]
+
+
+ 062 (loop [clauses' clauses]
+
+
+ 063 (if-not (= clauses' NIL)
+
+
+ 064 (let [test (prog-eval (CAAR clauses') vars env depth)]
+
+
+ 065 (if (not (#{NIL F} test))
+
+
+ 066 (prog-eval (CADAR clauses') vars env depth)
+
+
+ 067 (recur (.getCdr clauses'))))
+
+
+ 068 NIL)))
+
+
+ 069
+
+
+ 070 (defn- merge-vars [vars env]
+
+
+ 071 (reduce
+
+
+ 072 #(make-cons-cell
+
+
+ 073 (make-cons-cell %2 (@vars %2))
+
+
+ 074 env)
+
+
+ 075 env
+
+
+ 076 (keys @vars)))
+
+
+ 077
+
+
+ 078 (defn prog-eval
- 392 [expr env]
+ 079 "Like `EVAL`, q.v., except handling symbols, and expressions starting
+
+
+ 080 `GO`, `RETURN`, `SET` and `SETQ` specially."
+
+
+ 081 [expr vars env depth]
- 393 (cond
-
-
- 394 (true? (:trace *options*))
+ 082 (cond
- 395 (traced-eval expr env)
+ 083 (number? expr) expr
-
- 396 (=
+
+ 084 (symbol? expr) (@vars expr)
-
- 397 (ATOM? expr) T)
-
-
- 398 (CDR (ASSOC expr env))
-
-
- 399 (=
-
-
- 400 (ATOM? (CAR expr))
-
-
- 401 T)(cond
-
-
- 402 (= (CAR expr) 'QUOTE) (CADR expr)
-
-
- 403 (= (CAR expr) 'COND) (EVCON (CDR expr) env)
-
-
- 404 :else (APPLY
+
+ 085 (instance? ConsCell expr) (case (.getCar expr)
- 405 (CAR expr)
+ 086 COND (prog-cond (.getCdr expr)
-
- 406 (EVLIS (CDR expr) env)
+
+ 087 vars env depth)
+
+
+ 088 GO (make-cons-cell
+
+
+ 089 '*PROGGO* (.getCar (.getCdr expr)))
+
+
+ 090 RETURN (make-cons-cell
+
+
+ 091 '*PROGRETURN*
+
+
+ 092 (prog-eval (.getCar (.getCdr expr))
+
+
+ 093 vars env depth))
+
+
+ 094 SET (let [v (CADDR expr)]
+
+
+ 095 (swap! vars
- 407 env))
+ 096 assoc
-
- 408 :else (APPLY
+
+ 097 (prog-eval (CADR expr)
+
+
+ 098 vars env depth)
+
+
+ 099 (prog-eval (CADDR expr)
+
+
+ 100 vars env depth))
+
+
+ 101 v)
+
+
+ 102 SETQ (let [v (CADDR expr)]
- 409 (CAR expr)
-
-
- 410 (EVLIS (CDR expr) env)
+ 103 (swap! vars
- 411 env)))
+ 104 assoc
+
+
+ 105 (CADR expr)
+
+
+ 106 (prog-eval v
+
+
+ 107 vars env depth))
+
+
+ 108 v)
+
+
+ 109 ;; else
+
+
+ 110 (beowulf.bootstrap/EVAL expr
+
+
+ 111 (merge-vars vars env)
+
+
+ 112 depth))))
- 412
+ 113
+
+
+ 114 (defn PROG
+
+
+ 115 "The accursed `PROG` feature. See page 71 of the manual.
+
+
+ 116
+
+
+ 117 Lisp 1.5 introduced `PROG`, and most Lisps have been stuck with it ever
+
+
+ 118 since. It introduces imperative programming into what should be a pure
+
+
+ 119 functional language, and consequently it's going to be a pig to implement.
+
+
+ 120
+
+
+ 121 Broadly, `PROG` is a variadic pseudo function called as a `FEXPR` (or
+
+
+ 122 possibly an `FSUBR`, although I'm not presently sure that would even work.)
- 413
+ 123
+
+
+ 124 The arguments, which are unevaluated, are a list of forms, the first of
+
+
+ 125 which is expected to be a list of symbols which will be treated as names
+
+
+ 126 of variables within the program, and the rest of which (the 'program body')
+
+
+ 127 are either lists or symbols. Lists are treated as Lisp expressions which
+
+
+ 128 may be evaulated in turn. Symbols are treated as targets for the `GO`
+
+
+ 129 statement.
+
+
+ 130
+
+
+ 131 **GO:**
+
+
+ 132 A `GO` statement takes the form of `(GO target)`, where
+
+
+ 133 `target` should be one of the symbols which occur at top level among that
+
+
+ 134 particular invocation of `PROG`s arguments. A `GO` statement may occur at
+
+
+ 135 top level in a PROG, or in a clause of a `COND` statement in a `PROG`, but
+
+
+ 136 not in a function called from the `PROG` statement. When a `GO` statement
+
+
+ 137 is evaluated, execution should transfer immediately to the expression which
+
+
+ 138 is the argument list immediately following the symbol which is its target.
- 414
+ 139
+
+
+ 140 If the target is not found, an error with the code `A6` should be thrown.
+
+
+ 141
+
+
+ 142 **RETURN:**
+
+
+ 143 A `RETURN` statement takes the form `(RETURN value)`, where
+
+
+ 144 `value` is any value. Following the evaluation of a `RETURN` statement,
+
+
+ 145 the `PROG` should immediately exit without executing any further
+
+
+ 146 expressions, returning the value.
+
+
+ 147
+
+
+ 148 **SET and SETQ:**
+
+
+ 149 In addition to the above, if a `SET` or `SETQ` expression is encountered
+
+
+ 150 in any expression within the `PROG` body, it should affect not the global
+
+
+ 151 object list but instead only the local variables of the program.
+
+
+ 152
+
+
+ 153 **COND:**
+
+
+ 154 In **strict** mode, when in normal execution, a `COND` statement none of
+
+
+ 155 whose clauses match should not return `NIL` but should throw an error with
+
+
+ 156 the code `A3`... *except* that inside a `PROG` body, it should not do so.
+
+
+ 157 *sigh*.
+
+
+ 158
+
+
+ 159 **Flow of control:**
+
+
+ 160 Apart from the exceptions specified above, expressions in the program body
+
+
+ 161 are evaluated sequentially. If execution reaches the end of the program
+
+
+ 162 body, `NIL` is returned.
+
+
+ 163
+
+
+ 164 Got all that?
+
+
+ 165
+
+
+ 166 Good."
+
+
+ 167 [program env depth]
+
+
+ 168 (let [trace (traced? 'PROG)
+
+
+ 169 vars (atom (reduce merge (map #(assoc {} % NIL) (.getCar program))))
+
+
+ 170 body (.getCdr program)
+
+
+ 171 targets (set (filter symbol? body))]
+
+
+ 172 (when trace (do
+
+
+ 173 (println "Program:")
+
+
+ 174 (pretty-print program))) ;; for debugging
+
+
+ 175 (loop [cursor body]
+
+
+ 176 (let [step (.getCar cursor)]
+
+
+ 177 (when trace (do (println "Executing step: " step)
+
+
+ 178 (println " with vars: " @vars)))
+
+
+ 179 (cond (= cursor NIL) NIL
+
+
+ 180 (symbol? step) (recur (.getCdr cursor))
+
+
+ 181 :else (let [v (prog-eval (.getCar cursor) vars env depth)]
+
+
+ 182 (when trace (println " --> " v))
+
+
+ 183 (if (instance? ConsCell v)
+
+
+ 184 (case (.getCar v)
+
+
+ 185 *PROGGO* (let [target (.getCdr v)]
+
+
+ 186 (if (targets target)
+
+
+ 187 (recur (find-target target body))
+
+
+ 188 (throw (ex-info (str "Uncynlic GO miercels `"
+
+
+ 189 target "`")
+
+
+ 190 {:phase :lisp
+
+
+ 191 :function 'PROG
+
+
+ 192 :args program
+
+
+ 193 :type :lisp
+
+
+ 194 :code :A6
+
+
+ 195 :target target
+
+
+ 196 :targets targets}))))
+
+
+ 197 *PROGRETURN* (.getCdr v)
+
+
+ 198 ;; else
+
+
+ 199 (recur (.getCdr cursor)))
+
+
+ 200 (recur (.getCdr cursor)))))))))
+
+
+ 201
+
+
+ 202 ;;;; Tracing execution ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+ 203
+
+
+ 204 (defn- trace-call
+
+
+ 205 "Show a trace of a call to the function named by this `function-symbol`
+
+
+ 206 with these `args` at this depth."
+
+
+ 207 [function-symbol args depth]
+
+
+ 208 (when (traced? function-symbol)
+
+
+ 209 (let [indent (apply str (repeat depth "-"))]
+
+
+ 210 (println (str indent "> " function-symbol " " args)))))
+
+
+ 211
+
+
+ 212 (defn- trace-response
+
+
+ 213 "Show a trace of this `response` from the function named by this
+
+
+ 214 `function-symbol` at this depth."
+
+
+ 215 [function-symbol response depth]
+
+
+ 216 (when (traced? function-symbol)
+
+
+ 217 (let [indent (apply str (repeat depth "-"))]
+
+
+ 218 (println (str "<" indent " " function-symbol " " response))))
+
+
+ 219 response)
+
+
+ 220
+
+
+ 221 (defn- value
+
+
+ 222 "Seek a value for this symbol `s` by checking each of these indicators in
+
+
+ 223 turn."
+
+
+ 224 ([s]
+
+
+ 225 (value s (list 'APVAL 'EXPR 'FEXPR 'SUBR 'FSUBR)))
+
+
+ 226 ([s indicators]
+
+
+ 227 (when (symbol? s)
+
+
+ 228 (first (remove #(= % NIL) (map #(GET s %)
+
+
+ 229 indicators))))))
+
+
+ 230
+
+
+ 231 ;;;; APPLY ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+ 232
+
+
+ 233 (defn try-resolve-subroutine
+
+
+ 234 "Attempt to resolve this `subr` with these `args`."
+
+
+ 235 [subr args]
+
+
+ 236 (when (and subr (not= subr NIL))
+
+
+ 237 (try @(resolve subr)
+
+
+ 238 (catch Throwable any
+
+
+ 239 (throw (ex-info "þegnung (SUBR) ne āfand"
+
+
+ 240 {:phase :apply
+
+
+ 241 :function subr
+
+
+ 242 :args args
+
+
+ 243 :type :beowulf}
+
+
+ 244 any))))))
+
+
+ 245
+
+
+ 246 (defn- apply-symbolic
+
+
+ 247 "Apply this `funtion-symbol` to these `args` in this `environment` and
+
+
+ 248 return the result."
+
+
+ 249 [^Symbol function-symbol args ^ConsCell environment depth]
+
+
+ 250 (trace-call function-symbol args depth)
+
+
+ 251 (let [lisp-fn (value function-symbol '(EXPR FEXPR))
+
+
+ 252 args' (cond (= NIL args) args
+
+
+ 253 (empty? args) NIL
+
+
+ 254 (instance? ConsCell args) args
+
+
+ 255 :else (make-beowulf-list args))
+
+
+ 256 subr (value function-symbol '(SUBR FSUBR))
+
+
+ 257 host-fn (try-resolve-subroutine subr args')
+
+
+ 258 result (cond (and lisp-fn
+
+
+ 259 (not= lisp-fn NIL)) (APPLY lisp-fn args' environment depth)
+
+
+ 260 host-fn (try
+
+
+ 261 (apply host-fn (when (instance? ConsCell args') args'))
+
+
+ 262 (catch Exception any
+
+
+ 263 (throw (ex-info (str "Uncynlic þegnung: "
+
+
+ 264 (.getMessage any))
+
+
+ 265 {:phase :apply
+
+
+ 266 :function function-symbol
+
+
+ 267 :args args
+
+
+ 268 :type :beowulf}
+
+
+ 269 any))))
+
+
+ 270 :else (ex-info "þegnung ne āfand"
+
+
+ 271 {:phase :apply
+
+
+ 272 :function function-symbol
+
+
+ 273 :args args
+
+
+ 274 :type :beowulf}))]
+
+
+ 275 (trace-response function-symbol result depth)
+
+
+ 276 result))
+
+
+ 277
+
+
+ 278 (defn APPLY
+
+
+ 279 "Apply this `function` to these `arguments` in this `environment` and return
+
+
+ 280 the result.
+
+
+ 281
+
+
+ 282 For bootstrapping, at least, a version of APPLY written in Clojure.
+
+
+ 283 All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
+
+
+ 284 See page 13 of the Lisp 1.5 Programmers Manual."
+
+
+ 285 [function args environment depth]
+
+
+ 286 (trace-call 'APPLY (list function args environment) depth)
+
+
+ 287 (let [result (cond
+
+
+ 288 (= NIL function) (if (:strict *options*)
+
+
+ 289 NIL
+
+
+ 290 (throw (ex-info "NIL sí ne þegnung"
+
+
+ 291 {:phase :apply
+
+
+ 292 :function "NIL"
+
+
+ 293 :args args
+
+
+ 294 :type :beowulf})))
+
+
+ 295 (= (ATOM function) T) (apply-symbolic function args environment (inc depth))
+
+
+ 296 :else (case (first function)
+
+
+ 297 LABEL (APPLY
+
+
+ 298 (CADDR function)
+
+
+ 299 args
+
+
+ 300 (make-cons-cell
+
+
+ 301 (make-cons-cell
+
+
+ 302 (CADR function)
+
+
+ 303 (CADDR function))
+
+
+ 304 environment)
+
+
+ 305 depth)
+
+
+ 306 FUNARG (APPLY (CADR function) args (CADDR function) depth)
+
+
+ 307 LAMBDA (EVAL
+
+
+ 308 (CADDR function)
+
+
+ 309 (PAIRLIS (CADR function) args environment) depth)
+
+
+ 310 (throw (ex-info "Ungecnáwen wyrþan sí þegnung-weard"
+
+
+ 311 {:phase :apply
+
+
+ 312 :function function
+
+
+ 313 :args args
+
+
+ 314 :type :beowulf}))))]
+
+
+ 315 (trace-response 'APPLY result depth)
+
+
+ 316 result))
+
+
+ 317
+
+
+ 318 ;;;; EVAL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+ 319
+
+
+ 320 (defn- EVCON
+
+
+ 321 "Inner guts of primitive COND. All `clauses` are assumed to be
+
+
+ 322 `beowulf.cons-cell/ConsCell` objects. Note that tests in Lisp 1.5
+
+
+ 323 often return `F`, not `NIL`, on failure. If no clause matches,
+
+
+ 324 then, strictly, we throw an error with code `:A3`.
+
+
+ 325
+
+
+ 326 See pages 13 and 71 of the Lisp 1.5 Programmers Manual."
+
+
+ 327 [clauses env depth]
+
+
+ 328 (loop [clauses' clauses]
+
+
+ 329 (if-not (= clauses' NIL)
+
+
+ 330 (let [test (EVAL (CAAR clauses') env depth)]
+
+
+ 331 (if (not (#{NIL F} test))
+
+
+ 332 ;; (and (not= test NIL) (not= test F))
+
+
+ 333 (EVAL (CADAR clauses') env depth)
+
+
+ 334 (recur (.getCdr clauses'))))
+
+
+ 335 (if (:strict *options*)
+
+
+ 336 (throw (ex-info "Ne ġefōg dǣl in COND"
+
+
+ 337 {:phase :eval
+
+
+ 338 :function 'COND
+
+
+ 339 :args (list clauses)
+
+
+ 340 :type :lisp
+
+
+ 341 :code :A3}))
+
+
+ 342 NIL))))
+
+
+ 343
+
+
+ 344 (defn- EVLIS
+
+
+ 345 "Map `EVAL` across this list of `args` in the context of this
+
+
+ 346 `env`ironment.All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
+
+
+ 347 See page 13 of the Lisp 1.5 Programmers Manual."
+
+
+ 348 [args env depth]
+
+
+ 349 (cond
+
+
+ 350 (= NIL args) NIL
+
+
+ 351 :else
+
+
+ 352 (make-cons-cell
+
+
+ 353 (EVAL (CAR args) env depth)
+
+
+ 354 (EVLIS (CDR args) env depth))))
+
+
+ 355
+
+
+ 356 (defn- eval-symbolic
+
+
+ 357 [expr env depth]
+
+
+ 358 (let [v (ASSOC expr env)
+
+
+ 359 indent (apply str (repeat depth "-"))]
+
+
+ 360 (when (traced? 'EVAL)
+
+
+ 361 (println (str indent ": EVAL: sceald bindele: " (or v "nil"))))
+
+
+ 362 (if (instance? ConsCell v)
+
+
+ 363 (.getCdr v)
+
+
+ 364 (let [v' (value expr (list 'APVAL))]
+
+
+ 365 (when (traced? 'EVAL)
+
+
+ 366 (println (str indent ": EVAL: deóp bindele: (" expr " . " (or v' "nil") ")")))
+
+
+ 367 (if v'
+
+
+ 368 v'
+
+
+ 369 (throw (ex-info "Ne tácen-bindele āfand"
+
+
+ 370 {:phase :eval
+
+
+ 371 :function 'EVAL
+
+
+ 372 :args (list expr env depth)
+
+
+ 373 :type :lisp
+
+
+ 374 :code :A8})))))))
+
+
+ 375
+
+
+ 376 (defn EVAL
+
+
+ 377 "Evaluate this `expr` and return the result. If `environment` is not passed,
+
+
+ 378 it defaults to the current value of the global object list. The `depth`
+
+
+ 379 argument is part of the tracing system and should not be set by user code.
+
+
+ 380
+
+
+ 381 All args are assumed to be numbers, symbols or `beowulf.cons-cell/ConsCell`
+
+
+ 382 objects. However, if called with just a single arg, `expr`, I'll assume it's
+
+
+ 383 being called from the Clojure REPL and will coerce the `expr` to `ConsCell`."
+
+
+ 384 ([expr]
+
+
+ 385 (let [expr' (if (and (coll? expr) (not (instance? ConsCell expr)))
+
+
+ 386 (make-beowulf-list expr)
+
+
+ 387 expr)]
+
+
+ 388 (EVAL expr' NIL 0)))
+
+
+ 389 ([expr env depth]
+
+
+ 390 (trace-call 'EVAL (list expr env depth) depth)
+
+
+ 391 (let [result (cond
+
+
+ 392 (= NIL expr) NIL ;; it was probably a mistake to make Lisp
+
+
+ 393 ;; NIL distinct from Clojure nil
+
+
+ 394 (= (NUMBERP expr) T) expr
+
+
+ 395 (symbol? expr) (eval-symbolic expr env depth)
+
+
+ 396 (string? expr) (if (:strict *options*)
+
+
+ 397 (throw
+
+
+ 398 (ex-info
+
+
+ 399 (str "EVAL: strings not allowed in strict mode: \"" expr "\"")
+
+
+ 400 {:phase :eval
+
+
+ 401 :detail :strict
+
+
+ 402 :expr expr}))
+
+
+ 403 (symbol expr))
+
+
+ 404 (= (ATOM (CAR expr)) T) (case (CAR expr)
+
+
+ 405 COND (EVCON (CDR expr) env depth)
+
+
+ 406 FUNCTION (LIST 'FUNARG (CADR expr))
+
+
+ 407 PROG (PROG (CDR expr) env depth)
+
+
+ 408 QUOTE (CADR expr)
+
+
+ 409 ;; else
+
+
+ 410 (APPLY
+
+
+ 411 (CAR expr)
+
+
+ 412 (EVLIS (CDR expr) env depth)
+
+
+ 413 env
+
+
+ 414 depth))
+
+
+ 415 :else (APPLY
+
+
+ 416 (CAR expr)
+
+
+ 417 (EVLIS (CDR expr) env depth)
+
+
+ 418 env
+
+
+ 419 depth))]
+
+
+ 420 (trace-response 'EVAL result depth)
+
+
+ 421 result)))
+
+
+ 422