From b5e418118bdef98c7043da7f7b720c895b5fbc11 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 26 Mar 2023 11:50:56 +0100 Subject: [PATCH] Modularised the reader; some general improvement --- src/beowulf/bootstrap.clj | 76 ++++-- src/beowulf/cons_cell.clj | 150 ++++++------ src/beowulf/core.clj | 6 +- src/beowulf/read.clj | 405 ++------------------------------ src/beowulf/reader/generate.clj | 198 ++++++++++++++++ src/beowulf/reader/parser.clj | 84 +++++++ src/beowulf/reader/simplify.clj | 94 ++++++++ test/beowulf/bootstrap_test.clj | 35 +-- test/beowulf/cons_cell_test.clj | 7 +- test/beowulf/core_test.clj | 14 +- test/beowulf/host_test.clj | 22 +- test/beowulf/interop_test.clj | 4 +- test/beowulf/mexpr_test.clj | 24 +- test/beowulf/sexpr_test.clj | 31 ++- 14 files changed, 594 insertions(+), 556 deletions(-) create mode 100644 src/beowulf/reader/generate.clj create mode 100644 src/beowulf/reader/parser.clj create mode 100644 src/beowulf/reader/simplify.clj diff --git a/src/beowulf/bootstrap.clj b/src/beowulf/bootstrap.clj index ade18df..4e54623 100644 --- a/src/beowulf/bootstrap.clj +++ b/src/beowulf/bootstrap.clj @@ -11,7 +11,11 @@ objects." (:require [clojure.string :as s] [clojure.tools.trace :refer [deftrace]] - [beowulf.cons-cell :refer [cons-cell? make-beowulf-list make-cons-cell NIL pretty-print T F]])) + [beowulf.cons-cell :refer [cons-cell? make-beowulf-list make-cons-cell + NIL pretty-print T F]] + [beowulf.host :refer [ADD1 DIFFERENCE FIXP NUMBERP PLUS2 QUOTIENT + REMAINDER RPLACA RPLACD SUB1 TIMES2]]) + (:import [beowulf.cons_cell ConsCell])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -57,12 +61,6 @@ [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)) - (defmacro CONS "Construct a new instance of cons cell with this `car` and `cdr`." [car cdr] @@ -75,7 +73,7 @@ (if (= x NIL) NIL (try - (.getCar x) + (or (.getCar x) NIL) (catch Exception any (throw (Exception. (str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")") any)))))) @@ -109,7 +107,7 @@ {:cause :uaf :detail :unexpected-letter :expr (last path)}))) - (catch ClassCastException e + (catch ClassCastException e (throw (ex-info (str "uaf: Not a LISP list? " (type l)) {:cause :uaf @@ -149,9 +147,12 @@ (defn EQ "Returns `T` if and only if both `x` and `y` are bound to the same atom, - else `F`." + else `NIL`." [x y] - (if (and (= (ATOM x) T) (= x y)) T F)) + (cond (and (instance? ConsCell x) + (.equals x y)) T + (and (= (ATOM x) T) (= x y)) T + :else NIL)) (defn EQUAL "This is a predicate that is true if its two arguments are identical @@ -162,7 +163,7 @@ NOTE: returns `F` on failure, not `NIL`" [x y] (cond - (= (ATOM x) T) (EQ x y) + (= (ATOM x) T) (if (= x y) T F) (= (EQUAL (CAR x) (CAR y)) T) (EQUAL (CDR x) (CDR y)) :else F)) @@ -378,10 +379,10 @@ "Not certain whether or not this is part of LISP 1.5; adapted from PSL. return the current value of the object list. Note that in PSL this function returns a list of the symbols bound, not the whole association list." - [args] - (@oblist)) + [] + (make-beowulf-list (map CAR @oblist))) -(deftrace DEFINE +(defn DEFINE "Bootstrap-only version of `DEFINE` which, post boostrap, can be overwritten in LISP. @@ -399,7 +400,18 @@ (pretty-print a) a) (recur (CDR cursor) a)))) - (CAR args))) + (CAR args))) + +(defn SET + "Implementation of SET in Clojure. Add to the `oblist` a binding of the + value of `var` to the value of `val`. NOTE WELL: this is not SETQ!" + [symbol val] + (doall + (swap! + oblist + (fn [ob s v] (make-cons-cell (make-cons-cell s v) ob)) + symbol val) + NIL)) (defn APPLY "For bootstrapping, at least, a version of APPLY written in Clojure. @@ -407,23 +419,32 @@ See page 13 of the Lisp 1.5 Programmers Manual." [function args environment] (cond + (= NIL function) (throw (ex-info "NIL is not a function" {:context "APPLY" + :function "NIL" + :args args})) (= (ATOM? function) T) (cond - ;; TODO: doesn't check whether `function` is bound in the environment; - ;; we'll need that before we can bootstrap. + ;; (fn? (eval function)) (apply (eval function) args) + (not= + (ASSOC function environment) + NIL) (APPLY (CDR (ASSOC function environment)) args environment) + (= function 'ATOM) (if (ATOM? (CAR args)) T NIL) (= function 'CAR) (CAAR args) (= function 'CDR) (CDAR args) (= function 'CONS) (make-cons-cell (CAR args) (CADR args)) (= function 'DEFINE) (DEFINE args) - (= function 'ATOM) (if (ATOM? (CAR args)) T NIL) - (= function 'EQ) (if (= (CAR args) (CADR args)) T NIL) + (= function 'EQ) (apply EQ args) (= function 'INTEROP) (INTEROP (CAR args) (CDR args)) - :else - (APPLY + (= function 'SET) (SET (CAR args) (CADR args)) + (EVAL function environment)(APPLY (EVAL function environment) args - environment)) + environment) + :else + (throw (ex-info "No function found" {:context "APPLY" + :function function + :args args}))) (fn? function) ;; i.e., it's a Clojure function (apply function (to-clojure args)) (= (first function) 'LAMBDA) (EVAL @@ -508,8 +529,11 @@ "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 + ([expr] + (EVAL expr @oblist)) + ([expr env] + (if (:trace *options*) (traced-eval expr env) - (eval-internal expr env))) + (eval-internal expr env)))) + diff --git a/src/beowulf/cons_cell.clj b/src/beowulf/cons_cell.clj index f15106e..47f7e95 100644 --- a/src/beowulf/cons_cell.clj +++ b/src/beowulf/cons_cell.clj @@ -4,11 +4,7 @@ must have both CAR and CDR mutable, so cannot be implemented on top of Clojure lists.") -(declare cons-cell?) - -(def NIL - "The canonical empty list symbol." - (symbol "NIL")) +(declare cons-cell? NIL) (def T "The canonical true value." @@ -27,14 +23,18 @@ (rplacd [this value] "replace the rest (but-first; cdr) of this sequence with this value") - (getCar - [this] - "Return the first element of this sequence.") + (getCar + [this] + "Return the first element of this sequence.") (getCdr [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.") + (getUid + [this] + "Returns a unique identifier for this object") + ) -(deftype ConsCell [^:unsynchronized-mutable CAR ^:unsynchronized-mutable CDR] +(deftype ConsCell [^:unsynchronized-mutable CAR ^:unsynchronized-mutable CDR uid] ;; Note that, because the CAR and CDR fields are unsynchronised mutable - i.e. ;; plain old Java instance variables which can be written as well as read - ;; ConsCells are NOT thread safe. This does not matter, since Lisp 1.5 is @@ -73,13 +73,16 @@ (str "Invalid value in RPLACD: `" value "` (" (type value) ")") {:cause :bad-value :detail :rplaca})))) - (getCar [this] + + (getCar [this] (. this CAR)) (getCdr [this] - (. this CDR)) - + (. this CDR)) + (getUid [this] + (. this uid)) + clojure.lang.ISeq - (cons [this x] (ConsCell. x this)) + (cons [this x] (ConsCell. x this (gensym "c"))) (first [this] (.CAR this)) ;; next and more must return ISeq: ;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java @@ -101,7 +104,7 @@ clojure.lang.Sequential clojure.lang.IPersistentCollection - (empty [this] false) ;; a cons cell is by definition not empty. + (empty [this] (= this NIL)) ;; a cons cell is by definition not empty. (equiv [this other] (if (seq? other) (and @@ -120,26 +123,21 @@ false)) clojure.lang.Counted - (count [this] (loop [cell this + (count [this] (loop [cell this result 1] (if - (coll? (.getCdr this)) - (recur (.getCdr this) (inc result)) + (and (coll? (.getCdr cell)) (not= NIL (.getCdr cell))) + (recur (.getCdr cell) (inc result)) result))) -;; (if -;; (coll? (.getCdr this)) -;; (inc (.count (.getCdr this))) -;; 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))))) - ) + 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 "Printing ConsCells gave me a *lot* of trouble. This is an internal function @@ -151,22 +149,25 @@ n 0 s "("] (if - (instance? beowulf.cons_cell.ConsCell c) + (instance? beowulf.cons_cell.ConsCell c) (let [car (.first c) cdr (.getCdr c) - cons? (instance? beowulf.cons_cell.ConsCell cdr) + cons? (and + (instance? beowulf.cons_cell.ConsCell cdr) + (not (nil? cdr)) + (not= cdr NIL)) ss (str - s - (to-string car) - (cond - cons? - " " - (or (nil? cdr) (= cdr NIL)) - ")" - :else - (str " . " (to-string cdr) ")")))] + s + (to-string car) + (cond + (or (nil? cdr) (= cdr NIL)) + ")" + cons? + " " + :else + (str " . " (to-string cdr) ")")))] (if - cons? + cons? (recur cdr (inc n) ss) ss)) (str c)))) @@ -180,27 +181,27 @@ n (inc level) s "("] (if - (instance? beowulf.cons_cell.ConsCell c) + (instance? beowulf.cons_cell.ConsCell c) (let [car (.first c) cdr (.getCdr c) cons? (instance? beowulf.cons_cell.ConsCell cdr) print-width (count (print-str c)) indent (apply str (repeat n " ")) ss (str - s - (pretty-print car width n) - (cond - cons? - (if - (< (+ (count indent) print-width) width) - " " - (str "\n" indent)) - (or (nil? cdr) (= cdr NIL)) - ")" - :else - (str " . " (pretty-print cdr width n) ")")))] + s + (pretty-print car width n) + (cond + (or (nil? cdr) (= cdr NIL)) + ")" + cons? + (if + (< (+ (count indent) print-width) width) + " " + (str "\n" indent)) + :else + (str " . " (pretty-print cdr width n) ")")))] (if - cons? + cons? (recur cdr n ss) ss)) (str c))))) @@ -216,10 +217,14 @@ "Construct a new instance of cons cell with this `car` and `cdr`." [car cdr] (try - (ConsCell. car cdr) - (catch Exception any - (throw (ex-info "Cound not construct cons cell" {:car car - :cdr cdr} any))))) + (ConsCell. car cdr (gensym "c")) + (catch Exception any + (throw (ex-info "Cound not construct cons cell" {:car car + :cdr cdr} any))))) + +(def NIL + "The canonical empty list symbol." + 'NIL) (defn cons-cell? "Is this object `o` a beowulf cons-cell?" @@ -232,16 +237,17 @@ [x] (try (cond - (empty? x) NIL - (coll? x) (ConsCell. - (if + (empty? x) NIL + (coll? x) (ConsCell. + (if (coll? (first x)) - (make-beowulf-list (first x)) - (first x)) - (make-beowulf-list (rest x))) - :else - NIL) - (catch Exception any - (throw (ex-info "Could not construct Beowulf list" - {:content x} + (make-beowulf-list (first x)) + (first x)) + (make-beowulf-list (rest x)) + (gensym "c")) + :else + NIL) + (catch Exception any + (throw (ex-info "Could not construct Beowulf list" + {:content x} any))))) diff --git a/src/beowulf/core.clj b/src/beowulf/core.clj index 639b441..66d8dff 100644 --- a/src/beowulf/core.clj +++ b/src/beowulf/core.clj @@ -1,7 +1,7 @@ (ns beowulf.core "Essentially, the `-main` function and the bootstrap read-eval-print loop." (:require [beowulf.bootstrap :refer [EVAL oblist *options*]] - [beowulf.read :refer [READ]] + [beowulf.read :refer [READ read-from-console]] [clojure.java.io :as io] [clojure.pprint :refer [pprint]] [clojure.string :refer [trim]] @@ -31,7 +31,7 @@ (try ;; TODO: does not currently allow the reading of forms covering multiple ;; lines. - (let [input (trim (read-line))] + (let [input (trim (read-from-console))] (cond (= input stop-word) (throw (ex-info "\nFærwell!" {:cause :quit})) input (println (str "> " (print-str (EVAL (READ input) @oblist)))) @@ -41,7 +41,7 @@ e (let [data (ex-data e)] (println (.getMessage e)) - (if + (when data (case (:cause data) :parse-failure (println (:failure data)) diff --git a/src/beowulf/read.clj b/src/beowulf/read.clj index 9a1af2f..5757252 100644 --- a/src/beowulf/read.clj +++ b/src/beowulf/read.clj @@ -13,12 +13,10 @@ Both these extensions can be disabled by using the `--strict` command line switch." - (:require [beowulf.bootstrap :refer [*options*]] - [clojure.math.numeric-tower :refer [expt]] - [clojure.string :refer [join split starts-with? trim upper-case]] - [instaparse.core :as i] - [instaparse.failure :as f] - [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]]) + (:require [beowulf.reader.generate :refer [generate]] + [beowulf.reader.parser :refer [parse]] + [beowulf.reader.simplify :refer [simplify]] + [clojure.string :refer [join split starts-with? trim]]) (:import [java.io InputStream] [instaparse.gll Failure])) @@ -30,8 +28,6 @@ ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(declare generate) - (defn strip-line-comments "Strip blank lines and comment lines from this string `s`, expected to be Lisp source." @@ -55,386 +51,6 @@ (range) (split s #"\n")))))) -(def parse - "Parse a string presented as argument into a parse tree which can then - be operated upon further." - (i/parser - (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. - "expr := mexpr | sexpr ;" - - ;; comments. I'm pretty confident Lisp 1.5 did NOT have these. - "comment := opt-space <';;'> opt-space #'[^\\n\\r]*';" - - ;; there's a notation comprising a left brace followed by mexprs - ;; followed by a right brace which doesn't seem to be documented - ;; but I think must represent a prog(?) - - ;; "prog := lbrace exprs rbrace;" - ;; mexprs. I'm pretty clear that Lisp 1.5 could never read these, - ;; but it's a convenience. - - "exprs := expr | exprs;" - "mexpr := λexpr | fncall | defn | cond | mvar | iexpr | mexpr comment; - λexpr := λ lsqb bindings semi-colon body rsqb; - λ := 'λ'; - bindings := lsqb args rsqb; - body := (expr semi-colon opt-space)* expr; - fncall := fn-name lsqb args rsqb; - lsqb := '['; - rsqb := ']'; - lbrace := '{'; - rbrace := '}'; - defn := mexpr opt-space '=' opt-space mexpr; - cond := lsqb (opt-space cond-clause semi-colon opt-space)* cond-clause rsqb; - cond-clause := expr opt-space arrow opt-space expr opt-space; - arrow := '->'; - args := (opt-space expr semi-colon opt-space)* expr; - fn-name := mvar; - mvar := #'[a-z]+'; - semi-colon := ';';" - - ;; Infix operators appear in mexprs, e.g. on page 7. Ooops! - ;; I do not know what infix operators are considered legal. - "iexpr := iexp iop iexp; - iexp := mexpr | mvar | number | mexpr | opt-space iexp opt-space; - iop := '>' | '<' | '+' | '-' | '/' | '=' ;" - - ;; 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, - ;; but I've included it on the basis that it can do little harm. - "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 opt-space sexpr rpar | lpar opt-space (sexpr sep)* rpar | lpar opt-space (sexpr sep)* dot-terminal; - dotted-pair := lpar dot-terminal ; - dot := '.'; - lpar := '('; - rpar := ')'; - quoted-expr := quote sexpr; - quote := '\\''; - dot-terminal := sexpr space dot space sexpr rpar; - space := #'\\p{javaWhitespace}+'; - opt-space := #'\\p{javaWhitespace}*'; - sep := ',' | opt-space; - atom := #'[A-Z][A-Z0-9]*';" - - ;; Lisp 1.5 supported octal as well as decimal and scientific notation - "number := integer | decimal | scientific | octal; - integer := #'-?[1-9][0-9]*'; - decimal := #'-?[1-9][0-9]*\\.?[0-9]*' | #'0.[0-9]*'; - scientific := coefficient e exponent; - coefficient := decimal; - exponent := integer; - e := 'E'; - octal := #'[+-]?[0-7]+{1,12}' q scale-factor; - q := 'Q'; - scale-factor := #'[0-9]*'"))) - -(declare simplify) - -(defn simplify-second-of-two - "There are a number of possible simplifications such that if the `tree` has - only two elements, the second is semantically sufficient." - [tree context] - (if (= (count tree) 2) - (simplify (second tree) context) - tree)) - -(defn remove-optional-space - [tree] - (if (vector? tree) - (if (= :opt-space (first tree)) - nil - (remove nil? - (map remove-optional-space tree))) - tree)) - -(defn remove-nesting - [tree] - (let [tree' (remove-optional-space tree)] - (if-let [key (when (and (vector? tree') (keyword? (first tree'))) (first tree'))] - (loop [r tree'] - (if (and r (vector? r) (keyword? (first r))) - (if (= (first r) key) - (recur (simplify (second r) :foo)) - r) - r)) - tree'))) - - -(defn simplify - "Simplify this parse tree `p`. If `p` is an instaparse failure object, throw - an `ex-info`, with `p` as the value of its `:failure` key." - ([p] - (if - (instance? Failure p) - (throw (ex-info (str "Ic ne behæfd: " (f/pprint-failure p)) {:cause :parse-failure - :phase :simplify - :failure p})) - (simplify p :expr))) - ([p context] - (if - (coll? p) - (apply - vector - (remove - #(when (coll? %) (empty? %)) - (case (first p) - (:λexpr - :args :bindings :body :cond :cond-clause :defn :dot-terminal - :fncall :lhs :octal :quoted-expr :rhs :scientific) (map #(simplify % context) p) - (:arg :expr :coefficient :fn-name :number) (simplify (second p) context) - (:arrow :dot :e :lpar :lsqb :opt-comment :opt-space :q :quote :rpar :rsqb - :semi-colon :sep :space) nil - :atom (if - (= context :mexpr) - [:quoted-expr p] - p) - :comment (when - (:strict *options*) - (throw - (ex-info "Cannot parse comments in strict mode" - {:cause :strict}))) - :dotted-pair (if - (= context :mexpr) - [:fncall - [:mvar "cons"] - [:args - (simplify (nth p 1) context) - (simplify (nth p 2) context)]] - (map simplify p)) - :iexp (second (remove-nesting p)) - :iexpr [:iexpr - [:lhs (simplify (second p) context)] - (simplify (nth p 2) context) ;; really should be the operator - [:rhs (simplify (nth p 3) context)]] - :mexpr (if - (:strict *options*) - (throw - (ex-info "Cannot parse meta expressions in strict mode" - {:cause :strict})) - (simplify (second p) :mexpr)) - :list (if - (= context :mexpr) - [:fncall - [:mvar "list"] - [:args (apply vector (map simplify (rest p)))]] - (map #(simplify % context) p)) - :raw (first (remove empty? (map simplify (rest p)))) - :sexpr (simplify (second p) :sexpr) - ;;default - p))) - p))) - - -;; # From Lisp 1.5 Programmers Manual, page 10 -;; Note that I've retyped much of this, since copy/pasting out of PDF is less -;; than reliable. Any typos are mine. Quote starts [[ - -;; We are now in a position to define the universal LISP function -;; evalquote[fn;args], When evalquote is given a function and a list of arguments -;; for that function, it computes the value of the function applied to the arguments. -;; LISP functions have S-expressions as arguments. In particular, the argument "fn" -;; of the function evalquote must be an S-expression. Since we have been -;; writing functions as M-expressions, it is necessary to translate them into -;; S-expressions. - -;; The following rules define a method of translating functions written in the -;; meta-language into S-expressions. -;; 1. If the function is represented by its name, it is translated by changing -;; all of the letters to upper case, making it an atomic symbol. Thus is -;; translated to CAR. -;; 2. If the function uses the lambda notation, then the expression -;; λ[[x ..;xn]; ε] is translated into (LAMBDA (X1 ...XN) ε*), where ε* is the translation -;; of ε. -;; 3. If the function begins with label, then the translation of -;; label[α;ε] is (LABEL α* ε*). - -;; Forms are translated as follows: -;; 1. A variable, like a function name, is translated by using uppercase letters. -;; Thus the translation of varl is VAR1. -;; 2. The obvious translation of letting a constant translate into itself will not -;; work. Since the translation of x is X, the translation of X must be something -;; else to avoid ambiguity. The solution is to quote it. Thus X is translated -;; into (QUOTE X). -;; 3. The form fn[argl;. ..;argn] is translated into (fn* argl* ...argn*) -;; 4. The conditional expression [pl-el;...;pn-en] is translated into -;; (COND (p1* e1*)...(pn* en*)) - -;; ## Examples - -;; M-expressions S-expressions -;; x X -;; car CAR -;; car[x] (CAR X) -;; T (QUOTE T) -;; ff[car [x]] (FF (CAR X)) -;; [atom[x]->x; T->ff[car[x]]] (COND ((ATOM X) X) -;; ((QUOTE T)(FF (CAR X)))) -;; label[ff;λ[[x];[atom[x]->x; T->ff[car[x]]]]] (LABEL FF (LAMBDA (X) (COND -;; ((ATOM X) X) -;; ((QUOTE T)(FF (CAR X)))))) - -;; ]] quote ends - -(defn gen-cond-clause - "Generate a cond clause from this simplified parse tree fragment `p`; - returns `nil` if `p` does not represent a cond clause." - [p] - (when - (and (coll? p) (= :cond-clause (first p))) - (make-beowulf-list - (list (if (= (nth p 1) [:quoted-expr [:atom "T"]]) - 'T - (generate (nth p 1))) - (generate (nth p 2)))))) - -(defn gen-cond - "Generate a cond statement from this simplified parse tree fragment `p`; - returns `nil` if `p` does not represent a (MEXPR) cond statement." - [p] - (when - (and (coll? p) (= :cond (first p))) - (make-beowulf-list - (cons - 'COND - (map - generate - (rest p)))))) - -(defn gen-fn-call - "Generate a function call from this simplified parse tree fragment `p`; - returns `nil` if `p` does not represent a (MEXPR) function call." - [p] - (when - (and (coll? p) (= :fncall (first p)) (= :mvar (first (second p)))) - (make-cons-cell - (generate (second p)) - (generate (nth p 2))))) - - -(defn gen-dot-terminated-list - "Generate a list, which may be dot-terminated, from this partial parse tree - 'p'. Note that the function acts recursively and progressively decapitates - its argument, so that the argument will not always be a valid parse tree." - [p] - (cond - (empty? p) - NIL - (and (coll? (first p)) (= :dot-terminal (first (first p)))) - (let [dt (first p)] - (make-cons-cell - (generate (nth dt 1)) - (generate (nth dt 2)))) - :else - (make-cons-cell - (generate (first p)) - (gen-dot-terminated-list (rest p))))) - -(defn generate-defn - [tree] - (make-beowulf-list - (list 'SET - (list 'QUOTE (generate (-> tree second second))) - (list 'QUOTE - (cons 'LAMBDA - (cons (generate (nth (second tree) 2)) - (map generate (-> tree rest rest rest)))))))) - -(defn generate-set - "Actually not sure what the mexpr representation of set looks like" - [tree] - (throw (ex-info "Not Yet Implemented" {:feature "generate-set"}))) - -(defn generate-assign - "Generate an assignment statement based on this `tree`. If the thing - being assigned to is a function signature, then we have to do something - different to if it's an atom." - [tree] - (case (first (second tree)) - :fncall (generate-defn tree) - (:mvar :atom) (generate-set tree))) - -(defn strip-leading-zeros - "`read-string` interprets strings with leading zeros as octal; strip - any from this string `s`. If what's left is empty (i.e. there were - only zeros, return `\"0\"`." - ([s] - (strip-leading-zeros s "")) - ([s prefix] - (if - (empty? s) "0" - (case (first s) - (\+ \-) (strip-leading-zeros (subs s 1) (str (first s) prefix)) - "0" (strip-leading-zeros (subs s 1) prefix) - (str prefix s))))) - -(defn generate - "Generate lisp structure from this parse tree `p`. It is assumed that - `p` has been simplified." - [p] - (try - (if - (coll? p) - (case (first p) - :λ "LAMBDA" - :λexpr (make-cons-cell - (generate (nth p 1)) - (make-cons-cell (generate (nth p 2)) - (generate (nth p 3)))) - :args (make-beowulf-list (map generate (rest p))) - :atom (symbol (second p)) - :bindings (generate (second p)) - :body (make-beowulf-list (map generate (rest p))) - :cond (gen-cond p) - :cond-clause (gen-cond-clause p) - (:decimal :integer) (read-string (strip-leading-zeros (second p))) - :defn (generate-assign p) - :dotted-pair (make-cons-cell - (generate (nth p 1)) - (generate (nth p 2))) - :exponent (generate (second p)) - :fncall (gen-fn-call p) - :list (gen-dot-terminated-list (rest p)) - :mvar (symbol (upper-case (second p))) - :octal (let [n (read-string (strip-leading-zeros (second p) "0")) - scale (generate (nth p 2))] - (* n (expt 8 scale))) - - ;; the quote read macro (which probably didn't exist in Lisp 1.5, but...) - :quoted-expr (make-beowulf-list (list 'QUOTE (generate (second p)))) - :scale-factor (if - (empty? (second p)) 0 - (read-string (strip-leading-zeros (second p)))) - :scientific (let [n (generate (second p)) - exponent (generate (nth p 2))] - (* n (expt 10 exponent))) - - ;; default - (throw (ex-info (str "Unrecognised head: " (first p)) - {:generating p}))) - p) - (catch Throwable any - (throw (ex-info "Could not generate" - {:generating p} - any))))) - -;; (defn parse -;; "Parse string `s` into a parse tree which can then be operated upon further." -;; [s] -;; (let [r (parse-internal s)] -;; (when (instance? Failure r) -;; (throw -;; (ex-info "Parse failed" -;; (merge {:fail r :source s} r)))) -;; r)) - - (defn gsp "Shortcut macro - the internals of read; or, if you like, read-string. Argument `s` should be a string representation of a valid Lisp @@ -447,15 +63,24 @@ (throw (ex-info "Parse failed" (assoc parse-tree :source source)))) (generate (simplify parse-tree))))) +(defn read-from-console + "Attempt to read a complete lisp expression from the console." + [] + (loop [r (read-line)] + (if (= (count (re-seq #"\(" r)) + (count (re-seq #"\)" r))) + r + (recur (str r "\n" (read-line)))))) + (defn READ "An implementation of a Lisp reader sufficient for bootstrapping; not necessarily 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." ([] - (gsp (read-line))) + (gsp (read-from-console))) ([input] (cond - (empty? input) (gsp (read-line)) + (empty? input) (gsp (read-from-console)) (string? input) (gsp input) (instance? InputStream input) (READ (slurp input)) :else (throw (ex-info "READ: `input` should be a string or an input stream" {}))))) diff --git a/src/beowulf/reader/generate.clj b/src/beowulf/reader/generate.clj new file mode 100644 index 0000000..bd0d38f --- /dev/null +++ b/src/beowulf/reader/generate.clj @@ -0,0 +1,198 @@ +(ns beowulf.reader.generate + (:require [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]] + [clojure.math.numeric-tower :refer [expt]] + [clojure.string :refer [upper-case]])) + +;; # From Lisp 1.5 Programmers Manual, page 10 +;; Note that I've retyped much of this, since copy/pasting out of PDF is less +;; than reliable. Any typos are mine. Quote starts [[ + +;; We are now in a position to define the universal LISP function +;; evalquote[fn;args], When evalquote is given a function and a list of arguments +;; for that function, it computes the value of the function applied to the arguments. +;; LISP functions have S-expressions as arguments. In particular, the argument "fn" +;; of the function evalquote must be an S-expression. Since we have been +;; writing functions as M-expressions, it is necessary to translate them into +;; S-expressions. + +;; The following rules define a method of translating functions written in the +;; meta-language into S-expressions. +;; 1. If the function is represented by its name, it is translated by changing +;; all of the letters to upper case, making it an atomic symbol. Thus is +;; translated to CAR. +;; 2. If the function uses the lambda notation, then the expression +;; λ[[x ..;xn]; ε] is translated into (LAMBDA (X1 ...XN) ε*), where ε* is the translation +;; of ε. +;; 3. If the function begins with label, then the translation of +;; label[α;ε] is (LABEL α* ε*). + +;; Forms are translated as follows: +;; 1. A variable, like a function name, is translated by using uppercase letters. +;; Thus the translation of varl is VAR1. +;; 2. The obvious translation of letting a constant translate into itself will not +;; work. Since the translation of x is X, the translation of X must be something +;; else to avoid ambiguity. The solution is to quote it. Thus X is translated +;; into (QUOTE X). +;; 3. The form fn[argl;. ..;argn] is translated into (fn* argl* ...argn*) +;; 4. The conditional expression [pl-el;...;pn-en] is translated into +;; (COND (p1* e1*)...(pn* en*)) + +;; ## Examples + +;; M-expressions S-expressions +;; x X +;; car CAR +;; car[x] (CAR X) +;; T (QUOTE T) +;; ff[car [x]] (FF (CAR X)) +;; [atom[x]->x; T->ff[car[x]]] (COND ((ATOM X) X) +;; ((QUOTE T)(FF (CAR X)))) +;; label[ff;λ[[x];[atom[x]->x; T->ff[car[x]]]]] (LABEL FF (LAMBDA (X) (COND +;; ((ATOM X) X) +;; ((QUOTE T)(FF (CAR X)))))) + +;; ]] quote ends + +(declare generate) + +(defn gen-cond-clause + "Generate a cond clause from this simplified parse tree fragment `p`; + returns `nil` if `p` does not represent a cond clause." + [p] + (when + (and (coll? p) (= :cond-clause (first p))) + (make-beowulf-list + (list (if (= (nth p 1) [:quoted-expr [:atom "T"]]) + 'T + (generate (nth p 1))) + (generate (nth p 2)))))) + +(defn gen-cond + "Generate a cond statement from this simplified parse tree fragment `p`; + returns `nil` if `p` does not represent a (MEXPR) cond statement." + [p] + (when + (and (coll? p) (= :cond (first p))) + (make-beowulf-list + (cons + 'COND + (map + generate + (rest p)))))) + +(defn gen-fn-call + "Generate a function call from this simplified parse tree fragment `p`; + returns `nil` if `p` does not represent a (MEXPR) function call." + [p] + (when + (and (coll? p) (= :fncall (first p)) (= :mvar (first (second p)))) + (make-cons-cell + (generate (second p)) + (generate (nth p 2))))) + + +(defn gen-dot-terminated-list + "Generate a list, which may be dot-terminated, from this partial parse tree + 'p'. Note that the function acts recursively and progressively decapitates + its argument, so that the argument will not always be a valid parse tree." + [p] + (cond + (empty? p) + NIL + (and (coll? (first p)) (= :dot-terminal (first (first p)))) + (let [dt (first p)] + (make-cons-cell + (generate (nth dt 1)) + (generate (nth dt 2)))) + :else + (make-cons-cell + (generate (first p)) + (gen-dot-terminated-list (rest p))))) + +(defn generate-defn + [tree] + (make-beowulf-list + (list 'SET + (list 'QUOTE (generate (-> tree second second))) + (list 'QUOTE + (cons 'LAMBDA + (cons (generate (nth (second tree) 2)) + (map generate (-> tree rest rest rest)))))))) + +(defn generate-set + "Actually not sure what the mexpr representation of set looks like" + [tree] + (throw (ex-info "Not Yet Implemented" {:feature "generate-set"}))) + +(defn generate-assign + "Generate an assignment statement based on this `tree`. If the thing + being assigned to is a function signature, then we have to do something + different to if it's an atom." + [tree] + (case (first (second tree)) + :fncall (generate-defn tree) + (:mvar :atom) (generate-set tree))) + +(defn strip-leading-zeros + "`read-string` interprets strings with leading zeros as octal; strip + any from this string `s`. If what's left is empty (i.e. there were + only zeros, return `\"0\"`." + ([s] + (strip-leading-zeros s "")) + ([s prefix] + (if + (empty? s) "0" + (case (first s) + (\+ \-) (strip-leading-zeros (subs s 1) (str (first s) prefix)) + "0" (strip-leading-zeros (subs s 1) prefix) + (str prefix s))))) + +(defn generate + "Generate lisp structure from this parse tree `p`. It is assumed that + `p` has been simplified." + [p] + (try + (if + (coll? p) + (case (first p) + :λ "LAMBDA" + :λexpr (make-cons-cell + (generate (nth p 1)) + (make-cons-cell (generate (nth p 2)) + (generate (nth p 3)))) + :args (make-beowulf-list (map generate (rest p))) + :atom (symbol (second p)) + :bindings (generate (second p)) + :body (make-beowulf-list (map generate (rest p))) + :cond (gen-cond p) + :cond-clause (gen-cond-clause p) + (:decimal :integer) (read-string (strip-leading-zeros (second p))) + :defn (generate-assign p) + :dotted-pair (make-cons-cell + (generate (nth p 1)) + (generate (nth p 2))) + :exponent (generate (second p)) + :fncall (gen-fn-call p) + :list (gen-dot-terminated-list (rest p)) + :mvar (symbol (upper-case (second p))) + :octal (let [n (read-string (strip-leading-zeros (second p) "0")) + scale (generate (nth p 2))] + (* n (expt 8 scale))) + + ;; the quote read macro (which probably didn't exist in Lisp 1.5, but...) + :quoted-expr (make-beowulf-list (list 'QUOTE (generate (second p)))) + :scale-factor (if + (empty? (second p)) 0 + (read-string (strip-leading-zeros (second p)))) + :scientific (let [n (generate (second p)) + exponent (generate (nth p 2))] + (* n (expt 10 exponent))) + + ;; default + (throw (ex-info (str "Unrecognised head: " (first p)) + {:generating p}))) + p) + (catch Throwable any + (throw (ex-info "Could not generate" + {:generating p} + any))))) diff --git a/src/beowulf/reader/parser.clj b/src/beowulf/reader/parser.clj new file mode 100644 index 0000000..91acde0 --- /dev/null +++ b/src/beowulf/reader/parser.clj @@ -0,0 +1,84 @@ +(ns beowulf.reader.parser + "The actual parser, supporting both S-expression and M-expression syntax." + (:require [instaparse.core :as i])) + +(def parse + "Parse a string presented as argument into a parse tree which can then + be operated upon further." + (i/parser + (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. + "expr := mexpr | sexpr ;" + + ;; comments. I'm pretty confident Lisp 1.5 did NOT have these. + "comment := opt-space <';;'> opt-space #'[^\\n\\r]*';" + + ;; there's a notation comprising a left brace followed by mexprs + ;; followed by a right brace which doesn't seem to be documented + ;; but I think must represent a prog(?) + + ;; "prog := lbrace exprs rbrace;" + ;; mexprs. I'm pretty clear that Lisp 1.5 could never read these, + ;; but it's a convenience. + + "exprs := expr | exprs;" + "mexpr := λexpr | fncall | defn | cond | mvar | iexpr | mexpr comment; + λexpr := λ lsqb bindings semi-colon body rsqb; + λ := 'λ'; + bindings := lsqb args rsqb; + body := (expr semi-colon opt-space)* expr; + fncall := fn-name lsqb args rsqb; + lsqb := '['; + rsqb := ']'; + lbrace := '{'; + rbrace := '}'; + defn := mexpr opt-space '=' opt-space mexpr; + cond := lsqb (opt-space cond-clause semi-colon opt-space)* cond-clause rsqb; + cond-clause := expr opt-space arrow opt-space expr opt-space; + arrow := '->'; + args := (opt-space expr semi-colon opt-space)* expr; + fn-name := mvar; + mvar := #'[a-z]+'; + semi-colon := ';';" + + ;; Infix operators appear in mexprs, e.g. on page 7. Ooops! + ;; I do not know what infix operators are considered legal. + "iexpr := iexp iop iexp; + iexp := mexpr | mvar | number | mexpr | opt-space iexp opt-space; + iop := '>' | '<' | '+' | '-' | '/' | '=' ;" + + ;; 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, + ;; but I've included it on the basis that it can do little harm. + "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 opt-space sexpr rpar | lpar opt-space (sexpr sep)* rpar | lpar opt-space (sexpr sep)* dot-terminal; + dotted-pair := lpar dot-terminal ; + dot := '.'; + lpar := '('; + rpar := ')'; + quoted-expr := quote sexpr; + quote := '\\''; + dot-terminal := sexpr space dot space sexpr rpar; + space := #'\\p{javaWhitespace}+'; + opt-space := #'\\p{javaWhitespace}*'; + sep := ',' | opt-space; + atom := #'[A-Z][A-Z0-9]*';" + + ;; Lisp 1.5 supported octal as well as decimal and scientific notation + "number := integer | decimal | scientific | octal; + integer := #'-?[1-9][0-9]*'; + decimal := #'-?[1-9][0-9]*\\.?[0-9]*' | #'0.[0-9]*'; + scientific := coefficient e exponent; + coefficient := decimal; + exponent := integer; + e := 'E'; + octal := #'[+-]?[0-7]+{1,12}' q scale-factor; + q := 'Q'; + scale-factor := #'[0-9]*'"))) + diff --git a/src/beowulf/reader/simplify.clj b/src/beowulf/reader/simplify.clj new file mode 100644 index 0000000..48ed5d0 --- /dev/null +++ b/src/beowulf/reader/simplify.clj @@ -0,0 +1,94 @@ +(ns beowulf.reader.simplify + "Simplify parse trees. Be aware that this is very tightly coupled + with the parser." + (:require [beowulf.bootstrap :refer [*options*]] + [instaparse.failure :as f]) + (:import [instaparse.gll Failure])) + +(declare simplify) + +(defn remove-optional-space + [tree] + (if (vector? tree) + (if (= :opt-space (first tree)) + nil + (remove nil? + (map remove-optional-space tree))) + tree)) + +(defn remove-nesting + [tree] + (let [tree' (remove-optional-space tree)] + (if-let [key (when (and (vector? tree') (keyword? (first tree'))) (first tree'))] + (loop [r tree'] + (if (and r (vector? r) (keyword? (first r))) + (if (= (first r) key) + (recur (simplify (second r) :foo)) + r) + r)) + tree'))) + + +(defn simplify + "Simplify this parse tree `p`. If `p` is an instaparse failure object, throw + an `ex-info`, with `p` as the value of its `:failure` key." + ([p] + (if + (instance? Failure p) + (throw (ex-info (str "Ic ne behæfd: " (f/pprint-failure p)) {:cause :parse-failure + :phase :simplify + :failure p})) + (simplify p :expr))) + ([p context] + (if + (coll? p) + (apply + vector + (remove + #(when (coll? %) (empty? %)) + (case (first p) + (:λexpr + :args :bindings :body :cond :cond-clause :defn :dot-terminal + :fncall :lhs :octal :quoted-expr :rhs :scientific) (map #(simplify % context) p) + (:arg :expr :coefficient :fn-name :number) (simplify (second p) context) + (:arrow :dot :e :lpar :lsqb :opt-comment :opt-space :q :quote :rpar :rsqb + :semi-colon :sep :space) nil + :atom (if + (= context :mexpr) + [:quoted-expr p] + p) + :comment (when + (:strict *options*) + (throw + (ex-info "Cannot parse comments in strict mode" + {:cause :strict}))) + :dotted-pair (if + (= context :mexpr) + [:fncall + [:mvar "cons"] + [:args + (simplify (nth p 1) context) + (simplify (nth p 2) context)]] + (map simplify p)) + :iexp (second (remove-nesting p)) + :iexpr [:iexpr + [:lhs (simplify (second p) context)] + (simplify (nth p 2) context) ;; really should be the operator + [:rhs (simplify (nth p 3) context)]] + :mexpr (if + (:strict *options*) + (throw + (ex-info "Cannot parse meta expressions in strict mode" + {:cause :strict})) + (simplify (second p) :mexpr)) + :list (if + (= context :mexpr) + [:fncall + [:mvar "list"] + [:args (apply vector (map simplify (rest p)))]] + (map #(simplify % context) p)) + :raw (first (remove empty? (map simplify (rest p)))) + :sexpr (simplify (second p) :sexpr) + ;;default + p))) + p))) diff --git a/test/beowulf/bootstrap_test.clj b/test/beowulf/bootstrap_test.clj index 50e642f..0934988 100644 --- a/test/beowulf/bootstrap_test.clj +++ b/test/beowulf/bootstrap_test.clj @@ -1,8 +1,9 @@ (ns beowulf.bootstrap-test - (:require [clojure.math.numeric-tower :refer [abs]] - [clojure.test :refer :all] - [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]] - [beowulf.bootstrap :refer :all] + (:require [clojure.test :refer [deftest testing is]] + [beowulf.cons-cell :refer [make-cons-cell NIL T F]] + [beowulf.bootstrap :refer [APPEND ASSOC ATOM ATOM? CAR CAAAAR CADR + CADDR CADDDR CDR EQ EQUAL MEMBER + PAIRLIS SUBLIS SUBST]] [beowulf.read :refer [gsp]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -51,21 +52,6 @@ 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 @@ -132,13 +118,18 @@ (let [expected 'T actual (EQ 'FRED 'FRED)] (is (= actual expected) "identical symbols")) - (let [expected 'F + (let [expected 'NIL actual (EQ 'FRED 'ELFREDA)] (is (= actual expected) "different symbols")) - (let [expected 'F + (let [expected 'T l (gsp "(NOT AN ATOM)") actual (EQ l l)] - (is (= actual expected) "identical lists (EQ is not defined for lists)"))) + (is (= actual expected) "identically the same list")) + (let [expected 'NIL + l1 (gsp "(NOT AN ATOM)") + l2 (gsp "(NOT AN ATOM)") + actual (EQ l1 l2)] + (is (= actual expected) "different lists with the same content"))) (testing "equal" (let [expected 'T actual (EQUAL 'FRED 'FRED)] diff --git a/test/beowulf/cons_cell_test.clj b/test/beowulf/cons_cell_test.clj index c12443c..5b8a81a 100644 --- a/test/beowulf/cons_cell_test.clj +++ b/test/beowulf/cons_cell_test.clj @@ -1,11 +1,12 @@ (ns beowulf.cons-cell-test - (:require [clojure.test :refer :all] - [beowulf.cons-cell :refer :all])) + (:require [clojure.test :refer [deftest is testing]] + [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell pretty-print]]) + (:import [beowulf.cons_cell ConsCell])) (deftest cons-cell-tests (testing "make-cons-cell" (let [expected "(A . B)" - actual (print-str (beowulf.cons_cell.ConsCell. 'A 'B))] + actual (print-str (ConsCell. 'A 'B (gensym "c")))] (is (= actual expected) "Cons cells should print as cons cells, natch.")) (let [expected "(A . B)" actual (print-str (make-cons-cell 'A 'B))] diff --git a/test/beowulf/core_test.clj b/test/beowulf/core_test.clj index 63be2d9..81cb86b 100644 --- a/test/beowulf/core_test.clj +++ b/test/beowulf/core_test.clj @@ -1,8 +1,8 @@ (ns beowulf.core-test (:require [clojure.java.io :refer [reader]] [clojure.string :refer [split]] - [clojure.test :refer :all] - [beowulf.core :refer :all])) + [clojure.test :refer [deftest is testing]] + [beowulf.core :refer [-main repl stop-word]])) ;; (deftest a-test ;; (testing "FIXME, I fail." @@ -36,7 +36,7 @@ (testing "No flags" (let [expected-greeting "Hider wilcuman. Béowulf is mín nama." expected-quit-message (str "Sprecan '" stop-word "' tó laéfan") - expected-result #".*\(A \. B\)" + expected-result #".*\(3 \. 4\)" expected-prompt "Sprecan:: " expected-signoff "Færwell!" ;; anticipated output (note blank lines): @@ -45,11 +45,11 @@ ; Sprecan 'STOP' tó laéfan - ; Sprecan:: > (A . B) + ; Sprecan:: > (3 . 4) ; Sprecan:: ; Færwell! [_ greeting _ _ quit-message _ result prompt signoff] - (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))] + (with-open [r (reader (string->stream (str "cons[3; 4]\n" stop-word)))] (binding [*in* r] (split (with-out-str (-main)) #"\n")))] (is (= greeting expected-greeting)) @@ -63,11 +63,11 @@ (let [expected-greeting "Hider wilcuman. Béowulf is mín nama." expected-quit-message (str "Sprecan '" stop-word "' tó laéfan") expected-error #"Unknown option:.*" - expected-result #".*\(A \. B\)" + expected-result #".*\(5 \. 6\)" expected-prompt "Sprecan:: " expected-signoff "Færwell!" [_ greeting _ error quit-message _ result prompt signoff] - (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))] + (with-open [r (reader (string->stream (str "cons[5; 6]\n" stop-word)))] (binding [*in* r] (split (with-out-str (-main "--unknown")) #"\n")))] (is (= greeting expected-greeting)) diff --git a/test/beowulf/host_test.clj b/test/beowulf/host_test.clj index 67ffdba..867c5c0 100644 --- a/test/beowulf/host_test.clj +++ b/test/beowulf/host_test.clj @@ -1,9 +1,8 @@ (ns beowulf.host-test - (:require [clojure.math.numeric-tower :refer [abs]] - [clojure.test :refer :all] - [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]] + (:require [clojure.test :refer [deftest is testing]] [beowulf.bootstrap :refer [CDR]] - [beowulf.host :refer :all] + [beowulf.cons-cell :refer [F make-beowulf-list NIL T]] + [beowulf.host :refer [DIFFERENCE NUMBERP PLUS2 RPLACA RPLACD TIMES2]] [beowulf.read :refer [gsp]])) (deftest destructive-change-test @@ -35,6 +34,21 @@ ) ) +(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 arithmetic-test ;; These are just sanity-test tests; they're by no means exhaustive. (testing "PLUS2" diff --git a/test/beowulf/interop_test.clj b/test/beowulf/interop_test.clj index ddf7f38..10810fd 100644 --- a/test/beowulf/interop_test.clj +++ b/test/beowulf/interop_test.clj @@ -1,8 +1,6 @@ (ns beowulf.interop-test - (:require [clojure.test :refer :all] - [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]] + (:require [clojure.test :refer [deftest is testing]] [beowulf.bootstrap :refer [EVAL INTEROP QUOTE]] - [beowulf.host :refer :all] [beowulf.read :refer [gsp]])) diff --git a/test/beowulf/mexpr_test.clj b/test/beowulf/mexpr_test.clj index e518861..dc8e5b5 100644 --- a/test/beowulf/mexpr_test.clj +++ b/test/beowulf/mexpr_test.clj @@ -1,9 +1,12 @@ (ns beowulf.mexpr-test "These tests are taken generally from the examples on page 10 of Lisp 1.5 Programmers Manual" - (:require [clojure.test :refer :all] - [beowulf.bootstrap :refer [*options*]] - [beowulf.read :refer [parse simplify generate gsp]])) + (:require [clojure.test :refer [deftest is testing]] + [beowulf.bootstrap :refer [*options*]] + [beowulf.read :refer [gsp]] + [beowulf.reader.generate :refer [generate]] + [beowulf.reader.parser :refer [parse]] + [beowulf.reader.simplify :refer [simplify]])) ;; These tests are taken generally from the examples on page 10 of ;; Lisp 1.5 Programmers Manual: @@ -39,13 +42,14 @@ ;; Wrapping in a function call puts us into mexpr contest; ;; "T" would be interpreted as a sexpr, which would not be ;; quoted. - (let [expected "(ATOM (QUOTE A))" + (let [expected "(ATOM A)" actual (print-str (gsp "atom[A]"))] - (is (= actual expected) - "Atoms should normally be quoted")) + (is (= actual expected))) ;; I'm not clear how `car[(A B C)]` should be translated, but - ;; I suspect as (CAR (LIST 'A 'B 'C)). - + ;; I suspect as (CAR (LIST A B C)). + (let [expected "(CAR (LIST A B C))" + actual (print-str (gsp "car[(A B C)]"))] + (is (= actual expected))) )) (deftest fncall-tests @@ -79,6 +83,6 @@ (deftest assignment-tests (testing "Function assignment" - (let [expected "(SET (QUOTE FF) (LAMBDA (X) (COND ((ATOM X) X) (T (FF (CAR X))))))" - actual (gsp "ff[x]=[atom[x] -> x; T -> ff[car[x]]]")] + (let [expected "(SET (QUOTE FF) (QUOTE (LAMBDA (X) (COND ((ATOM X) X) (T (FF (CAR X)))))))" + actual (print-str (gsp "ff[x]=[atom[x] -> x; T -> ff[car[x]]]"))] (is (= actual expected))))) diff --git a/test/beowulf/sexpr_test.clj b/test/beowulf/sexpr_test.clj index 7086976..e8e0892 100644 --- a/test/beowulf/sexpr_test.clj +++ b/test/beowulf/sexpr_test.clj @@ -1,28 +1,27 @@ (ns beowulf.sexpr-test - (:require [clojure.math.numeric-tower :refer [abs]] - [clojure.test :refer :all] - [beowulf.cons-cell :refer :all] + (:require [clojure.test :refer [deftest is testing]] [beowulf.bootstrap :refer [*options*]] - [beowulf.read :refer [parse simplify generate gsp]])) + [beowulf.cons-cell :refer []] + [beowulf.read :refer [gsp]])) ;; broadly, sexprs should be homoiconic (deftest atom-tests (testing "Reading atoms" (let [expected 'A - actual (gsp(str expected))] + actual (gsp (str expected))] (is (= actual expected))) (let [expected 'APPLE - actual (gsp(str expected))] + actual (gsp (str expected))] (is (= actual expected))) (let [expected 'PART2 - actual (gsp(str expected))] + actual (gsp (str expected))] (is (= actual expected))) (let [expected 'EXTRALONGSTRINGOFLETTERS - actual (gsp(str expected))] + actual (gsp (str expected))] (is (= actual expected))) (let [expected 'A4B66XYZ2 - actual (gsp(str expected))] + actual (gsp (str expected))] (is (= actual expected))))) (deftest comment-tests @@ -41,13 +40,13 @@ B C)"))] (is (= actual expected) "Really important that comments work inside lists")) -;; ;; TODO: Currently failing and I'm not sure why -;; (binding [*options* {:strict true}] -;; (is (thrown-with-msg? -;; Exception -;; #"Cannot parse comments in strict mode" -;; (gsp "(A ;; comment -;; B C)")))) + ;; ;; TODO: Currently failing and I'm not sure why + ;; (binding [*options* {:strict true}] + ;; (is (thrown-with-msg? + ;; Exception + ;; #"Cannot parse comments in strict mode" + ;; (gsp "(A ;; comment + ;; B C)")))) ))