Beginning work on infix operators in mexprs.

project.clj

@@ -7,12 +7,14 @@
   :description "An implementation of LISP 1.5 in Clojure"
   :license {:name "GPL-2.0-or-later"
             :url "https://www.eclipse.org/legal/epl-2.0/"}
-  :dependencies [[org.clojure/clojure "1.8.0"]
+  :dependencies [[org.clojure/clojure "1.11.1"]
-                 [org.clojure/math.numeric-tower "0.0.4"]
+                 [org.clojure/math.numeric-tower "0.0.5"]
-                 [org.clojure/tools.cli "0.4.2"]
+                 [org.clojure/tools.cli "1.0.214"]
-                 [org.clojure/tools.trace "0.7.10"]
+                 [org.clojure/tools.trace "0.7.11"]
-                 [environ "1.1.0"]
+                 [environ "1.2.0"]
-                 [instaparse "1.4.10"]]
+                 [instaparse "1.4.12"]
+                 [rhizome "0.2.9"] ;; not needed in production builds
+                 ]
   :main ^:skip-aot beowulf.core
   :plugins [[lein-cloverage "1.1.1"]
             [lein-codox "0.10.7"]

resources/apply-2.mexpr.lsp

@@ -18,5 +18,4 @@ apply[fn;args;a] = [
                                 cons[cons[cadr[fn];caddr[fn]]; a]];
     eq[car[fn]; FUNARG] -> apply[cadr[fn]; args; caddr[fn]];
     eq[car[fn]; LAMBDA] -> eval[caddr[fn]; nconc[pair[cadr[fn]; args]; a]];
-    T -> apply[eval[fn;a]; args; a]]
+    T -> apply[eval[fn;a]; args; a]]
-

resources/ff.mexpr.lsp

@@ -0,0 +1,3 @@
+;; From page 6 of Lisp 1.5 Programmer's Manual
+
+ff[x]=[atom[x] -> x; T -> ff[car[x]]]

resources/gcd.mexpr.lsp

@@ -0,0 +1,3 @@
+gcd[x;y] = [x>y -> gcd[y;x];
+            rem[y;x] = 0 -> x;
+            T -> gcd[rem[y;x];x]]

src/beowulf/read.clj

@@ -5,7 +5,7 @@
 
   Intended deviations from the behaviour of the real Lisp reader are as follows:
 
-  1. It reads the meta-expression language `MEXPR` in addition to the
+  1. It reads the meta-expression language `MEXPR` in addition to fLAMthe
       symbolic expression language `SEXPR`, which I do not believe the Lisp 1.5
       reader ever did;
   2. It treats everything between a semi-colon and an end of line as a comment,
@@ -15,7 +15,7 @@
   switch."
   (:require [beowulf.bootstrap :refer [*options*]]
             [clojure.math.numeric-tower :refer [expt]]
-            [clojure.string :refer [join split starts-with? upper-case]]
+            [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]])
@@ -32,6 +32,29 @@
 
 (declare generate)
 
+(defn strip-line-comments
+  "Strip blank lines and comment lines from this string `s`, expected to
+   be Lisp source."
+  [^String s]
+  (join "\n"
+        (remove
+         #(or (empty? %)
+              (starts-with? (trim %) ";;"))
+         (split s #"\n"))))
+
+(defn number-lines
+  ([^String s]
+   (number-lines s nil))
+  ([^String s ^Failure e]
+   (let [l (-> e :line)
+         c (-> e :column)]
+     (join "\n"
+           (map #(str (format "%5d %s" (inc %1) %2)
+                      (when (= l (inc %1))
+                        (str "\n" (apply str (repeat c " ")) "^")))
+                (range)
+                (split s #"\n"))))))
+
 (def parse
   "Parse a string presented as argument into a parse tree which can then
   be operated upon further."
@@ -54,7 +77,7 @@
       ;; but it's a convenience.
 
     "exprs := expr | exprs;"
-    "mexpr := λexpr | fncall | defn | cond | mvar | mexpr comment;
+    "mexpr := λexpr | fncall | defn | cond | mvar | iexpr | mexpr comment;
       λexpr := λ lsqb bindings semi-colon body rsqb;
       λ := 'λ';
       bindings := lsqb args rsqb;
@@ -65,14 +88,20 @@
        lbrace := '{';
        rbrace := '}';
       defn := mexpr opt-space '=' opt-space mexpr;
-      cond := lsqb (cond-clause semi-colon opt-space)* cond-clause rsqb;
+      cond := lsqb (opt-space cond-clause semi-colon opt-space)* cond-clause rsqb;
-      cond-clause := expr opt-space arrow opt-space expr;
+      cond-clause := expr opt-space arrow opt-space expr opt-space;
       arrow := '->';
-      args := (expr semi-colon opt-space)* expr;
+      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;"
@@ -106,6 +135,38 @@
       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."
@@ -113,27 +174,28 @@
    (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 :sexpr)))
+     (simplify p :expr)))
   ([p context]
    (if
     (coll? p)
      (apply
       vector
       (remove
-       #(if (coll? %) (empty? %))
+       #(when (coll? %) (empty? %))
        (case (first p)
-         (:arg :expr :coefficient :fn-name :number :sexpr) (simplify (second p) context)
          (:λexpr
-          :args :bindings :body :cond :cond-clause :dot-terminal
+          :args :bindings :body :cond :cond-clause :defn :dot-terminal
-          :fncall :octal :quoted-expr :scientific) (map #(simplify % context) p)
+          :fncall :lhs :octal :quoted-expr :rhs :scientific) (map #(simplify % context) p)
-         (:arrow :dot :e :lpar :lsqb :opt-space :q :quote :rpar :rsqb
+         (: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 :opt-comment) (if
+         :comment (when
                    (:strict *options*)
                     (throw
                      (ex-info "Cannot parse comments in strict mode"
@@ -146,6 +208,11 @@
                           (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
@@ -159,6 +226,7 @@
                   [: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)))
@@ -268,6 +336,29 @@
      (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
@@ -303,6 +394,7 @@
         :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)))
@@ -332,20 +424,38 @@
                       {:generating p}
                       any)))))
 
-(defmacro gsp
+;; (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
   expression."
   [s]
-  `(generate (simplify (parse ~s))))
+  (let [source (strip-line-comments s)
+        parse-tree (parse source)]
+    (if (instance? Failure parse-tree)
+      (doall (println (number-lines source parse-tree))
+             (throw (ex-info "Parse failed" (assoc parse-tree :source source))))
+      (generate (simplify parse-tree)))))
 
 (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."
-  [input]
+  ([]
-  (cond
+   (gsp (read-line)))
-    (empty? input) (gsp (read-line))
+  ([input]
-    (string? input) (gsp input)
+   (cond
-    (instance? InputStream input) (READ (slurp input))
+     (empty? input) (gsp (read-line))
-    :else    (throw (ex-info "READ: `input` should be a string or an input stream" {}))))
+     (string? input) (gsp input)
+     (instance? InputStream input) (READ (slurp input))
+     :else    (throw (ex-info "READ: `input` should be a string or an input stream" {})))))

test/beowulf/mexpr_test.clj

@@ -76,3 +76,9 @@
             Exception
             #"Cannot parse meta expressions in strict mode"
             (gsp "label[ff;λ[[x];[atom[x]->x; T->ff[car[x]]]]]"))))))
+
+(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]]]")]
+      (is (= actual expected)))))