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

306
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
\a (uaf (.first l) (butlast path)) (try
\d (uaf (.getCdr l) (butlast path))))) (case (last path)
\a (uaf (.first 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`.
@ -189,8 +211,13 @@
;; robust if `x` and `y` are not the same length. ;; robust if `x` and `y` are not the same length.
(or (= NIL x) (= NIL y)) a (or (= NIL x) (= NIL y)) a
:else (make-cons-cell :else (make-cons-cell
(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
@ -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
@ -243,16 +270,28 @@
underscores cannot be represented with this scheme." underscores cannot be represented with this scheme."
[l] [l]
(if (if
(seq? l) (seq? l)
(symbol (symbol
(s/reverse (s/reverse
(s/replace-first (s/replace-first
(s/reverse (s/reverse
(s/join "." (map str l))) (s/join "." (map str l)))
"." "."
"/"))) "/")))
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,39 +314,50 @@
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]
(let (if-not (:strict *options*)
[q-name (if (let
[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)) (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 "`")
{:cause :interop {:cause :interop
: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)]
(cond (print (str "INTEROP: evaluating `" (cons f args') "`"))
(instance? beowulf.cons_cell.ConsCell result) result (flush)
(seq? result) (make-beowulf-list result) (let [result (eval (conj args' f))] ;; this has the potential to blow up the world
(symbol? result) result (println (str "; returning `" result "`"))
(string? result) (symbol result)
(number? result) result (cond
:else (throw (instance? beowulf.cons_cell.ConsCell result) result
(ex-info (coll? result) (make-beowulf-list result)
(str "INTEROP: Cannot return `" result "` to Lisp 1.5.") (symbol? result) result
{:cause :interop (string? result) (symbol result)
:detail :not-representable (number? result) result
:result result}))))) :else (throw
(ex-info
(str "INTEROP: Cannot return `" result "` to Lisp 1.5.")
{:cause :interop
:detail :not-representable
: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.
@ -316,29 +366,32 @@
[function args environment] [function args environment]
(cond (cond
(= (=
(ATOM? function) (ATOM? function)
T)(cond T) (cond
(= function 'CAR) (CAAR args) ;; TODO: doesn't check whether `function` is bound in the environment;
(= function 'CDR) (CDAR args) ;; we'll need that before we can bootstrap.
(= function 'CONS) (make-cons-cell (CAR args) (CADR args)) (= function 'CAR) (CAAR args)
(= function 'ATOM) (if (ATOM? (CAR args)) T NIL) (= function 'CDR) (CDAR args)
(= function 'EQ) (if (= (CAR args) (CADR args)) T NIL) (= function 'CONS) (make-cons-cell (CAR args) (CADR args))
:else (= function 'ATOM) (if (ATOM? (CAR args)) T NIL)
(APPLY (= function 'EQ) (if (= (CAR args) (CADR args)) T NIL)
(EVAL function environment) (= function 'INTEROP) (INTEROP (CAR args) (CDR args))
args :else
environment)) (APPLY
(EVAL function environment)
args
environment))
(= (first function) 'LAMBDA) (EVAL (= (first function) 'LAMBDA) (EVAL
(CADDR function)
(PAIRLIS (CADR function) args environment))
(= (first function) 'LABEL) (APPLY
(CADDR function) (CADDR function)
args (PAIRLIS (CADR function) args environment))
(= (first function) 'LABEL) (APPLY
(CADDR function)
args
(make-cons-cell
(make-cons-cell (make-cons-cell
(make-cons-cell (CADR function)
(CADR function) (CADDR function))
(CADDR function)) environment))))
environment))))
(defn- EVCON (defn- EVCON
"Inner guts of primitive COND. All args are assumed to be "Inner guts of primitive COND. All args are assumed to be
@ -346,7 +399,7 @@
See page 13 of the Lisp 1.5 Programmers Manual." See page 13 of the Lisp 1.5 Programmers Manual."
[clauses env] [clauses env]
(if (if
(not= (EVAL (CAAR clauses) env) NIL) (not= (EVAL (CAAR clauses) env) NIL)
(EVAL (CADAR clauses) env) (EVAL (CADAR clauses) env)
(EVCON (CDR clauses) env))) (EVCON (CDR clauses) env)))
@ -359,54 +412,59 @@
(= NIL args) NIL (= NIL args) NIL
:else :else
(make-cons-cell (make-cons-cell
(EVAL (CAR args) env) (EVAL (CAR args) env)
(EVLIS (CDR args) env)))) (EVLIS (CDR args) env))))
(defn eval-internal
"Common guts for both EVAL and traced-eval"
[expr env]
(cond
(= (NUMBERP expr) T) expr
(string? expr) (if (:strict *options*)
(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))
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)))
(deftrace traced-eval (deftrace traced-eval
"Essentially, identical to EVAL except traced." "Essentially, identical to EVAL except traced."
[expr env] [expr env]
(cond (eval-internal expr env))
(=
(ATOM? expr) T) ;; (defmacro EVAL
(CDR (ASSOC expr env)) ;; "For bootstrapping, at least, a version of EVAL written in Clojure.
(= ;; All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
(ATOM? (CAR expr)) ;; See page 13 of the Lisp 1.5 Programmers Manual."
T)(cond ;; [expr env]
(= (CAR expr) 'QUOTE) (CADR expr) ;; `(if
(= (CAR expr) 'COND) (EVCON (CDR expr) env) ;; (:trace *options*)
:else (APPLY ;; (traced-eval ~expr ~env)
(CAR expr) ;; (eval-internal ~expr ~env)))
(EVLIS (CDR expr) env)
env))
:else (APPLY
(CAR expr)
(EVLIS (CDR expr) env)
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)))

99
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,33 +99,42 @@
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
;; (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

20
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,18 +29,20 @@
(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
Exception Exception
e e
(let [data (ex-data e)] (let [data (ex-data e)]
(println (.getMessage e)) (println (.getMessage e))
(if (if
data data
(case (:cause data) (case (:cause data)
:parse-failure (println (:failure data)) :parse-failure (println (:failure data))
:strict nil ;; the message, which has already been printed, is enough. :strict nil ;; the message, which has already been printed, is enough.
@ -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)) " "))

39
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
;; top level: we accept mexprs as well as sexprs. ;; we tolerate whitespace and comments around legitimate input
"expr := mexpr | sexpr | opt-space expr opt-space;" "raw := expr | opt-comment expr opt-comment;"
;; top level: we accept mexprs as well as sexprs.
"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

246
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"))]
(binding [*in* r] ; Hider wilcuman. Béowulf is mín nama.
(split (with-out-str (-main)) #"\n")))]
; 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]
(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))))
)