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 CAADR CADAR CADDR CADR CAR CDR
015 CONS ERROR GET LIST NUMBERP PAIRLIS traced?]]
016 [beowulf.oblist :refer [*options* NIL]]
017 [clojure.string :as s]
018 [clojure.tools.trace :refer [deftrace]])
019 (:import [beowulf.cons_cell ConsCell]
020 [clojure.lang Symbol]))
021
022 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
023 ;;;
024 ;;; Copyright (C) 2022-2023 Simon Brooke
025 ;;;
026 ;;; This program is free software; you can redistribute it and/or
027 ;;; modify it under the terms of the GNU General Public License
028 ;;; as published by the Free Software Foundation; either version 2
029 ;;; of the License, or (at your option) any later version.
030 ;;;
031 ;;; This program is distributed in the hope that it will be useful,
032 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
033 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
034 ;;; GNU General Public License for more details.
035 ;;;
036 ;;; You should have received a copy of the GNU General Public License
037 ;;; along with this program; if not, write to the Free Software
038 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
039 ;;;
040 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
041
042 (declare APPLY EVAL EVCON prog-eval)
043
044 ;;;; The PROGram feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
045
046 (def ^:dynamic
047 *depth*
048 "Stack depth. Unfortunately we need to be able to pass round depth for
049 functions which call EVAL/APPLY but do not know about depth."
050 0)
051
052 (defn- trace-indent
053 ([] (trace-indent *depth*))
054 ([d] (s/join (repeat d " "))))
055
056 (def find-target
057 (memoize
058 (fn [target body]
059 (loop [body' body]
060 (cond
061 (= body' NIL) (throw (ex-info (str "Mislar GO miercels: `" target "`")
062 {:phase :lisp
063 :function 'PROG
064 :type :lisp
065 :code :A6
066 :target target}))
067 (= (.getCar body') target) body'
068 :else (recur (.getCdr body')))))))
069
070 (defn- prog-cond
071 "Like `EVCON`, q.v. except using `prog-eval` instead of `EVAL` and not
072 throwing an error if no clause matches."
073 [clauses vars env depth]
074 (loop [clauses' clauses]
075 (if-not (= clauses' NIL)
076 (let [test (prog-eval (CAAR clauses') vars env depth)]
077 (if (not (#{NIL F} test))
078 (prog-eval (CADAR clauses') vars env depth)
079 (recur (.getCdr clauses'))))
080 NIL)))
081
082 (defn- merge-vars [vars env]
083 (reduce
084 #(make-cons-cell
085 (make-cons-cell %2 (@vars %2))
086 env)
087 env
088 (keys @vars)))
089
090 (defn prog-eval
091 "Like `EVAL`, q.v., except handling symbols, and expressions starting
092 `GO`, `RETURN`, `SET` and `SETQ` specially."
093 [expr vars env depth]
094 (cond
095 (number? expr) expr
096 (symbol? expr) (@vars expr)
097 (instance? ConsCell expr) (case (CAR expr)
098 COND (prog-cond (CDR expr)
099 vars env depth)
100 GO (let [target (CADR expr)]
101 (when (traced? 'PROG)
102 (println " PROG:GO: Goto " target))
103 (make-cons-cell
104 '*PROGGO* target))
105 RETURN (let [val (prog-eval
106 (CADR expr)
107 vars env depth)]
108 (when (traced? 'PROG)
109 (println " PROG:RETURN: Returning "
110 val))
111 (make-cons-cell
112 '*PROGRETURN*
113 val))
114 SET (let [var (prog-eval (CADR expr)
115 vars env depth)
116 val (prog-eval (CADDR expr)
117 vars env depth)]
118 (when (traced? 'PROG)
119 (println " PROG:SET: Setting "
120 var " to " val))
121 (swap! vars
122 assoc
123 var
124 val)
125 val)
126 SETQ (let [var (CADDR expr)
127 val (prog-eval var
128 vars env depth)]
129 (when (traced? 'PROG)
130 (println " PROG:SETQ: Setting " var " to " val))
131 (swap! vars
132 assoc
133 (CADR expr)
134 val)
135 val)
136 ;; else
137 (beowulf.bootstrap/EVAL expr
138 (merge-vars vars env)
139 depth))))
140
141 (defn PROG
142 "The accursed `PROG` feature. See page 71 of the manual.
143
144 Lisp 1.5 introduced `PROG`, and most Lisps have been stuck with it ever
145 since. It introduces imperative programming into what should be a pure
146 functional language, and consequently it's going to be a pig to implement.
147
148 Broadly, `PROG` is a variadic pseudo function called as a `FEXPR` (or
149 possibly an `FSUBR`, although I'm not presently sure that would even work.)
150
151 The arguments, which are unevaluated, are a list of forms, the first of
152 which is expected to be a list of symbols which will be treated as names
153 of variables within the program, and the rest of which (the 'program body')
154 are either lists or symbols. Lists are treated as Lisp expressions which
155 may be evaulated in turn. Symbols are treated as targets for the `GO`
156 statement.
157
158 **GO:**
159 A `GO` statement takes the form of `(GO target)`, where
160 `target` should be one of the symbols which occur at top level among that
161 particular invocation of `PROG`s arguments. A `GO` statement may occur at
162 top level in a PROG, or in a clause of a `COND` statement in a `PROG`, but
163 not in a function called from the `PROG` statement. When a `GO` statement
164 is evaluated, execution should transfer immediately to the expression which
165 is the argument list immediately following the symbol which is its target.
166
167 If the target is not found, an error with the code `A6` should be thrown.
168
169 **RETURN:**
170 A `RETURN` statement takes the form `(RETURN value)`, where
171 `value` is any value. Following the evaluation of a `RETURN` statement,
172 the `PROG` should immediately exit without executing any further
173 expressions, returning the value.
174
175 **SET and SETQ:**
176 In addition to the above, if a `SET` or `SETQ` expression is encountered
177 in any expression within the `PROG` body, it should affect not the global
178 object list but instead only the local variables of the program.
179
180 **COND:**
181 In **strict** mode, when in normal execution, a `COND` statement none of
182 whose clauses match should not return `NIL` but should throw an error with
183 the code `A3`... *except* that inside a `PROG` body, it should not do so.
184 *sigh*.
185
186 **Flow of control:**
187 Apart from the exceptions specified above, expressions in the program body
188 are evaluated sequentially. If execution reaches the end of the program
189 body, `NIL` is returned.
190
191 Got all that?
192
193 Good."
194 [program env depth]
195 (let [trace (traced? 'PROG)
196 vars (atom (reduce merge (map #(assoc {} % NIL) (.getCar program))))
197 body (.getCdr program)
198 targets (set (filter symbol? body))]
199 (when trace (do
200 (println "Program:")
201 (pretty-print program))) ;; for debugging
202 (loop [cursor body]
203 (let [step (if (= NIL cursor) NIL (.getCar cursor))]
204 (when trace (do (println "Executing step: " step)
205 (println " with vars: " @vars)))
206 (cond (= cursor NIL) NIL
207 (symbol? step) (recur (.getCdr cursor))
208 :else (let [v (prog-eval (.getCar cursor) vars env depth)]
209 (when trace (println " --> " v))
210 (if (instance? ConsCell v)
211 (case (.getCar v)
212 *PROGGO* (let [target (.getCdr v)]
213 (if (targets target)
214 (recur (find-target target body))
215 (throw (ex-info (str "Uncynlic GO miercels `"
216 target "`")
217 {:phase :lisp
218 :function 'PROG
219 :args program
220 :type :lisp
221 :code :A6
222 :target target
223 :targets targets}))))
224 *PROGRETURN* (.getCdr v)
225 ;; else
226 (recur (.getCdr cursor)))
227 (recur (.getCdr cursor)))))))))
228
229 ;;;; Tracing execution ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
230
231 (defn- trace-call
232 "Show a trace of a call to the function named by this `function-symbol`
233 with these `args` at this depth."
234 [function-symbol args depth]
235 (when (traced? function-symbol)
236 (let [indent (trace-indent depth)]
237 (println (str indent "> " function-symbol " " args)))))
238
239 (defn- trace-response
240 "Show a trace of this `response` from the function named by this
241 `function-symbol` at this depth."
242 [function-symbol response depth]
243 (when (traced? function-symbol)
244 (let [indent (apply str (trace-indent depth))]
245 (println (str "<" indent " " function-symbol " " response))))
246 response)
247
248 ;;;; Support functions for interpreter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
249
250 (defn value
251 "Seek a value for this symbol `s` by checking each of these indicators in
252 turn."
253 ([s]
254 (value s (list 'APVAL 'EXPR 'FEXPR 'SUBR 'FSUBR)))
255 ([s indicators]
256 (when (symbol? s)
257 (first (remove #(= % NIL) (map #(GET s %)
258 indicators))))))
259
260 (defn SASSOC
261 "Like `ASSOC`, but with an action to take if no value is found.
262
263 From the manual, page 60:
264
265 'The function `sassoc` searches `y`, which is a list of dotted pairs, for
266 a pair whose first element that is `x`. If such a pair is found, the value
267 of `sassoc` is this pair. Otherwise the function `u` of no arguments is
268 taken as the value of `sassoc`.'"
269 [x y u]
270 (let [v (ASSOC x y)]
271 (if-not (= v NIL) v
272 (APPLY u NIL NIL))))
273
274
275 ;;;; APPLY ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
276
277 (defn try-resolve-subroutine
278 "Attempt to resolve this `subr` with these `args`."
279 [subr args]
280 (when (and subr (not= subr NIL))
281 (try @(resolve subr)
282 (catch Throwable any
283 (throw (ex-info "þegnung (SUBR) ne āfand"
284 {:phase :apply
285 :function subr
286 :args args
287 :type :beowulf}
288 any))))))
289
290 (defn- apply-symbolic
291 "Apply this `funtion-symbol` to these `args` in this `environment` and
292 return the result."
293 [^Symbol function-symbol args ^ConsCell environment depth]
294 (trace-call function-symbol args depth)
295 (let [lisp-fn (value function-symbol '(EXPR FEXPR)) ;; <-- should these be handled differently? I think so!
296 args' (cond (= NIL args) args
297 (empty? args) NIL
298 (instance? ConsCell args) args
299 :else (make-beowulf-list args))
300 subr (value function-symbol '(SUBR FSUBR))
301 host-fn (try-resolve-subroutine subr args')
302 result (cond (and lisp-fn
303 (not= lisp-fn NIL)) (APPLY lisp-fn args' environment depth)
304 host-fn (try
305 (apply host-fn (when (instance? ConsCell args') args'))
306 (catch Exception any
307 (throw (ex-info (str "Uncynlic þegnung: "
308 (.getMessage any))
309 {:phase :apply
310 :function function-symbol
311 :args args
312 :type :beowulf}
313 any))))
314 :else (ex-info "þegnung ne āfand"
315 {:phase :apply
316 :function function-symbol
317 :args args
318 :type :beowulf}))]
319 (trace-response function-symbol result depth)
320 result))
321
322 ;; (LABEL ARGS
323 ;; (COND ((COND ((ONEP (LENGTH ARGS)) ARGS)
324 ;; (T (ATTRIB (CAR ARGS) (APPLY CONC (CDR ARGS) NIL))))
325 ;; ARGS)))
326 ;; ((1 2 3 4) (5 6 7 8) (9 10 11 12))
327 ;; NIL
328 ;; (def function (make-beowulf-list '(LABEL ARGS (COND
329 ;; ((COND ((ONEP (LENGTH ARGS)) ARGS)
330 ;; (T (ATTRIB (CAR ARGS)
331 ;; (APPLY CONC (CDR ARGS) NIL))))
332 ;; ARGS)))))
333 ;; (def args (make-beowulf-list '((1 2 3 4) (5 6 7 8) (9 10 11 12))))
334
335 ;; function
336 ;; (CADR function)
337 ;; (CADDR function)
338
339 (defn apply-label
340 "Apply in the special case that the first element in the function is `LABEL`."
341 [function args environment depth]
342 (EVAL
343 (CADDR function)
344 (CONS
345 (CONS (CADR function) args)
346 environment)
347 depth))
348
349 ;; (apply-label function args NIL 1)
350 ;; (APPLY function args NIL 1)
351
352 (defn- apply-lambda
353 "Apply in the special case that the first element in the function is `LAMBDA`."
354 [function args environment depth]
355 (EVAL
356 (CADDR function)
357 (PAIRLIS (CADR function) args environment) depth))
358
359 (defn APPLY
360 "Apply this `function` to these `arguments` in this `environment` and return
361 the result.
362
363 For bootstrapping, at least, a version of APPLY written in Clojure.
364 All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
365 See page 13 of the Lisp 1.5 Programmers Manual."
366 ([function args environment]
367 (APPLY function args environment *depth*))
368 ([function args environment depth]
369 (binding [*depth* (inc depth)]
370 (trace-call 'APPLY (list function args environment) depth)
371 (let [result (cond
372 (= NIL function) (if (:strict *options*)
373 NIL
374 (throw (ex-info "NIL sí ne þegnung"
375 {:phase :apply
376 :function "NIL"
377 :args args
378 :type :beowulf})))
379 (= (ATOM function) T) (apply-symbolic function args environment (inc depth))
380 :else (case (first function)
381 LABEL (apply-label function args environment depth)
382 FUNARG (APPLY (CADR function) args (CADDR function) depth)
383 LAMBDA (apply-lambda function args environment depth)
384 ;; else
385 ;; OK, this is *not* what is says in the manual...
386 ;; COND (EVCON ???)
387 (throw (ex-info "Ungecnáwen wyrþan sí þegnung-weard"
388 {:phase :apply
389 :function function
390 :args args
391 :type :beowulf}))))]
392 (trace-response 'APPLY result depth)
393 result))))
394
395 ;;;; EVAL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
396
397 (defn- EVCON
398 "Inner guts of primitive COND. All `clauses` are assumed to be
399 `beowulf.cons-cell/ConsCell` objects. Note that tests in Lisp 1.5
400 often return `F`, not `NIL`, on failure. If no clause matches,
401 then, strictly, we throw an error with code `:A3`.
402
403 See pages 13 and 71 of the Lisp 1.5 Programmers Manual."
404 [clauses env depth]
405 (loop [clauses' clauses]
406 (if-not (= clauses' NIL)
407 (let [test (EVAL (CAAR clauses') env depth)]
408 (if (not (#{NIL F} test))
409 ;; (and (not= test NIL) (not= test F))
410 (EVAL (CADAR clauses') env depth)
411 (recur (.getCdr clauses'))))
412 (if (:strict *options*)
413 (throw (ex-info "Ne ġefōg dǣl in COND"
414 {:phase :eval
415 :function 'COND
416 :args (list clauses)
417 :type :lisp
418 :code :A3}))
419 NIL))))
420
421 (defn- EVLIS
422 "Map `EVAL` across this list of `args` in the context of this
423 `env`ironment.All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
424 See page 13 of the Lisp 1.5 Programmers Manual."
425 [args env depth]
426 (cond
427 (= NIL args) NIL
428 :else
429 (make-cons-cell
430 (EVAL (CAR args) env depth)
431 (EVLIS (CDR args) env depth))))
432
433 (defn- eval-symbolic
434 [expr env depth]
435 (let [v (ASSOC expr env)
436 indent (apply str (repeat depth "-"))]
437 (when (traced? 'EVAL)
438 (println (str indent ": EVAL: sceald bindele: " (or v "nil"))))
439 (if (instance? ConsCell v)
440 (.getCdr v)
441 (let [v' (value expr)]
442 (when (traced? 'EVAL)
443 (println (str indent ": EVAL: deóp bindele: (" expr " . " (or v' "nil") ")")))
444 (if v'
445 v'
446 (throw (ex-info (format "Ne tácen-bindele āfand: `%s`" expr)
447 {:phase :eval
448 :function 'EVAL
449 :args (list expr env depth)
450 :type :lisp
451 :code :A8})))))))
452
453 (defn EVAL
454 "Evaluate this `expr` and return the result. If `environment` is not passed,
455 it defaults to the current value of the global object list. The `depth`
456 argument is part of the tracing system and should not be set by user code.
457
458 All args are assumed to be numbers, symbols or `beowulf.cons-cell/ConsCell`
459 objects. However, if called with just a single arg, `expr`, I'll assume it's
460 being called from the Clojure REPL and will coerce the `expr` to `ConsCell`."
461 ([expr]
462 (let [expr' (if (and (coll? expr) (not (instance? ConsCell expr)))
463 (make-beowulf-list expr)
464 expr)]
465 (EVAL expr' NIL 0)))
466 ([expr env depth]
467 (trace-call 'EVAL (list expr env depth) depth)
468 (let [result (cond
469 (= NIL expr) NIL ;; it was probably a mistake to make Lisp
470 ;; NIL distinct from Clojure nil
471 (= (NUMBERP expr) T) expr
472 (symbol? expr) (eval-symbolic expr env depth)
473 (string? expr) (if (:strict *options*)
474 (throw
475 (ex-info
476 (str "EVAL: strings not allowed in strict mode: \"" expr "\"")
477 {:phase :eval
478 :detail :strict
479 :expr expr}))
480 (symbol expr))
481 (= (ATOM (CAR expr)) T) (case (CAR expr)
482 COND (EVCON (CDR expr) env depth)
483 FUNCTION (LIST 'FUNARG (CADR expr))
484 PROG (PROG (CDR expr) env depth)
485 QUOTE (CADR expr)
486 ;; else
487 (APPLY
488 (CAR expr)
489 (EVLIS (CDR expr) env depth)
490 env
491 depth))
492 :else (EVAL (CONS (CDR (SASSOC (CAR expr) env (fn [] (ERROR 'A9))))
493 (CDR expr))
494 env
495 (inc depth)))]
496 (trace-response 'EVAL result depth)
497 result)))
498