Merge branch 'feature/1' into develop
This commit is contained in:
commit
49aa58ea8a
7
doc/further_reading.md
Normal file
7
doc/further_reading.md
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
# Further Reading
|
||||
|
||||
1. [CODING for the MIT-IBM 704 COMPUTER, October 1957](http://bitsavers.org/pdf/mit/computer_center/Coding_for_the_MIT-IBM_704_Computer_Oct57.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)
|
||||
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)
|
||||
5. [Early LISP History (1956 - 1959), Herbert Stoyan, August 1984](https://dl.acm.org/doi/pdf/10.1145/800055.802047#page=3)
|
||||
1476
doc/lisp1.5.md
1476
doc/lisp1.5.md
File diff suppressed because it is too large
Load diff
|
|
@ -47,6 +47,22 @@ O14 (read lines O and 1)
|
|||
|
||||
Of course, this isn't proof. If `CAR` and `CDR` used here are standard IBM 704 assembler mnemonics -- as I believe they are -- then what is `CONS`? It's used in a syntactically identical way. If it also is an assembler mnemonic, then it's hard to believe that, as legend relates, it is short for 'construct'; on the other hand, if it's a label representing an entry point into a subroutine, then why should `CAR` and `CDR` not also be labels?
|
||||
|
||||
-----
|
||||
|
||||
**Edited 3<sup>rd</sup> April to add:** I've found a document, not related to Lisp (although John McCarthy is credited as one of the authors), which does confirm -- or strictly, amend -- the story. This is the [CODING for the MIT-IBM 704 COMPUTER](http://bitsavers.org/pdf/mit/computer_center/Coding_for_the_MIT-IBM_704_Computer_Oct57.pdf), dating from October 1957. The registers of the 704 were divided into four parts, named respectively the prefix part, the address part, the tag part, and the decrement part, of 3, 15, 3, and 15 bits respectively. The decrement part was not used in addressing; that part of the folklore I was taught isn't right. But the names are correct. Consider [this excerpt](http://bitsavers.org/pdf/mit/computer_center/Coding_for_the_MIT-IBM_704_Computer_Oct57.pdf#page=145) :
|
||||
|
||||
> The address, tag and decrement parts of symbolic instructions are given in that order. In some cases the decrement, tag or address parts are not necessary; therefore the following combinations where OP represents the instruction abbreviation are permissible.
|
||||
|
||||
This doesn't prove there were individual machine instructions with the mnemonics `CAR` and `CDR`; in fact, I'm going to say with some confidence that there were not, by reference to [the table of instructions](http://bitsavers.org/pdf/mit/computer_center/Coding_for_the_MIT-IBM_704_Computer_Oct57.pdf#page=170) appended to the same document. The instructions do have three letter mnemonics, and they do use 'A' and 'D' as abbreviations for 'address' and 'decrement' respectively, but `CAR` and `CDR` are not included.
|
||||
|
||||
So it seems probable that `CAR` and `CDR` were labels for subroutines, as I hypothesised above. But they were quite likely pre-existing subroutines, in use before the instantiation of the Lisp project, because they would be generally useful; and the suggestion that they are contractions of 'contents of the address part' and 'contents of the decrement part', respectively, seem confirmed.
|
||||
|
||||
And, going further down the rabbit hole, [there's this](https://dl.acm.org/doi/pdf/10.1145/800055.802047#page=3). In 1957, before work on the Lisp project started, McCarthy was writing functions to add list processing to the then-new FORTRAN language, on the very same IBM 704 machine.
|
||||
|
||||
> in this time any function that delivered integer values had to have a first letter X. Any function (as opposited to subroutines) had to have a last letter F in its name. Therefore the functions selecting parts of the IBM704 memory register (word) were introduced to be XCSRF, XCPRF, XCDRF, XCTRF and XCARF
|
||||
|
||||
-----
|
||||
|
||||
I think that the answer has to be that if `CAR` and `CDR` had been named by the early Lisp team -- John McCarthy and his immediate colleagues -- they would not have been named as they were. If not `FRST` and `REST`, as in more modern Lisps, then something like `P1` and `P2`. `CAR` and `CDR` are distinctive and memorable (and therefore in my opinion worth preserving) because they very specifically name the parts of a cons cell and of nothing else.
|
||||
|
||||
Let's be clear, here: when `CAR` and `CDR` are used in Lisp, they are returning pointers, certainly -- but not in the sense that one points to a page and the other to a word. Each is an offset into a cell array, which is almost certainly an array of single 36 bit words held on a single page. So both are in effect being used as decrements. Their use in Lisp is an overload onto their original semantic meaning; they are no longer being used for the purpose for which they are named.
|
||||
|
|
@ -262,6 +278,49 @@ Lisp 1.5 doesn't have `PUT`, `PUTPROP` or `DEFUN` because setting properties ind
|
|||
|
||||
-----
|
||||
|
||||
## Deeper delving
|
||||
|
||||
After writing, and publishing, this essay, I went on procrastinating, which is what I do when I'm sure I'm missing something; and to procrastinate, I went on reading the earliest design documents of Lisp I could find. And so I came across the MIT AI team's first ever memo, written by John McCarthy in September 1958. And in that, I find this:
|
||||
|
||||
> 3.2.1. First we have those that extract parts of a 704 word and form a word from parts. We shall distinguish the following parts of a word and indicate each of them by a characteristic letter.
|
||||
>
|
||||
> | Letter | Description |
|
||||
> | ---- | ---------------------------- |
|
||||
> | w | the whole word |
|
||||
> | p | the prefix (bits s, 1, 2) |
|
||||
> | i | the indicator (bits 1 and 2) |
|
||||
> | s | the sign bit |
|
||||
> | d | the decrement (bits 3-17) |
|
||||
> | t | the tag (bits 18-20) |
|
||||
> | a | the address (bits 21-35) |
|
||||
|
||||
In the discussion of functions which access properties on [page 58 of the Lisp 1.5 programmer's manual](https://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf#page=66), the word 'indicator' is used in preference to 'symbol' for the name of a property: for example
|
||||
|
||||
> The function `deflist` is a more general defining function. Its first argument is a list of pairs as for define. Its second argument is the *indicator* that is to be used. After `deflist` has been executed with (u<sub>i</sub> v<sub>i</sub>) among its first argument, the property list of u<sub>i</sub> will begin:
|
||||
>
|
||||
> If `deflist` or `define` is used twice on the same object with the same *indicator*, the old value will be replaced by the new one.
|
||||
|
||||
(my emphasis).
|
||||
|
||||
That use of 'indicator' has been nagging at me for a week. It looks like a term of art. If it's just an ordinary atomic symbol, why isn't it called a symbol?
|
||||
|
||||
Is it an indicator in the special sense of the indicator part of the machine word? If it were, then the property list could just be a flat list of values. And what's been worrying and surprising me is that property lists are shown in the manual as flat lists. Eureka? I don't *think* so.
|
||||
|
||||
The reason I don't think so is that there are only two bits in the indicator part of the word, so only four distinct values; whereas we know that Lisp 1.5 has (at least) five distinct indicator values, `APVAL`, `EXPR`, `FEXPR`, `SUBR` and `FSUBR`.
|
||||
|
||||
Furthermore, on [page 39](https://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf#page=47), we have:
|
||||
|
||||
> A property list is characterized by having the special constant 77777<sub>8</sub> (i. e., minus 1)
|
||||
> as the first element of the list. The rest of the list contains various properties of the
|
||||
> atomic symbol. Each property is preceded by an *atomic symbol* which is called its
|
||||
> *indicator*.
|
||||
|
||||
(again, my emphasis)
|
||||
|
||||
But I'm going to hypothesise that the properties were originally intended to be discriminated by the indicator bits in the cons cell, that they were originally coded that way, and that there was some code which depended on property lists being flat lists; and that, when it was discovered that four indicators were not enough and that something else was going to have to be used, the new format of the property list using atomic symbols as indicators was bodged in.
|
||||
|
||||
-----
|
||||
|
||||
So what this is about is I've spent most of a whole day procrastinating, because I'm not exactly sure how I'm going to make the change I've got to make. Versions of Beowulf up to and including 0.2.1 used the naive understanding of the architecture; version 0.3.0 *should* use the corrected version. But before it can, I need to be reasonably confident that I understand what the correct solution is.
|
||||
|
||||
I *shall* implement `PUT`, even though it isn't in the spec, because it's a useful building block on which to build `DEFINE` and `DEFLIS`, both of which are. And also, because `PUT` would have been very easy for the Lisp 1.5 implementers to implement, if it had been relevant to their working environment.
|
||||
I *shall* implement `PUT`, even though it isn't in the spec, because it's a useful building block on which to build `DEFINE` and `DEFLIS`, both of which are. And also, because `PUT` would have been very easy for the Lisp 1.5 implementers to implement, if it had been relevant to their working environment. And I shall implement property list as flat lists of interleaved 'indicator' symbols and values, even with that nonsense 77777<sub>8</sub> as a prefix, because now I know (or think I know) that it was a bodge, it seems right in the spirit of historical reconstruction to reconstruct the bodge.
|
||||
|
|
|
|||
1
docs/index.html
Symbolic link
1
docs/index.html
Symbolic link
|
|
@ -0,0 +1 @@
|
|||
codox/intro.html
|
||||
|
|
@ -1,150 +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) (T (CONS (CAR X) (APPEND (CDR X) Y))))))
|
||||
(APPLY 32767 SUBR (BEOWULF BOOTSTRAP APPLY))
|
||||
(ASSOC
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA
|
||||
(X L)
|
||||
(COND
|
||||
((NULL L) NIL)
|
||||
((AND (CONSP (CAR L)) (EQ (CAAR L) X)) (CAR L))
|
||||
(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) NIL)
|
||||
((ATOM X) X) (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)
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA (X Y) (CONS (QUOTIENT X Y) (CONS (REMAINDER X Y) NIL))))
|
||||
(DOC 32767 SUBR (BEOWULF HOST 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 L)
|
||||
(COND
|
||||
((NULL L) NIL)
|
||||
((EQUAL X (CAR L)) (CDR L)) (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) NIL)
|
||||
((EQ (CAR X) Y) (CAR (CDR X))) (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) NIL)
|
||||
((MEMBER (CAR X) Y) (CONS (CAR X) (INTERSECTION (CDR X) Y)))
|
||||
(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) (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)) T) (T (MEMBER A (CDR X))))))
|
||||
(MINUSP 32767 EXPR (LAMBDA (X) (LESSP X 0)))
|
||||
(NOT 32767 EXPR (LAMBDA (X) (COND (X NIL) (T T))))
|
||||
(NULL
|
||||
32767 EXPR (LAMBDA (X) (COND ((EQUAL X NIL) 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)
|
||||
(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)) (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) NIL) (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) (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)) (T (SUB2 (CDAR A) Z)))))
|
||||
(SUBLIS
|
||||
32767 EXPR (LAMBDA (A Y) (COND ((ATOM Y) (SUB2 A Y)) (T (CONS)))))
|
||||
(SUBST
|
||||
32767
|
||||
EXPR
|
||||
(LAMBDA
|
||||
(X Y Z)
|
||||
(COND
|
||||
((EQUAL Y Z) X)
|
||||
((ATOM Z) Z)
|
||||
(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))))
|
||||
|
|
|
|||
0
resources/mexpr/properties.mexpr.lsp
Normal file
0
resources/mexpr/properties.mexpr.lsp
Normal file
|
|
@ -9,18 +9,10 @@
|
|||
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-beowulf-list make-cons-cell T]]
|
||||
[beowulf.host :refer [ASSOC ATOM CAAR CADAR CADDR CADR CAR CDR GET
|
||||
LIST NUMBERP PAIRLIS traced?]]
|
||||
[beowulf.oblist :refer [*options* NIL oblist]])
|
||||
(:import [beowulf.cons_cell ConsCell]
|
||||
[clojure.lang Symbol]))
|
||||
|
||||
|
|
@ -46,253 +38,67 @@
|
|||
|
||||
(declare APPLY EVAL)
|
||||
|
||||
(defmacro QUOTE
|
||||
"Quote, but in upper case for LISP 1.5"
|
||||
[f]
|
||||
`(quote ~f))
|
||||
(defn try-resolve-subroutine
|
||||
"Attempt to resolve this `subr` with these `arg`."
|
||||
[subr args]
|
||||
(when (and subr (not= subr NIL))
|
||||
(try @(resolve subr)
|
||||
(catch Throwable any
|
||||
(throw (ex-info "Failed to resolve subroutine"
|
||||
{:phase :apply
|
||||
:function subr
|
||||
:args args
|
||||
:type :beowulf}
|
||||
any))))))
|
||||
|
||||
(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}))))))
|
||||
(defn- trace-call
|
||||
"Show a trace of a call to the function named by this `function-symbol`
|
||||
with these `args` at this depth."
|
||||
[function-symbol args depth]
|
||||
(when (traced? function-symbol)
|
||||
(let [indent (apply str (repeat depth "-"))]
|
||||
(println (str indent "> " function-symbol " " args)))))
|
||||
|
||||
(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)))
|
||||
(defn- trace-response
|
||||
"Show a trace of this `response` from the function named by this
|
||||
`function-symbol` at this depth."
|
||||
[function-symbol response depth]
|
||||
(when (traced? function-symbol)
|
||||
(let [indent (apply str (repeat depth "-"))]
|
||||
(println (str "<" indent " " function-symbol " " response))))
|
||||
response)
|
||||
|
||||
(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]
|
||||
(let [indent (apply str (repeat depth "-"))]
|
||||
(println (str indent "> " function-symbol " " args))
|
||||
(let [r (APPLY lisp-fn args environment depth)]
|
||||
(println (str "<" indent " " r))
|
||||
r)))
|
||||
|
||||
(defn- safe-apply
|
||||
"We've a real problem with varargs functions when `args` is `NIL`, because
|
||||
Clojure does not see `NIL` as an empty sequence."
|
||||
[clj-fn args]
|
||||
(let [args' (when (instance? ConsCell args) args)]
|
||||
(apply clj-fn args')))
|
||||
(defn- value
|
||||
"Seek a value for this symbol `s` by checking each of these indicators in
|
||||
turn."
|
||||
([s]
|
||||
(value s (list 'APVAL 'EXPR 'FEXPR 'SUBR 'FSUBR)))
|
||||
([s indicators]
|
||||
(when (symbol? s)
|
||||
(first (remove #(= % NIL) (map #(GET s %)
|
||||
indicators))))))
|
||||
|
||||
(defn- apply-symbolic
|
||||
"Apply this `funtion-symbol` to these `args` in this `environment` and
|
||||
return the result."
|
||||
[^Symbol function-symbol args ^ConsCell environment depth]
|
||||
(let [lisp-fn (try (EVAL function-symbol environment depth)
|
||||
(catch Throwable any (when (:trace *options*)
|
||||
(println any))))]
|
||||
(if (and lisp-fn
|
||||
(not= lisp-fn NIL)) (if (traced? function-symbol)
|
||||
(traced-apply function-symbol
|
||||
args
|
||||
lisp-fn
|
||||
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)
|
||||
;; else
|
||||
(ex-info "No function found"
|
||||
{:context "APPLY"
|
||||
:function function-symbol
|
||||
:args args})))))
|
||||
(trace-call function-symbol args depth)
|
||||
(let [lisp-fn ;; (try
|
||||
(value function-symbol '(EXPR FEXPR))
|
||||
;; (catch Exception any (when (traced? function-symbol)
|
||||
;; (println any))))
|
||||
subr (value function-symbol '(SUBR FSUBR))
|
||||
host-fn (try-resolve-subroutine subr args)
|
||||
result (cond (and lisp-fn
|
||||
(not= lisp-fn NIL)) (APPLY lisp-fn args environment depth)
|
||||
host-fn (apply host-fn (when (instance? ConsCell args) args))
|
||||
:else (ex-info "No function found"
|
||||
{:phase :apply
|
||||
:function function-symbol
|
||||
:args args
|
||||
:type :beowulf}))]
|
||||
(trace-response function-symbol result depth)
|
||||
result))
|
||||
|
||||
(defn APPLY
|
||||
"Apply this `function` to these `arguments` in this `environment` and return
|
||||
|
|
@ -302,33 +108,37 @@
|
|||
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
|
||||
See page 13 of the Lisp 1.5 Programmers Manual."
|
||||
[function args environment depth]
|
||||
(cond
|
||||
(= NIL function) (if (:strict *options*)
|
||||
NIL
|
||||
(throw (ex-info "NIL is not a function"
|
||||
{:context "APPLY"
|
||||
:function "NIL"
|
||||
:args args})))
|
||||
(= (ATOM? function) T) (apply-symbolic function args environment (inc depth))
|
||||
:else (case (first function)
|
||||
LABEL (APPLY
|
||||
(CADDR function)
|
||||
args
|
||||
(make-cons-cell
|
||||
(make-cons-cell
|
||||
(CADR function)
|
||||
(CADDR function))
|
||||
environment)
|
||||
depth)
|
||||
FUNARG (APPLY (CADR function) args (CADDR function) depth)
|
||||
LAMBDA (EVAL
|
||||
(CADDR function)
|
||||
(PAIRLIS (CADR function) args environment) depth)
|
||||
(throw (ex-info "Unrecognised value in function position"
|
||||
{:phase :apply
|
||||
:function function
|
||||
:args args
|
||||
:type :beowulf})))))
|
||||
(trace-call 'APPLY (list function args environment) depth)
|
||||
(let [result (cond
|
||||
(= NIL function) (if (:strict *options*)
|
||||
NIL
|
||||
(throw (ex-info "NIL is not a function"
|
||||
{:phase :apply
|
||||
:function "NIL"
|
||||
:args args
|
||||
:type :beowulf})))
|
||||
(= (ATOM function) T) (apply-symbolic function args environment (inc depth))
|
||||
:else (case (first function)
|
||||
LABEL (APPLY
|
||||
(CADDR function)
|
||||
args
|
||||
(make-cons-cell
|
||||
(make-cons-cell
|
||||
(CADR function)
|
||||
(CADDR function))
|
||||
environment)
|
||||
depth)
|
||||
FUNARG (APPLY (CADR function) args (CADDR function) depth)
|
||||
LAMBDA (EVAL
|
||||
(CADDR function)
|
||||
(PAIRLIS (CADR function) args environment) depth)
|
||||
(throw (ex-info "Unrecognised value in function position"
|
||||
{:phase :apply
|
||||
:function function
|
||||
:args args
|
||||
:type :beowulf}))))]
|
||||
(trace-response 'APPLY result depth)
|
||||
result))
|
||||
|
||||
(defn- EVCON
|
||||
"Inner guts of primitive COND. All `clauses` are assumed to be
|
||||
|
|
@ -355,14 +165,25 @@
|
|||
(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
|
||||
[expr env depth]
|
||||
(let [v (value expr (list 'APVAL))
|
||||
indent (apply str (repeat depth "-"))]
|
||||
(when (traced? 'EVAL)
|
||||
(println (str indent ": EVAL: deep binding (" expr " . " (or v "nil") ")")))
|
||||
(if (and v (not= v NIL))
|
||||
v
|
||||
(let [v' (ASSOC expr env)]
|
||||
(when (traced? 'EVAL)
|
||||
(println (str indent ": EVAL: shallow binding: " (or v' "nil"))))
|
||||
(if (and v' (not= v' NIL))
|
||||
(.getCdr v')
|
||||
(throw (ex-info "No binding for symbol found"
|
||||
{:phase :eval
|
||||
:function 'EVAL
|
||||
:args (list expr env depth)
|
||||
:type :lisp
|
||||
:code :A8})))))))
|
||||
|
||||
(defn EVAL
|
||||
"Evaluate this `expr` and return the result. If `environment` is not passed,
|
||||
|
|
@ -370,36 +191,43 @@
|
|||
argument is part of the tracing system and should not be set by user code.
|
||||
|
||||
All args are assumed to be numbers, symbols or `beowulf.cons-cell/ConsCell`
|
||||
objects."
|
||||
objects. However, if called with just a single arg, `expr`, I'll assume it's
|
||||
being called from the Clojure REPL and will coerce the `expr` to `ConsCell`."
|
||||
([expr]
|
||||
(EVAL expr @oblist 0))
|
||||
(let [expr' (if (and (coll? expr) (not (instance? ConsCell expr)))
|
||||
(make-beowulf-list expr)
|
||||
expr)]
|
||||
(EVAL expr' @oblist 0)))
|
||||
([expr env depth]
|
||||
(cond
|
||||
(= (NUMBERP expr) T) expr
|
||||
(symbol? expr) (eval-symbolic expr env)
|
||||
(string? expr) (if (:strict *options*)
|
||||
(throw
|
||||
(ex-info
|
||||
(str "EVAL: strings not allowed in strict mode: \"" expr "\"")
|
||||
{:phase :eval
|
||||
: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)
|
||||
(trace-call 'EVAL (list expr env depth) depth)
|
||||
(let [result (cond
|
||||
(= NIL expr) NIL ;; it was probably a mistake to make Lisp
|
||||
;; NIL distinct from Clojure nil
|
||||
(= (NUMBERP expr) T) expr
|
||||
(symbol? expr) (eval-symbolic expr env depth)
|
||||
(string? expr) (if (:strict *options*)
|
||||
(throw
|
||||
(ex-info
|
||||
(str "EVAL: strings not allowed in strict mode: \"" expr "\"")
|
||||
{:phase :eval
|
||||
: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)
|
||||
;; else
|
||||
(APPLY
|
||||
(CAR expr)
|
||||
(EVLIS (CDR expr) env depth)
|
||||
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)
|
||||
env
|
||||
depth))]
|
||||
(trace-response 'EVAL result depth)
|
||||
result)))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
"Essentially, the `-main` function and the bootstrap read-eval-print loop."
|
||||
(:require [beowulf.bootstrap :refer [EVAL]]
|
||||
[beowulf.io :refer [default-sysout SYSIN]]
|
||||
[beowulf.oblist :refer [*options* NIL]]
|
||||
[beowulf.read :refer [READ read-from-console]]
|
||||
[beowulf.oblist :refer [*options* oblist]]
|
||||
[clojure.java.io :as io]
|
||||
[clojure.pprint :refer [pprint]]
|
||||
[clojure.string :refer [trim]]
|
||||
|
|
@ -55,7 +55,7 @@
|
|||
(defn- re
|
||||
"Like REPL, but it isn't a loop and doesn't print."
|
||||
[input]
|
||||
(EVAL (READ input) @oblist 0))
|
||||
(EVAL (READ input) NIL 0))
|
||||
|
||||
(defn repl
|
||||
"Read/eval/print loop."
|
||||
|
|
|
|||
|
|
@ -2,14 +2,12 @@
|
|||
"provides Lisp 1.5 functions which can't be (or can't efficiently
|
||||
be) implemented in Lisp 1.5, which therefore need to be implemented in the
|
||||
host language, in this case Clojure."
|
||||
(:require [clojure.string :refer [upper-case]]
|
||||
[beowulf.cons-cell :refer [F make-cons-cell make-beowulf-list
|
||||
pretty-print T]]
|
||||
;; note hyphen - this is Clojure...
|
||||
(:require [beowulf.cons-cell :refer [F make-beowulf-list make-cons-cell T]] ;; note hyphen - this is Clojure...
|
||||
[beowulf.gendoc :refer [open-doc]]
|
||||
[beowulf.oblist :refer [*options* oblist NIL]])
|
||||
(:import [beowulf.cons_cell ConsCell]
|
||||
;; note underscore - same namespace, but Java.
|
||||
[beowulf.oblist :refer [*options* NIL oblist]]
|
||||
[clojure.set :refer [union]]
|
||||
[clojure.string :refer [upper-case]])
|
||||
(:import [beowulf.cons_cell ConsCell] ;; note underscore - same namespace, but Java.
|
||||
))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -164,17 +162,32 @@
|
|||
(number? value)
|
||||
(symbol? value)
|
||||
(= value NIL))
|
||||
(do
|
||||
(try
|
||||
(.rplaca cell value)
|
||||
cell)
|
||||
cell
|
||||
(catch Throwable any
|
||||
(throw (ex-info
|
||||
(str (.getMessage any) " in RPLACA: `")
|
||||
{:cause :upstream-error
|
||||
:phase :host
|
||||
:function :rplaca
|
||||
:args (list cell value)
|
||||
:type :beowulf}
|
||||
any))))
|
||||
(throw (ex-info
|
||||
(str "Invalid value in RPLACA: `" value "` (" (type value) ")")
|
||||
{:cause :bad-value
|
||||
:detail :rplaca})))
|
||||
:phase :host
|
||||
:function :rplaca
|
||||
:args (list cell value)
|
||||
:type :beowulf})))
|
||||
(throw (ex-info
|
||||
(str "Invalid cell in RPLACA: `" cell "` (" (type cell) ")")
|
||||
{:cause :bad-value
|
||||
:detail :rplaca}))))
|
||||
{:cause :bad-cell
|
||||
:phase :host
|
||||
:function :rplaca
|
||||
:args (list cell value)
|
||||
:type :beowulf}))))
|
||||
|
||||
(defn RPLACD
|
||||
"Replace the CDR pointer of this `cell` with this `value`. Dangerous, should
|
||||
|
|
@ -189,17 +202,32 @@
|
|||
(number? value)
|
||||
(symbol? value)
|
||||
(= value NIL))
|
||||
(do
|
||||
(try
|
||||
(.rplacd cell value)
|
||||
cell)
|
||||
cell
|
||||
(catch Throwable any
|
||||
(throw (ex-info
|
||||
(str (.getMessage any) " in RPLACD: `")
|
||||
{:cause :upstream-error
|
||||
:phase :host
|
||||
:function :rplacd
|
||||
:args (list cell value)
|
||||
:type :beowulf}
|
||||
any))))
|
||||
(throw (ex-info
|
||||
(str "Invalid value in RPLACD: `" value "` (" (type value) ")")
|
||||
{:cause :bad-value
|
||||
:detail :rplaca})))
|
||||
:phase :host
|
||||
:function :rplacd
|
||||
:args (list cell value)
|
||||
:type :beowulf})))
|
||||
(throw (ex-info
|
||||
(str "Invalid cell in RPLACD: `" cell "` (" (type cell) ")")
|
||||
{:cause :bad-value
|
||||
:detail :rplaca}))));; PLUS
|
||||
{:cause :bad-cell
|
||||
:phase :host
|
||||
:detail :rplacd
|
||||
:args (list cell value)
|
||||
:type :beowulf}))));; PLUS
|
||||
|
||||
(defn LIST
|
||||
[& args]
|
||||
|
|
@ -260,9 +288,20 @@
|
|||
In `beowulf.host` principally because I don't yet feel confident to define
|
||||
varargs functions in Lisp."
|
||||
[& args]
|
||||
(if (empty? (filter #(or (= 'F %) (= NIL %) (nil? %)) args))
|
||||
'T
|
||||
'F))
|
||||
(cond (= NIL args) T
|
||||
(not (#{NIL F} (.getCar args))) (AND (.getCdr args))
|
||||
:else T))
|
||||
|
||||
(defn OR
|
||||
"`T` if and only if at least one of my `args` evaluates to something other
|
||||
than either `F` or `NIL`, else `F`.
|
||||
|
||||
In `beowulf.host` principally because I don't yet feel confident to define
|
||||
varargs functions in Lisp."
|
||||
[& args]
|
||||
(cond (= NIL args) F
|
||||
(not (#{NIL F} (.getCar args))) T
|
||||
:else (OR (.getCdr args))))
|
||||
|
||||
;;;; Operations on lists ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
@ -394,38 +433,87 @@
|
|||
(make-beowulf-list (map CAR @oblist))
|
||||
NIL))
|
||||
|
||||
(def magic-marker
|
||||
"The unexplained magic number which marks the start of a property list."
|
||||
(Integer/parseInt "77777" 8))
|
||||
|
||||
(defn PUT
|
||||
"Put this `value` as the value of the property indicated by this `indicator`
|
||||
of this `symbol`. Return `value` on success.
|
||||
|
||||
NOTE THAT there is no `PUT` defined in the manual, but it would have been
|
||||
easy to have defined it so I don't think this fully counts as an extension."
|
||||
[symbol indicator value]
|
||||
(if-let [binding (ASSOC symbol @oblist)]
|
||||
(if-let [prop (ASSOC indicator (CDDR binding))]
|
||||
(RPLACD prop value)
|
||||
(RPLACD binding
|
||||
(make-cons-cell
|
||||
magic-marker
|
||||
(make-cons-cell
|
||||
indicator
|
||||
(make-cons-cell value (CDDR binding))))))
|
||||
(swap!
|
||||
oblist
|
||||
(fn [ob s p v]
|
||||
(make-cons-cell
|
||||
(make-beowulf-list (list s magic-marker p v))
|
||||
ob))
|
||||
symbol indicator value)))
|
||||
|
||||
(defn GET
|
||||
"From the manual:
|
||||
|
||||
'`get` is somewhat like `prop`; however its value is car of the rest of
|
||||
the list if the `indicator` is found, and NIL otherwise.'
|
||||
|
||||
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 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
|
||||
(= binding NIL) NIL
|
||||
(= magic-marker (CADR binding)) (loop [b binding]
|
||||
(cond (= b NIL) NIL
|
||||
(= (CAR b) indicator) (CADR b)
|
||||
:else (recur (CDR b))))
|
||||
:else (throw
|
||||
(ex-info "Misformatted property list (missing magic marker)"
|
||||
{:phase :host
|
||||
:function :get
|
||||
:args (list symbol indicator)
|
||||
:type :beowulf})))))
|
||||
|
||||
(defn DEFLIST
|
||||
"For each pair in this association list `a-list`, set the property with this
|
||||
`indicator` of the symbol which is the first element of the pair to the
|
||||
value which is the second element of the pair. See page 58 of the manual."
|
||||
[a-list indicator]
|
||||
(map
|
||||
#(PUT (CAR %) indicator (CDR %))
|
||||
a-list))
|
||||
|
||||
(defn DEFINE
|
||||
"Bootstrap-only version of `DEFINE` which, post boostrap, can be overwritten
|
||||
in LISP.
|
||||
|
||||
The single argument to `DEFINE` should be an assoc list which should be
|
||||
nconc'ed onto the front of the oblist. Broadly,
|
||||
(SETQ OBLIST (NCONC ARG1 OBLIST))"
|
||||
[args]
|
||||
(swap!
|
||||
oblist
|
||||
(fn [ob arg1]
|
||||
(loop [cursor arg1 a arg1]
|
||||
(if (= (CDR cursor) NIL)
|
||||
(do
|
||||
(.rplacd cursor @oblist)
|
||||
(pretty-print a)
|
||||
a)
|
||||
(recur (CDR cursor) a))))
|
||||
(CAR args)))
|
||||
The single argument to `DEFINE` should be an association list of symbols to
|
||||
lambda functions. See page 58 of the manual."
|
||||
[a-list]
|
||||
(DEFLIST a-list 'EXPR))
|
||||
|
||||
(defn SET
|
||||
"Implementation of SET in Clojure. Add to the `oblist` a binding of the
|
||||
value of `var` to the value of `val`. NOTE WELL: this is not SETQ!"
|
||||
[symbol val]
|
||||
(when
|
||||
(swap!
|
||||
oblist
|
||||
(fn [ob s v] (if-let [binding (ASSOC symbol ob)]
|
||||
(RPLACD binding v)
|
||||
(make-cons-cell (make-cons-cell s v) ob)))
|
||||
symbol val)
|
||||
val))
|
||||
(PUT symbol 'APVAL val))
|
||||
|
||||
;;;; TRACE and friends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -437,19 +525,26 @@
|
|||
"Return `true` iff `s` is a symbol currently being traced, else `nil`."
|
||||
[s]
|
||||
(try (contains? @traced-symbols s)
|
||||
(catch Throwable _)))
|
||||
(catch Throwable _ nil)))
|
||||
|
||||
(defn TRACE
|
||||
"Add this symbol `s` to the set of symbols currently being traced. If `s`
|
||||
is not a symbol, does nothing."
|
||||
"Add this `s` to the set of symbols currently being traced. If `s`
|
||||
is not a symbol or sequence of symbols, does nothing."
|
||||
[s]
|
||||
(when (symbol? s)
|
||||
(swap! traced-symbols #(conj % s))))
|
||||
(swap! traced-symbols
|
||||
#(cond
|
||||
(symbol? s) (conj % s)
|
||||
(and (seq? s) (every? symbol? s)) (union % (set s))
|
||||
:else %)))
|
||||
|
||||
(defn UNTRACE
|
||||
"Remove this `s` from the set of symbols currently being traced. If `s`
|
||||
is not a symbol or sequence of symbols, does nothing."
|
||||
[s]
|
||||
(when (symbol? s)
|
||||
(swap! traced-symbols #(set (remove (fn [x] (= s x)) %)))))
|
||||
(cond
|
||||
(symbol? s) (swap! traced-symbols #(set (remove (fn [x] (= s x)) %)))
|
||||
(and (seq? s) (every? symbol? s)) (map UNTRACE s))
|
||||
@traced-symbols)
|
||||
|
||||
;;;; Extensions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -470,4 +565,4 @@
|
|||
argument was, or was not, a cons cell."
|
||||
[o]
|
||||
(when (lax? 'CONSP)
|
||||
(if (instance? o ConsCell) 'T 'F)))
|
||||
(if (instance? ConsCell o) 'T 'F)))
|
||||
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?]]
|
||||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -64,7 +64,8 @@
|
|||
cond := lsqb (opt-space cond-clause semi-colon opt-space)* cond-clause rsqb;
|
||||
cond-clause := mexpr opt-space arrow opt-space mexpr opt-space;
|
||||
arrow := '->';
|
||||
args := mexpr | (opt-space mexpr semi-colon opt-space)* opt-space mexpr opt-space;
|
||||
args := arg | (opt-space arg semi-colon opt-space)* opt-space arg opt-space;
|
||||
arg := mexpr | sexpr;
|
||||
fn-name := mvar;
|
||||
mvar := #'[a-z][a-z0-9]*';
|
||||
mconst := #'[A-Z][A-Z0-9]*';
|
||||
|
|
|
|||
|
|
@ -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