001 (ns beowulf.host
002 "provides Lisp 1.5 functions which can't be (or can't efficiently
003 be) implemented in Lisp 1.5, which therefore need to be implemented in the
004 host language, in this case Clojure."
005 (:require [beowulf.cons-cell :refer [F make-beowulf-list make-cons-cell
006 pretty-print T]] ;; note hyphen - this is Clojure...
007 [beowulf.gendoc :refer [open-doc]]
008 [beowulf.oblist :refer [*options* NIL oblist]]
009 [clojure.set :refer [union]]
010 [clojure.string :refer [upper-case]])
011 (:import [beowulf.cons_cell ConsCell] ;; note underscore - same namespace, but Java.
012 ))
013
014 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
015 ;;;
016 ;;; Copyright (C) 2022-2023 Simon Brooke
017 ;;;
018 ;;; This program is free software; you can redistribute it and/or
019 ;;; modify it under the terms of the GNU General Public License
020 ;;; as published by the Free Software Foundation; either version 2
021 ;;; of the License, or (at your option) any later version.
022 ;;;
023 ;;; This program is distributed in the hope that it will be useful,
024 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
025 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
026 ;;; GNU General Public License for more details.
027 ;;;
028 ;;; You should have received a copy of the GNU General Public License
029 ;;; along with this program; if not, write to the Free Software
030 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
031 ;;;
032 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
033
034 ;; these are CANDIDATES to be host-implemented. only a subset of them MUST be.
035 ;; those which can be implemented in Lisp should be, since that aids
036 ;; portability.
037
038
039 (defn lax?
040 "Are we in lax mode? If so. return true; is not, throw an exception with
041 this `symbol`."
042 [symbol]
043 (when (:strict *options*)
044 (throw (ex-info (format "%s ne āfand innan Lisp 1.5" symbol)
045 {:type :strict
046 :phase :host
047 :function symbol})))
048 true)
049
050 ;;;; Basic operations on cons cells ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
051
052 (defn CONS
053 "Construct a new instance of cons cell with this `car` and `cdr`."
054 [car cdr]
055 (beowulf.cons_cell.ConsCell. car cdr (gensym "c")))
056
057 (defn CAR
058 "Return the item indicated by the first pointer of a pair. NIL is treated
059 specially: the CAR of NIL is NIL."
060 [x]
061 (cond
062 (= x NIL) NIL
063 (instance? ConsCell x) (or (.getCar x) NIL)
064 :else (throw (ex-info
065 (str "Ne can tace CAR of `" x "` (" (.getName (.getClass x)) ")")
066 {:phase :host
067 :function 'CAR
068 :args (list x)
069 :type :beowulf}))))
070
071 (defn CDR
072 "Return the item indicated by the second pointer of a pair. NIL is treated
073 specially: the CDR of NIL is NIL."
074 [x]
075 (cond
076 (= x NIL) NIL
077 (instance? ConsCell x) (or (.getCdr x) NIL)
078 :else (throw (ex-info
079 (str "Ne can tace CDR of `" x "` (" (.getName (.getClass x)) ")")
080 {:phase :host
081 :function 'CDR
082 :args (list x)
083 :type :beowulf}))))
084
085
086 (defn uaf
087 "Universal access function; `l` is expected to be an arbitrary LISP list, `path`
088 a (clojure) list of the characters `a` and `d`. Intended to make declaring
089 all those fiddly `#'c[ad]+r'` functions a bit easier"
090 [l path]
091 (cond
092 (= l NIL) NIL
093 (empty? path) l
094 :else
095 (try
096 (case (last path)
097 \a (uaf (.first l) (butlast path))
098 \d (uaf (.getCdr l) (butlast path))
099 (throw (ex-info (str "uaf: unexpected letter in path (only `a` and `d` permitted): " (last path))
100 {:cause :uaf
101 :detail :unexpected-letter
102 :expr (last path)})))
103 (catch ClassCastException e
104 (throw (ex-info
105 (str "uaf: Not a LISP list? " (type l))
106 {:cause :uaf
107 :detail :not-a-lisp-list
108 :expr l}
109 e))))))
110
111 (defmacro CAAR [x] `(uaf ~x '(\a \a)))
112 (defmacro CADR [x] `(uaf ~x '(\a \d)))
113 (defmacro CDDR [x] `(uaf ~x '(\d \d)))
114 (defmacro CDAR [x] `(uaf ~x '(\d \a)))
115
116 (defmacro CAAAR [x] `(uaf ~x '(\a \a \a)))
117 (defmacro CAADR [x] `(uaf ~x '(\a \a \d)))
118 (defmacro CADAR [x] `(uaf ~x '(\a \d \a)))
119 (defmacro CADDR [x] `(uaf ~x '(\a \d \d)))
120 (defmacro CDDAR [x] `(uaf ~x '(\d \d \a)))
121 (defmacro CDDDR [x] `(uaf ~x '(\d \d \d)))
122 (defmacro CDAAR [x] `(uaf ~x '(\d \a \a)))
123 (defmacro CDADR [x] `(uaf ~x '(\d \a \d)))
124
125 (defmacro CAAAAR [x] `(uaf ~x '(\a \a \a \a)))
126 (defmacro CAADAR [x] `(uaf ~x '(\a \a \d \a)))
127 (defmacro CADAAR [x] `(uaf ~x '(\a \d \a \a)))
128 (defmacro CADDAR [x] `(uaf ~x '(\a \d \d \a)))
129 (defmacro CDDAAR [x] `(uaf ~x '(\d \d \a \a)))
130 (defmacro CDDDAR [x] `(uaf ~x '(\d \d \d \a)))
131 (defmacro CDAAAR [x] `(uaf ~x '(\d \a \a \a)))
132 (defmacro CDADAR [x] `(uaf ~x '(\d \a \d \a)))
133 (defmacro CAAADR [x] `(uaf ~x '(\a \a \a \d)))
134 (defmacro CAADDR [x] `(uaf ~x '(\a \a \d \d)))
135 (defmacro CADADR [x] `(uaf ~x '(\a \d \a \d)))
136 (defmacro CADDDR [x] `(uaf ~x '(\a \d \d \d)))
137 (defmacro CDDADR [x] `(uaf ~x '(\d \d \a \d)))
138 (defmacro CDDDDR [x] `(uaf ~x '(\d \d \d \d)))
139 (defmacro CDAADR [x] `(uaf ~x '(\d \a \a \d)))
140 (defmacro CDADDR [x] `(uaf ~x '(\d \a \d \d)))
141
142 (defn RPLACA
143 "Replace the CAR pointer of this `cell` with this `value`. Dangerous, should
144 really not exist, but does in Lisp 1.5 (and was important for some
145 performance hacks in early Lisps)"
146 [^ConsCell cell value]
147 (if
148 (instance? ConsCell cell)
149 (if
150 (or
151 (instance? ConsCell value)
152 (number? value)
153 (symbol? value)
154 (= value NIL))
155 (try
156 (.rplaca cell value)
157 cell
158 (catch Throwable any
159 (throw (ex-info
160 (str (.getMessage any) " in RPLACA: `")
161 {:cause :upstream-error
162 :phase :host
163 :function :rplaca
164 :args (list cell value)
165 :type :beowulf}
166 any))))
167 (throw (ex-info
168 (str "Un-ġefōg þing in RPLACA: `" value "` (" (type value) ")")
169 {:cause :bad-value
170 :phase :host
171 :function :rplaca
172 :args (list cell value)
173 :type :beowulf})))
174 (throw (ex-info
175 (str "Uncynlic miercels in RPLACA: `" cell "` (" (type cell) ")")
176 {:cause :bad-cell
177 :phase :host
178 :function :rplaca
179 :args (list cell value)
180 :type :beowulf}))))
181
182 (defn RPLACD
183 "Replace the CDR pointer of this `cell` with this `value`. Dangerous, should
184 really not exist, but does in Lisp 1.5 (and was important for some
185 performance hacks in early Lisps)"
186 [^ConsCell cell value]
187 (if
188 (instance? ConsCell cell)
189 (if
190 (or
191 (instance? ConsCell value)
192 (number? value)
193 (symbol? value)
194 (= value NIL))
195 (try
196 (.rplacd cell value)
197 cell
198 (catch Throwable any
199 (throw (ex-info
200 (str (.getMessage any) " in RPLACD: `")
201 {:cause :upstream-error
202 :phase :host
203 :function :rplacd
204 :args (list cell value)
205 :type :beowulf}
206 any))))
207 (throw (ex-info
208 (str "Un-ġefōg þing in RPLACD: `" value "` (" (type value) ")")
209 {:cause :bad-value
210 :phase :host
211 :function :rplacd
212 :args (list cell value)
213 :type :beowulf})))
214 (throw (ex-info
215 (str "Uncynlic miercels in RPLACD: `" cell "` (" (type cell) ")")
216 {:cause :bad-cell
217 :phase :host
218 :detail :rplacd
219 :args (list cell value)
220 :type :beowulf}))));; PLUS
221
222 (defn LIST
223 [& args]
224 (make-beowulf-list args))
225
226 ;;;; Basic predicates ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
227
228 (defmacro NULL
229 "Returns `T` if and only if the argument `x` is bound to `NIL`; else `F`."
230 [x]
231 `(if (= ~x NIL) T F))
232
233 (defmacro NILP
234 "Not part of LISP 1.5: `T` if `o` is `NIL`, else `NIL`."
235 [x]
236 `(if (= ~x NIL) T NIL))
237
238 (defn ATOM
239 "Returns `T` if and only if the argument `x` is bound to an atom; else `F`.
240 It is not clear to me from the documentation whether `(ATOM 7)` should return
241 `T` or `F`. I'm going to assume `T`."
242 [x]
243 (if (or (symbol? x) (number? x)) T F))
244
245 (defmacro ATOM?
246 "The convention of returning `F` from predicates, rather than `NIL`, is going
247 to tie me in knots. This is a variant of `ATOM` which returns `NIL`
248 on failure."
249 [x]
250 `(if (or (symbol? ~x) (number? ~x)) T NIL))
251
252 (defn EQ
253 "Returns `T` if and only if both `x` and `y` are bound to the same atom,
254 else `NIL`."
255 [x y]
256 (cond (and (instance? ConsCell x)
257 (.equals x y)) T
258 (and (= (ATOM x) T) (= x y)) T
259 :else NIL))
260
261 (defn EQUAL
262 "This is a predicate that is true if its two arguments are identical
263 S-expressions, and false if they are different. (The elementary predicate
264 `EQ` is defined only for atomic arguments.) The definition of `EQUAL` is
265 an example of a conditional expression inside a conditional expression.
266
267 NOTE: returns `F` on failure, not `NIL`"
268 [x y]
269 (cond
270 (= (ATOM x) T) (if (= x y) T F)
271 (= (EQUAL (CAR x) (CAR y)) T) (EQUAL (CDR x) (CDR y))
272 :else F))
273
274 (defn AND
275 "`T` if and only if none of my `args` evaluate to either `F` or `NIL`,
276 else `F`.
277
278 In `beowulf.host` principally because I don't yet feel confident to define
279 varargs functions in Lisp."
280 [& args]
281 ;; (println "AND: " args " type: " (type args) " seq? " (seq? args))
282 ;; (println " filtered: " (seq (filter #{F NIL} args)))
283 (cond (= NIL args) T
284 (seq? args) (if (seq (filter #{F NIL} args)) F T)
285 :else T))
286
287
288 (defn OR
289 "`T` if and only if at least one of my `args` evaluates to something other
290 than either `F` or `NIL`, else `F`.
291
292 In `beowulf.host` principally because I don't yet feel confident to define
293 varargs functions in Lisp."
294 [& args]
295 ;; (println "OR: " args " type: " (type args) " seq? " (seq? args))
296 ;; (println " filtered: " (seq (remove #{F NIL} args)))
297 (cond (= NIL args) F
298 (seq? args) (if (seq (remove #{F NIL} args)) T F)
299 :else F))
300
301
302 ;;;; Operations on lists ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
303 ;;
304 ;; TODO: These are candidates for moving to Lisp urgently!
305
306 (defn ASSOC
307 "If a is an association list such as the one formed by PAIRLIS in the above
308 example, then assoc will produce the first pair whose first term is x. Thus
309 it is a table searching function.
310
311 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
312 See page 12 of the Lisp 1.5 Programmers Manual.
313
314 **NOTE THAT** this function is overridden by an implementation in Lisp,
315 but is currently still present for bootstrapping."
316 [x a]
317 (cond
318 (= NIL a) NIL ;; this clause is not present in the original but is added for
319 ;; robustness.
320 (= (EQUAL (CAAR a) x) T) (CAR a)
321 :else
322 (ASSOC x (CDR a))))
323
324 (defn PAIRLIS
325 "This function gives the list of pairs of corresponding elements of the
326 lists `x` and `y`, and APPENDs this to the list `a`. The resultant list
327 of pairs, which is like a table with two columns, is called an
328 association list.
329
330 Eessentially, it builds the environment on the stack, implementing shallow
331 binding.
332
333 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
334 See page 12 of the Lisp 1.5 Programmers Manual.
335
336 **NOTE THAT** this function is overridden by an implementation in Lisp,
337 but is currently still present for bootstrapping."
338 [x y a]
339 (cond
340 ;; the original tests only x; testing y as well will be a little more
341 ;; robust if `x` and `y` are not the same length.
342 (or (= NIL x) (= NIL y)) a
343 :else (make-cons-cell
344 (make-cons-cell (CAR x) (CAR y))
345 (PAIRLIS (CDR x) (CDR y) a))))
346
347 ;;;; Arithmetic ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
348 ;;
349 ;; TODO: When in strict mode, should we limit arithmetic precision to that
350 ;; supported by Lisp 1.5?
351
352 (defn PLUS
353 [& args]
354 (let [s (apply + args)]
355 (if (integer? s) s (float s))))
356
357 (defn TIMES
358 [& args]
359 (let [p (apply * args)]
360 (if (integer? p) p (float p))))
361
362 (defn DIFFERENCE
363 [x y]
364 (let [d (- x y)]
365 (if (integer? d) d (float d))))
366
367 (defn QUOTIENT
368 "I'm not certain from the documentation whether Lisp 1.5 `QUOTIENT` returned
369 the integer part of the quotient, or a realnum representing the whole
370 quotient. I am for now implementing the latter."
371 [x y]
372 (let [q (/ x y)]
373 (if (integer? q) q (float q))))
374
375 (defn REMAINDER
376 [x y]
377 (rem x y))
378
379 (defn ADD1
380 [x]
381 (inc x))
382
383 (defn SUB1
384 [x]
385 (dec x))
386
387 (defn FIXP
388 [x]
389 (if (integer? x) T F))
390
391 (defn NUMBERP
392 [x]
393 (if (number? x) T F))
394
395 (defn LESSP
396 [x y]
397 (if (< x y) T F))
398
399 (defn GREATERP
400 [x y]
401 (if (> x y) T F))
402
403 ;;;; Miscellaneous ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
404
405 (defn GENSYM
406 "Generate a unique symbol."
407 []
408 (symbol (upper-case (str (gensym "SYM")))))
409
410 (defn ERROR
411 "Throw an error"
412 [& args]
413 (throw (ex-info "LISP STÆFLEAHTER" {:args args
414 :phase :eval
415 :function 'ERROR
416 :type :lisp
417 :code (or (first args) 'A1)})))
418
419 ;;;; Assignment and the object list ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
420
421 (defn OBLIST
422 "Return a list of the symbols currently bound on the object list.
423
424 **NOTE THAT** in the Lisp 1.5 manual, footnote at the bottom of page 69, it implies
425 that an argument can be passed but I'm not sure of the semantics of
426 this."
427 []
428 (if (instance? ConsCell @oblist)
429 (make-beowulf-list (map CAR @oblist))
430 NIL))
431
432 (def magic-marker
433 "The unexplained magic number which marks the start of a property list."
434 (Integer/parseInt "77777" 8))
435
436 (defn PUT
437 "Put this `value` as the value of the property indicated by this `indicator`
438 of this `symbol`. Return `value` on success.
439
440 NOTE THAT there is no `PUT` defined in the manual, but it would have been
441 easy to have defined it so I don't think this fully counts as an extension."
442 [symbol indicator value]
443 (if-let [binding (ASSOC symbol @oblist)]
444 (if-let [prop (ASSOC indicator (CDDR binding))]
445 (RPLACD prop value)
446 (RPLACD binding
447 (make-cons-cell
448 magic-marker
449 (make-cons-cell
450 indicator
451 (make-cons-cell value (CDDR binding))))))
452 (swap!
453 oblist
454 (fn [ob s p v]
455 (make-cons-cell
456 (make-beowulf-list (list s magic-marker p v))
457 ob))
458 symbol indicator value)))
459
460 (defn GET
461 "From the manual:
462
463 '`get` is somewhat like `prop`; however its value is car of the rest of
464 the list if the `indicator` is found, and NIL otherwise.'
465
466 It's clear that `GET` is expected to be defined in terms of `PROP`, but
467 we can't implement `PROP` here because we lack `EVAL`; and we can't have
468 `EVAL` here because both it and `APPLY` depends on `GET`.
469
470 OK, It's worse than that: the statement of the definition of `GET` (and
471 of) `PROP` on page 59 says that the first argument to each must be a list;
472 But the in the definition of `ASSOC` on page 70, when `GET` is called its
473 first argument is always an atom. Since it's `ASSOC` and `EVAL` which I
474 need to make work, I'm going to assume that page 59 is wrong."
475 [symbol indicator]
476 (let [binding (ASSOC symbol @oblist)
477 val (cond
478 (= binding NIL) NIL
479 (= magic-marker
480 (CADR binding)) (loop [b binding]
481 ;; (println "GET loop, seeking " indicator ":")
482 ;; (pretty-print b)
483 (if (instance? ConsCell b)
484 (if (= (CAR b) indicator)
485 (CADR b) ;; <- this is what we should actually be returning
486 (recur (CDR b)))
487 NIL))
488 :else (throw
489 (ex-info "Misformatted property list (missing magic marker)"
490 {:phase :host
491 :function :get
492 :args (list symbol indicator)
493 :type :beowulf})))]
494 ;; (println "<< GET returning: " val)
495 val))
496
497 (defn DEFLIST
498 "For each pair in this association list `a-list`, set the property with this
499 `indicator` of the symbol which is the first element of the pair to the
500 value which is the second element of the pair. See page 58 of the manual."
501 [a-list indicator]
502 (map
503 #(PUT (CAR %) indicator (CDR %))
504 a-list))
505
506 (defn DEFINE
507 "Bootstrap-only version of `DEFINE` which, post boostrap, can be overwritten
508 in LISP.
509
510 The single argument to `DEFINE` should be an association list of symbols to
511 lambda functions. See page 58 of the manual."
512 [a-list]
513 (DEFLIST a-list 'EXPR))
514
515 (defn SET
516 "Implementation of SET in Clojure. Add to the `oblist` a binding of the
517 value of `var` to the value of `val`. NOTE WELL: this is not SETQ!"
518 [symbol val]
519 (PUT symbol 'APVAL val))
520
521 ;;;; TRACE and friends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
522
523 (def traced-symbols
524 "Symbols currently being traced."
525 (atom #{}))
526
527 (defn traced?
528 "Return `true` iff `s` is a symbol currently being traced, else `nil`."
529 [s]
530 (try (contains? @traced-symbols s)
531 (catch Throwable _ nil)))
532
533 (defn TRACE
534 "Add this `s` to the set of symbols currently being traced. If `s`
535 is not a symbol or sequence of symbols, does nothing."
536 [s]
537 (swap! traced-symbols
538 #(cond
539 (symbol? s) (conj % s)
540 (and (seq? s) (every? symbol? s)) (union % (set s))
541 :else %)))
542
543 (defn UNTRACE
544 "Remove this `s` from the set of symbols currently being traced. If `s`
545 is not a symbol or sequence of symbols, does nothing."
546 [s]
547 (cond
548 (symbol? s) (swap! traced-symbols #(set (remove (fn [x] (= s x)) %)))
549 (and (seq? s) (every? symbol? s)) (map UNTRACE s))
550 @traced-symbols)
551
552 ;;;; Extensions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
553
554 (defn DOC
555 "Open the page for this `symbol` in the Lisp 1.5 manual, if known, in the
556 default web browser.
557
558 **NOTE THAT** this is an extension function, not available in strct mode."
559 [symbol]
560 (when (lax? 'DOC)
561 (open-doc symbol)))
562
563 (defn CONSP
564 "Return `T` if object `o` is a cons cell, else `F`.
565
566 **NOTE THAT** this is an extension function, not available in strct mode.
567 I believe that Lisp 1.5 did not have any mechanism for testing whether an
568 argument was, or was not, a cons cell."
569 [o]
570 (when (lax? 'CONSP)
571 (if (instance? ConsCell o) 'T 'F)))