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

Very close to working FSUBRs - but not quite there.

Browse source
This commit is contained in:
Simon Brooke 2023-04-12 09:04:44 +01:00
parent 7c4d3668a8
commit e9406d5574
6 changed files with 126 additions and 52 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
doc/lisp1.5.md
View file

@ -1721,6 +1721,7 @@ represented in storage only once,
The following simple example has been included to illustrate the exact construction
of list structures. Two types of list structures are shown, and a function for deriving
one from the other is given in LISP.
We assume that we have a list of the form
n, = ((A B C) (D E F),... , (X Y z)),
@ -2709,7 +2710,9 @@ If `deflist` or `define` is used twice on the same object with the same indicato
The function attrib concatenates its two arguments by changing the last element of its first argument to point to the second argument. Thus it is commonly used to tack something onto the end of a property list. The value of attrib is the second argument.
For example
attrib[~~; (EXPR (LAMBDA (X) (COND ((ATOM X) X) (T (FF (CAR x))))))]
```
attrib[FF; (EXPR (LAMBDA (X) (COND ((ATOM X) X) (T (FF (CAR x))))))]
```
would put EXPR followed by the LAMBDA expression for FF onto the end of the prop-
erty list for FF.

12
resources/lisp1.5.lsp
View file

@ -25,6 +25,7 @@
(T (ASSOC X (CDR L)))))
SUBR (BEOWULF HOST ASSOC))
(ATOM 32767 SUBR (BEOWULF HOST ATOM))
(ATTRIB 32767 SUBR (BEOWULF HOST ATTRIB))
(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))))))
@ -55,6 +56,16 @@
(CDDDR 32767 EXPR (LAMBDA (X) (CDR (CDR (CDR X)))))
(CDDR 32767 EXPR (LAMBDA (X) (CDR (CDR X))))
(CDR 32767 SUBR (BEOWULF HOST CDR))
(CONC
32767
FEXPR
(LABEL
ARGS
(COND
((COND
((ONEP (LENGTH ARGS)) ARGS)
(T (ATTRIB (CAR ARGS) (APPLY CONC (CDR ARGS) NIL))))
ARGS))))
(CONS 32767 SUBR (BEOWULF HOST CONS))
(CONSP 32767 SUBR (BEOWULF HOST CONSP))
(COPY
@ -188,6 +199,7 @@
(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))
(SASSOC 32767 SUBR (BEOWULF BOOTSTRAP SASSOC))
(SEARCH 32767 EXPR
(LAMBDA (X P F U)
(COND ((NULL X) (U X))

8
resources/sexpr/conc.lsp
View file

@ -1 +1,7 @@
;; TODO
;; This isn't working but it's really not far off.
(PUT 'CONC 'FEXPR
;; possibly ARGS should be (ARGS)...
'(LABEL ARGS
(COND ((COND ((ONEP (LENGTH ARGS)) ARGS)
(T (ATTRIB (CAR ARGS) (APPLY CONC (CDR ARGS) NIL)))) ARGS))))

112
src/beowulf/bootstrap.clj
View file

@ -11,9 +11,9 @@
objects."
(:require [beowulf.cons-cell :refer [F make-beowulf-list make-cons-cell
pretty-print T]]
[beowulf.host :refer [ASSOC ATOM CAAR CADAR CADDR CADR CAR CDR GET
LIST NUMBERP PAIRLIS traced?]]
[beowulf.oblist :refer [*options* NIL oblist]])
[beowulf.host :refer [ASSOC ATOM CAAR CADAR CADDR CADR CAR CDR
CONS ERROR GET LIST NUMBERP PAIRLIS traced?]]
[beowulf.oblist :refer [*options* NIL]])
(:import [beowulf.cons_cell ConsCell]
[clojure.lang Symbol]))
@ -41,6 +41,12 @@
;;;; The PROGram feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:dynamic
*depth*
"Stack depth. Unfortunately we need to be able to pass round depth for
functions which call EVAL/APPLY but do not know about depth."
0)
(def find-target
(memoize
(fn [target body]
@ -228,6 +234,21 @@
(first (remove #(= % NIL) (map #(GET s %)
indicators))))))
(defn SASSOC
"Like `ASSOC`, but with an action to take if no value is found.
From the manual, page 60:
'The function `sassoc` searches `y`, which is a list of dotted pairs, for
a pair whose first element that is `x`. If such a pair is found, the value
of `sassoc` is this pair. Otherwise the function `u` of no arguments is
taken as the value of `sassoc`.'"
[x y u]
(let [v (ASSOC x y)]
(if-not (= v NIL) v
(APPLY u NIL NIL))))
;;;; APPLY ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn try-resolve-subroutine
@ -275,6 +296,24 @@
(trace-response function-symbol result depth)
result))
(defn- apply-label
"Apply in the special case that the first element in the function is `LABEL`."
[function args environment depth]
(APPLY
(CADDR function)
args
(CONS
(CONS (CADR function) (CADDR function))
environment)
depth))
(defn- apply-lambda
"Apply in the special case that the first element in the function is `LAMBDA`."
[function args environment depth]
(EVAL
(CADDR function)
(PAIRLIS (CADR function) args environment) depth))
(defn APPLY
"Apply this `function` to these `arguments` in this `environment` and return
the result.
@ -282,38 +321,32 @@
For bootstrapping, at least, a version of APPLY written in Clojure.
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]
(trace-call 'APPLY (list function args environment) depth)
(let [result (cond
(= NIL function) (if (:strict *options*)
NIL
(throw (ex-info "NIL sí ne þegnung"
{: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 "Ungecnáwen wyrþan sí þegnung-weard"
{:phase :apply
:function function
:args args
:type :beowulf}))))]
(trace-response 'APPLY result depth)
result))
([function args environment]
(APPLY function args environment *depth*))
([function args environment depth]
(binding [*depth* (inc depth)]
(trace-call 'APPLY (list function args environment) depth)
(let [result (cond
(= NIL function) (if (:strict *options*)
NIL
(throw (ex-info "NIL sí ne þegnung"
{:phase :apply
:function "NIL"
:args args
:type :beowulf})))
(= (ATOM function) T) (apply-symbolic function args environment (inc depth))
:else (case (first function)
LABEL (apply-label function args environment depth)
FUNARG (APPLY (CADR function) args (CADDR function) depth)
LAMBDA (apply-lambda function args environment depth)
;; else
(throw (ex-info "Ungecnáwen wyrþan sí þegnung-weard"
{:phase :apply
:function function
:args args
:type :beowulf}))))]
(trace-response 'APPLY result depth)
result))))
;;;; EVAL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -412,11 +445,10 @@
(EVLIS (CDR expr) env depth)
env
depth))
:else (APPLY
(CAR expr)
(EVLIS (CDR expr) env depth)
env
depth))]
:else (EVAL (CONS (CDR (SASSOC (CAR expr) env (fn [] (ERROR 'A9))))
(CDR expr))
env
(inc depth)))]
(trace-response 'EVAL result depth)
result)))

34
src/beowulf/host.clj
View file

@ -216,7 +216,7 @@
:phase :host
:detail :rplacd
:args (list cell value)
:type :beowulf}))));; PLUS
:type :beowulf}))))
(defn LIST
[& args]
@ -447,6 +447,26 @@
:else (hit-or-miss-assoc target (CDDR plist)))
NIL))
(defn ATTRIB
"Destructive append. From page 59 of the manual:
The function `attrib` concatenates its two arguments by changing the last
element of its first argument to point to the second argument. Thus it
is commonly used to tack something onto the end of a property list.
The value of `attrib` is the second argument.
For example
```
attrib[FF; (EXPR (LAMBDA (X) (COND ((ATOM X) X) (T (FF (CAR x))))))]
```
would put EXPR followed by the LAMBDA expression for FF onto the end of
the property list for FF."
[x e]
(loop [l x]
(cond
(instance? ConsCell (CDR l)) (recur (CDR l))
:else (when (RPLACD l e) e))))
(defn PUT
"Put this `value` as the value of the property indicated by this `indicator`
of this `symbol`. Return `value` on success.
@ -459,6 +479,8 @@
(let [prop (hit-or-miss-assoc indicator (CDDR binding))]
(if (instance? ConsCell prop)
(RPLACA (CDR prop) value)
;; The implication is ATTRIB was used here, but I have not made that
;; work and this does work, so if it ain't broke don't fix it.
(RPLACD binding
(make-cons-cell
magic-marker
@ -494,13 +516,9 @@
val (cond
(= binding NIL) NIL
(= magic-marker
(CADR binding)) (loop [b binding]
;; (println "GET loop, seeking " indicator ":")
;; (pretty-print b)
(if (instance? ConsCell b)
(if (= (CAR b) indicator)
(CADR b) ;; <- this is what we should actually be returning
(recur (CDR b)))
(CADR binding)) (let [p (hit-or-miss-assoc indicator binding)]
(if-not (= NIL p)
(CADR p)
NIL))
:else (throw
(ex-info "Misformatted property list (missing magic marker)"

7
src/beowulf/io.clj
View file

@ -91,7 +91,8 @@
([]
(SYSOUT nil))
([filepath]
(spit (full-path (str filepath))
(let [destination (full-path (str filepath))]
(spit destination
(with-out-str
(println (apply str (repeat 79 ";")))
(println (format ";; Beowulf %s Sysout file generated at %s"
@ -103,7 +104,9 @@
(println)
(let [output (safely-wrap-subrs @oblist)]
(pretty-print output)
)))))
)))
(println "Saved sysout to " destination)
NIL)))
(defn resolve-subr
"If this oblist `entry` references a subroutine, attempt to fix up that