001 (ns beowulf.bootstrap
002 "Lisp as defined in Chapter 1 (pages 1-14) of the
003 `Lisp 1.5 Programmer's Manual`; that is to say, a very simple Lisp language,
004 which should, I believe, be sufficient in conjunction with the functions
005 provided by `beowulf.host`, be sufficient to bootstrap the full Lisp 1.5
006 interpreter..
007
008 The convention is adopted that functions in this file with names in
009 ALLUPPERCASE are Lisp 1.5 functions (although written in Clojure) and that
010 therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell`
011 objects."
012 (:require [beowulf.cons-cell :refer [F make-beowulf-list make-cons-cell
013 pretty-print T]]
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]))
019
020 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
021 ;;;
022 ;;; Copyright (C) 2022-2023 Simon Brooke
023 ;;;
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
039
040 (declare APPLY EVAL prog-eval)
041
042 ;;;; The PROGram feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
043
044 (def find-target
045 (memoize
046 (fn [target body]
047 (loop [body' body]
048 (cond
049 (= body' NIL) (throw (ex-info (str "Mislar GO miercels: `" target "`")
050 {:phase :lisp
051 :function 'PROG
052 :type :lisp
053 :code :A6
054 :target target}))
055 (= (.getCar body') target) body'
056 :else (recur (.getCdr body')))))))
057
058 (defn- prog-cond
059 "Like `EVCON`, q.v. except using `prog-eval` instead of `EVAL` and not
060 throwing an error if no clause matches."
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
079 "Like `EVAL`, q.v., except handling symbols, and expressions starting
080 `GO`, `RETURN`, `SET` and `SETQ` specially."
081 [expr vars env depth]
082 (cond
083 (number? expr) expr
084 (symbol? expr) (@vars expr)
085 (instance? ConsCell expr) (case (.getCar expr)
086 COND (prog-cond (.getCdr expr)
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
096 assoc
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)]
103 (swap! vars
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))))
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.)
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.
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