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 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 of list structures. Two types of list structures are shown, and a function for deriving
one from the other is given in LISP. one from the other is given in LISP.
We assume that we have a list of the form We assume that we have a list of the form
n, = ((A B C) (D E F),... , (X Y z)), 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. 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 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- would put EXPR followed by the LAMBDA expression for FF onto the end of the prop-
erty list for FF. erty list for FF.

12
resources/lisp1.5.lsp
View file

@ -25,6 +25,7 @@
(T (ASSOC X (CDR L))))) (T (ASSOC X (CDR L)))))
SUBR (BEOWULF HOST ASSOC)) SUBR (BEOWULF HOST ASSOC))
(ATOM 32767 SUBR (BEOWULF HOST ATOM)) (ATOM 32767 SUBR (BEOWULF HOST ATOM))
(ATTRIB 32767 SUBR (BEOWULF HOST ATTRIB))
(CAR 32767 SUBR (BEOWULF HOST CAR)) (CAR 32767 SUBR (BEOWULF HOST CAR))
(CAAAAR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR (CAR X)))))) (CAAAAR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR (CAR X))))))
(CAAADR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR (CDR X)))))) (CAAADR 32767 EXPR (LAMBDA (X) (CAR (CAR (CAR (CDR X))))))
@ -55,6 +56,16 @@
(CDDDR 32767 EXPR (LAMBDA (X) (CDR (CDR (CDR X))))) (CDDDR 32767 EXPR (LAMBDA (X) (CDR (CDR (CDR X)))))
(CDDR 32767 EXPR (LAMBDA (X) (CDR (CDR X)))) (CDDR 32767 EXPR (LAMBDA (X) (CDR (CDR X))))
(CDR 32767 SUBR (BEOWULF HOST CDR)) (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)) (CONS 32767 SUBR (BEOWULF HOST CONS))
(CONSP 32767 SUBR (BEOWULF HOST CONSP)) (CONSP 32767 SUBR (BEOWULF HOST CONSP))
(COPY (COPY
@ -188,6 +199,7 @@
(LAMBDA (N X) (COND ((EQ N 0) NIL) (T (CONS X (REPEAT (SUB1 N) X)))))) (LAMBDA (N X) (COND ((EQ N 0) NIL) (T (CONS X (REPEAT (SUB1 N) X))))))
(RPLACA 32767 SUBR (BEOWULF HOST RPLACA)) (RPLACA 32767 SUBR (BEOWULF HOST RPLACA))
(RPLACD 32767 SUBR (BEOWULF HOST RPLACD)) (RPLACD 32767 SUBR (BEOWULF HOST RPLACD))
(SASSOC 32767 SUBR (BEOWULF BOOTSTRAP SASSOC))
(SEARCH 32767 EXPR (SEARCH 32767 EXPR
(LAMBDA (X P F U) (LAMBDA (X P F U)
(COND ((NULL X) (U X)) (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." objects."
(:require [beowulf.cons-cell :refer [F make-beowulf-list make-cons-cell (:require [beowulf.cons-cell :refer [F make-beowulf-list make-cons-cell
pretty-print T]] pretty-print T]]
[beowulf.host :refer [ASSOC ATOM CAAR CADAR CADDR CADR CAR CDR GET [beowulf.host :refer [ASSOC ATOM CAAR CADAR CADDR CADR CAR CDR
LIST NUMBERP PAIRLIS traced?]] CONS ERROR GET LIST NUMBERP PAIRLIS traced?]]
[beowulf.oblist :refer [*options* NIL oblist]]) [beowulf.oblist :refer [*options* NIL]])
(:import [beowulf.cons_cell ConsCell] (:import [beowulf.cons_cell ConsCell]
[clojure.lang Symbol])) [clojure.lang Symbol]))
@ -41,6 +41,12 @@
;;;; The PROGram feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; 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 (def find-target
(memoize (memoize
(fn [target body] (fn [target body]
@ -228,6 +234,21 @@
(first (remove #(= % NIL) (map #(GET s %) (first (remove #(= % NIL) (map #(GET s %)
indicators)))))) 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; APPLY ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn try-resolve-subroutine (defn try-resolve-subroutine
@ -275,6 +296,24 @@
(trace-response function-symbol result depth) (trace-response function-symbol result depth)
result)) 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 (defn APPLY
"Apply this `function` to these `arguments` in this `environment` and return "Apply this `function` to these `arguments` in this `environment` and return
the result. the result.
@ -282,38 +321,32 @@
For bootstrapping, at least, a version of APPLY written in Clojure. For bootstrapping, at least, a version of APPLY written in Clojure.
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects. All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
See page 13 of the Lisp 1.5 Programmers Manual." See page 13 of the Lisp 1.5 Programmers Manual."
[function args environment depth] ([function args environment]
(trace-call 'APPLY (list function args environment) depth) (APPLY function args environment *depth*))
(let [result (cond ([function args environment depth]
(= NIL function) (if (:strict *options*) (binding [*depth* (inc depth)]
NIL (trace-call 'APPLY (list function args environment) depth)
(throw (ex-info "NIL sí ne þegnung" (let [result (cond
{:phase :apply (= NIL function) (if (:strict *options*)
:function "NIL" NIL
:args args (throw (ex-info "NIL sí ne þegnung"
:type :beowulf}))) {:phase :apply
(= (ATOM function) T) (apply-symbolic function args environment (inc depth)) :function "NIL"
:else (case (first function) :args args
LABEL (APPLY :type :beowulf})))
(CADDR function) (= (ATOM function) T) (apply-symbolic function args environment (inc depth))
args :else (case (first function)
(make-cons-cell LABEL (apply-label function args environment depth)
(make-cons-cell FUNARG (APPLY (CADR function) args (CADDR function) depth)
(CADR function) LAMBDA (apply-lambda function args environment depth)
(CADDR function)) ;; else
environment) (throw (ex-info "Ungecnáwen wyrþan sí þegnung-weard"
depth) {:phase :apply
FUNARG (APPLY (CADR function) args (CADDR function) depth) :function function
LAMBDA (EVAL :args args
(CADDR function) :type :beowulf}))))]
(PAIRLIS (CADR function) args environment) depth) (trace-response 'APPLY result depth)
(throw (ex-info "Ungecnáwen wyrþan sí þegnung-weard" result))))
{:phase :apply
:function function
:args args
:type :beowulf}))))]
(trace-response 'APPLY result depth)
result))
;;;; EVAL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; EVAL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -412,11 +445,10 @@
(EVLIS (CDR expr) env depth) (EVLIS (CDR expr) env depth)
env env
depth)) depth))
:else (APPLY :else (EVAL (CONS (CDR (SASSOC (CAR expr) env (fn [] (ERROR 'A9))))
(CAR expr) (CDR expr))
(EVLIS (CDR expr) env depth) env
env (inc depth)))]
depth))]
(trace-response 'EVAL result depth) (trace-response 'EVAL result depth)
result))) result)))

34
src/beowulf/host.clj
View file

@ -216,7 +216,7 @@
:phase :host :phase :host
:detail :rplacd :detail :rplacd
:args (list cell value) :args (list cell value)
:type :beowulf}))));; PLUS :type :beowulf}))))
(defn LIST (defn LIST
[& args] [& args]
@ -447,6 +447,26 @@
:else (hit-or-miss-assoc target (CDDR plist))) :else (hit-or-miss-assoc target (CDDR plist)))
NIL)) 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 (defn PUT
"Put this `value` as the value of the property indicated by this `indicator` "Put this `value` as the value of the property indicated by this `indicator`
of this `symbol`. Return `value` on success. of this `symbol`. Return `value` on success.
@ -459,6 +479,8 @@
(let [prop (hit-or-miss-assoc indicator (CDDR binding))] (let [prop (hit-or-miss-assoc indicator (CDDR binding))]
(if (instance? ConsCell prop) (if (instance? ConsCell prop)
(RPLACA (CDR prop) value) (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 (RPLACD binding
(make-cons-cell (make-cons-cell
magic-marker magic-marker
@ -494,13 +516,9 @@
val (cond val (cond
(= binding NIL) NIL (= binding NIL) NIL
(= magic-marker (= magic-marker
(CADR binding)) (loop [b binding] (CADR binding)) (let [p (hit-or-miss-assoc indicator binding)]
;; (println "GET loop, seeking " indicator ":") (if-not (= NIL p)
;; (pretty-print b) (CADR p)
(if (instance? ConsCell b)
(if (= (CAR b) indicator)
(CADR b) ;; <- this is what we should actually be returning
(recur (CDR b)))
NIL)) NIL))
:else (throw :else (throw
(ex-info "Misformatted property list (missing magic marker)" (ex-info "Misformatted property list (missing magic marker)"

7
src/beowulf/io.clj
View file

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