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

89
src/beowulf/cons_cell.clj
View file

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

3
src/beowulf/read.clj
View file

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

15
test/beowulf/bootstrap_test.clj
View file

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

4
test/beowulf/interop_test.clj
View file

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