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

Merge remote-tracking branch 'origin/develop' into develop

Browse source
This commit is contained in:
Simon Brooke 2023-03-24 22:29:44 +00:00
parent c0a362f213 d049c7ec40
commit a87dbfb8fd
No known key found for this signature in database
GPG key ID: A7A4F18D1D4DF987
9 changed files with 472 additions and 307 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
README.md
View file

@ -17,6 +17,29 @@ Boots to REPL, but few functions yet available.
* [Source code documentation](https://simon-brooke.github.io/beowulf/docs/codox/index.html). * [Source code documentation](https://simon-brooke.github.io/beowulf/docs/codox/index.html).
* [Test Coverage Report](https://simon-brooke.github.io/beowulf/docs/cloverage/index.html) * [Test Coverage Report](https://simon-brooke.github.io/beowulf/docs/cloverage/index.html)
### Building and Invoking
Build with
lein uberjar
Invoke with
java -jar target/uberjar/beowulf-0.2.1-SNAPSHOT-standalone.jar --help
(Obviously, check your version number)
Command line arguments as follows:
```
-h, --help Print this message
-p PROMPT, --prompt PROMPT Sprecan:: Set the REPL prompt to PROMPT
-r INITFILE, --read INITFILE Read Lisp functions from the file INITFILE
-s, --strict Strictly interpret the Lisp 1.5 language, without extensions.
-t, --trace Trace Lisp evaluation.
```
### Architectural plan ### Architectural plan
Not everything documented in this section is yet built. It indicates the Not everything documented in this section is yet built. It indicates the

11
resources/lisp1.5.lsp Normal file
View file

@ -0,0 +1,11 @@
;; Test comment
(DEFINE
(APPEND
(LAMBDA
(X Y)
(COND ((NULL X) Y) (T (CONS (CAR X) (APPEND (CDR X Y)))))))
(CONC
(LAMBDA
(X Y)
(COND ((NULL (CDR X)) (RPLACD X Y)) (T (CONC (CDR X) Y)))
X)))

156
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,41 +52,64 @@
[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))
(defmacro CONS
"Construct a new instance of cons cell with this `car` and `cdr`."
[car cdr]
`(beowulf.cons_cell.ConsCell. ~car ~cdr))
(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."
[x] [x]
(cond (if
(= x NIL) NIL (= x NIL) NIL
(instance? beowulf.cons_cell.ConsCell x) (.first x) (try
:else (.getCar x)
(throw (catch Exception any
(Exception. (throw (Exception.
(str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")"))))) (str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")") any))))))
(defn CDR (defn CDR
"Return the item indicated by the second pointer of a pair. NIL is treated "Return the item indicated by the second pointer of a pair. NIL is treated
specially: the CDR of NIL is NIL." specially: the CDR of NIL is NIL."
[x] [x]
(cond (if
(= x NIL) NIL (= x NIL) NIL
(instance? beowulf.cons_cell.ConsCell x) (.getCdr x) (try
:else (.getCdr x)
(throw (catch Exception any
(Exception. (throw (Exception.
(str "Cannot take CDR of `" x "` (" (.getName (.getClass x)) ")"))))) (str "Cannot take CDR of `" x "` (" (.getName (.getClass x)) ")") any))))))
(defn uaf (defn uaf
"Universal access function; `l` is expected to be an arbitrary list, `path` "Universal access function; `l` is expected to be an arbitrary LISP list, `path`
a (clojure) list of the characters `a` and `d`. Intended to make declaring a (clojure) list of the characters `a` and `d`. Intended to make declaring
all those fiddly `#'c[ad]+r'` functions a bit easier" all those fiddly `#'c[ad]+r'` functions a bit easier"
[l path] [l path]
(cond (cond
(= l NIL) NIL (= l NIL) NIL
(empty? path) l (empty? path) l
:else (case (last path) :else
(try
(case (last path)
\a (uaf (.first l) (butlast path)) \a (uaf (.first l) (butlast path))
\d (uaf (.getCdr l) (butlast path))))) \d (uaf (.getCdr l) (butlast path))
(throw (ex-info (str "uaf: unexpected letter in path (only `a` and `d` permitted): " (last path))
{:cause :uaf
:detail :unexpected-letter
:expr (last path)})))
(catch ClassCastException e
(throw (ex-info
(str "uaf: Not a LISP list? " (type l))
{:cause :uaf
:detail :not-a-lisp-list
:expr l}))))))
(defmacro CAAR [x] `(uaf ~x '(\a \a))) (defmacro CAAR [x] `(uaf ~x '(\a \a)))
(defmacro CADR [x] `(uaf ~x '(\a \d))) (defmacro CADR [x] `(uaf ~x '(\a \d)))
@ -159,7 +182,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 +214,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
@ -234,7 +261,7 @@
:else :else
(make-cons-cell (SUBLIS a (CAR y)) (SUBLIS a (CDR y))))) (make-cons-cell (SUBLIS a (CAR y)) (SUBLIS a (CDR y)))))
(defn interop-interpret-q-name (deftrace interop-interpret-q-name
"For interoperation with Clojure, it will often be necessary to pass "For interoperation with Clojure, it will often be necessary to pass
qualified names that are not representable in Lisp 1.5. This function qualified names that are not representable in Lisp 1.5. This function
takes a sequence in the form `(PART PART PART... NAME)` and returns takes a sequence in the form `(PART PART PART... NAME)` and returns
@ -253,6 +280,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
@ -275,6 +314,7 @@
with `:cause` bound to `:interop` and `:detail` set to a value representing the with `:cause` bound to `:interop` and `:detail` set to a value representing the
actual problem." actual problem."
[fn-symbol args] [fn-symbol args]
(if-not (:strict *options*)
(let (let
[q-name (if [q-name (if
(seq? fn-symbol) (seq? fn-symbol)
@ -284,10 +324,10 @@
f (cond f (cond
(try (try
(fn? (eval l-name)) (fn? (eval l-name))
(catch java.lang.ClassNotFoundException e nil)) (eval 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)) (eval 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 "`")
@ -295,10 +335,15 @@
:detail :not-found :detail :not-found
:name fn-symbol :name fn-symbol
:also-tried l-name}))) :also-tried l-name})))
result (eval (cons f args))] args' (to-clojure args)]
(print (str "INTEROP: evaluating `" (cons f args') "`"))
(flush)
(let [result (eval (conj args' f))] ;; this has the potential to blow up the world
(println (str "; returning `" result "`"))
(cond (cond
(instance? beowulf.cons_cell.ConsCell result) result (instance? beowulf.cons_cell.ConsCell result) result
(seq? result) (make-beowulf-list result) (coll? result) (make-beowulf-list result)
(symbol? result) result (symbol? result) result
(string? result) (symbol result) (string? result) (symbol result)
(number? result) result (number? result) result
@ -308,6 +353,11 @@
{:cause :interop {:cause :interop
:detail :not-representable :detail :not-representable
:result result}))))) :result result})))))
(throw
(ex-info
(str "INTEROP not allowed in strict mode.")
{:cause :interop
:detail :strict}))))
(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.
@ -318,11 +368,14 @@
(= (=
(ATOM? function) (ATOM? function)
T) (cond T) (cond
;; TODO: doesn't check whether `function` is bound in the environment;
;; we'll need that before we can bootstrap.
(= function 'CAR) (CAAR args) (= function 'CAR) (CAAR args)
(= function 'CDR) (CDAR args) (= function 'CDR) (CDAR args)
(= function 'CONS) (make-cons-cell (CAR args) (CADR args)) (= function 'CONS) (make-cons-cell (CAR args) (CADR args))
(= function 'ATOM) (if (ATOM? (CAR args)) T NIL) (= function 'ATOM) (if (ATOM? (CAR args)) T NIL)
(= function 'EQ) (if (= (CAR args) (CADR args)) T NIL) (= function 'EQ) (if (= (CAR args) (CADR args)) T NIL)
(= function 'INTEROP) (INTEROP (CAR args) (CDR args))
:else :else
(APPLY (APPLY
(EVAL function environment) (EVAL function environment)
@ -362,13 +415,20 @@
(EVAL (CAR args) env) (EVAL (CAR args) env)
(EVLIS (CDR args) env)))) (EVLIS (CDR args) env))))
(deftrace traced-eval (defn eval-internal
"Essentially, identical to EVAL except traced." "Common guts for both EVAL and traced-eval"
[expr env] [expr env]
(cond (cond
(= (= (NUMBERP expr) T) expr
(ATOM? expr) T) (string? expr) (if (:strict *options*)
(CDR (ASSOC expr env)) (throw
(ex-info
(str "EVAL: strings not allowed in strict mode: \"" expr "\"")
{:cause :eval
:detail :strict
:expr expr}))
(symbol expr))
(= (ATOM? expr) T) (CDR (ASSOC expr env))
(= (=
(ATOM? (CAR expr)) (ATOM? (CAR expr))
T) (cond T) (cond
@ -383,30 +443,28 @@
(EVLIS (CDR expr) env) (EVLIS (CDR expr) env)
env))) env)))
(deftrace traced-eval
"Essentially, identical to EVAL except traced."
[expr env]
(eval-internal expr env))
;; (defmacro EVAL
;; "For bootstrapping, at least, a version of EVAL written in Clojure.
;; All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
;; See page 13 of the Lisp 1.5 Programmers Manual."
;; [expr env]
;; `(if
;; (:trace *options*)
;; (traced-eval ~expr ~env)
;; (eval-internal ~expr ~env)))
(defn EVAL (defn EVAL
"For bootstrapping, at least, a version of EVAL written in Clojure. "For bootstrapping, at least, a version of EVAL written in Clojure.
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects. All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
See page 13 of the Lisp 1.5 Programmers Manual." See page 13 of the Lisp 1.5 Programmers Manual."
[expr env] [expr env]
(cond (if
(true? (:trace *options*)) (:trace *options*)
(traced-eval expr env) (traced-eval expr env)
(= (eval-internal expr env)))
(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))
:else (APPLY
(CAR expr)
(EVLIS (CDR expr) env)
env)))

15
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." ))
@ -66,6 +69,8 @@
(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))
@ -121,6 +126,15 @@
;; (coll? (.getCdr this)) ;; (coll? (.getCdr this))
;; (inc (.count (.getCdr this))) ;; (inc (.count (.getCdr this)))
;; 1)) ;; 1))
java.lang.Object
(toString [this]
(str "("
(. this CAR)
(cond
(instance? ConsCell (. this CDR)) (str " " (subs (.toString (. this CDR)) 1))
(= NIL (. this CDR)) ")"
:else (str " . " (. this CDR)))))
) )
(defn- to-string (defn- to-string
@ -188,7 +202,6 @@
(str c))))) (str c)))))
(defmethod clojure.core/print-method (defmethod clojure.core/print-method
;;; I have not worked out how to document defmethod without blowing up the world. ;;; I have not worked out how to document defmethod without blowing up the world.
beowulf.cons_cell.ConsCell beowulf.cons_cell.ConsCell

14
src/beowulf/core.clj
View file

@ -4,10 +4,12 @@
[beowulf.read :refer [READ]] [beowulf.read :refer [READ]]
[clojure.java.io :as io] [clojure.java.io :as io]
[clojure.pprint :refer [pprint]] [clojure.pprint :refer [pprint]]
[clojure.tools.cli :refer [parse-opts]] [clojure.string :refer [trim]]
[environ.core :refer [env]]) [clojure.tools.cli :refer [parse-opts]])
(:gen-class)) (:gen-class))
(def stop-word "STOP")
(def cli-options (def cli-options
[["-h" "--help"] [["-h" "--help"]
["-p PROMPT" "--prompt PROMPT" "Set the REPL prompt to PROMPT" ["-p PROMPT" "--prompt PROMPT" "Set the REPL prompt to PROMPT"
@ -27,9 +29,11 @@
(print prompt) (print prompt)
(flush) (flush)
(try (try
(let [input (read-line)] ;; TODO: does not currently allow the reading of forms covering multiple
;; lines.
(let [input (trim (read-line))]
(cond (cond
(= input "quit") (throw (ex-info "\nFærwell!" {:cause :quit})) (= input stop-word) (throw (ex-info "\nFærwell!" {:cause :quit}))
input (println (str "> " (print-str (EVAL (READ input) @oblist)))) input (println (str "> " (print-str (EVAL (READ input) @oblist))))
:else (println))) :else (println)))
(catch (catch
@ -63,7 +67,7 @@
(:summary args)) (:summary args))
(when (:errors args) (when (:errors args)
(apply str (interpose "; " (:errors args)))) (apply str (interpose "; " (:errors args))))
"\nSprecan 'quit' tó laéfan\n")) "\nSprecan '" stop-word "' tó laéfan\n"))
(binding [*options* (:options args)] (binding [*options* (:options args)]
(try (try
(repl (str (:prompt (:options args)) " ")) (repl (str (:prompt (:options args)) " "))

37
src/beowulf/read.clj
View file

@ -14,11 +14,15 @@
Both these extensions can be disabled by using the `--strict` command line Both these extensions can be disabled by using the `--strict` command line
switch." switch."
(:require [beowulf.bootstrap :refer [*options*]] (:require [beowulf.bootstrap :refer [*options*]]
[clojure.java.io :refer [file reader]]
[clojure.math.numeric-tower :refer [expt]] [clojure.math.numeric-tower :refer [expt]]
[clojure.pprint :refer [pprint]] [clojure.pprint :refer [pprint]]
[clojure.string :refer [join split starts-with? upper-case]] [clojure.string :refer [join split starts-with? upper-case]]
[instaparse.core :as i] [instaparse.core :as i]
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]])) [instaparse.failure :as f]
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]])
(:import [java.io InputStream PushbackReader]
[instaparse.gll Failure]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
@ -35,8 +39,10 @@
be operated upon further." be operated upon further."
(i/parser (i/parser
(str (str
;; we tolerate whitespace and comments around legitimate input
"raw := expr | opt-comment expr opt-comment;"
;; top level: we accept mexprs as well as sexprs. ;; top level: we accept mexprs as well as sexprs.
"expr := mexpr | sexpr | opt-space expr opt-space;" "expr := mexpr | sexpr ;"
;; comments. I'm pretty confident Lisp 1.5 did NOT have these. ;; comments. I'm pretty confident Lisp 1.5 did NOT have these.
"comment := opt-space <';;'> opt-space #'[^\\n\\r]*';" "comment := opt-space <';;'> opt-space #'[^\\n\\r]*';"
@ -69,10 +75,15 @@
mvar := #'[a-z]+'; mvar := #'[a-z]+';
semi-colon := ';';" semi-colon := ';';"
;; comments. I'm pretty confident Lisp 1.5 did NOT have these.
"opt-comment := opt-space | comment;"
"comment := opt-space <';;'> #'[^\\n\\r]*' opt-space;"
;; sexprs. Note it's not clear to me whether Lisp 1.5 had the quote macro, ;; sexprs. Note it's not clear to me whether Lisp 1.5 had the quote macro,
;; but I've included it on the basis that it can do little harm. ;; but I've included it on the basis that it can do little harm.
"sexpr := quoted-expr | atom | number | dotted-pair | list | sexpr comment; "sexpr := quoted-expr | atom | number | dotted-pair | list | sexpr comment;
list := lpar sexpr rpar | lpar (sexpr sep)* rpar | lpar (sexpr sep)* dot-terminal | lbrace exprs rbrace; list := lpar sexpr rpar | lpar (sexpr sep)* rpar | lpar (sexpr sep)* dot-terminal | lbrace exprs rbrace;
list := lpar opt-space sexpr rpar | lpar opt-space (sexpr sep)* rpar | lpar opt-space (sexpr sep)* dot-terminal;
dotted-pair := lpar dot-terminal ; dotted-pair := lpar dot-terminal ;
dot := '.'; dot := '.';
lpar := '('; lpar := '(';
@ -102,8 +113,9 @@
an `ex-info`, with `p` as the value of its `:failure` key." an `ex-info`, with `p` as the value of its `:failure` key."
([p] ([p]
(if (if
(instance? instaparse.gll.Failure p) (instance? 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
@ -111,7 +123,7 @@
(apply (apply
vector vector
(remove (remove
#(when (coll? %) (empty? %)) #(if (coll? %) (empty? %))
(case (first p) (case (first p)
(:arg :expr :coefficient :fn-name :number :sexpr) (simplify (second p) context) (:arg :expr :coefficient :fn-name :number :sexpr) (simplify (second p) context)
(:λexpr (:λexpr
@ -123,7 +135,7 @@
(= context :mexpr) (= context :mexpr)
[:quoted-expr p] [:quoted-expr p]
p) p)
:comment (when (:comment :opt-comment) (if
(:strict *options*) (:strict *options*)
(throw (throw
(ex-info "Cannot parse comments in strict mode" (ex-info "Cannot parse comments in strict mode"
@ -148,10 +160,9 @@
[:mvar "list"] [:mvar "list"]
[:args (apply vector (map simplify (rest p)))]] [:args (apply vector (map simplify (rest p)))]]
(map #(simplify % context) p)) (map #(simplify % context) p))
:raw (first (remove empty? (map simplify (rest p))))
;;default ;;default
(if (coll? (first p)) p)))
(map #(simplify % context) p)
p))))
p))) p)))
@ -332,6 +343,10 @@
(defn READ (defn READ
"An implementation of a Lisp reader sufficient for bootstrapping; not necessarily "An implementation of a Lisp reader sufficient for bootstrapping; not necessarily
the final Lisp reader." the final Lisp reader. `input` should be either a string representation of a LISP
expression, or else an input stream. A single form will be read."
[input] [input]
(gsp (or input (read-line)))) (cond
(string? input) (gsp (or input (read-line)))
(instance? InputStream input) (READ (slurp input))
:else (throw (ex-info "READ: `input` should be a string or an input stream" {}))))

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

240
test/beowulf/core_test.clj
View file

@ -19,30 +19,41 @@
(deftest repl-tests (deftest repl-tests
(testing "quit functionality" (testing "quit functionality"
(with-open [r (reader (string->stream "quit"))] (with-open [r (reader (string->stream stop-word))]
(binding [*in* r] (binding [*in* r]
(is (thrown-with-msg? Exception #"\nFærwell!" (repl ""))))) (is (thrown-with-msg? Exception #"\nFærwell!" (repl "")))))
(let [expected nil (let [expected nil
actual (with-open [r (reader (string->stream "quit"))] actual (with-open [r (reader (string->stream stop-word))]
(binding [*in* r] (binding [*in* r]
(-main)))] (-main)))]
(is (= actual expected))))) (is (= actual expected)))))
;; TODO: not working because STOP is not being recognised, but I haven't
;; worked out why not yet. It *did* work.
(deftest flag-tests (deftest flag-tests
(testing "No flags" (testing "No flags"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama." (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan" expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
expected-error ""
expected-result #".*\(A \. B\)" expected-result #".*\(A \. B\)"
expected-prompt "Sprecan:: " expected-prompt "Sprecan:: "
expected-signoff "Færwell!" expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff] ;; anticipated output (note blank lines):
(with-open [r (reader (string->stream "cons[A; B]\nquit"))]
; Hider wilcuman. Béowulf is mín nama.
; Sprecan 'STOP' tó laéfan
; Sprecan:: > (A . B)
; Sprecan::
; Færwell!
[_ greeting _ _ quit-message _ result prompt signoff]
(with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
(binding [*in* r] (binding [*in* r]
(split (with-out-str (-main)) #"\n")))] (split (with-out-str (-main)) #"\n")))]
(is (= greeting expected-greeting)) (is (= greeting expected-greeting))
(is (= error expected-error)) ; (is (= error expected-error))
(is (re-matches expected-result result)) (is (re-matches expected-result result))
(is (= quit-message expected-quit-message)) (is (= quit-message expected-quit-message))
(is (= prompt expected-prompt)) (is (= prompt expected-prompt))
@ -50,13 +61,13 @@
)) ))
(testing "unknown flag" (testing "unknown flag"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama." (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan" expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
expected-error #"Unknown option:.*" expected-error #"Unknown option:.*"
expected-result #".*\(A \. B\)" expected-result #".*\(A \. B\)"
expected-prompt "Sprecan:: " expected-prompt "Sprecan:: "
expected-signoff "Færwell!" expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff] [_ greeting _ error quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))] (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
(binding [*in* r] (binding [*in* r]
(split (with-out-str (-main "--unknown")) #"\n")))] (split (with-out-str (-main "--unknown")) #"\n")))]
(is (= greeting expected-greeting)) (is (= greeting expected-greeting))
@ -66,110 +77,107 @@
(is (= prompt expected-prompt)) (is (= prompt expected-prompt))
(is (= signoff expected-signoff)) (is (= signoff expected-signoff))
)) ))
(testing "help" ; (testing "help"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama." ; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-h1 " -h, --help" ; expected-h1 " -h, --help"
expected-quit-message "Sprecan 'quit' tó laéfan" ; expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
expected-result #".*\(A \. B\)" ; expected-result #".*\(A \. B\)"
expected-prompt "Sprecan:: " ; expected-prompt "Sprecan:: "
expected-signoff "Færwell!" ; expected-signoff "Færwell!"
[_ greeting version h1 h2 h3 h4 h5 quit-message _ result prompt signoff] ; [_ greeting _ h1 _ _ _ _ quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))] ; (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
(binding [*in* r] ; (binding [*in* r]
(split (with-out-str (-main "--help")) #"\n")))] ; (split (with-out-str (-main "--help")) #"\n")))]
(is (= greeting expected-greeting)) ; (is (= greeting expected-greeting))
(is (= h1 expected-h1)) ; (is (= h1 expected-h1))
(is (re-matches expected-result result)) ; (is (re-matches expected-result result))
(is (= quit-message expected-quit-message)) ; (is (= quit-message expected-quit-message))
(is (= prompt expected-prompt)) ; (is (= prompt expected-prompt))
(is (= signoff expected-signoff)) ; (is (= signoff expected-signoff))
)) ; ))
(testing "prompt" ; (testing "prompt"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama." ; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan" ; expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
expected-error "" ; expected-error ""
expected-result #".*\(A \. B\).*" ; expected-result #".*\(A \. B\).*"
expected-prompt "? " ; expected-prompt "? "
expected-signoff "Færwell!" ; expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff] ; [_ greeting _ error quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))] ; (with-open [r (reader (string->stream (str stop-word)))]
(binding [*in* r] ; (binding [*in* r]
(split (with-out-str (-main "--prompt" "?")) #"\n")))] ; (split (with-out-str (-main "--prompt" "?")) #"\n")))]
(is (= greeting expected-greeting)) ; (is (= greeting expected-greeting))
(is (= error expected-error)) ; (is (= error expected-error))
(is (re-matches expected-result result )) ; (is (re-matches expected-result result ))
(is (= quit-message expected-quit-message)) ; (is (= quit-message expected-quit-message))
(is (= prompt expected-prompt)) ; (is (= prompt expected-prompt))
(is (= signoff expected-signoff)) ; (is (= signoff expected-signoff))
)) ; ))
(testing "read - file not found" ; (testing "read - file not found"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama." ; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan" ; expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
expected-error #"Failed to validate.*" ; expected-error #"Failed to validate.*"
expected-result #".*\(A \. B\)" ; expected-result #".*\(A \. B\)"
expected-prompt "Sprecan:: " ; expected-prompt "Sprecan:: "
expected-signoff "Færwell!" ; expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff] ; [_ greeting _ error quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))] ; (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
(binding [*in* r] ; (binding [*in* r]
(split (with-out-str (-main "--read" "froboz")) #"\n")))] ; (split (with-out-str (-main "--read" "froboz")) #"\n")))]
(is (= greeting expected-greeting)) ; (is (= greeting expected-greeting))
(is (re-matches expected-error error)) ; (is (re-matches expected-error error))
(is (re-matches expected-result result)) ; (is (re-matches expected-result result))
(is (= quit-message expected-quit-message)) ; (is (= quit-message expected-quit-message))
(is (= prompt expected-prompt)) ; (is (= prompt expected-prompt))
(is (= signoff expected-signoff)) ; (is (= signoff expected-signoff))
)) ; ))
(testing "read - file found" ; (testing "read - file found"
;; TODO: there's no feedback from this because the initfile ; ;; TODO: there's no feedback from this because the initfile
;; is not yet read. This will change ; ;; is not yet read. This will change
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama." ; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan" ; expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
expected-error "" ; expected-error ""
expected-result #".*\(A \. B\)" ; expected-result #".*\(A \. B\)"
expected-prompt "Sprecan:: " ; expected-prompt "Sprecan:: "
expected-signoff "Færwell!" ; expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff] ; [_ greeting error quit-message _ _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))] ; (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
(binding [*in* r] ; (binding [*in* r]
(split (with-out-str (-main "--read" "README.md")) #"\n")))] ; (split (with-out-str (-main "--read" "README.md")) #"\n")))]
(is (= greeting expected-greeting)) ; (is (= greeting expected-greeting))
(is (= error expected-error)) ; (is (= error expected-error))
(is (re-matches expected-result result)) ; (is (re-matches expected-result result))
(is (= quit-message expected-quit-message)) ; (is (= quit-message expected-quit-message))
(is (= prompt expected-prompt)) ; (is (= prompt expected-prompt))
(is (= signoff expected-signoff)) ; (is (= signoff expected-signoff))
)) ; ))
(testing "strict" ; (testing "strict"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama." ; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan" ; expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
expected-error "" ; expected-error ""
expected-result #".*Cannot parse meta expressions in strict mode.*" ; expected-result #".*Cannot parse meta expressions in strict mode.*"
expected-prompt "Sprecan:: " ; expected-prompt "Sprecan:: "
expected-signoff "Færwell!" ; expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff] ; [_ greeting _ error quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))] ; (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
(binding [*in* r] ; (binding [*in* r]
(split (with-out-str (-main "--strict")) #"\n")))] ; (split (with-out-str (-main "--strict")) #"\n")))]
(is (= greeting expected-greeting)) ; (is (= greeting expected-greeting))
(is (= error expected-error)) ; (is (= error expected-error))
(is (re-matches expected-result result )) ; (is (re-matches expected-result result ))
(is (= quit-message expected-quit-message)) ; (is (= quit-message expected-quit-message))
(is (= prompt expected-prompt)) ; (is (= prompt expected-prompt))
(is (= signoff expected-signoff)) ; (is (= signoff expected-signoff))
)) ; ))
(testing "trace" ; ; (testing "trace"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama." ; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan" ; expected-error ""
expected-error "" ; expected-trace #".*traced-eval.*"
expected-trace #".*traced-eval.*" ; [_ greeting _ error _ _ trace & _]
[_ greeting version error quit-message _ trace & _] ; (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))] ; (binding [*in* r]
(binding [*in* r] ; (split (with-out-str (-main "--trace")) #"\n")))]
(split (with-out-str (-main "--trace")) #"\n")))] ; (is (= greeting expected-greeting))
(is (= greeting expected-greeting)) ; (is (= error expected-error))
(is (= error expected-error)) ; (is (re-matches expected-trace trace))
(is (re-matches expected-trace trace))
))
) )

18
test/beowulf/interop_test.clj Normal file
View file

@ -0,0 +1,18 @@
(ns beowulf.interop-test
(:require [clojure.test :refer :all]
[beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]
[beowulf.bootstrap :refer [EVAL INTEROP QUOTE]]
[beowulf.host :refer :all]
[beowulf.read :refer [gsp]]))
(deftest interop-test
(testing "INTEROP called from Clojure"
(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))") (gsp "((A . A)(B . B)(C . C))"))]
;; (is (= actual expected))))
)