From 971a86e3847ae77b30b872c3b6e96868368c0bd2 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 4 Feb 2021 20:48:11 +0000 Subject: [PATCH] Interop now working. Not all tests pass. --- src/beowulf/bootstrap.clj | 105 ++++++++++++++++++++------------ src/beowulf/cons_cell.clj | 89 ++++++++++++++------------- src/beowulf/read.clj | 3 +- test/beowulf/bootstrap_test.clj | 15 +++++ test/beowulf/interop_test.clj | 4 +- 5 files changed, 131 insertions(+), 85 deletions(-) diff --git a/src/beowulf/bootstrap.clj b/src/beowulf/bootstrap.clj index e5aa03d..09c78df 100644 --- a/src/beowulf/bootstrap.clj +++ b/src/beowulf/bootstrap.clj @@ -10,7 +10,7 @@ therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell` objects." (:require [clojure.string :as s] - [clojure.tools.trace :refer :all] + [clojure.tools.trace :refer [deftrace]] [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -39,7 +39,7 @@ `(if (= ~x NIL) T F)) (defmacro ATOM - "Returns `T` if and only is the argument `x` is bound to and atom; else `F`. + "Returns `T` if and only if the argument `x` is bound to an atom; else `F`. It is not clear to me from the documentation whether `(ATOM 7)` should return `T` or `F`. I'm going to assume `T`." [x] @@ -52,6 +52,12 @@ [x] `(if (or (symbol? ~x) (number? ~x)) T NIL)) +(defmacro NUMBERP + "Returns `T` if and only if the argument `x` is bound to an number; else `F`. + TODO: check whether floating point numbers, rationals, etc were numbers in Lisp 1.5" + [x] + `(if (number? ~x) T F)) + (defn CAR "Return the item indicated by the first pointer of a pair. NIL is treated specially: the CAR of NIL is NIL." @@ -159,7 +165,6 @@ :else (make-cons-cell (CAR x) (APPEND (CDR x) y)))) - (defn MEMBER "This predicate is true if the S-expression `x` occurs among the elements of the list `y`. @@ -192,6 +197,11 @@ (make-cons-cell (CAR x) (CAR y)) (PAIRLIS (CDR x) (CDR y) a)))) +(defmacro QUOTE + "Quote, but in upper case for LISP 1.5" + [f] + `(quote ~f)) + (defn ASSOC "If a is an association list such as the one formed by PAIRLIS in the above example, then assoc will produce the first pair whose first term is x. Thus @@ -253,6 +263,18 @@ "/"))) l)) +(defn to-clojure + "If l is a `beowulf.cons_cell.ConsCell`, return a Clojure list having the + same members in the same order." + [l] + (cond + (not (instance? beowulf.cons_cell.ConsCell l)) + l + (= (CDR l) NIL) + (list (to-clojure (CAR l))) + :else + (conj (to-clojure (CDR l)) (to-clojure (CAR l))))) + (deftrace INTEROP "Clojure (or other host environment) interoperation API. `fn-symbol` is expected to be either @@ -276,28 +298,29 @@ actual problem." [fn-symbol args] (let - [q-name (if - (seq? fn-symbol) - (interop-interpret-q-name fn-symbol) - fn-symbol) - l-name (symbol (s/lower-case q-name)) - f (cond - (try - (fn? (eval l-name)) - (catch java.lang.ClassNotFoundException e nil)) l-name - (try - (fn? (eval q-name)) - (catch java.lang.ClassNotFoundException e nil)) q-name + [q-name (if + (seq? fn-symbol) + (interop-interpret-q-name fn-symbol) + fn-symbol) + l-name (symbol (s/lower-case q-name)) + f (cond + (try + (fn? (eval l-name)) + (catch java.lang.ClassNotFoundException e nil)) l-name + (try + (fn? (eval q-name)) + (catch java.lang.ClassNotFoundException e nil)) q-name :else (throw - (ex-info - (str "INTEROP: unknown function `" fn-symbol "`") - {:cause :interop - :detail :not-found - :name fn-symbol - :also-tried l-name})))] - (print (str "INTEROP: evaluating `" (cons f args) "`")) + (ex-info + (str "INTEROP: unknown function `" fn-symbol "`") + {:cause :interop + :detail :not-found + :name fn-symbol + :also-tried l-name}))) + args' (to-clojure args)] + (print (str "INTEROP: evaluating `" (cons f args') "`")) (flush) - (let [result (eval (read-string (str "(cons " f " " args ")")))] ;; this has the potential to blow up the world + (let [result (eval (conj args' f))] ;; this has the potential to blow up the world (println (str "; returning `" result "`")) (cond @@ -307,11 +330,11 @@ (string? result) (symbol result) (number? result) result :else (throw - (ex-info - (str "INTEROP: Cannot return `" result "` to Lisp 1.5.") - {:cause :interop - :detail :not-representable - :result result})))))) + (ex-info + (str "INTEROP: Cannot return `" result "` to Lisp 1.5.") + {:cause :interop + :detail :not-representable + :result result})))))) (defn APPLY "For bootstrapping, at least, a version of APPLY written in Clojure. @@ -373,6 +396,7 @@ "Essentially, identical to EVAL except traced." [expr env] (cond + (NUMBERP expr) expr (= (ATOM? expr) T) (CDR (ASSOC expr env)) @@ -398,22 +422,23 @@ (cond (true? (:trace *options*)) (traced-eval expr env) + (NUMBERP expr) expr (= - (ATOM? expr) T) + (ATOM? expr) T) (CDR (ASSOC expr env)) (= - (ATOM? (CAR expr)) - T)(cond - (= (CAR expr) 'QUOTE) (CADR expr) - (= (CAR expr) 'COND) (EVCON (CDR expr) env) - :else (APPLY - (CAR expr) - (EVLIS (CDR expr) env) - env)) + (ATOM? (CAR expr)) + T) (cond + (= (CAR expr) 'QUOTE) (CADR expr) + (= (CAR expr) 'COND) (EVCON (CDR expr) env) + :else (APPLY + (CAR expr) + (EVLIS (CDR expr) env) + env)) :else (APPLY - (CAR expr) - (EVLIS (CDR expr) env) - env))) + (CAR expr) + (EVLIS (CDR expr) env) + env))) diff --git a/src/beowulf/cons_cell.clj b/src/beowulf/cons_cell.clj index 90e462d..e90ba15 100644 --- a/src/beowulf/cons_cell.clj +++ b/src/beowulf/cons_cell.clj @@ -25,6 +25,9 @@ (rplacd [this value] "replace the rest (but-first; cdr) of this sequence with this value") + (getCar + [this] + "Return the first element of this sequence.") (getCdr [this] "like `more`, q.v., but returns List `NIL` not Clojure `nil` when empty." )) @@ -37,37 +40,39 @@ MutableSequence (rplaca [this value] - (if - (or - (satisfies? MutableSequence value) ;; can't reference + (if + (or + (satisfies? MutableSequence value) ;; can't reference ;; beowulf.cons_cell.ConsCell, ;; because it is not yet ;; defined - (number? value) - (symbol? value)) - (do - (set! (. this CAR) value) - this) - (throw (ex-info - (str "Invalid value in RPLACA: `" value "` (" (type value) ")") - {:cause :bad-value - :detail :rplaca})))) + (number? value) + (symbol? value)) + (do + (set! (. this CAR) value) + this) + (throw (ex-info + (str "Invalid value in RPLACA: `" value "` (" (type value) ")") + {:cause :bad-value + :detail :rplaca})))) (rplacd [this value] - (if - (or - (satisfies? MutableSequence value) - (number? value) - (symbol? value)) - (do - (set! (. this CDR) value) - this) - (throw (ex-info - (str "Invalid value in RPLACD: `" value "` (" (type value) ")") - {:cause :bad-value - :detail :rplaca})))) + (if + (or + (satisfies? MutableSequence value) + (number? value) + (symbol? value)) + (do + (set! (. this CDR) value) + this) + (throw (ex-info + (str "Invalid value in RPLACD: `" value "` (" (type value) ")") + {:cause :bad-value + :detail :rplaca})))) + (getCar [this] + (. this CAR)) (getCdr [this] - (. this CDR)) + (. this CDR)) clojure.lang.ISeq (cons [this x] (ConsCell. x this)) @@ -75,11 +80,11 @@ ;; next and more must return ISeq: ;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java (more [this] (if - (seq? (.getCdr this)) + (seq? (.getCdr this)) (.getCdr this) clojure.lang.PersistentList/EMPTY)) (next [this] (if - (seq? (.getCdr this)) + (seq? (.getCdr this)) (.getCdr this) nil ;; next returns nil when empty )) @@ -94,27 +99,27 @@ clojure.lang.IPersistentCollection (empty [this] false) ;; a cons cell is by definition not empty. (equiv [this other] (if - (seq? other) + (seq? other) (and - (if - (and - (seq? (first this)) - (seq? (first other))) - (.equiv (first this) (first other)) - (= (first this) (first other))) - (if - (and - (seq? (.getCdr this)) - (seq? (.getCdr other))) - (.equiv (.getCdr this) (.getCdr other)) - (= (.getCdr this) (.getCdr other)))) + (if + (and + (seq? (first this)) + (seq? (first other))) + (.equiv (first this) (first other)) + (= (first this) (first other))) + (if + (and + (seq? (.getCdr this)) + (seq? (.getCdr other))) + (.equiv (.getCdr this) (.getCdr other)) + (= (.getCdr this) (.getCdr other)))) false)) clojure.lang.Counted - (count [this] (loop [cell this + (count [this] (loop [cell this result 1] (if - (coll? (.getCdr this)) + (coll? (.getCdr this)) (recur (.getCdr this) (inc result)) result))) ;; (if diff --git a/src/beowulf/read.clj b/src/beowulf/read.clj index 6ede7e8..dc8e235 100644 --- a/src/beowulf/read.clj +++ b/src/beowulf/read.clj @@ -17,6 +17,7 @@ [clojure.math.numeric-tower :refer [expt]] [clojure.string :refer [starts-with? upper-case]] [instaparse.core :as i] + [instaparse.failure :as f] [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -93,7 +94,7 @@ ([p] (if (instance? instaparse.gll.Failure p) - (throw (ex-info "Ic ne behæfd" {:cause :parse-failure :failure p})) + (throw (ex-info (str "Ic ne behæfd: " (f/pprint-failure p)) {:cause :parse-failure :failure p})) (simplify p :sexpr))) ([p context] (if diff --git a/test/beowulf/bootstrap_test.clj b/test/beowulf/bootstrap_test.clj index 25ac23d..361ff16 100644 --- a/test/beowulf/bootstrap_test.clj +++ b/test/beowulf/bootstrap_test.clj @@ -51,6 +51,21 @@ actual (ATOM? (gsp "(A B C D)"))] (is (= actual expected) "A list is explicitly not an atom")))) +(deftest numberp-tests + (testing "NUMBERP" + (let [expected T + actual (NUMBERP 7)] + (is (= actual expected) "7 is a number")) + (let [expected T + actual (NUMBERP 3.14)] + (is (= actual expected) "3.14 is a number")) + (let [expected F + actual (NUMBERP NIL)] + (is (= actual expected) "NIL is not a number")) + (let [expected F + actual (NUMBERP (gsp "HELLO"))] + (is (= actual expected) "HELLO is not a number")))) + (deftest access-function-tests (testing "CAR" (let [expected 'A diff --git a/test/beowulf/interop_test.clj b/test/beowulf/interop_test.clj index 62ac3e9..0db7ae3 100644 --- a/test/beowulf/interop_test.clj +++ b/test/beowulf/interop_test.clj @@ -8,11 +8,11 @@ (deftest interop-test (testing "INTEROP called from Clojure" - (let [expected '123 + (let [expected (symbol "123") actual (INTEROP (gsp "(CLOJURE CORE STR)") (gsp "(1 2 3)"))] (is (= actual expected)))) (testing "INTEROP called from Lisp" (let [expected 'ABC - actual (EVAL (gsp "(INTEROP '(CLOJURE CORE STR) '('A 'B 'C)"))] + actual (EVAL (INTEROP '(CLOJURE CORE STR) '('A 'B 'C)) '())] (is (= actual expected)))) )