From b9a22d0961f6f06a48d27268c0709a50429c09fc Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Fri, 7 Apr 2023 18:58:32 +0100
Subject: [PATCH] PROG is working, but regression in EVAL.
---
src/beowulf/bootstrap.clj | 98 +++++++++++++++++++++------------
test/beowulf/bootstrap_test.clj | 40 ++++++++------
test/beowulf/lisp_test.clj | 10 +++-
3 files changed, 94 insertions(+), 54 deletions(-)
diff --git a/src/beowulf/bootstrap.clj b/src/beowulf/bootstrap.clj
index b1ea963..92d9478 100644
--- a/src/beowulf/bootstrap.clj
+++ b/src/beowulf/bootstrap.clj
@@ -39,16 +39,19 @@
(declare APPLY EVAL prog-eval)
+;;;; The PROGram feature ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
(def find-target
(memoize
(fn [target body]
(loop [body' body]
(cond
- (= body' NIL) (throw (ex-info "Invalid GO target"
+ (= body' NIL) (throw (ex-info (str "Invalid GO target `" target "`")
{:phase :lisp
:function 'PROG
- :type :lisp
- :code :A6}))
+ :type :lisp
+ :code :A6
+ :target target}))
(= (.getCar body') target) body'
:else (recur (.getCdr body')))))))
@@ -64,6 +67,14 @@
(recur (.getCdr clauses'))))
NIL)))
+(defn- merge-vars [vars env]
+ (reduce
+ #(make-cons-cell
+ (make-cons-cell %2 (@vars %2))
+ env)
+ env
+ (keys @vars)))
+
(defn prog-eval
"Like `EVAL`, q.v., except handling symbols, and expressions starting
`GO`, `RETURN`, `SET` and `SETQ` specially."
@@ -75,23 +86,30 @@
COND (prog-cond (.getCdr expr)
vars env depth)
GO (make-cons-cell
- '*PROGGO* (.getCdr expr))
+ '*PROGGO* (.getCar (.getCdr expr)))
RETURN (make-cons-cell
'*PROGRETURN*
- (EVAL (.getCdr expr) env depth))
- SET (swap! vars
+ (prog-eval (.getCar (.getCdr expr))
+ vars env depth))
+ SET (let [v (CADDR expr)]
+ (swap! vars
assoc
(prog-eval (CADR expr)
vars env depth)
(prog-eval (CADDR expr)
vars env depth))
- SETQ (swap! vars
+ v)
+ SETQ (let [v (CADDR expr)]
+ (swap! vars
assoc
(CADR expr)
- (prog-eval (CADDR expr)
+ (prog-eval v
vars env depth))
+ v)
;; else
- (beowulf.bootstrap/EVAL expr env depth))))
+ (beowulf.bootstrap/EVAL expr
+ (merge-vars vars env)
+ depth))))
(defn PROG
"The accursed `PROG` feature. See page 71 of the manual.
@@ -157,40 +175,31 @@
(loop [cursor body]
(let [step (.getCar cursor)]
(when trace (do (println "Executing step: " step)
- (println " with vars: " vars)))
+ (println " with vars: " @vars)))
(cond (= cursor NIL) NIL
- (symbol? step) (recur step)
+ (symbol? step) (recur (.getCdr cursor))
:else (let [v (prog-eval (.getCar cursor) vars env depth)]
+ (when trace (println " --> " v))
(if (instance? ConsCell v)
(case (.getCar v)
*PROGGO* (let [target (.getCdr v)]
(if (targets target)
(recur (find-target target body))
- (throw (ex-info "Invalid GO target"
+ (throw (ex-info (str "Invalid GO target `"
+ target "`")
{:phase :lisp
:function 'PROG
:args program
:type :lisp
- :code :A6}))))
+ :code :A6
+ :target target
+ :targets targets}))))
*PROGRETURN* (.getCdr v)
;; else
(recur (.getCdr cursor)))
(recur (.getCdr cursor)))))))))
-
-
-(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))))))
+;;;; Tracing execution ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- trace-call
"Show a trace of a call to the function named by this `function-symbol`
@@ -219,6 +228,21 @@
(first (remove #(= % NIL) (map #(GET s %)
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
"Apply this `funtion-symbol` to these `args` in this `environment` and
return the result."
@@ -281,6 +305,8 @@
(trace-response 'APPLY result depth)
result))
+;;;; EVAL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
(defn- EVCON
"Inner guts of primitive COND. All `clauses` are assumed to be
`beowulf.cons-cell/ConsCell` objects. Note that tests in Lisp 1.5
@@ -319,17 +345,17 @@
(defn- eval-symbolic
[expr env depth]
- (let [v (value expr (list 'APVAL))
+ (let [v (ASSOC expr env)
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)]
+ (println (str indent ": EVAL: shallow binding: " (or v "nil"))))
+ (if (instance? ConsCell v)
+ (.getCdr v)
+ (let [v' (value expr (list 'APVAL))]
(when (traced? 'EVAL)
- (println (str indent ": EVAL: shallow binding: " (or v' "nil"))))
- (if (and v' (not= v' NIL))
- (.getCdr v')
+ (println (str indent ": EVAL: deep binding: (" expr " . " (or v' "nil") ")" )))
+ (if v'
+ v'
(throw (ex-info "No binding for symbol found"
{:phase :eval
:function 'EVAL
@@ -349,7 +375,7 @@
(let [expr' (if (and (coll? expr) (not (instance? ConsCell expr)))
(make-beowulf-list expr)
expr)]
- (EVAL expr' @oblist 0)))
+ (EVAL expr' NIL 0)))
([expr env depth]
(trace-call 'EVAL (list expr env depth) depth)
(let [result (cond
diff --git a/test/beowulf/bootstrap_test.clj b/test/beowulf/bootstrap_test.clj
index 242d186..eb68606 100644
--- a/test/beowulf/bootstrap_test.clj
+++ b/test/beowulf/bootstrap_test.clj
@@ -1,20 +1,27 @@
(ns beowulf.bootstrap-test
- (:require [clojure.test :refer [deftest testing is]]
- [beowulf.cons-cell :refer [make-cons-cell T F]]
- [beowulf.host :refer [ASSOC ATOM ATOM? CAR CAAAAR CADR
- CADDR CADDDR CDR EQ EQUAL
- PAIRLIS]]
+ (:require [beowulf.bootstrap :refer [EVAL]]
+ [beowulf.cons-cell :refer [F make-cons-cell T]]
+ [beowulf.host :refer [ASSOC ATOM ATOM? CAAAAR CADDDR CADDR CADR
+ CAR CDR EQ EQUAL PAIRLIS]]
[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
;;; 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
(testing "ATOM"
(let [expected T
@@ -197,12 +204,13 @@
(gsp "((A . (M N)) (B . (CAR X)) (C . (QUOTE M)) (C . (CDR X)))")))]
(is (= actual expected)))))
-;; TODO: need to reimplement this in lisp_test
-;; (deftest sublis-tests
-;; (testing "sublis"
-;; (let [expected "(SHAKESPEARE WROTE (THE TEMPEST))"
-;; actual (print-str
-;; (SUBLIS
-;; (gsp "((X . SHAKESPEARE) (Y . (THE TEMPEST)))")
-;; (gsp "(X WROTE Y)")))]
-;; (is (= actual expected)))))
+(deftest prog-tests
+ (testing "PROG"
+ (let [expected "5"
+ actual (reps "(PROG (X)
+ (SETQ X 1)
+ START
+ (SETQ X (ADD1 X))
+ (COND ((EQ X 5) (RETURN X))
+ (T (GO START))))")]
+ (is (= actual expected)))))
\ No newline at end of file
diff --git a/test/beowulf/lisp_test.clj b/test/beowulf/lisp_test.clj
index 933bddd..628fbd5 100644
--- a/test/beowulf/lisp_test.clj
+++ b/test/beowulf/lisp_test.clj
@@ -146,5 +146,11 @@
actual (reps "(MEMBER 'BERTRAM '(ALBERT BELINDA CHARLIE DORIS ELFREDA FRED))")]
(is (= actual expected)))))
-
-
\ No newline at end of file
+(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)))))