simon/beowulf
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

This isn't working, but it's very close.

Browse source
This commit is contained in:
Simon Brooke 2023-04-05 23:35:41 +01:00
parent b5afb1ad44
commit 5b5ddb9444
7 changed files with 447 additions and 402 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
doc/further_reading.md
View file

@ -4,4 +4,4 @@
2. [MIT AI Memo 1, John McCarthy, September 1958](https://www.softwarepreservation.org/projects/LISP/MIT/AIM-001.pdf) 2. [MIT AI Memo 1, John McCarthy, September 1958](https://www.softwarepreservation.org/projects/LISP/MIT/AIM-001.pdf)
3. [Lisp 1 Programmer's Manual, Phyllis Fox, March 1960](https://bitsavers.org/pdf/mit/rle_lisp/LISP_I_Programmers_Manual_Mar60.pdf) 3. [Lisp 1 Programmer's Manual, Phyllis Fox, March 1960](https://bitsavers.org/pdf/mit/rle_lisp/LISP_I_Programmers_Manual_Mar60.pdf)
4. [Lisp 1.5 Programmer's Manual, Michael I. Levin, August 1962](https://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf#page=81) 4. [Lisp 1.5 Programmer's Manual, Michael I. Levin, August 1962](https://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf#page=81)
4. [Early LISP History (1956 - 1959)](https://dl.acm.org/doi/pdf/10.1145/800055.802047#page=3) 5. [Early LISP History (1956 - 1959), Herbert Stoyan, August 1984](https://dl.acm.org/doi/pdf/10.1145/800055.802047#page=3)

350
resources/lisp1.5.lsp
View file

@ -1,157 +1,223 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Beowulf Sysout file generated at 2023-03-31T02:24:08.808 ;; Beowulf 0.3.0-SNAPSHOT Sysout file generated at 2023-04-05T23:30:32.954
;; generated by simon ;; generated by simon
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
((NIL) ((NIL 32767 APVAL NIL)
(T . T) (T 32767 APVAL T)
(F) (F 32767 APVAL NIL)
(ADD1) (ADD1 32767 SUBR (BEOWULF HOST ADD1))
(AND) (AND 32767 SUBR (BEOWULF HOST AND))
(APPEND LAMBDA (APPEND
(X Y) (COND ((NULL X) Y) ((QUOTE T) (CONS (CAR X) (APPEND (CDR X) Y))))) 32767
(APPLY) EXPR
(ASSOC LAMBDA (X L) (LAMBDA
(COND (X Y) (COND ((NULL X) Y) ((QUOTE T) (CONS (CAR X) (APPEND (CDR X) Y))))))
((NULL L) (QUOTE NIL)) (APPLY 32767 SUBR (BEOWULF BOOTSTRAP APPLY))
((AND (CONSP (CAR L)) (EQ (CAAR L) X)) (CAR L)) (ASSOC
((QUOTE T) (ASSOC X (CDR L))))) 32767
(ATOM) EXPR
(CAR) (LAMBDA
(CAAAAR LAMBDA (X) (CAR (CAR (CAR (CAR X))))) (X L)
(CAAADR LAMBDA (X) (CAR (CAR (CAR (CDR X))))) (COND
(CAAAR LAMBDA (X) (CAR (CAR (CAR X)))) ((NULL L) (QUOTE NIL))
(CAADAR LAMBDA (X) (CAR (CAR (CDR (CAR X))))) ((AND (CONSP (CAR L)) (EQ (CAAR L) X)) (CAR L))
(CAADDR LAMBDA (X) (CAR (CAR (CDR (CDR X))))) ((QUOTE T) (ASSOC X (CDR L)))))
(CAADR LAMBDA (X) (CAR (CAR (CDR X)))) SUBR (BEOWULF HOST ASSOC))
(CAAR LAMBDA (X) (CAR (CAR X))) (ATOM 32767 SUBR (BEOWULF HOST ATOM))
(CADAAR LAMBDA (X) (CAR (CDR (CAR (CAR X))))) (CAR 32767 SUBR (BEOWULF HOST CAR))
(CADADR LAMBDA (X) (CAR (CDR (CAR (CDR X))))) (CAAAAR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR (CAR X))))))
(CADAR LAMBDA (X) (CAR (CDR (CAR X)))) (CAAADR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR (CDR X))))))
(CADDAR LAMBDA (X) (CAR (CDR (CDR (CAR X))))) (CAAAR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR X)))))
(CADDDR LAMBDA (X) (CAR (CDR (CDR (CDR X))))) (CAADAR 32767 EXPR (LAMBDA (X) (CAR (CAR (CDR (CAR X))))))
(CADDR LAMBDA (X) (CAR (CDR (CDR X)))) (CAADDR 32767 EXPR (LAMBDA (X) (CAR (CAR (CDR (CDR X))))))
(CADR LAMBDA (X) (CAR (CDR X))) (CAADR 32767 EXPR (LAMBDA (X) (CAR (CAR (CDR X)))))
(CDAAAR LAMBDA (X) (CDR (CAR (CAR (CAR X))))) (CAAR 32767 EXPR (LAMBDA (X) (CAR (CAR X))))
(CDAADR LAMBDA (X) (CDR (CAR (CAR (CDR X))))) (CADAAR 32767 EXPR (LAMBDA (X) (CAR (CDR (CAR (CAR X))))))
(CDAAR LAMBDA (X) (CDR (CAR (CAR X)))) (CADADR 32767 EXPR (LAMBDA (X) (CAR (CDR (CAR (CDR X))))))
(CDADAR LAMBDA (X) (CDR (CAR (CDR (CAR X))))) (CADAR 32767 EXPR (LAMBDA (X) (CAR (CDR (CAR X)))))
(CDADDR LAMBDA (X) (CDR (CAR (CDR (CDR X))))) (CADDAR 32767 EXPR (LAMBDA (X) (CAR (CDR (CDR (CAR X))))))
(CDADR LAMBDA (X) (CDR (CAR (CDR X)))) (CADDDR 32767 EXPR (LAMBDA (X) (CAR (CDR (CDR (CDR X))))))
(CDAR LAMBDA (X) (CDR (CAR X))) (CADDR 32767 EXPR (LAMBDA (X) (CAR (CDR (CDR X)))))
(CDDAAR LAMBDA (X) (CDR (CDR (CAR (CAR X))))) (CADR 32767 EXPR (LAMBDA (X) (CAR (CDR X))))
(CDDADR LAMBDA (X) (CDR (CDR (CAR (CDR X))))) (CDAAAR 32767 EXPR (LAMBDA (X) (CDR (CAR (CAR (CAR X))))))
(CDDAR LAMBDA (X) (CDR (CDR (CAR X)))) (CDAADR 32767 EXPR (LAMBDA (X) (CDR (CAR (CAR (CDR X))))))
(CDDDAR LAMBDA (X) (CDR (CDR (CDR (CAR X))))) (CDAAR 32767 EXPR (LAMBDA (X) (CDR (CAR (CAR X)))))
(CDDDDR LAMBDA (X) (CDR (CDR (CDR (CDR X))))) (CDADAR 32767 EXPR (LAMBDA (X) (CDR (CAR (CDR (CAR X))))))
(CDDDR LAMBDA (X) (CDR (CDR (CDR X)))) (CDADDR 32767 EXPR (LAMBDA (X) (CDR (CAR (CDR (CDR X))))))
(CDDR LAMBDA (X) (CDR (CDR X))) (CDADR 32767 EXPR (LAMBDA (X) (CDR (CAR (CDR X)))))
(CDR) (CDAR 32767 EXPR (LAMBDA (X) (CDR (CAR X))))
(CONS) (CDDAAR 32767 EXPR (LAMBDA (X) (CDR (CDR (CAR (CAR X))))))
(CONSP) (CDDADR 32767 EXPR (LAMBDA (X) (CDR (CDR (CAR (CDR X))))))
(CDDAR 32767 EXPR (LAMBDA (X) (CDR (CDR (CAR X)))))
(CDDDAR 32767 EXPR (LAMBDA (X) (CDR (CDR (CDR (CAR X))))))
(CDDDDR 32767 EXPR (LAMBDA (X) (CDR (CDR (CDR (CDR X))))))
(CDDDR 32767 EXPR (LAMBDA (X) (CDR (CDR (CDR X)))))
(CDDR 32767 EXPR (LAMBDA (X) (CDR (CDR X))))
(CDR 32767 SUBR (BEOWULF HOST CDR))
(CONS 32767 SUBR (BEOWULF HOST CONS))
(CONSP 32767 SUBR (BEOWULF HOST CONSP))
(COPY (COPY
LAMBDA 32767
(X) EXPR
(COND (LAMBDA
((NULL X) (QUOTE NIL)) (X)
((ATOM X) X) ((QUOTE T) (CONS (COPY (CAR X)) (COPY (CDR X)))))) (COND
(DEFINE) ((NULL X) (QUOTE NIL))
(DIFFERENCE) ((ATOM X) X) ((QUOTE T) (CONS (COPY (CAR X)) (COPY (CDR X)))))))
(DEFINE 32767 SUBR (BEOWULF HOST DEFINE))
(DIFFERENCE 32767 SUBR (BEOWULF HOST DIFFERENCE))
(DIVIDE (DIVIDE
LAMBDA (X Y) (CONS (QUOTIENT X Y) (CONS (REMAINDER X Y) (QUOTE NIL)))) 32767
(DOC) EXPR
(LAMBDA (X Y) (CONS (QUOTIENT X Y) (CONS (REMAINDER X Y) (QUOTE NIL)))))
(DOC 32767 SUBR (BEOWULF HOST DOC))
(EFFACE (EFFACE
LAMBDA (X L) (COND ((NULL L) (QUOTE NIL)) 32767
((EQUAL X (CAR L)) (CDR L)) EXPR
((QUOTE T) (RPLACD L (EFFACE X (CDR L)))))) (LAMBDA
(ERROR) (X L)
(EQ) (COND
(EQUAL) ((NULL L) (QUOTE NIL))
(EVAL) ((EQUAL X (CAR L)) (CDR L)) ((QUOTE T) (RPLACD L (EFFACE X (CDR L)))))))
(ERROR 32767 SUBR (BEOWULF HOST ERROR))
(EQ 32767 SUBR (BEOWULF HOST EQ))
(EQUAL 32767 SUBR (BEOWULF HOST EQUAL))
(EVAL 32767 SUBR (BEOWULF BOOTSTRAP EVAL))
(FACTORIAL (FACTORIAL
LAMBDA (N) (COND ((EQ N 1) 1) (T (TIMES N (FACTORIAL (SUB1 N)))))) 32767
(FIXP) EXPR (LAMBDA (N) (COND ((EQ N 1) 1) (T (TIMES N (FACTORIAL (SUB1 N)))))))
(GENSYM) (FIXP 32767 SUBR (BEOWULF HOST FIXP))
(GENSYM 32767 SUBR (BEOWULF HOST GENSYM))
(GET (GET
LAMBDA 32767
(X Y) EXPR
(COND (LAMBDA
((NULL X) (QUOTE NIL)) (X Y)
((EQ (CAR X) Y) (CAR (CDR X))) ((QUOTE T) (GET (CDR X) Y)))) (COND
(GREATERP) ((NULL X) (QUOTE NIL))
(INTEROP) ((EQ (CAR X) Y) (CAR (CDR X))) ((QUOTE T) (GET (CDR X) Y))))
SUBR (BEOWULF HOST GET))
(GREATERP 32767 SUBR (BEOWULF HOST GREATERP))
(INTEROP 32767 SUBR (BEOWULF INTEROP INTEROP))
(INTERSECTION (INTERSECTION
LAMBDA 32767
(X Y) EXPR
(COND (LAMBDA
((NULL X) (QUOTE NIL)) (X Y)
((MEMBER (CAR X) Y) (CONS (CAR X) (INTERSECTION (CDR X) Y))) (COND
((QUOTE T) (INTERSECTION (CDR X) Y)))) ((NULL X) (QUOTE NIL))
((MEMBER (CAR X) Y) (CONS (CAR X) (INTERSECTION (CDR X) Y)))
((QUOTE T) (INTERSECTION (CDR X) Y)))))
(LENGTH (LENGTH
LAMBDA 32767
(L) (COND ((EQ NIL L) 0) ((CONSP (CDR L)) (ADD1 (LENGTH (CDR L)))) (T 0))) EXPR
(LESSP) (LAMBDA
(MAPLIST LAMBDA (L F) (COND ((NULL L) NIL) ((QUOTE T) (CONS (F (CAR L)) (MAPLIST (CDR L) F))))) (L)
(COND ((EQ NIL L) 0) ((CONSP (CDR L)) (ADD1 (LENGTH (CDR L)))) (T 0))))
(LESSP 32767 SUBR (BEOWULF HOST LESSP))
(MAPLIST
32767
EXPR
(LAMBDA
(L F)
(COND
((NULL L) NIL) ((QUOTE T) (CONS (F (CAR L)) (MAPLIST (CDR L) F))))))
(MEMBER (MEMBER
LAMBDA 32767
(A X) EXPR
(COND (LAMBDA
((NULL X) (QUOTE F)) (A X)
((EQ A (CAR X)) (QUOTE T)) ((QUOTE T) (MEMBER A (CDR X))))) (COND
(MINUSP LAMBDA (X) (LESSP X 0)) ((NULL X) (QUOTE F))
(NOT LAMBDA (X) (COND (X (QUOTE NIL)) ((QUOTE T) (QUOTE T)))) ((EQ A (CAR X)) (QUOTE T)) ((QUOTE T) (MEMBER A (CDR X))))))
(NULL LAMBDA (X) (COND ((EQUAL X NIL) (QUOTE T)) (T (QUOTE F)))) (MINUSP 32767 EXPR (LAMBDA (X) (LESSP X 0)))
(NUMBERP) (NOT 32767 EXPR (LAMBDA (X) (COND (X (QUOTE NIL)) ((QUOTE T) (QUOTE T)))))
(OBLIST) (NULL
(ONEP LAMBDA (X) (EQ X 1)) 32767 EXPR (LAMBDA (X) (COND ((EQUAL X NIL) (QUOTE T)) (T (QUOTE F)))))
(NUMBERP 32767 SUBR (BEOWULF HOST NUMBERP))
(OBLIST 32767 SUBR (BEOWULF HOST OBLIST))
(ONEP 32767 EXPR (LAMBDA (X) (EQ X 1)))
(PAIR (PAIR
LAMBDA 32767
(X Y) EXPR
(COND (LAMBDA
((AND (NULL X) (NULL Y)) NIL) (X Y)
((NULL X) (ERROR (QUOTE F2))) (COND
((NULL Y) (ERROR (QUOTE F3))) ((AND (NULL X) (NULL Y)) NIL)
(T (CONS (CONS (CAR X) (CAR Y)) (PAIR (CDR X) (CDR Y)))))) ((NULL X) (ERROR (QUOTE F2)))
(PAIRLIS LAMBDA (X Y A) ((NULL Y) (ERROR (QUOTE F3)))
(COND (T (CONS (CONS (CAR X) (CAR Y)) (PAIR (CDR X) (CDR Y)))))))
((NULL X) A) (PAIRLIS
((QUOTE T) (CONS (CONS (CAR X) (CAR Y)) (PAIRLIS (CDR X) (CDR Y) A))))) 32767
(PLUS) EXPR
(PRETTY) (LAMBDA
(PRINT) (X Y A)
(COND
((NULL X) A)
((QUOTE T) (CONS (CONS (CAR X) (CAR Y)) (PAIRLIS (CDR X) (CDR Y) A)))))
SUBR (BEOWULF HOST PAIRLIS))
(PLUS 32767 SUBR (BEOWULF HOST PLUS))
(PRETTY 32767)
(PRINT 32767)
(PROP (PROP
LAMBDA 32767
(X Y U) EXPR
(COND (LAMBDA
((NULL X) (U)) ((EQ (CAR X) Y) (CDR X)) ((QUOTE T) (PROP (CDR X) Y U)))) (X Y U)
(QUOTE LAMBDA (X) X) (COND
(QUOTIENT) ((NULL X) (U))
(RANGE LAMBDA (N M) (COND ((LESSP M N) (QUOTE NIL)) ((QUOTE T) (CONS N (RANGE (ADD1 N) M))))) ((EQ (CAR X) Y) (CDR X)) ((QUOTE T) (PROP (CDR X) Y U)))))
(READ) (QUOTE 32767 EXPR (LAMBDA (X) X))
(REMAINDER) (QUOTIENT 32767 SUBR (BEOWULF HOST QUOTIENT))
(RANGE
32767
EXPR
(LAMBDA
(N M)
(COND
((LESSP M N) (QUOTE NIL)) ((QUOTE T) (CONS N (RANGE (ADD1 N) M))))))
(READ 32767 SUBR (BEOWULF READ READ))
(REMAINDER 32767 SUBR (BEOWULF HOST REMAINDER))
(REPEAT (REPEAT
LAMBDA (N X) (COND ((EQ N 0) NIL) (T (CONS X (REPEAT (SUB1 N) X))))) 32767
(RPLACA) EXPR
(RPLACD) (LAMBDA (N X) (COND ((EQ N 0) NIL) (T (CONS X (REPEAT (SUB1 N) X))))))
(SET) (RPLACA 32767 SUBR (BEOWULF HOST RPLACA))
(SUB1 LAMBDA (N) (DIFFERENCE N 1)) (RPLACD 32767 SUBR (BEOWULF HOST RPLACD))
(SUB2 LAMBDA (A Z) (SET 32767 SUBR (BEOWULF HOST SET))
(COND (SUB1 32767 EXPR (LAMBDA (N) (DIFFERENCE N 1)) SUBR (BEOWULF HOST SUB1))
((NULL A) Z) (SUB2
((EQ (CAAR A) Z) (CDAR A)) 32767
((QUOTE T) (SUB2 (CDAR A) Z)))) EXPR
(SUBLIS LAMBDA (A Y) (COND ((ATOM Y) (SUB2 A Y)) ((QUOTE T) (CONS)))) (LAMBDA
(SUBST LAMBDA (X Y Z) (A Z)
(COND (COND
((EQUAL Y Z) X) ((NULL A) Z) ((EQ (CAAR A) Z) (CDAR A)) ((QUOTE T) (SUB2 (CDAR A) Z)))))
((ATOM Z) Z) (SUBLIS
((QUOTE T) (CONS (SUBST X Y (CAR Z)) (SUBST X Y (CDR Z)))))) 32767 EXPR (LAMBDA (A Y) (COND ((ATOM Y) (SUB2 A Y)) ((QUOTE T) (CONS)))))
(SYSIN) (SUBST
(SYSOUT) (TERPRI) (TIMES) (TRACE) 32767
(UNION LAMBDA (X Y) EXPR
(COND (LAMBDA
((NULL X) Y) (X Y Z)
((MEMBER (CAR X) Y) (UNION (CDR X) Y)) (COND
(T (CONS (CAR X) (UNION (CDR X) Y))))) ((EQUAL Y Z) X)
(UNTRACE) ((ATOM Z) Z)
(ZEROP LAMBDA (N) (EQ N 0))) ((QUOTE T) (CONS (SUBST X Y (CAR Z)) (SUBST X Y (CDR Z)))))))
(SYSIN 32767 SUBR (BEOWULF IO SYSIN))
(SYSOUT 32767 SUBR (BEOWULF IO SYSOUT))
(TERPRI 32767)
(TIMES 32767 SUBR (BEOWULF HOST TIMES))
(TRACE 32767 SUBR (BEOWULF HOST TRACE))
(UNION
32767
EXPR
(LAMBDA
(X Y)
(COND
((NULL X) Y)
((MEMBER (CAR X) Y) (UNION (CDR X) Y))
(T (CONS (CAR X) (UNION (CDR X) Y))))))
(UNTRACE 32767 SUBR (BEOWULF HOST UNTRACE))
(ZEROP 32767 EXPR (LAMBDA (N) (EQ N 0))))

266
src/beowulf/bootstrap.clj
View file

@ -9,18 +9,11 @@
ALLUPPERCASE are Lisp 1.5 functions (although written in Clojure) and that ALLUPPERCASE are Lisp 1.5 functions (although written in Clojure) and that
therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell` therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell`
objects." objects."
(:require [clojure.string :as s] (:require [beowulf.cons-cell :refer [make-cons-cell T]]
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell [beowulf.host :refer [ATOM CAAR CADAR CADDR CADR CAR CDR GET LIST
pretty-print T F]] NUMBERP PAIRLIS traced?]]
[beowulf.host :refer [ADD1 AND ASSOC ATOM ATOM? CAR CDR CONS DEFINE [beowulf.interop :refer [to-clojure]]
DIFFERENCE DOC EQ EQUAL ERROR FIXP GENSYM [beowulf.oblist :refer [*options* NIL oblist]])
GREATERP lax? LESSP LIST NUMBERP OBLIST PAIRLIS
PLUS
QUOTIENT REMAINDER RPLACA RPLACD SET
TIMES TRACE traced? UNTRACE]]
[beowulf.io :refer [SYSIN SYSOUT]]
[beowulf.oblist :refer [*options* oblist NIL]]
[beowulf.read :refer [READ]])
(:import [beowulf.cons_cell ConsCell] (:import [beowulf.cons_cell ConsCell]
[clojure.lang Symbol])) [clojure.lang Symbol]))
@ -51,171 +44,6 @@
[f] [f]
`(quote ~f)) `(quote ~f))
(defn uaf
"Universal access function; `l` is expected to be an arbitrary LISP list, `path`
a (clojure) list of the characters `a` and `d`. Intended to make declaring
all those fiddly `#'c[ad]+r'` functions a bit easier"
[l path]
(cond
(= l NIL) NIL
(empty? path) l
:else
(try
(case (last path)
\a (uaf (.first l) (butlast path))
\d (uaf (.getCdr l) (butlast path))
(throw (ex-info (str "uaf: unexpected letter in path (only `a` and `d` permitted): " (last path))
{:cause :uaf
:detail :unexpected-letter
:expr (last path)})))
(catch ClassCastException e
(throw (ex-info
(str "uaf: Not a LISP list? " (type l))
{:cause :uaf
:detail :not-a-lisp-list
:expr l}))))))
(defmacro CAAR [x] `(uaf ~x '(\a \a)))
(defmacro CADR [x] `(uaf ~x '(\a \d)))
(defmacro CDDR [x] `(uaf ~x '(\d \d)))
(defmacro CDAR [x] `(uaf ~x '(\d \a)))
(defmacro CAAAR [x] `(uaf ~x '(\a \a \a)))
(defmacro CAADR [x] `(uaf ~x '(\a \a \d)))
(defmacro CADAR [x] `(uaf ~x '(\a \d \a)))
(defmacro CADDR [x] `(uaf ~x '(\a \d \d)))
(defmacro CDDAR [x] `(uaf ~x '(\d \d \a)))
(defmacro CDDDR [x] `(uaf ~x '(\d \d \d)))
(defmacro CDAAR [x] `(uaf ~x '(\d \a \a)))
(defmacro CDADR [x] `(uaf ~x '(\d \a \d)))
(defmacro CAAAAR [x] `(uaf ~x '(\a \a \a \a)))
(defmacro CAADAR [x] `(uaf ~x '(\a \a \d \a)))
(defmacro CADAAR [x] `(uaf ~x '(\a \d \a \a)))
(defmacro CADDAR [x] `(uaf ~x '(\a \d \d \a)))
(defmacro CDDAAR [x] `(uaf ~x '(\d \d \a \a)))
(defmacro CDDDAR [x] `(uaf ~x '(\d \d \d \a)))
(defmacro CDAAAR [x] `(uaf ~x '(\d \a \a \a)))
(defmacro CDADAR [x] `(uaf ~x '(\d \a \d \a)))
(defmacro CAAADR [x] `(uaf ~x '(\a \a \a \d)))
(defmacro CAADDR [x] `(uaf ~x '(\a \a \d \d)))
(defmacro CADADR [x] `(uaf ~x '(\a \d \a \d)))
(defmacro CADDDR [x] `(uaf ~x '(\a \d \d \d)))
(defmacro CDDADR [x] `(uaf ~x '(\d \d \a \d)))
(defmacro CDDDDR [x] `(uaf ~x '(\d \d \d \d)))
(defmacro CDAADR [x] `(uaf ~x '(\d \a \a \d)))
(defmacro CDADDR [x] `(uaf ~x '(\d \a \d \d)))
;;;; INTEROP feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn interop-interpret-q-name
"For interoperation with Clojure, it will often be necessary to pass
qualified names that are not representable in Lisp 1.5. This function
takes a sequence in the form `(PART PART PART... NAME)` and returns
a symbol in the form `PART.PART.PART/NAME`. This symbol will then be
tried in both that form and lower-cased. Names with hyphens or
underscores cannot be represented with this scheme."
[l]
(if
(seq? l)
(symbol
(s/reverse
(s/replace-first
(s/reverse
(s/join "." (map str l)))
"."
"/")))
l))
(defn to-beowulf
"Return a beowulf-native representation of the Clojure object `o`.
Numbers and symbols are unaffected. Collections have to be converted;
strings must be converted to symbols."
[o]
(cond
(coll? o) (make-beowulf-list o)
(string? o) (symbol (s/upper-case o))
:else o))
(defn to-clojure
"If l is a `beowulf.cons_cell.ConsCell`, return a Clojure list having the
same members in the same order."
[l]
(cond
(not (instance? beowulf.cons_cell.ConsCell l))
l
(= (CDR l) NIL)
(list (to-clojure (CAR l)))
:else
(conj (to-clojure (CDR l)) (to-clojure (CAR l)))))
(defn INTEROP
"Clojure (or other host environment) interoperation API. `fn-symbol` is expected
to be either
1. a symbol bound in the host environment to a function; or
2. a sequence (list) of symbols forming a qualified path name bound to a
function.
Lower case characters cannot normally be represented in Lisp 1.5, so both the
upper case and lower case variants of `fn-symbol` will be tried. If the
function you're looking for has a mixed case name, that is not currently
accessible.
`args` is expected to be a Lisp 1.5 list of arguments to be passed to that
function. Return value must be something acceptable to Lisp 1.5, so either
a symbol, a number, or a Lisp 1.5 list.
If `fn-symbol` is not found (even when cast to lower case), or is not a function,
or the value returned cannot be represented in Lisp 1.5, an exception is thrown
with `:cause` bound to `:interop` and `:detail` set to a value representing the
actual problem."
[fn-symbol args]
(if-not (:strict *options*)
(let
[q-name (if
(seq? fn-symbol)
(interop-interpret-q-name fn-symbol)
fn-symbol)
l-name (symbol (s/lower-case q-name))
f (cond
(try
(fn? (eval l-name))
(catch java.lang.ClassNotFoundException _ nil)) l-name
(try
(fn? (eval q-name))
(catch java.lang.ClassNotFoundException _ nil)) q-name
:else (throw
(ex-info
(str "INTEROP: unknown function `" fn-symbol "`")
{:cause :interop
:detail :not-found
:name fn-symbol
:also-tried l-name})))
args' (to-clojure args)]
(print (str "INTEROP: evaluating `" (cons f args') "`"))
(flush)
(let [result (eval (conj args' f))] ;; this has the potential to blow up the world
(println (str "; returning `" result "`"))
(cond
(instance? beowulf.cons_cell.ConsCell result) result
(coll? result) (make-beowulf-list result)
(symbol? result) result
(string? result) (symbol result)
(number? result) result
:else (throw
(ex-info
(str "INTEROP: Cannot return `" result "` to Lisp 1.5.")
{:cause :interop
:detail :not-representable
:result result})))))
(throw
(ex-info
(str "INTEROP not allowed in strict mode.")
{:cause :interop
:detail :strict}))))
(defn- traced-apply (defn- traced-apply
"Like `APPLY`, but with trace output to console." "Like `APPLY`, but with trace output to console."
[function-symbol args lisp-fn environment depth] [function-symbol args lisp-fn environment depth]
@ -247,47 +75,10 @@
environment environment
depth) depth)
(APPLY lisp-fn args environment depth)) (APPLY lisp-fn args environment depth))
(case function-symbol ;; there must be a better way of doing this! (if function-symbol
ADD1 (safe-apply ADD1 args) (let [f (GET function-symbol 'SUBR)]
AND (safe-apply AND args) (when f
APPLY (APPLY (first args) (rest args) environment depth) (apply @(resolve f) (to-clojure args))))
ATOM (ATOM? (CAR args))
CAR (safe-apply CAR args)
CDR (safe-apply CDR args)
CONS (safe-apply CONS args)
DEFINE (DEFINE (CAR args))
DIFFERENCE (DIFFERENCE (CAR args) (CADR args))
DOC (DOC (first args))
EQ (safe-apply EQ args)
EQUAL (safe-apply EQUAL args)
ERROR (safe-apply ERROR args)
;; think about EVAL. Getting the environment right is subtle
FIXP (safe-apply FIXP args)
GENSYM (GENSYM)
GREATERP (safe-apply GREATERP args)
INTEROP (when (lax? INTEROP) (safe-apply INTEROP args))
LESSP (safe-apply LESSP args)
LIST (safe-apply LIST args)
NUMBERP (safe-apply NUMBERP args)
OBLIST (OBLIST)
PLUS (safe-apply PLUS args)
PRETTY (when (lax? 'PRETTY)
(safe-apply pretty-print args))
PRINT (safe-apply print args)
QUOTIENT (safe-apply QUOTIENT args)
READ (READ)
REMAINDER (safe-apply REMAINDER args)
RPLACA (safe-apply RPLACA args)
RPLACD (safe-apply RPLACD args)
SET (safe-apply SET args)
SYSIN (when (lax? 'SYSIN)
(safe-apply SYSIN args))
SYSOUT (when (lax? 'SYSOUT)
(safe-apply SYSOUT args))
TERPRI (println)
TIMES (safe-apply TIMES args)
TRACE (safe-apply TRACE args)
UNTRACE (safe-apply UNTRACE args)
;; else ;; else
(ex-info "No function found" (ex-info "No function found"
{:context "APPLY" {:context "APPLY"
@ -309,7 +100,7 @@
{:context "APPLY" {:context "APPLY"
:function "NIL" :function "NIL"
:args args}))) :args args})))
(= (ATOM? function) T) (apply-symbolic function args environment (inc depth)) (= (ATOM function) T) (apply-symbolic function args environment (inc depth))
:else (case (first function) :else (case (first function)
LABEL (APPLY LABEL (APPLY
(CADDR function) (CADDR function)
@ -355,14 +146,13 @@
(EVAL (CAR args) env depth) (EVAL (CAR args) env depth)
(EVLIS (CDR args) env depth)))) (EVLIS (CDR args) env depth))))
(defn- eval-symbolic [^Symbol s env] ;; (defn- eval-symbolic [^Symbol s env]
(let [binding (ASSOC s env)] ;; (let [binding (ASSOC s env)]
(if (= binding NIL) ;; (if (= binding NIL)
(throw (ex-info (format "No binding for symbol `%s`" s) ;; (throw (ex-info (format "No binding for symbol `%s`" s)
{:phase :eval ;; {:phase :eval
:symbol s})) ;; :symbol s}))
(CDR binding)))) ;; (CDR binding))))
(defn EVAL (defn EVAL
"Evaluate this `expr` and return the result. If `environment` is not passed, "Evaluate this `expr` and return the result. If `environment` is not passed,
@ -376,7 +166,7 @@
([expr env depth] ([expr env depth]
(cond (cond
(= (NUMBERP expr) T) expr (= (NUMBERP expr) T) expr
(symbol? expr) (eval-symbolic expr env) (symbol? expr) (GET expr 'APVAL)
(string? expr) (if (:strict *options*) (string? expr) (if (:strict *options*)
(throw (throw
(ex-info (ex-info
@ -385,18 +175,16 @@
:detail :strict :detail :strict
:expr expr})) :expr expr}))
(symbol expr)) (symbol expr))
(= (= (ATOM (CAR expr)) T) (case (CAR expr)
(ATOM? (CAR expr)) QUOTE (CADR expr)
T) (case (CAR expr) FUNCTION (LIST 'FUNARG (CADR expr))
QUOTE (CADR expr) COND (EVCON (CDR expr) env depth)
FUNCTION (LIST 'FUNARG (CADR expr) )
COND (EVCON (CDR expr) env depth)
;; else ;; else
(APPLY (APPLY
(CAR expr) (CAR expr)
(EVLIS (CDR expr) env depth) (EVLIS (CDR expr) env depth)
env env
depth)) depth))
:else (APPLY :else (APPLY
(CAR expr) (CAR expr)
(EVLIS (CDR expr) env depth) (EVLIS (CDR expr) env depth)

12
src/beowulf/host.clj
View file

@ -424,9 +424,9 @@
(make-beowulf-list (map CAR @oblist)) (make-beowulf-list (map CAR @oblist))
NIL)) NIL))
(def ^:private magic-marker (def magic-marker
"The unexplained magic number which marks the start of a property list." "The unexplained magic number which marks the start of a property list."
(Integer/parseInt "777778" 8)) (Integer/parseInt "77777" 8))
(defn PUT (defn PUT
"Put this `value` as the value of the property indicated by this `indicator` "Put this `value` as the value of the property indicated by this `indicator`
@ -460,7 +460,13 @@
It's clear that `GET` is expected to be defined in terms of `PROP`, but It's clear that `GET` is expected to be defined in terms of `PROP`, but
we can't implement `PROP` here because we lack `EVAL`; and we can't have we can't implement `PROP` here because we lack `EVAL`; and we can't have
`EVAL` here because it depends on `GET`." `EVAL` here because both it and `APPLY` depends on `GET`.
OK, It's worse than that: the statement of the definition of `GET` (and
of) `PROP` on page 59 says that the first argument to each must be a list;
But the in the definition of `ASSOC` on page 70, when `GET` is called its
first argument is always an atom. Since it's `ASSOC` and `EVAL` which I
need to make work, I'm going to assume that page 59 is wrong."
[symbol indicator] [symbol indicator]
(let [binding (ASSOC symbol @oblist)] (let [binding (ASSOC symbol @oblist)]
(cond (cond

129
src/beowulf/interop.clj Normal file
View file

@ -0,0 +1,129 @@
(ns beowulf.interop
(:require [beowulf.cons-cell :refer [make-beowulf-list]]
[beowulf.host :refer [CAR CDR]]
[beowulf.oblist :refer [*options* NIL]]
[clojure.string :as s :refer [last-index-of lower-case split
upper-case]]))
;;;; INTEROP feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn listify-qualified-name
"We need to be able to print something we can link to the particular Clojure
function `subr` in a form in which Lisp 1.5 is able to read it back in and
relink it.
This assumes `subr` is either
1. a string in the format `#'beowulf.io/SYSIN` or `beowulf.io/SYSIN`; or
2. something which, when coerced to a string with `str`, will have such
a format."
[subr]
(make-beowulf-list
(map
#(symbol (upper-case %))
(remove empty? (split (str subr) #"[#'./]")))))
(defn interpret-qualified-name
"For interoperation with Clojure, it will often be necessary to pass
qualified names that are not representable in Lisp 1.5. This function
takes a sequence in the form `(PART PART PART... NAME)` and returns
a symbol in the form `part.part.part/NAME`. This symbol will then be
tried in both that form and lower-cased. Names with hyphens or
underscores cannot be represented with this scheme."
([l]
(symbol
(let [n (s/join "."
(concat (map #(lower-case (str %)) (butlast l))
(list (last l))))
s (last-index-of n ".")]
(if s
(str (subs n 0 s) "/" (subs n (inc s)))
n)))))
(defn to-beowulf
"Return a beowulf-native representation of the Clojure object `o`.
Numbers and symbols are unaffected. Collections have to be converted;
strings must be converted to symbols."
[o]
(cond
(coll? o) (make-beowulf-list o)
(string? o) (symbol (s/upper-case o))
:else o))
(defn to-clojure
"If l is a `beowulf.cons_cell.ConsCell`, return a Clojure list having the
same members in the same order."
[l]
(cond
(not (instance? beowulf.cons_cell.ConsCell l))
l
(= (CDR l) NIL)
(list (to-clojure (CAR l)))
:else
(conj (to-clojure (CDR l)) (to-clojure (CAR l)))))
(defn INTEROP
"Clojure (or other host environment) interoperation API. `fn-symbol` is expected
to be either
1. a symbol bound in the host environment to a function; or
2. a sequence (list) of symbols forming a qualified path name bound to a
function.
Lower case characters cannot normally be represented in Lisp 1.5, so both the
upper case and lower case variants of `fn-symbol` will be tried. If the
function you're looking for has a mixed case name, that is not currently
accessible.
`args` is expected to be a Lisp 1.5 list of arguments to be passed to that
function. Return value must be something acceptable to Lisp 1.5, so either
a symbol, a number, or a Lisp 1.5 list.
If `fn-symbol` is not found (even when cast to lower case), or is not a function,
or the value returned cannot be represented in Lisp 1.5, an exception is thrown
with `:cause` bound to `:interop` and `:detail` set to a value representing the
actual problem."
[fn-symbol args]
(if-not (:strict *options*)
(let
[q-name (if
(seq? fn-symbol)
(interpret-qualified-name fn-symbol)
fn-symbol)
l-name (symbol (s/lower-case q-name))
f (cond
(try
(fn? (eval l-name))
(catch java.lang.ClassNotFoundException _ nil)) l-name
(try
(fn? (eval q-name))
(catch java.lang.ClassNotFoundException _ nil)) q-name
:else (throw
(ex-info
(str "INTEROP: unknown function `" fn-symbol "`")
{:cause :interop
:detail :not-found
:name fn-symbol
:also-tried l-name})))
args' (to-clojure args)]
(print (str "INTEROP: evaluating `" (cons f args') "`"))
(flush)
(let [result (eval (conj args' f))] ;; this has the potential to blow up the world
(println (str "; returning `" result "`"))
(cond
(instance? beowulf.cons_cell.ConsCell result) result
(coll? result) (make-beowulf-list result)
(symbol? result) result
(string? result) (symbol result)
(number? result) result
:else (throw
(ex-info
(str "INTEROP: Cannot return `" result "` to Lisp 1.5.")
{:cause :interop
:detail :not-representable
:result result})))))
(throw
(ex-info
(str "INTEROP not allowed in strict mode.")
{:cause :interop
:detail :strict}))))

83
src/beowulf/io.clj
View file

@ -15,8 +15,12 @@
oblist with data from that file. oblist with data from that file.
Hence functions SYSOUT and SYSIN, which do just that." Hence functions SYSOUT and SYSIN, which do just that."
(:require [beowulf.cons-cell :refer [pretty-print]] (:require [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell
[beowulf.oblist :refer [*options* oblist]] pretty-print]]
[beowulf.host :refer [CADR CAR CDDR CDR]]
[beowulf.interop :refer [interpret-qualified-name
listify-qualified-name]]
[beowulf.oblist :refer [*options* NIL oblist]]
[beowulf.read :refer [READ]] [beowulf.read :refer [READ]]
[clojure.java.io :refer [file resource]] [clojure.java.io :refer [file resource]]
[clojure.string :refer [ends-with?]] [clojure.string :refer [ends-with?]]
@ -59,6 +63,24 @@
"" ""
".lsp"))) ".lsp")))
;; (find-var (symbol "beowulf.io/SYSIN"))
;; (@(resolve (symbol "beowulf.host/TIMES")) 2 2)
(defn safely-wrap-subr
[entry]
(cond (= entry NIL) NIL
(= (CAR entry) 'SUBR) (make-cons-cell
(CAR entry)
(make-cons-cell
(listify-qualified-name (CADR entry))
(CDDR entry)))
:else (make-cons-cell
(CAR entry) (safely-wrap-subr (CDR entry)))))
(defn safely-wrap-subrs
[objects]
(make-beowulf-list (map safely-wrap-subr objects)))
(defn SYSOUT (defn SYSOUT
"Dump the current content of the object list to file. If no `filepath` is "Dump the current content of the object list to file. If no `filepath` is
specified, a file name will be constructed of the symbol `Sysout` and specified, a file name will be constructed of the symbol `Sysout` and
@ -79,7 +101,38 @@
(println (format ";; generated by %s" (System/getenv "USER")))) (println (format ";; generated by %s" (System/getenv "USER"))))
(println (apply str (repeat 79 ";"))) (println (apply str (repeat 79 ";")))
(println) (println)
(pretty-print @oblist))))) (let [output (safely-wrap-subrs @oblist)]
(pretty-print output)
)))))
(defn- resolve-subr
"If this oblist `entry` references a subroutine, attempt to fix up that
reference."
[entry]
(cond (= entry NIL) NIL
(= (CAR entry) 'SUBR) (try
(make-cons-cell
(CAR entry)
(make-cons-cell
(interpret-qualified-name
(CADR entry))
(CDDR entry)))
(catch Exception _
(print "Warning: failed to resolve "
(CADR entry))
(CDDR entry)))
:else (make-cons-cell
(CAR entry) (resolve-subr (CDR entry)))))
(defn- resolve-subroutines
"Attempt to fix up the references to subroutines (Clojure functions) among
these `objects`, being new content for the object list."
[objects]
(make-beowulf-list
(map
resolve-subr
objects)))
(defn SYSIN (defn SYSIN
"Read the contents of the file at this `filename` into the object list. "Read the contents of the file at this `filename` into the object list.
@ -100,14 +153,16 @@
([] ([]
(SYSIN (or (:read *options*) default-sysout))) (SYSIN (or (:read *options*) default-sysout)))
([filename] ([filename]
(let [fp (file (full-path (str filename))) (let [fp (file (full-path (str filename)))
file (when (and (.exists fp) (.canRead fp)) fp) file (when (and (.exists fp) (.canRead fp)) fp)
res (try (resource filename) res (try (resource filename)
(catch Throwable _ nil)) (catch Throwable _ nil))
content (try (READ (slurp (or file res))) content (try (READ (slurp (or file res)))
(catch Throwable any (catch Throwable any
(throw (ex-info "Could not read from file" (throw (ex-info "Could not read from file"
{:context "SYSIN" {:context "SYSIN"
:filepath fp} :filepath fp}
any))))] any))))]
(swap! oblist #(when (or % (seq content)) content))))) (swap! oblist
#(when (or % (seq content))
(resolve-subroutines content))))))

3
test/beowulf/interop_test.clj
View file

@ -1,6 +1,7 @@
(ns beowulf.interop-test (ns beowulf.interop-test
(:require [clojure.test :refer [deftest is testing]] (:require [clojure.test :refer [deftest is testing]]
[beowulf.bootstrap :refer [EVAL INTEROP]] [beowulf.bootstrap :refer [EVAL]]
[beowulf.interop :refer [INTEROP]]
[beowulf.read :refer [gsp]])) [beowulf.read :refer [gsp]]))