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

PROG is working, but regression in EVAL.

Browse source
This commit is contained in:
Simon Brooke 2023-04-07 18:58:32 +01:00
parent 022e409c51
commit b9a22d0961
3 changed files with 94 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

96
src/beowulf/bootstrap.clj
View file

@ -39,16 +39,19 @@
(declare APPLY EVAL prog-eval) (declare APPLY EVAL prog-eval)
;;;; The PROGram feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def find-target (def find-target
(memoize (memoize
(fn [target body] (fn [target body]
(loop [body' body] (loop [body' body]
(cond (cond
(= body' NIL) (throw (ex-info "Invalid GO target" (= body' NIL) (throw (ex-info (str "Invalid GO target `" target "`")
{:phase :lisp {:phase :lisp
:function 'PROG :function 'PROG
:type :lisp :type :lisp
:code :A6})) :code :A6
:target target}))
(= (.getCar body') target) body' (= (.getCar body') target) body'
:else (recur (.getCdr body'))))))) :else (recur (.getCdr body')))))))
@ -64,6 +67,14 @@
(recur (.getCdr clauses')))) (recur (.getCdr clauses'))))
NIL))) NIL)))
(defn- merge-vars [vars env]
(reduce
#(make-cons-cell
(make-cons-cell %2 (@vars %2))
env)
env
(keys @vars)))
(defn prog-eval (defn prog-eval
"Like `EVAL`, q.v., except handling symbols, and expressions starting "Like `EVAL`, q.v., except handling symbols, and expressions starting
`GO`, `RETURN`, `SET` and `SETQ` specially." `GO`, `RETURN`, `SET` and `SETQ` specially."
@ -75,23 +86,30 @@
COND (prog-cond (.getCdr expr) COND (prog-cond (.getCdr expr)
vars env depth) vars env depth)
GO (make-cons-cell GO (make-cons-cell
'*PROGGO* (.getCdr expr)) '*PROGGO* (.getCar (.getCdr expr)))
RETURN (make-cons-cell RETURN (make-cons-cell
'*PROGRETURN* '*PROGRETURN*
(EVAL (.getCdr expr) env depth)) (prog-eval (.getCar (.getCdr expr))
SET (swap! vars vars env depth))
SET (let [v (CADDR expr)]
(swap! vars
assoc assoc
(prog-eval (CADR expr) (prog-eval (CADR expr)
vars env depth) vars env depth)
(prog-eval (CADDR expr) (prog-eval (CADDR expr)
vars env depth)) vars env depth))
SETQ (swap! vars v)
SETQ (let [v (CADDR expr)]
(swap! vars
assoc assoc
(CADR expr) (CADR expr)
(prog-eval (CADDR expr) (prog-eval v
vars env depth)) vars env depth))
v)
;; else ;; else
(beowulf.bootstrap/EVAL expr env depth)))) (beowulf.bootstrap/EVAL expr
(merge-vars vars env)
depth))))
(defn PROG (defn PROG
"The accursed `PROG` feature. See page 71 of the manual. "The accursed `PROG` feature. See page 71 of the manual.
@ -157,40 +175,31 @@
(loop [cursor body] (loop [cursor body]
(let [step (.getCar cursor)] (let [step (.getCar cursor)]
(when trace (do (println "Executing step: " step) (when trace (do (println "Executing step: " step)
(println " with vars: " vars))) (println " with vars: " @vars)))
(cond (= cursor NIL) NIL (cond (= cursor NIL) NIL
(symbol? step) (recur step) (symbol? step) (recur (.getCdr cursor))
:else (let [v (prog-eval (.getCar cursor) vars env depth)] :else (let [v (prog-eval (.getCar cursor) vars env depth)]
(when trace (println " --> " v))
(if (instance? ConsCell v) (if (instance? ConsCell v)
(case (.getCar v) (case (.getCar v)
*PROGGO* (let [target (.getCdr v)] *PROGGO* (let [target (.getCdr v)]
(if (targets target) (if (targets target)
(recur (find-target target body)) (recur (find-target target body))
(throw (ex-info "Invalid GO target" (throw (ex-info (str "Invalid GO target `"
target "`")
{:phase :lisp {:phase :lisp
:function 'PROG :function 'PROG
:args program :args program
:type :lisp :type :lisp
:code :A6})))) :code :A6
:target target
:targets targets}))))
*PROGRETURN* (.getCdr v) *PROGRETURN* (.getCdr v)
;; else ;; else
(recur (.getCdr cursor))) (recur (.getCdr cursor)))
(recur (.getCdr cursor))))))))) (recur (.getCdr cursor)))))))))
;;;; Tracing execution ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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- trace-call (defn- trace-call
"Show a trace of a call to the function named by this `function-symbol` "Show a trace of a call to the function named by this `function-symbol`
@ -219,6 +228,21 @@
(first (remove #(= % NIL) (map #(GET s %) (first (remove #(= % NIL) (map #(GET s %)
indicators)))))) indicators))))))
;;;; APPLY ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn try-resolve-subroutine
"Attempt to resolve this `subr` with these `args`."
[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- apply-symbolic (defn- apply-symbolic
"Apply this `funtion-symbol` to these `args` in this `environment` and "Apply this `funtion-symbol` to these `args` in this `environment` and
return the result." return the result."
@ -281,6 +305,8 @@
(trace-response 'APPLY result depth) (trace-response 'APPLY result depth)
result)) result))
;;;; EVAL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- EVCON (defn- EVCON
"Inner guts of primitive COND. All `clauses` are assumed to be "Inner guts of primitive COND. All `clauses` are assumed to be
`beowulf.cons-cell/ConsCell` objects. Note that tests in Lisp 1.5 `beowulf.cons-cell/ConsCell` objects. Note that tests in Lisp 1.5
@ -319,17 +345,17 @@
(defn- eval-symbolic (defn- eval-symbolic
[expr env depth] [expr env depth]
(let [v (value expr (list 'APVAL)) (let [v (ASSOC expr env)
indent (apply str (repeat depth "-"))] indent (apply str (repeat depth "-"))]
(when (traced? 'EVAL) (when (traced? 'EVAL)
(println (str indent ": EVAL: deep binding (" expr " . " (or v "nil") ")"))) (println (str indent ": EVAL: shallow binding: " (or v "nil"))))
(if (and v (not= v NIL)) (if (instance? ConsCell v)
v (.getCdr v)
(let [v' (ASSOC expr env)] (let [v' (value expr (list 'APVAL))]
(when (traced? 'EVAL) (when (traced? 'EVAL)
(println (str indent ": EVAL: shallow binding: " (or v' "nil")))) (println (str indent ": EVAL: deep binding: (" expr " . " (or v' "nil") ")" )))
(if (and v' (not= v' NIL)) (if v'
(.getCdr v') v'
(throw (ex-info "No binding for symbol found" (throw (ex-info "No binding for symbol found"
{:phase :eval {:phase :eval
:function 'EVAL :function 'EVAL
@ -349,7 +375,7 @@
(let [expr' (if (and (coll? expr) (not (instance? ConsCell expr))) (let [expr' (if (and (coll? expr) (not (instance? ConsCell expr)))
(make-beowulf-list expr) (make-beowulf-list expr)
expr)] expr)]
(EVAL expr' @oblist 0))) (EVAL expr' NIL 0)))
([expr env depth] ([expr env depth]
(trace-call 'EVAL (list expr env depth) depth) (trace-call 'EVAL (list expr env depth) depth)
(let [result (cond (let [result (cond

40
test/beowulf/bootstrap_test.clj
View file

@ -1,20 +1,27 @@
(ns beowulf.bootstrap-test (ns beowulf.bootstrap-test
(:require [clojure.test :refer [deftest testing is]] (:require [beowulf.bootstrap :refer [EVAL]]
[beowulf.cons-cell :refer [make-cons-cell T F]] [beowulf.cons-cell :refer [F make-cons-cell T]]
[beowulf.host :refer [ASSOC ATOM ATOM? CAR CAAAAR CADR [beowulf.host :refer [ASSOC ATOM ATOM? CAAAAR CADDDR CADDR CADR
CADDR CADDDR CDR EQ EQUAL CAR CDR EQ EQUAL PAIRLIS]]
PAIRLIS]]
[beowulf.oblist :refer [NIL]] [beowulf.oblist :refer [NIL]]
[beowulf.read :refer [gsp]])) [beowulf.read :refer [gsp READ]]
[clojure.test :refer [deftest is testing]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; This file is primarily tests of the functions in `beowulf.eval` - which ;;; This file is primarily tests of the functions in `beowulf.bootstrap` - which
;;; are Clojure functions, but aim to provide sufficient functionality that ;;; are Clojure functions, but aim to provide sufficient functionality that
;;; Beowulf can get up to the level of running its own code. ;;; Beowulf can get up to the level of running its own code.
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- reps
"'Read eval print string', or 'read eval print single'.
Reads and evaluates one input string, and returns the
output string."
[input]
(with-out-str (print (EVAL (READ input)))))
(deftest atom-tests (deftest atom-tests
(testing "ATOM" (testing "ATOM"
(let [expected T (let [expected T
@ -197,12 +204,13 @@
(gsp "((A . (M N)) (B . (CAR X)) (C . (QUOTE M)) (C . (CDR X)))")))] (gsp "((A . (M N)) (B . (CAR X)) (C . (QUOTE M)) (C . (CDR X)))")))]
(is (= actual expected))))) (is (= actual expected)))))
;; TODO: need to reimplement this in lisp_test (deftest prog-tests
;; (deftest sublis-tests (testing "PROG"
;; (testing "sublis" (let [expected "5"
;; (let [expected "(SHAKESPEARE WROTE (THE TEMPEST))" actual (reps "(PROG (X)
;; actual (print-str (SETQ X 1)
;; (SUBLIS START
;; (gsp "((X . SHAKESPEARE) (Y . (THE TEMPEST)))") (SETQ X (ADD1 X))
;; (gsp "(X WROTE Y)")))] (COND ((EQ X 5) (RETURN X))
;; (is (= actual expected))))) (T (GO START))))")]
(is (= actual expected)))))

10
test/beowulf/lisp_test.clj
View file

@ -146,5 +146,11 @@
actual (reps "(MEMBER 'BERTRAM '(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED))")] actual (reps "(MEMBER 'BERTRAM '(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED))")]
(is (= actual expected))))) (is (= actual expected)))))
(deftest sublis-tests
(testing "sublis"
(let [expected "(SHAKESPEARE WROTE (THE TEMPEST))"
actual (reps
"(SUBLIS
'((X . SHAKESPEARE) (Y . (THE TEMPEST)))
'(X WROTE Y))")]
(is (= actual expected)))))