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)))))