diff --git a/doc/lisp1.5.md b/doc/lisp1.5.md
index 6042cc8..11fe6db 100644
--- a/doc/lisp1.5.md
+++ b/doc/lisp1.5.md
@@ -1721,6 +1721,7 @@ represented in storage only once,
The following simple example has been included to illustrate the exact construction
of list structures. Two types of list structures are shown, and a function for deriving
one from the other is given in LISP.
+
We assume that we have a list of the form
n, = ((A B C) (D E F),... , (X Y z)),
@@ -2709,7 +2710,9 @@ If `deflist` or `define` is used twice on the same object with the same indicato
The function attrib concatenates its two arguments by changing the last element of its first argument to point to the second argument. Thus it is commonly used to tack something onto the end of a property list. The value of attrib is the second argument.
For example
-attrib[~~; (EXPR (LAMBDA (X) (COND ((ATOM X) X) (T (FF (CAR x))))))]
+```
+attrib[FF; (EXPR (LAMBDA (X) (COND ((ATOM X) X) (T (FF (CAR x))))))]
+```
would put EXPR followed by the LAMBDA expression for FF onto the end of the prop-
erty list for FF.
diff --git a/docs/cloverage/beowulf/bootstrap.clj.html b/docs/cloverage/beowulf/bootstrap.clj.html
index 20afabb..8a1fa87 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