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 (not (instance? ConsCell l)) (throw (ex-info (str "Ne liste: "
095 l "; " (type l))
096 {:phase :eval
097 :function "universal access function"
098 :args [l path]
099 :type :beowulf}))
100 :else (case (last path)
101 \a (uaf (.first l) (butlast path))
102 \d (uaf (.getCdr l) (butlast path))
103 (throw (ex-info (str "uaf: unexpected letter in path (only `a` and `d` permitted): "
104 (last path))
105 {:phase :eval
106 :function "universal access function"
107 :args [l path]
108 :type :beowulf})))))
109
110 (defmacro CAAR [x] `(uaf ~x '(\a \a)))
111 (defmacro CADR [x] `(uaf ~x '(\a \d)))
112 (defmacro CDDR [x] `(uaf ~x '(\d \d)))
113 (defmacro CDAR [x] `(uaf ~x '(\d \a)))
114
115 (defmacro CAAAR [x] `(uaf ~x '(\a \a \a)))
116 (defmacro CAADR [x] `(uaf ~x '(\a \a \d)))
117 (defmacro CADAR [x] `(uaf ~x '(\a \d \a)))
118 (defmacro CADDR [x] `(uaf ~x '(\a \d \d)))
119 (defmacro CDDAR [x] `(uaf ~x '(\d \d \a)))
120 (defmacro CDDDR [x] `(uaf ~x '(\d \d \d)))
121 (defmacro CDAAR [x] `(uaf ~x '(\d \a \a)))
122 (defmacro CDADR [x] `(uaf ~x '(\d \a \d)))
123
124 (defmacro CAAAAR [x] `(uaf ~x '(\a \a \a \a)))
125 (defmacro CAADAR [x] `(uaf ~x '(\a \a \d \a)))
126 (defmacro CADAAR [x] `(uaf ~x '(\a \d \a \a)))
127 (defmacro CADDAR [x] `(uaf ~x '(\a \d \d \a)))
128 (defmacro CDDAAR [x] `(uaf ~x '(\d \d \a \a)))
129 (defmacro CDDDAR [x] `(uaf ~x '(\d \d \d \a)))
130 (defmacro CDAAAR [x] `(uaf ~x '(\d \a \a \a)))
131 (defmacro CDADAR [x] `(uaf ~x '(\d \a \d \a)))
132 (defmacro CAAADR [x] `(uaf ~x '(\a \a \a \d)))
133 (defmacro CAADDR [x] `(uaf ~x '(\a \a \d \d)))
134 (defmacro CADADR [x] `(uaf ~x '(\a \d \a \d)))
135 (defmacro CADDDR [x] `(uaf ~x '(\a \d \d \d)))
136 (defmacro CDDADR [x] `(uaf ~x '(\d \d \a \d)))
137 (defmacro CDDDDR [x] `(uaf ~x '(\d \d \d \d)))
138 (defmacro CDAADR [x] `(uaf ~x '(\d \a \a \d)))
139 (defmacro CDADDR [x] `(uaf ~x '(\d \a \d \d)))
140
141 (defn RPLACA
142 "Replace the CAR pointer of this `cell` with this `value`. Dangerous, should
143 really not exist, but does in Lisp 1.5 (and was important for some
144 performance hacks in early Lisps)"
145 [^ConsCell cell value]
146 (if
147 (instance? ConsCell cell)
148 (if
149 (or
150 (instance? ConsCell value)
151 (number? value)
152 (symbol? value)
153 (= value NIL))
154 (try
155 (.rplaca cell value)
156 cell
157 (catch Throwable any
158 (throw (ex-info
159 (str (.getMessage any) " in RPLACA: `")
160 {:cause :upstream-error
161 :phase :host
162 :function :rplaca
163 :args (list cell value)
164 :type :beowulf}
165 any))))
166 (throw (ex-info
167 (str "Un-ġefōg þing in RPLACA: `" value "` (" (type value) ")")
168 {:cause :bad-value
169 :phase :host
170 :function :rplaca
171 :args (list cell value)
172 :type :beowulf})))
173 (throw (ex-info
174 (str "Uncynlic miercels in RPLACA: `" cell "` (" (type cell) ")")
175 {:cause :bad-cell
176 :phase :host
177 :function :rplaca
178 :args (list cell value)
179 :type :beowulf}))))
180
181 (defn RPLACD
182 "Replace the CDR pointer of this `cell` with this `value`. Dangerous, should
183 really not exist, but does in Lisp 1.5 (and was important for some
184 performance hacks in early Lisps)"
185 [^ConsCell cell value]
186 (if
187 (instance? ConsCell cell)
188 (if
189 (or
190 (instance? ConsCell value)
191 (number? value)
192 (symbol? value)
193 (= value NIL))
194 (try
195 (.rplacd cell value)
196 cell
197 (catch Throwable any
198 (throw (ex-info
199 (str (.getMessage any) " in RPLACD: `")
200 {:cause :upstream-error
201 :phase :host
202 :function :rplacd
203 :args (list cell value)
204 :type :beowulf}
205 any))))
206 (throw (ex-info
207 (str "Un-ġefōg þing in RPLACD: `" value "` (" (type value) ")")
208 {:cause :bad-value
209 :phase :host
210 :function :rplacd
211 :args (list cell value)
212 :type :beowulf})))
213 (throw (ex-info
214 (str "Uncynlic miercels in RPLACD: `" cell "` (" (type cell) ")")
215 {:cause :bad-cell
216 :phase :host
217 :detail :rplacd
218 :args (list cell value)
219 :type :beowulf}))));; PLUS
220
221 (defn LIST
222 [& args]
223 (make-beowulf-list args))
224
225 ;;;; Basic predicates ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
226
227 (defmacro NULL
228 "Returns `T` if and only if the argument `x` is bound to `NIL`; else `F`."
229 [x]
230 `(if (= ~x NIL) T F))
231
232 (defmacro NILP
233 "Not part of LISP 1.5: `T` if `o` is `NIL`, else `NIL`."
234 [x]
235 `(if (= ~x NIL) T NIL))
236
237 (defn ATOM
238 "Returns `T` if and only if the argument `x` is bound to an atom; else `F`.
239 It is not clear to me from the documentation whether `(ATOM 7)` should return
240 `T` or `F`. I'm going to assume `T`."
241 [x]
242 (if (or (symbol? x) (number? x)) T F))
243
244 (defmacro ATOM?
245 "The convention of returning `F` from predicates, rather than `NIL`, is going
246 to tie me in knots. This is a variant of `ATOM` which returns `NIL`
247 on failure."
248 [x]
249 `(if (or (symbol? ~x) (number? ~x)) T NIL))
250
251 (defn EQ
252 "Returns `T` if and only if both `x` and `y` are bound to the same atom,
253 else `NIL`."
254 [x y]
255 (cond (and (instance? ConsCell x)
256 (.equals x y)) T
257 (and (= (ATOM x) T) (= x y)) T
258 :else NIL))
259
260 (defn EQUAL
261 "This is a predicate that is true if its two arguments are identical
262 S-expressions, and false if they are different. (The elementary predicate
263 `EQ` is defined only for atomic arguments.) The definition of `EQUAL` is
264 an example of a conditional expression inside a conditional expression.
265
266 NOTE: returns `F` on failure, not `NIL`"
267 [x y]
268 (cond
269 (= (ATOM x) T) (if (= x y) T F)
270 (= (EQUAL (CAR x) (CAR y)) T) (EQUAL (CDR x) (CDR y))
271 :else F))
272
273 (defn AND
274 "`T` if and only if none of my `args` evaluate to either `F` or `NIL`,
275 else `F`.
276
277 In `beowulf.host` principally because I don't yet feel confident to define
278 varargs functions in Lisp."
279 [& args]
280 ;; (println "AND: " args " type: " (type args) " seq? " (seq? args))
281 ;; (println " filtered: " (seq (filter #{F NIL} args)))
282 (cond (= NIL args) T
283 (seq? args) (if (seq (filter #{F NIL} args)) F T)
284 :else T))
285
286
287 (defn OR
288 "`T` if and only if at least one of my `args` evaluates to something other
289 than either `F` or `NIL`, else `F`.
290
291 In `beowulf.host` principally because I don't yet feel confident to define
292 varargs functions in Lisp."
293 [& args]
294 ;; (println "OR: " args " type: " (type args) " seq? " (seq? args))
295 ;; (println " filtered: " (seq (remove #{F NIL} args)))
296 (cond (= NIL args) F
297 (seq? args) (if (seq (remove #{F NIL} args)) T F)
298 :else F))
299
300
301 ;;;; Operations on lists ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
302 ;;
303 ;; TODO: These are candidates for moving to Lisp urgently!
304
305 (defn ASSOC
306 "If a is an association list such as the one formed by PAIRLIS in the above
307 example, then assoc will produce the first pair whose first term is x. Thus
308 it is a table searching function.
309
310 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
311 See page 12 of the Lisp 1.5 Programmers Manual.
312
313 **NOTE THAT** this function is overridden by an implementation in Lisp,
314 but is currently still present for bootstrapping."
315 [x a]
316 (cond
317 (= NIL a) NIL ;; this clause is not present in the original but is added for
318 ;; robustness.
319 (= (EQUAL (CAAR a) x) T) (CAR a)
320 :else
321 (ASSOC x (CDR a))))
322
323 (defn PAIRLIS
324 "This function gives the list of pairs of corresponding elements of the
325 lists `x` and `y`, and APPENDs this to the list `a`. The resultant list
326 of pairs, which is like a table with two columns, is called an
327 association list.
328
329 Eessentially, it builds the environment on the stack, implementing shallow
330 binding.
331
332 All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
333 See page 12 of the Lisp 1.5 Programmers Manual.
334
335 **NOTE THAT** this function is overridden by an implementation in Lisp,
336 but is currently still present for bootstrapping."
337 [x y a]
338 (cond
339 ;; the original tests only x; testing y as well will be a little more
340 ;; robust if `x` and `y` are not the same length.
341 (or (= NIL x) (= NIL y)) a
342 :else (make-cons-cell
343 (make-cons-cell (CAR x) (CAR y))
344 (PAIRLIS (CDR x) (CDR y) a))))
345
346 ;;;; Arithmetic ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
347 ;;
348 ;; TODO: When in strict mode, should we limit arithmetic precision to that
349 ;; supported by Lisp 1.5?
350
351 (defn PLUS
352 [& args]
353 (let [s (apply + args)]
354 (if (integer? s) s (float s))))
355
356 (defn TIMES
357 [& args]
358 (let [p (apply * args)]
359 (if (integer? p) p (float p))))
360
361 (defn DIFFERENCE
362 [x y]
363 (let [d (- x y)]
364 (if (integer? d) d (float d))))
365
366 (defn QUOTIENT
367 "I'm not certain from the documentation whether Lisp 1.5 `QUOTIENT` returned
368 the integer part of the quotient, or a realnum representing the whole
369 quotient. I am for now implementing the latter."
370 [x y]
371 (let [q (/ x y)]
372 (if (integer? q) q (float q))))
373
374 (defn REMAINDER
375 [x y]
376 (rem x y))
377
378 (defn ADD1
379 [x]
380 (inc x))
381
382 (defn SUB1
383 [x]
384 (dec x))
385
386 (defn FIXP
387 [x]
388 (if (integer? x) T F))
389
390 (defn NUMBERP
391 [x]
392 (if (number? x) T F))
393
394 (defn LESSP
395 [x y]
396 (if (< x y) T F))
397
398 (defn GREATERP
399 [x y]
400 (if (> x y) T F))
401
402 ;;;; Miscellaneous ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
403
404 (defn GENSYM
405 "Generate a unique symbol."
406 []
407 (symbol (upper-case (str (gensym "SYM")))))
408
409 (defn ERROR
410 "Throw an error"
411 [& args]
412 (throw (ex-info "LISP STÆFLEAHTER" {:args args
413 :phase :eval
414 :function 'ERROR
415 :type :lisp
416 :code (or (first args) 'A1)})))
417
418 ;;;; Assignment and the object list ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
419
420 (defn OBLIST
421 "Return a list of the symbols currently bound on the object list.
422
423 **NOTE THAT** in the Lisp 1.5 manual, footnote at the bottom of page 69, it implies
424 that an argument can be passed but I'm not sure of the semantics of
425 this."
426 []
427 (if (instance? ConsCell @oblist)
428 (make-beowulf-list (map CAR @oblist))
429 NIL))
430
431 (def magic-marker
432 "The unexplained magic number which marks the start of a property list."
433 (Integer/parseInt "77777" 8))
434
435 (defn hit-or-miss-assoc
436 "Find the position of the binding of this `target` in a Lisp 1.5
437 property list `plist`.
438
439 Lisp 1.5 property lists are not assoc lists, but lists of the form
440 `(name value name value name value...)`. It's therefore necessary to
441 recurse down the list two entries at a time to avoid confusing names
442 with values."
443 [target plist]
444 (if (and (instance? ConsCell plist) (even? (count plist)))
445 (cond (= plist NIL) NIL
446 (= (first plist) target) plist
447 :else (hit-or-miss-assoc target (CDDR plist)))
448 NIL))
449
450 (defn PUT
451 "Put this `value` as the value of the property indicated by this `indicator`
452 of this `symbol`. Return `value` on success.
453
454 NOTE THAT there is no `PUT` defined in the manual, but it would have been
455 easy to have defined it so I don't think this fully counts as an extension."
456 [symbol indicator value]
457 (let [binding (ASSOC symbol @oblist)]
458 (if (instance? ConsCell binding)
459 (let [prop (hit-or-miss-assoc indicator (CDDR binding))]
460 (if (instance? ConsCell prop)
461 (RPLACA (CDR prop) value)
462 (RPLACD binding
463 (make-cons-cell
464 magic-marker
465 (make-cons-cell
466 indicator
467 (make-cons-cell value (CDDR binding)))))))
468 (swap!
469 oblist
470 (fn [ob s p v]
471 (make-cons-cell
472 (make-beowulf-list (list s magic-marker p v))
473 ob))
474 symbol indicator value)))
475 value)
476
477 (defn GET
478 "From the manual:
479
480 '`get` is somewhat like `prop`; however its value is car of the rest of
481 the list if the `indicator` is found, and NIL otherwise.'
482
483 It's clear that `GET` is expected to be defined in terms of `PROP`, but
484 we can't implement `PROP` here because we lack `EVAL`; and we can't have
485 `EVAL` here because both it and `APPLY` depends on `GET`.
486
487 OK, It's worse than that: the statement of the definition of `GET` (and
488 of) `PROP` on page 59 says that the first argument to each must be a list;
489 But the in the definition of `ASSOC` on page 70, when `GET` is called its
490 first argument is always an atom. Since it's `ASSOC` and `EVAL` which I
491 need to make work, I'm going to assume that page 59 is wrong."
492 [symbol indicator]
493 (let [binding (ASSOC symbol @oblist)
494 val (cond
495 (= binding NIL) NIL
496 (= magic-marker
497 (CADR binding)) (loop [b binding]
498 ;; (println "GET loop, seeking " indicator ":")
499 ;; (pretty-print b)
500 (if (instance? ConsCell b)
501 (if (= (CAR b) indicator)
502 (CADR b) ;; <- this is what we should actually be returning
503 (recur (CDR b)))
504 NIL))
505 :else (throw
506 (ex-info "Misformatted property list (missing magic marker)"
507 {:phase :host
508 :function :get
509 :args (list symbol indicator)
510 :type :beowulf})))]
511 ;; (println "<< GET returning: " val)
512 val))
513
514 (defn DEFLIST
515 "For each pair in this association list `a-list`, set the property with this
516 `indicator` of the symbol which is the first element of the pair to the
517 value which is the second element of the pair. See page 58 of the manual."
518 [a-list indicator]
519 (doall
520 (map
521 #(when (PUT (CAR %) indicator (CDR %)) (CAR %))
522 a-list)))
523
524 (defn DEFINE
525 "Bootstrap-only version of `DEFINE` which, post boostrap, can be overwritten
526 in LISP.
527
528 The single argument to `DEFINE` should be an association list of symbols to
529 lambda functions. See page 58 of the manual."
530 [a-list]
531 (DEFLIST a-list 'EXPR))
532
533 (defn SET
534 "Implementation of SET in Clojure. Add to the `oblist` a binding of the
535 value of `var` to the value of `val`. NOTE WELL: this is not SETQ!"
536 [symbol val]
537 (PUT symbol 'APVAL val))
538
539 ;;;; TRACE and friends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
540
541 (def traced-symbols
542 "Symbols currently being traced."
543 (atom #{}))
544
545 (defn traced?
546 "Return `true` iff `s` is a symbol currently being traced, else `nil`."
547 [s]
548 (try (contains? @traced-symbols s)
549 (catch Throwable _ nil)))
550
551 (defn TRACE
552 "Add this `s` to the set of symbols currently being traced. If `s`
553 is not a symbol or sequence of symbols, does nothing."
554 [s]
555 (swap! traced-symbols
556 #(cond
557 (symbol? s) (conj % s)
558 (and (seq? s) (every? symbol? s)) (union % (set s))
559 :else %)))
560
561 (defn UNTRACE
562 "Remove this `s` from the set of symbols currently being traced. If `s`
563 is not a symbol or sequence of symbols, does nothing."
564 [s]
565 (cond
566 (symbol? s) (swap! traced-symbols #(set (remove (fn [x] (= s x)) %)))
567 (and (seq? s) (every? symbol? s)) (map UNTRACE s))
568 @traced-symbols)
569
570 ;;;; Extensions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
571
572 (defn DOC
573 "Open the page for this `symbol` in the Lisp 1.5 manual, if known, in the
574 default web browser.
575
576 **NOTE THAT** this is an extension function, not available in strct mode."
577 [symbol]
578 (when (lax? 'DOC)
579 (open-doc symbol)))
580
581 (defn CONSP
582 "Return `T` if object `o` is a cons cell, else `F`.
583
584 **NOTE THAT** this is an extension function, not available in strct mode.
585 I believe that Lisp 1.5 did not have any mechanism for testing whether an
586 argument was, or was not, a cons cell."
587 [o]
588 (when (lax? 'CONSP)
589 (if (instance? ConsCell o) 'T 'F)))