This isn't working, but it's very close.
This commit is contained in:
parent
b5afb1ad44
commit
5b5ddb9444
|
|
@ -4,4 +4,4 @@
|
|||
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)
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
((NIL)
|
||||
(T . T)
|
||||
(F)
|
||||
(ADD1)
|
||||
(AND)
|
||||
(APPEND LAMBDA
|
||||
(X Y) (COND ((NULL X) Y) ((QUOTE T) (CONS (CAR X) (APPEND (CDR X) Y)))))
|
||||
(APPLY)
|
||||
(ASSOC LAMBDA (X L)
|
||||
(COND
|
||||
((NULL L) (QUOTE NIL))
|
||||
((AND (CONSP (CAR L)) (EQ (CAAR L) X)) (CAR L))
|
||||
((QUOTE T) (ASSOC X (CDR L)))))
|
||||
(ATOM)
|
||||
(CAR)
|
||||
(CAAAAR LAMBDA (X) (CAR (CAR (CAR (CAR X)))))
|
||||
(CAAADR LAMBDA (X) (CAR (CAR (CAR (CDR X)))))
|
||||
(CAAAR LAMBDA (X) (CAR (CAR (CAR X))))
|
||||
(CAADAR LAMBDA (X) (CAR (CAR (CDR (CAR X)))))
|
||||
(CAADDR LAMBDA (X) (CAR (CAR (CDR (CDR X)))))
|
||||
(CAADR LAMBDA (X) (CAR (CAR (CDR X))))
|
||||
(CAAR LAMBDA (X) (CAR (CAR X)))
|
||||
(CADAAR LAMBDA (X) (CAR (CDR (CAR (CAR X)))))
|
||||
(CADADR LAMBDA (X) (CAR (CDR (CAR (CDR X)))))
|
||||
(CADAR LAMBDA (X) (CAR (CDR (CAR X))))
|
||||
(CADDAR LAMBDA (X) (CAR (CDR (CDR (CAR X)))))
|
||||
(CADDDR LAMBDA (X) (CAR (CDR (CDR (CDR X)))))
|
||||
(CADDR LAMBDA (X) (CAR (CDR (CDR X))))
|
||||
(CADR LAMBDA (X) (CAR (CDR X)))
|
||||
(CDAAAR LAMBDA (X) (CDR (CAR (CAR (CAR X)))))
|
||||
(CDAADR LAMBDA (X) (CDR (CAR (CAR (CDR X)))))
|
||||
(CDAAR LAMBDA (X) (CDR (CAR (CAR X))))
|
||||
(CDADAR LAMBDA (X) (CDR (CAR (CDR (CAR X)))))
|
||||
(CDADDR LAMBDA (X) (CDR (CAR (CDR (CDR X)))))
|
||||
(CDADR LAMBDA (X) (CDR (CAR (CDR X))))
|
||||
(CDAR LAMBDA (X) (CDR (CAR X)))
|
||||
(CDDAAR LAMBDA (X) (CDR (CDR (CAR (CAR X)))))
|
||||
(CDDADR LAMBDA (X) (CDR (CDR (CAR (CDR X)))))
|
||||
(CDDAR LAMBDA (X) (CDR (CDR (CAR X))))
|
||||
(CDDDAR LAMBDA (X) (CDR (CDR (CDR (CAR X)))))
|
||||
(CDDDDR LAMBDA (X) (CDR (CDR (CDR (CDR X)))))
|
||||
(CDDDR LAMBDA (X) (CDR (CDR (CDR X))))
|
||||
(CDDR LAMBDA (X) (CDR (CDR X)))
|
||||
(CDR)
|
||||
(CONS)
|
||||
(CONSP)
|
||||
((NIL 32767 APVAL NIL)
|
||||
(T 32767 APVAL T)
|
||||
(F 32767 APVAL NIL)
|
||||
(ADD1 32767 SUBR (BEOWULF HOST ADD1))
|
||||
(AND 32767 SUBR (BEOWULF HOST AND))
|
||||
(APPEND
|
||||
32767
|
||||
EXPR
|
||||
(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
|
||||
((NULL L) (QUOTE NIL))
|
||||
((AND (CONSP (CAR L)) (EQ (CAAR L) X)) (CAR L))
|
||||
((QUOTE T) (ASSOC X (CDR L)))))
|
||||
SUBR (BEOWULF HOST ASSOC))
|
||||
(ATOM 32767 SUBR (BEOWULF HOST ATOM))
|
||||
(CAR 32767 SUBR (BEOWULF HOST CAR))
|
||||
(CAAAAR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR (CAR X))))))
|
||||
(CAAADR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR (CDR X))))))
|
||||
(CAAAR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR X)))))
|
||||
(CAADAR 32767 EXPR (LAMBDA (X) (CAR (CAR (CDR (CAR X))))))
|
||||
(CAADDR 32767 EXPR (LAMBDA (X) (CAR (CAR (CDR (CDR X))))))
|
||||
(CAADR 32767 EXPR (LAMBDA (X) (CAR (CAR (CDR X)))))
|
||||
(CAAR 32767 EXPR (LAMBDA (X) (CAR (CAR X))))
|
||||
(CADAAR 32767 EXPR (LAMBDA (X) (CAR (CDR (CAR (CAR X))))))
|
||||
(CADADR 32767 EXPR (LAMBDA (X) (CAR (CDR (CAR (CDR X))))))
|
||||
(CADAR 32767 EXPR (LAMBDA (X) (CAR (CDR (CAR X)))))
|
||||
(CADDAR 32767 EXPR (LAMBDA (X) (CAR (CDR (CDR (CAR X))))))
|
||||
(CADDDR 32767 EXPR (LAMBDA (X) (CAR (CDR (CDR (CDR X))))))
|
||||
(CADDR 32767 EXPR (LAMBDA (X) (CAR (CDR (CDR X)))))
|
||||
(CADR 32767 EXPR (LAMBDA (X) (CAR (CDR X))))
|
||||
(CDAAAR 32767 EXPR (LAMBDA (X) (CDR (CAR (CAR (CAR X))))))
|
||||
(CDAADR 32767 EXPR (LAMBDA (X) (CDR (CAR (CAR (CDR X))))))
|
||||
(CDAAR 32767 EXPR (LAMBDA (X) (CDR (CAR (CAR X)))))
|
||||
(CDADAR 32767 EXPR (LAMBDA (X) (CDR (CAR (CDR (CAR X))))))
|
||||
(CDADDR 32767 EXPR (LAMBDA (X) (CDR (CAR (CDR (CDR X))))))
|
||||
(CDADR 32767 EXPR (LAMBDA (X) (CDR (CAR (CDR X)))))
|
||||
(CDAR 32767 EXPR (LAMBDA (X) (CDR (CAR X))))
|
||||
(CDDAAR 32767 EXPR (LAMBDA (X) (CDR (CDR (CAR (CAR X))))))
|
||||
(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
|
||||
LAMBDA
|
||||
(X)
|
||||
(COND
|
||||
((NULL X) (QUOTE NIL))
|
||||
((ATOM X) X) ((QUOTE T) (CONS (COPY (CAR X)) (COPY (CDR X))))))
|
||||
(DEFINE)
|
||||
(DIFFERENCE)
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA
|
||||
(X)
|
||||
(COND
|
||||
((NULL X) (QUOTE NIL))
|
||||
((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
|
||||
LAMBDA (X Y) (CONS (QUOTIENT X Y) (CONS (REMAINDER X Y) (QUOTE NIL))))
|
||||
(DOC)
|
||||
(EFFACE
|
||||
LAMBDA (X L) (COND ((NULL L) (QUOTE NIL))
|
||||
((EQUAL X (CAR L)) (CDR L))
|
||||
((QUOTE T) (RPLACD L (EFFACE X (CDR L))))))
|
||||
(ERROR)
|
||||
(EQ)
|
||||
(EQUAL)
|
||||
(EVAL)
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA (X Y) (CONS (QUOTIENT X Y) (CONS (REMAINDER X Y) (QUOTE NIL)))))
|
||||
(DOC 32767 SUBR (BEOWULF HOST DOC))
|
||||
(EFFACE
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA
|
||||
(X L)
|
||||
(COND
|
||||
((NULL L) (QUOTE NIL))
|
||||
((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
|
||||
LAMBDA (N) (COND ((EQ N 1) 1) (T (TIMES N (FACTORIAL (SUB1 N))))))
|
||||
(FIXP)
|
||||
(GENSYM)
|
||||
32767
|
||||
EXPR (LAMBDA (N) (COND ((EQ N 1) 1) (T (TIMES N (FACTORIAL (SUB1 N)))))))
|
||||
(FIXP 32767 SUBR (BEOWULF HOST FIXP))
|
||||
(GENSYM 32767 SUBR (BEOWULF HOST GENSYM))
|
||||
(GET
|
||||
LAMBDA
|
||||
(X Y)
|
||||
(COND
|
||||
((NULL X) (QUOTE NIL))
|
||||
((EQ (CAR X) Y) (CAR (CDR X))) ((QUOTE T) (GET (CDR X) Y))))
|
||||
(GREATERP)
|
||||
(INTEROP)
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA
|
||||
(X Y)
|
||||
(COND
|
||||
((NULL X) (QUOTE NIL))
|
||||
((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
|
||||
LAMBDA
|
||||
(X Y)
|
||||
(COND
|
||||
((NULL X) (QUOTE NIL))
|
||||
((MEMBER (CAR X) Y) (CONS (CAR X) (INTERSECTION (CDR X) Y)))
|
||||
((QUOTE T) (INTERSECTION (CDR X) Y))))
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA
|
||||
(X Y)
|
||||
(COND
|
||||
((NULL X) (QUOTE NIL))
|
||||
((MEMBER (CAR X) Y) (CONS (CAR X) (INTERSECTION (CDR X) Y)))
|
||||
((QUOTE T) (INTERSECTION (CDR X) Y)))))
|
||||
(LENGTH
|
||||
LAMBDA
|
||||
(L) (COND ((EQ NIL L) 0) ((CONSP (CDR L)) (ADD1 (LENGTH (CDR L)))) (T 0)))
|
||||
(LESSP)
|
||||
(MAPLIST LAMBDA (L F) (COND ((NULL L) NIL) ((QUOTE T) (CONS (F (CAR L)) (MAPLIST (CDR L) F)))))
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA
|
||||
(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
|
||||
LAMBDA
|
||||
(A X)
|
||||
(COND
|
||||
((NULL X) (QUOTE F))
|
||||
((EQ A (CAR X)) (QUOTE T)) ((QUOTE T) (MEMBER A (CDR X)))))
|
||||
(MINUSP LAMBDA (X) (LESSP X 0))
|
||||
(NOT LAMBDA (X) (COND (X (QUOTE NIL)) ((QUOTE T) (QUOTE T))))
|
||||
(NULL LAMBDA (X) (COND ((EQUAL X NIL) (QUOTE T)) (T (QUOTE F))))
|
||||
(NUMBERP)
|
||||
(OBLIST)
|
||||
(ONEP LAMBDA (X) (EQ X 1))
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA
|
||||
(A X)
|
||||
(COND
|
||||
((NULL X) (QUOTE F))
|
||||
((EQ A (CAR X)) (QUOTE T)) ((QUOTE T) (MEMBER A (CDR X))))))
|
||||
(MINUSP 32767 EXPR (LAMBDA (X) (LESSP X 0)))
|
||||
(NOT 32767 EXPR (LAMBDA (X) (COND (X (QUOTE NIL)) ((QUOTE T) (QUOTE T)))))
|
||||
(NULL
|
||||
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
|
||||
LAMBDA
|
||||
(X Y)
|
||||
(COND
|
||||
((AND (NULL X) (NULL Y)) NIL)
|
||||
((NULL X) (ERROR (QUOTE F2)))
|
||||
((NULL Y) (ERROR (QUOTE F3)))
|
||||
(T (CONS (CONS (CAR X) (CAR Y)) (PAIR (CDR X) (CDR Y))))))
|
||||
(PAIRLIS LAMBDA (X Y A)
|
||||
(COND
|
||||
((NULL X) A)
|
||||
((QUOTE T) (CONS (CONS (CAR X) (CAR Y)) (PAIRLIS (CDR X) (CDR Y) A)))))
|
||||
(PLUS)
|
||||
(PRETTY)
|
||||
(PRINT)
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA
|
||||
(X Y)
|
||||
(COND
|
||||
((AND (NULL X) (NULL Y)) NIL)
|
||||
((NULL X) (ERROR (QUOTE F2)))
|
||||
((NULL Y) (ERROR (QUOTE F3)))
|
||||
(T (CONS (CONS (CAR X) (CAR Y)) (PAIR (CDR X) (CDR Y)))))))
|
||||
(PAIRLIS
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA
|
||||
(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
|
||||
LAMBDA
|
||||
(X Y U)
|
||||
(COND
|
||||
((NULL X) (U)) ((EQ (CAR X) Y) (CDR X)) ((QUOTE T) (PROP (CDR X) Y U))))
|
||||
(QUOTE LAMBDA (X) X)
|
||||
(QUOTIENT)
|
||||
(RANGE LAMBDA (N M) (COND ((LESSP M N) (QUOTE NIL)) ((QUOTE T) (CONS N (RANGE (ADD1 N) M)))))
|
||||
(READ)
|
||||
(REMAINDER)
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA
|
||||
(X Y U)
|
||||
(COND
|
||||
((NULL X) (U))
|
||||
((EQ (CAR X) Y) (CDR X)) ((QUOTE T) (PROP (CDR X) Y U)))))
|
||||
(QUOTE 32767 EXPR (LAMBDA (X) X))
|
||||
(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
|
||||
LAMBDA (N X) (COND ((EQ N 0) NIL) (T (CONS X (REPEAT (SUB1 N) X)))))
|
||||
(RPLACA)
|
||||
(RPLACD)
|
||||
(SET)
|
||||
(SUB1 LAMBDA (N) (DIFFERENCE N 1))
|
||||
(SUB2 LAMBDA (A Z)
|
||||
(COND
|
||||
((NULL A) Z)
|
||||
((EQ (CAAR A) Z) (CDAR A))
|
||||
((QUOTE T) (SUB2 (CDAR A) Z))))
|
||||
(SUBLIS LAMBDA (A Y) (COND ((ATOM Y) (SUB2 A Y)) ((QUOTE T) (CONS))))
|
||||
(SUBST LAMBDA (X Y Z)
|
||||
(COND
|
||||
((EQUAL Y Z) X)
|
||||
((ATOM Z) Z)
|
||||
((QUOTE T) (CONS (SUBST X Y (CAR Z)) (SUBST X Y (CDR Z))))))
|
||||
(SYSIN)
|
||||
(SYSOUT) (TERPRI) (TIMES) (TRACE)
|
||||
(UNION LAMBDA (X Y)
|
||||
(COND
|
||||
((NULL X) Y)
|
||||
((MEMBER (CAR X) Y) (UNION (CDR X) Y))
|
||||
(T (CONS (CAR X) (UNION (CDR X) Y)))))
|
||||
(UNTRACE)
|
||||
(ZEROP LAMBDA (N) (EQ N 0)))
|
||||
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
|
||||
((EQUAL Y Z) X)
|
||||
((ATOM Z) Z)
|
||||
((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))))
|
||||
|
|
|
|||
|
|
@ -9,18 +9,11 @@
|
|||
ALLUPPERCASE are Lisp 1.5 functions (although written in Clojure) and that
|
||||
therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell`
|
||||
objects."
|
||||
(:require [clojure.string :as s]
|
||||
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell
|
||||
pretty-print T F]]
|
||||
[beowulf.host :refer [ADD1 AND ASSOC ATOM ATOM? CAR CDR CONS DEFINE
|
||||
DIFFERENCE DOC EQ EQUAL ERROR FIXP GENSYM
|
||||
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]])
|
||||
(:require [beowulf.cons-cell :refer [make-cons-cell T]]
|
||||
[beowulf.host :refer [ATOM CAAR CADAR CADDR CADR CAR CDR GET LIST
|
||||
NUMBERP PAIRLIS traced?]]
|
||||
[beowulf.interop :refer [to-clojure]]
|
||||
[beowulf.oblist :refer [*options* NIL oblist]])
|
||||
(:import [beowulf.cons_cell ConsCell]
|
||||
[clojure.lang Symbol]))
|
||||
|
||||
|
|
@ -51,171 +44,6 @@
|
|||
[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
|
||||
"Like `APPLY`, but with trace output to console."
|
||||
[function-symbol args lisp-fn environment depth]
|
||||
|
|
@ -247,47 +75,10 @@
|
|||
environment
|
||||
depth)
|
||||
(APPLY lisp-fn args environment depth))
|
||||
(case function-symbol ;; there must be a better way of doing this!
|
||||
ADD1 (safe-apply ADD1 args)
|
||||
AND (safe-apply AND args)
|
||||
APPLY (APPLY (first args) (rest args) environment depth)
|
||||
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)
|
||||
(if function-symbol
|
||||
(let [f (GET function-symbol 'SUBR)]
|
||||
(when f
|
||||
(apply @(resolve f) (to-clojure args))))
|
||||
;; else
|
||||
(ex-info "No function found"
|
||||
{:context "APPLY"
|
||||
|
|
@ -309,7 +100,7 @@
|
|||
{:context "APPLY"
|
||||
:function "NIL"
|
||||
: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)
|
||||
LABEL (APPLY
|
||||
(CADDR function)
|
||||
|
|
@ -355,14 +146,13 @@
|
|||
(EVAL (CAR args) env depth)
|
||||
(EVLIS (CDR args) env depth))))
|
||||
|
||||
(defn- eval-symbolic [^Symbol s env]
|
||||
(let [binding (ASSOC s env)]
|
||||
(if (= binding NIL)
|
||||
(throw (ex-info (format "No binding for symbol `%s`" s)
|
||||
{:phase :eval
|
||||
:symbol s}))
|
||||
(CDR binding))))
|
||||
|
||||
;; (defn- eval-symbolic [^Symbol s env]
|
||||
;; (let [binding (ASSOC s env)]
|
||||
;; (if (= binding NIL)
|
||||
;; (throw (ex-info (format "No binding for symbol `%s`" s)
|
||||
;; {:phase :eval
|
||||
;; :symbol s}))
|
||||
;; (CDR binding))))
|
||||
|
||||
(defn EVAL
|
||||
"Evaluate this `expr` and return the result. If `environment` is not passed,
|
||||
|
|
@ -376,7 +166,7 @@
|
|||
([expr env depth]
|
||||
(cond
|
||||
(= (NUMBERP expr) T) expr
|
||||
(symbol? expr) (eval-symbolic expr env)
|
||||
(symbol? expr) (GET expr 'APVAL)
|
||||
(string? expr) (if (:strict *options*)
|
||||
(throw
|
||||
(ex-info
|
||||
|
|
@ -385,18 +175,16 @@
|
|||
:detail :strict
|
||||
:expr expr}))
|
||||
(symbol expr))
|
||||
(=
|
||||
(ATOM? (CAR expr))
|
||||
T) (case (CAR expr)
|
||||
QUOTE (CADR expr)
|
||||
FUNCTION (LIST 'FUNARG (CADR expr) )
|
||||
COND (EVCON (CDR expr) env depth)
|
||||
(= (ATOM (CAR expr)) T) (case (CAR expr)
|
||||
QUOTE (CADR expr)
|
||||
FUNCTION (LIST 'FUNARG (CADR expr))
|
||||
COND (EVCON (CDR expr) env depth)
|
||||
;; else
|
||||
(APPLY
|
||||
(CAR expr)
|
||||
(EVLIS (CDR expr) env depth)
|
||||
env
|
||||
depth))
|
||||
(APPLY
|
||||
(CAR expr)
|
||||
(EVLIS (CDR expr) env depth)
|
||||
env
|
||||
depth))
|
||||
:else (APPLY
|
||||
(CAR expr)
|
||||
(EVLIS (CDR expr) env depth)
|
||||
|
|
|
|||
|
|
@ -424,9 +424,9 @@
|
|||
(make-beowulf-list (map CAR @oblist))
|
||||
NIL))
|
||||
|
||||
(def ^:private magic-marker
|
||||
(def magic-marker
|
||||
"The unexplained magic number which marks the start of a property list."
|
||||
(Integer/parseInt "777778" 8))
|
||||
(Integer/parseInt "77777" 8))
|
||||
|
||||
(defn PUT
|
||||
"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
|
||||
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]
|
||||
(let [binding (ASSOC symbol @oblist)]
|
||||
(cond
|
||||
|
|
|
|||
129
src/beowulf/interop.clj
Normal file
129
src/beowulf/interop.clj
Normal 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}))))
|
||||
|
|
@ -15,8 +15,12 @@
|
|||
oblist with data from that file.
|
||||
|
||||
Hence functions SYSOUT and SYSIN, which do just that."
|
||||
(:require [beowulf.cons-cell :refer [pretty-print]]
|
||||
[beowulf.oblist :refer [*options* oblist]]
|
||||
(:require [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell
|
||||
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]]
|
||||
[clojure.java.io :refer [file resource]]
|
||||
[clojure.string :refer [ends-with?]]
|
||||
|
|
@ -44,7 +48,7 @@
|
|||
|
||||
(def ^:constant default-sysout "resources/lisp1.5.lsp")
|
||||
|
||||
(defn- full-path
|
||||
(defn- full-path
|
||||
[fp]
|
||||
(str
|
||||
(if (:filepath *options*)
|
||||
|
|
@ -59,6 +63,24 @@
|
|||
""
|
||||
".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
|
||||
"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
|
||||
|
|
@ -79,7 +101,38 @@
|
|||
(println (format ";; generated by %s" (System/getenv "USER"))))
|
||||
(println (apply str (repeat 79 ";")))
|
||||
(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
|
||||
"Read the contents of the file at this `filename` into the object list.
|
||||
|
|
@ -100,14 +153,16 @@
|
|||
([]
|
||||
(SYSIN (or (:read *options*) default-sysout)))
|
||||
([filename]
|
||||
(let [fp (file (full-path (str filename)))
|
||||
file (when (and (.exists fp) (.canRead fp)) fp)
|
||||
res (try (resource filename)
|
||||
(catch Throwable _ nil))
|
||||
content (try (READ (slurp (or file res)))
|
||||
(catch Throwable any
|
||||
(throw (ex-info "Could not read from file"
|
||||
{:context "SYSIN"
|
||||
:filepath fp}
|
||||
any))))]
|
||||
(swap! oblist #(when (or % (seq content)) content)))))
|
||||
(let [fp (file (full-path (str filename)))
|
||||
file (when (and (.exists fp) (.canRead fp)) fp)
|
||||
res (try (resource filename)
|
||||
(catch Throwable _ nil))
|
||||
content (try (READ (slurp (or file res)))
|
||||
(catch Throwable any
|
||||
(throw (ex-info "Could not read from file"
|
||||
{:context "SYSIN"
|
||||
:filepath fp}
|
||||
any))))]
|
||||
(swap! oblist
|
||||
#(when (or % (seq content))
|
||||
(resolve-subroutines content))))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
(ns beowulf.interop-test
|
||||
(:require [clojure.test :refer [deftest is testing]]
|
||||
[beowulf.bootstrap :refer [EVAL INTEROP]]
|
||||
[beowulf.bootstrap :refer [EVAL]]
|
||||
[beowulf.interop :refer [INTEROP]]
|
||||
[beowulf.read :refer [gsp]]))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue