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)

282
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
(X Y) (COND ((NULL X) Y) ((QUOTE T) (CONS (CAR X) (APPEND (CDR X) Y))))))
(APPLY 32767 SUBR (BEOWULF BOOTSTRAP APPLY))
(ASSOC
32767
EXPR
(LAMBDA
(X L)
(COND (COND
((NULL L) (QUOTE NIL)) ((NULL L) (QUOTE NIL))
((AND (CONSP (CAR L)) (EQ (CAAR L) X)) (CAR L)) ((AND (CONSP (CAR L)) (EQ (CAAR L) X)) (CAR L))
((QUOTE T) (ASSOC X (CDR L))))) ((QUOTE T) (ASSOC X (CDR L)))))
(ATOM) SUBR (BEOWULF HOST ASSOC))
(CAR) (ATOM 32767 SUBR (BEOWULF HOST ATOM))
(CAAAAR LAMBDA (X) (CAR (CAR (CAR (CAR X))))) (CAR 32767 SUBR (BEOWULF HOST CAR))
(CAAADR LAMBDA (X) (CAR (CAR (CAR (CDR X))))) (CAAAAR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR (CAR X))))))
(CAAAR LAMBDA (X) (CAR (CAR (CAR X)))) (CAAADR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR (CDR X))))))
(CAADAR LAMBDA (X) (CAR (CAR (CDR (CAR X))))) (CAAAR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR X)))))
(CAADDR LAMBDA (X) (CAR (CAR (CDR (CDR X))))) (CAADAR 32767 EXPR (LAMBDA (X) (CAR (CAR (CDR (CAR X))))))
(CAADR LAMBDA (X) (CAR (CAR (CDR X)))) (CAADDR 32767 EXPR (LAMBDA (X) (CAR (CAR (CDR (CDR X))))))
(CAAR LAMBDA (X) (CAR (CAR X))) (CAADR 32767 EXPR (LAMBDA (X) (CAR (CAR (CDR X)))))
(CADAAR LAMBDA (X) (CAR (CDR (CAR (CAR X))))) (CAAR 32767 EXPR (LAMBDA (X) (CAR (CAR X))))
(CADADR LAMBDA (X) (CAR (CDR (CAR (CDR X))))) (CADAAR 32767 EXPR (LAMBDA (X) (CAR (CDR (CAR (CAR X))))))
(CADAR LAMBDA (X) (CAR (CDR (CAR X)))) (CADADR 32767 EXPR (LAMBDA (X) (CAR (CDR (CAR (CDR X))))))
(CADDAR LAMBDA (X) (CAR (CDR (CDR (CAR X))))) (CADAR 32767 EXPR (LAMBDA (X) (CAR (CDR (CAR X)))))
(CADDDR LAMBDA (X) (CAR (CDR (CDR (CDR X))))) (CADDAR 32767 EXPR (LAMBDA (X) (CAR (CDR (CDR (CAR X))))))
(CADDR LAMBDA (X) (CAR (CDR (CDR X)))) (CADDDR 32767 EXPR (LAMBDA (X) (CAR (CDR (CDR (CDR X))))))
(CADR LAMBDA (X) (CAR (CDR X))) (CADDR 32767 EXPR (LAMBDA (X) (CAR (CDR (CDR X)))))
(CDAAAR LAMBDA (X) (CDR (CAR (CAR (CAR X))))) (CADR 32767 EXPR (LAMBDA (X) (CAR (CDR X))))
(CDAADR LAMBDA (X) (CDR (CAR (CAR (CDR X))))) (CDAAAR 32767 EXPR (LAMBDA (X) (CDR (CAR (CAR (CAR X))))))
(CDAAR LAMBDA (X) (CDR (CAR (CAR X)))) (CDAADR 32767 EXPR (LAMBDA (X) (CDR (CAR (CAR (CDR X))))))
(CDADAR LAMBDA (X) (CDR (CAR (CDR (CAR X))))) (CDAAR 32767 EXPR (LAMBDA (X) (CDR (CAR (CAR X)))))
(CDADDR LAMBDA (X) (CDR (CAR (CDR (CDR X))))) (CDADAR 32767 EXPR (LAMBDA (X) (CDR (CAR (CDR (CAR X))))))
(CDADR LAMBDA (X) (CDR (CAR (CDR X)))) (CDADDR 32767 EXPR (LAMBDA (X) (CDR (CAR (CDR (CDR X))))))
(CDAR LAMBDA (X) (CDR (CAR X))) (CDADR 32767 EXPR (LAMBDA (X) (CDR (CAR (CDR X)))))
(CDDAAR LAMBDA (X) (CDR (CDR (CAR (CAR X))))) (CDAR 32767 EXPR (LAMBDA (X) (CDR (CAR X))))
(CDDADR LAMBDA (X) (CDR (CDR (CAR (CDR X))))) (CDDAAR 32767 EXPR (LAMBDA (X) (CDR (CDR (CAR (CAR X))))))
(CDDAR LAMBDA (X) (CDR (CDR (CAR X)))) (CDDADR 32767 EXPR (LAMBDA (X) (CDR (CDR (CAR (CDR X))))))
(CDDDAR LAMBDA (X) (CDR (CDR (CDR (CAR X))))) (CDDAR 32767 EXPR (LAMBDA (X) (CDR (CDR (CAR X)))))
(CDDDDR LAMBDA (X) (CDR (CDR (CDR (CDR X))))) (CDDDAR 32767 EXPR (LAMBDA (X) (CDR (CDR (CDR (CAR X))))))
(CDDDR LAMBDA (X) (CDR (CDR (CDR X)))) (CDDDDR 32767 EXPR (LAMBDA (X) (CDR (CDR (CDR (CDR X))))))
(CDDR LAMBDA (X) (CDR (CDR X))) (CDDDR 32767 EXPR (LAMBDA (X) (CDR (CDR (CDR X)))))
(CDR) (CDDR 32767 EXPR (LAMBDA (X) (CDR (CDR X))))
(CONS) (CDR 32767 SUBR (BEOWULF HOST CDR))
(CONSP) (CONS 32767 SUBR (BEOWULF HOST CONS))
(CONSP 32767 SUBR (BEOWULF HOST CONSP))
(COPY (COPY
LAMBDA 32767
EXPR
(LAMBDA
(X) (X)
(COND (COND
((NULL X) (QUOTE NIL)) ((NULL X) (QUOTE NIL))
((ATOM X) X) ((QUOTE T) (CONS (COPY (CAR X)) (COPY (CDR X)))))) ((ATOM X) X) ((QUOTE T) (CONS (COPY (CAR X)) (COPY (CDR X)))))))
(DEFINE) (DEFINE 32767 SUBR (BEOWULF HOST DEFINE))
(DIFFERENCE) (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
EXPR
(LAMBDA
(X Y) (X Y)
(COND (COND
((NULL X) (QUOTE NIL)) ((NULL X) (QUOTE NIL))
((EQ (CAR X) Y) (CAR (CDR X))) ((QUOTE T) (GET (CDR X) Y)))) ((EQ (CAR X) Y) (CAR (CDR X))) ((QUOTE T) (GET (CDR X) Y))))
(GREATERP) SUBR (BEOWULF HOST GET))
(INTEROP) (GREATERP 32767 SUBR (BEOWULF HOST GREATERP))
(INTEROP 32767 SUBR (BEOWULF INTEROP INTEROP))
(INTERSECTION (INTERSECTION
LAMBDA 32767
EXPR
(LAMBDA
(X Y) (X Y)
(COND (COND
((NULL X) (QUOTE NIL)) ((NULL X) (QUOTE NIL))
((MEMBER (CAR X) Y) (CONS (CAR X) (INTERSECTION (CDR X) Y))) ((MEMBER (CAR X) Y) (CONS (CAR X) (INTERSECTION (CDR X) Y)))
((QUOTE T) (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
EXPR
(LAMBDA
(A X) (A X)
(COND (COND
((NULL X) (QUOTE F)) ((NULL X) (QUOTE F))
((EQ A (CAR X)) (QUOTE T)) ((QUOTE T) (MEMBER A (CDR X))))) ((EQ A (CAR X)) (QUOTE T)) ((QUOTE T) (MEMBER A (CDR X))))))
(MINUSP LAMBDA (X) (LESSP X 0)) (MINUSP 32767 EXPR (LAMBDA (X) (LESSP X 0)))
(NOT LAMBDA (X) (COND (X (QUOTE NIL)) ((QUOTE T) (QUOTE T)))) (NOT 32767 EXPR (LAMBDA (X) (COND (X (QUOTE NIL)) ((QUOTE T) (QUOTE T)))))
(NULL LAMBDA (X) (COND ((EQUAL X NIL) (QUOTE T)) (T (QUOTE F)))) (NULL
(NUMBERP) 32767 EXPR (LAMBDA (X) (COND ((EQUAL X NIL) (QUOTE T)) (T (QUOTE F)))))
(OBLIST) (NUMBERP 32767 SUBR (BEOWULF HOST NUMBERP))
(ONEP LAMBDA (X) (EQ X 1)) (OBLIST 32767 SUBR (BEOWULF HOST OBLIST))
(ONEP 32767 EXPR (LAMBDA (X) (EQ X 1)))
(PAIR (PAIR
LAMBDA 32767
EXPR
(LAMBDA
(X Y) (X Y)
(COND (COND
((AND (NULL X) (NULL Y)) NIL) ((AND (NULL X) (NULL Y)) NIL)
((NULL X) (ERROR (QUOTE F2))) ((NULL X) (ERROR (QUOTE F2)))
((NULL Y) (ERROR (QUOTE F3))) ((NULL Y) (ERROR (QUOTE F3)))
(T (CONS (CONS (CAR X) (CAR Y)) (PAIR (CDR X) (CDR Y)))))) (T (CONS (CONS (CAR X) (CAR Y)) (PAIR (CDR X) (CDR Y)))))))
(PAIRLIS LAMBDA (X Y A) (PAIRLIS
32767
EXPR
(LAMBDA
(X Y A)
(COND (COND
((NULL X) A) ((NULL X) A)
((QUOTE T) (CONS (CONS (CAR X) (CAR Y)) (PAIRLIS (CDR X) (CDR Y) A))))) ((QUOTE T) (CONS (CONS (CAR X) (CAR Y)) (PAIRLIS (CDR X) (CDR Y) A)))))
(PLUS) SUBR (BEOWULF HOST PAIRLIS))
(PRETTY) (PLUS 32767 SUBR (BEOWULF HOST PLUS))
(PRINT) (PRETTY 32767)
(PRINT 32767)
(PROP (PROP
LAMBDA 32767
EXPR
(LAMBDA
(X Y U) (X Y U)
(COND (COND
((NULL X) (U)) ((EQ (CAR X) Y) (CDR X)) ((QUOTE T) (PROP (CDR X) Y U)))) ((NULL X) (U))
(QUOTE LAMBDA (X) X) ((EQ (CAR X) Y) (CDR X)) ((QUOTE T) (PROP (CDR X) Y U)))))
(QUOTIENT) (QUOTE 32767 EXPR (LAMBDA (X) X))
(RANGE LAMBDA (N M) (COND ((LESSP M N) (QUOTE NIL)) ((QUOTE T) (CONS N (RANGE (ADD1 N) M))))) (QUOTIENT 32767 SUBR (BEOWULF HOST QUOTIENT))
(READ) (RANGE
(REMAINDER) 32767
(REPEAT EXPR
LAMBDA (N X) (COND ((EQ N 0) NIL) (T (CONS X (REPEAT (SUB1 N) X))))) (LAMBDA
(RPLACA) (N M)
(RPLACD)
(SET)
(SUB1 LAMBDA (N) (DIFFERENCE N 1))
(SUB2 LAMBDA (A Z)
(COND (COND
((NULL A) Z) ((LESSP M N) (QUOTE NIL)) ((QUOTE T) (CONS N (RANGE (ADD1 N) M))))))
((EQ (CAAR A) Z) (CDAR A)) (READ 32767 SUBR (BEOWULF READ READ))
((QUOTE T) (SUB2 (CDAR A) Z)))) (REMAINDER 32767 SUBR (BEOWULF HOST REMAINDER))
(SUBLIS LAMBDA (A Y) (COND ((ATOM Y) (SUB2 A Y)) ((QUOTE T) (CONS)))) (REPEAT
(SUBST LAMBDA (X Y Z) 32767
EXPR
(LAMBDA (N X) (COND ((EQ N 0) NIL) (T (CONS X (REPEAT (SUB1 N) X))))))
(RPLACA 32767 SUBR (BEOWULF HOST RPLACA))
(RPLACD 32767 SUBR (BEOWULF HOST RPLACD))
(SET 32767 SUBR (BEOWULF HOST SET))
(SUB1 32767 EXPR (LAMBDA (N) (DIFFERENCE N 1)) SUBR (BEOWULF HOST SUB1))
(SUB2
32767
EXPR
(LAMBDA
(A Z)
(COND
((NULL A) Z) ((EQ (CAAR A) Z) (CDAR A)) ((QUOTE T) (SUB2 (CDAR A) Z)))))
(SUBLIS
32767 EXPR (LAMBDA (A Y) (COND ((ATOM Y) (SUB2 A Y)) ((QUOTE T) (CONS)))))
(SUBST
32767
EXPR
(LAMBDA
(X Y Z)
(COND (COND
((EQUAL Y Z) X) ((EQUAL Y Z) X)
((ATOM Z) Z) ((ATOM Z) Z)
((QUOTE T) (CONS (SUBST X Y (CAR Z)) (SUBST X Y (CDR Z)))))) ((QUOTE T) (CONS (SUBST X Y (CAR Z)) (SUBST X Y (CDR Z)))))))
(SYSIN) (SYSIN 32767 SUBR (BEOWULF IO SYSIN))
(SYSOUT) (TERPRI) (TIMES) (TRACE) (SYSOUT 32767 SUBR (BEOWULF IO SYSOUT))
(UNION LAMBDA (X Y) (TERPRI 32767)
(TIMES 32767 SUBR (BEOWULF HOST TIMES))
(TRACE 32767 SUBR (BEOWULF HOST TRACE))
(UNION
32767
EXPR
(LAMBDA
(X Y)
(COND (COND
((NULL X) Y) ((NULL X) Y)
((MEMBER (CAR X) Y) (UNION (CDR X) Y)) ((MEMBER (CAR X) Y) (UNION (CDR X) Y))
(T (CONS (CAR X) (UNION (CDR X) Y))))) (T (CONS (CAR X) (UNION (CDR X) Y))))))
(UNTRACE) (UNTRACE 32767 SUBR (BEOWULF HOST UNTRACE))
(ZEROP LAMBDA (N) (EQ N 0))) (ZEROP 32767 EXPR (LAMBDA (N) (EQ N 0))))

252
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,11 +175,9 @@
:detail :strict :detail :strict
:expr expr})) :expr expr}))
(symbol expr)) (symbol expr))
(= (= (ATOM (CAR expr)) T) (case (CAR expr)
(ATOM? (CAR expr))
T) (case (CAR expr)
QUOTE (CADR expr) QUOTE (CADR expr)
FUNCTION (LIST 'FUNARG (CADR expr) ) FUNCTION (LIST 'FUNARG (CADR expr))
COND (EVCON (CDR expr) env depth) COND (EVCON (CDR expr) env depth)
;; else ;; else
(APPLY (APPLY

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}))))

63
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.
@ -110,4 +163,6 @@
{: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]]))