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

Interop now working. Not all tests pass.

Browse source
This commit is contained in:
Simon Brooke 2021-02-04 20:48:11 +00:00
parent d6801ee443
commit 971a86e384
5 changed files with 131 additions and 85 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

105
src/beowulf/bootstrap.clj
View file

@ -10,7 +10,7 @@
therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell` therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell`
objects." objects."
(:require [clojure.string :as s] (: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]])) [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -39,7 +39,7 @@
`(if (= ~x NIL) T F)) `(if (= ~x NIL) T F))
(defmacro ATOM (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 It is not clear to me from the documentation whether `(ATOM 7)` should return
`T` or `F`. I'm going to assume `T`." `T` or `F`. I'm going to assume `T`."
[x] [x]
@ -52,6 +52,12 @@
[x] [x]
`(if (or (symbol? ~x) (number? ~x)) T NIL)) `(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 (defn CAR
"Return the item indicated by the first pointer of a pair. NIL is treated "Return the item indicated by the first pointer of a pair. NIL is treated
specially: the CAR of NIL is NIL." specially: the CAR of NIL is NIL."
@ -159,7 +165,6 @@
:else :else
(make-cons-cell (CAR x) (APPEND (CDR x) y)))) (make-cons-cell (CAR x) (APPEND (CDR x) y))))
(defn MEMBER (defn MEMBER
"This predicate is true if the S-expression `x` occurs among the elements "This predicate is true if the S-expression `x` occurs among the elements
of the list `y`. of the list `y`.
@ -192,6 +197,11 @@
(make-cons-cell (CAR x) (CAR y)) (make-cons-cell (CAR x) (CAR y))
(PAIRLIS (CDR x) (CDR y) a)))) (PAIRLIS (CDR x) (CDR y) a))))
(defmacro QUOTE
"Quote, but in upper case for LISP 1.5"
[f]
`(quote ~f))
(defn ASSOC (defn ASSOC
"If a is an association list such as the one formed by PAIRLIS in the above "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 example, then assoc will produce the first pair whose first term is x. Thus
@ -253,6 +263,18 @@
"/"))) "/")))
l)) 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 (deftrace INTEROP
"Clojure (or other host environment) interoperation API. `fn-symbol` is expected "Clojure (or other host environment) interoperation API. `fn-symbol` is expected
to be either to be either
@ -276,28 +298,29 @@
actual problem." actual problem."
[fn-symbol args] [fn-symbol args]
(let (let
[q-name (if [q-name (if
(seq? fn-symbol) (seq? fn-symbol)
(interop-interpret-q-name fn-symbol) (interop-interpret-q-name fn-symbol)
fn-symbol) fn-symbol)
l-name (symbol (s/lower-case q-name)) l-name (symbol (s/lower-case q-name))
f (cond f (cond
(try (try
(fn? (eval l-name)) (fn? (eval l-name))
(catch java.lang.ClassNotFoundException e nil)) l-name (catch java.lang.ClassNotFoundException e nil)) l-name
(try (try
(fn? (eval q-name)) (fn? (eval q-name))
(catch java.lang.ClassNotFoundException e nil)) q-name (catch java.lang.ClassNotFoundException e nil)) q-name
:else (throw :else (throw
(ex-info (ex-info
(str "INTEROP: unknown function `" fn-symbol "`") (str "INTEROP: unknown function `" fn-symbol "`")
{:cause :interop {:cause :interop
:detail :not-found :detail :not-found
:name fn-symbol :name fn-symbol
:also-tried l-name})))] :also-tried l-name})))
(print (str "INTEROP: evaluating `" (cons f args) "`")) args' (to-clojure args)]
(print (str "INTEROP: evaluating `" (cons f args') "`"))
(flush) (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 "`")) (println (str "; returning `" result "`"))
(cond (cond
@ -307,11 +330,11 @@
(string? result) (symbol result) (string? result) (symbol result)
(number? result) result (number? result) result
:else (throw :else (throw
(ex-info (ex-info
(str "INTEROP: Cannot return `" result "` to Lisp 1.5.") (str "INTEROP: Cannot return `" result "` to Lisp 1.5.")
{:cause :interop {:cause :interop
:detail :not-representable :detail :not-representable
:result result})))))) :result result}))))))
(defn APPLY (defn APPLY
"For bootstrapping, at least, a version of APPLY written in Clojure. "For bootstrapping, at least, a version of APPLY written in Clojure.
@ -373,6 +396,7 @@
"Essentially, identical to EVAL except traced." "Essentially, identical to EVAL except traced."
[expr env] [expr env]
(cond (cond
(NUMBERP expr) expr
(= (=
(ATOM? expr) T) (ATOM? expr) T)
(CDR (ASSOC expr env)) (CDR (ASSOC expr env))
@ -398,22 +422,23 @@
(cond (cond
(true? (:trace *options*)) (true? (:trace *options*))
(traced-eval expr env) (traced-eval expr env)
(NUMBERP expr) expr
(= (=
(ATOM? expr) T) (ATOM? expr) T)
(CDR (ASSOC expr env)) (CDR (ASSOC expr env))
(= (=
(ATOM? (CAR expr)) (ATOM? (CAR expr))
T)(cond T) (cond
(= (CAR expr) 'QUOTE) (CADR expr) (= (CAR expr) 'QUOTE) (CADR expr)
(= (CAR expr) 'COND) (EVCON (CDR expr) env) (= (CAR expr) 'COND) (EVCON (CDR expr) env)
:else (APPLY :else (APPLY
(CAR expr) (CAR expr)
(EVLIS (CDR expr) env) (EVLIS (CDR expr) env)
env)) env))
:else (APPLY :else (APPLY
(CAR expr) (CAR expr)
(EVLIS (CDR expr) env) (EVLIS (CDR expr) env)
env))) env)))

89
src/beowulf/cons_cell.clj
View file

@ -25,6 +25,9 @@
(rplacd (rplacd
[this value] [this value]
"replace the rest (but-first; cdr) of this sequence with this value") "replace the rest (but-first; cdr) of this sequence with this value")
(getCar
[this]
"Return the first element of this sequence.")
(getCdr (getCdr
[this] [this]
"like `more`, q.v., but returns List `NIL` not Clojure `nil` when empty." )) "like `more`, q.v., but returns List `NIL` not Clojure `nil` when empty." ))
@ -37,37 +40,39 @@
MutableSequence MutableSequence
(rplaca [this value] (rplaca [this value]
(if (if
(or (or
(satisfies? MutableSequence value) ;; can't reference (satisfies? MutableSequence value) ;; can't reference
;; beowulf.cons_cell.ConsCell, ;; beowulf.cons_cell.ConsCell,
;; because it is not yet ;; because it is not yet
;; defined ;; defined
(number? value) (number? value)
(symbol? value)) (symbol? value))
(do (do
(set! (. this CAR) value) (set! (. this CAR) value)
this) this)
(throw (ex-info (throw (ex-info
(str "Invalid value in RPLACA: `" value "` (" (type value) ")") (str "Invalid value in RPLACA: `" value "` (" (type value) ")")
{:cause :bad-value {:cause :bad-value
:detail :rplaca})))) :detail :rplaca}))))
(rplacd [this value] (rplacd [this value]
(if (if
(or (or
(satisfies? MutableSequence value) (satisfies? MutableSequence value)
(number? value) (number? value)
(symbol? value)) (symbol? value))
(do (do
(set! (. this CDR) value) (set! (. this CDR) value)
this) this)
(throw (ex-info (throw (ex-info
(str "Invalid value in RPLACD: `" value "` (" (type value) ")") (str "Invalid value in RPLACD: `" value "` (" (type value) ")")
{:cause :bad-value {:cause :bad-value
:detail :rplaca})))) :detail :rplaca}))))
(getCar [this]
(. this CAR))
(getCdr [this] (getCdr [this]
(. this CDR)) (. this CDR))
clojure.lang.ISeq clojure.lang.ISeq
(cons [this x] (ConsCell. x this)) (cons [this x] (ConsCell. x this))
@ -75,11 +80,11 @@
;; next and more must return ISeq: ;; next and more must return ISeq:
;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java ;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java
(more [this] (if (more [this] (if
(seq? (.getCdr this)) (seq? (.getCdr this))
(.getCdr this) (.getCdr this)
clojure.lang.PersistentList/EMPTY)) clojure.lang.PersistentList/EMPTY))
(next [this] (if (next [this] (if
(seq? (.getCdr this)) (seq? (.getCdr this))
(.getCdr this) (.getCdr this)
nil ;; next returns nil when empty nil ;; next returns nil when empty
)) ))
@ -94,27 +99,27 @@
clojure.lang.IPersistentCollection clojure.lang.IPersistentCollection
(empty [this] false) ;; a cons cell is by definition not empty. (empty [this] false) ;; a cons cell is by definition not empty.
(equiv [this other] (if (equiv [this other] (if
(seq? other) (seq? other)
(and (and
(if (if
(and (and
(seq? (first this)) (seq? (first this))
(seq? (first other))) (seq? (first other)))
(.equiv (first this) (first other)) (.equiv (first this) (first other))
(= (first this) (first other))) (= (first this) (first other)))
(if (if
(and (and
(seq? (.getCdr this)) (seq? (.getCdr this))
(seq? (.getCdr other))) (seq? (.getCdr other)))
(.equiv (.getCdr this) (.getCdr other)) (.equiv (.getCdr this) (.getCdr other))
(= (.getCdr this) (.getCdr other)))) (= (.getCdr this) (.getCdr other))))
false)) false))
clojure.lang.Counted clojure.lang.Counted
(count [this] (loop [cell this (count [this] (loop [cell this
result 1] result 1]
(if (if
(coll? (.getCdr this)) (coll? (.getCdr this))
(recur (.getCdr this) (inc result)) (recur (.getCdr this) (inc result))
result))) result)))
;; (if ;; (if

3
src/beowulf/read.clj
View file

@ -17,6 +17,7 @@
[clojure.math.numeric-tower :refer [expt]] [clojure.math.numeric-tower :refer [expt]]
[clojure.string :refer [starts-with? upper-case]] [clojure.string :refer [starts-with? upper-case]]
[instaparse.core :as i] [instaparse.core :as i]
[instaparse.failure :as f]
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]])) [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -93,7 +94,7 @@
([p] ([p]
(if (if
(instance? instaparse.gll.Failure p) (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))) (simplify p :sexpr)))
([p context] ([p context]
(if (if

15
test/beowulf/bootstrap_test.clj
View file

@ -51,6 +51,21 @@
actual (ATOM? (gsp "(A B C D)"))] actual (ATOM? (gsp "(A B C D)"))]
(is (= actual expected) "A list is explicitly not an atom")))) (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 (deftest access-function-tests
(testing "CAR" (testing "CAR"
(let [expected 'A (let [expected 'A

4
test/beowulf/interop_test.clj
View file

@ -8,11 +8,11 @@
(deftest interop-test (deftest interop-test
(testing "INTEROP called from Clojure" (testing "INTEROP called from Clojure"
(let [expected '123 (let [expected (symbol "123")
actual (INTEROP (gsp "(CLOJURE CORE STR)") (gsp "(1 2 3)"))] actual (INTEROP (gsp "(CLOJURE CORE STR)") (gsp "(1 2 3)"))]
(is (= actual expected)))) (is (= actual expected))))
(testing "INTEROP called from Lisp" (testing "INTEROP called from Lisp"
(let [expected 'ABC (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)))) (is (= actual expected))))
) )