From 9d4c05e0eb428314b368f377ed9a42d76452e844 Mon Sep 17 00:00:00 2001
From: sogaiu <983021772@users.noreply.github.com>
Date: Tue, 24 Nov 2020 22:28:17 +0900
Subject: [PATCH] Add step 4

---
 impls/fennel/core.fnl           | 160 ++++++++++++++++++++++++++++++++
 impls/fennel/env.fnl            |  28 +++++-
 impls/fennel/step4_if_fn_do.fnl | 136 +++++++++++++++++++++++++++
 impls/fennel/types.fnl          |  80 ++++++++++++++++
 4 files changed, 402 insertions(+), 2 deletions(-)
 create mode 100644 impls/fennel/core.fnl
 create mode 100644 impls/fennel/step4_if_fn_do.fnl

diff --git a/impls/fennel/core.fnl b/impls/fennel/core.fnl
new file mode 100644
index 00000000..dd700017
--- /dev/null
+++ b/impls/fennel/core.fnl
@@ -0,0 +1,160 @@
+(local t (require :types))
+(local u (require :utils))
+(local printer (require :printer))
+
+(local mal-list
+  (t.make-fn
+    (fn [asts]
+      (t.make-list asts))))
+
+(local mal-list?
+  (t.make-fn
+    (fn [asts]
+      (when (< (length asts) 1)
+        (u.throw* (t.make-string "list? takes 1 argument")))
+      (t.make-boolean (t.list?* (. asts 1))))))
+
+(local mal-empty?
+  (t.make-fn
+    (fn [asts]
+      (when (< (length asts) 1)
+        (u.throw* (t.make-string "empty? takes 1 argument")))
+      (let [arg-ast (. asts 1)]
+        (if (t.nil?* arg-ast)
+            t.mal-true
+            (t.make-boolean (t.empty?* arg-ast)))))))
+
+(local mal-count
+  (t.make-fn
+    (fn [asts]
+      (when (< (length asts) 1)
+        (u.throw* (t.make-string "count takes 1 argument")))
+      (let [arg-ast (. asts 1)]
+        (if (t.nil?* arg-ast)
+            (t.make-number 0)
+            (t.make-number (length (t.get-value arg-ast))))))))
+
+(local mal-=
+  (t.make-fn
+    (fn [asts]
+      (when (< (length asts) 2)
+        (u.throw* (t.make-string "= takes 2 arguments")))
+      (let [ast-1 (. asts 1)
+            ast-2 (. asts 2)]
+        (if (t.equals?* ast-1 ast-2)
+            t.mal-true
+            t.mal-false)))))
+
+(local mal-pr-str
+  (t.make-fn
+    (fn [asts]
+      (local buf [])
+      (when (> (length asts) 0)
+        (each [i ast (ipairs asts)]
+          (table.insert buf (printer.pr_str ast true))
+          (table.insert buf " "))
+        ;; remove extra space at end
+        (table.remove buf))
+      (t.make-string (table.concat buf)))))
+
+(local mal-str
+  (t.make-fn
+    (fn [asts]
+      (local buf [])
+      (when (> (length asts) 0)
+        (each [i ast (ipairs asts)]
+          (table.insert buf (printer.pr_str ast false))))
+      (t.make-string (table.concat buf)))))
+
+(local mal-prn
+  (t.make-fn
+    (fn [asts]
+      (local buf [])
+      (when (> (length asts) 0)
+        (each [i ast (ipairs asts)]
+          (table.insert buf (printer.pr_str ast true))
+          (table.insert buf " "))
+        ;; remove extra space at end
+        (table.remove buf))
+      (print (table.concat buf))
+      t.mal-nil)))
+
+(local mal-println
+  (t.make-fn
+    (fn [asts]
+      (local buf [])
+      (when (> (length asts) 0)
+        (each [i ast (ipairs asts)]
+          (table.insert buf (printer.pr_str ast false))
+          (table.insert buf " "))
+        ;; remove extra space at end
+        (table.remove buf))
+      (print (table.concat buf))
+      t.mal-nil)))
+
+{"+" (t.make-fn (fn [asts]
+                  (var total 0)
+                  (each [i val (ipairs asts)]
+                    (set total
+                         (+ total (t.get-value val))))
+                  (t.make-number total)))
+ "-" (t.make-fn (fn [asts]
+                  (var total 0)
+                  (let [n-args (length asts)]
+                    (if (= 0 n-args)
+                        (t.make-number 0)
+                        (= 1 n-args)
+                        (t.make-number (- 0 (t.get-value (. asts 1))))
+                        (do
+                         (set total (t.get-value (. asts 1)))
+                         (for [idx 2 n-args]
+                           (let [cur (t.get-value (. asts idx))]
+                             (set total
+                                  (- total cur))))
+                         (t.make-number total))))))
+ "*" (t.make-fn (fn [asts]
+                  (var total 1)
+                  (each [i val (ipairs asts)]
+                    (set total
+                         (* total (t.get-value val))))
+                  (t.make-number total)))
+ "/" (t.make-fn (fn [asts]
+                  (var total 1)
+                  (let [n-args (length asts)]
+                    (if (= 0 n-args)
+                        (t.make-number 1)
+                        (= 1 n-args)
+                        (t.make-number (/ 1 (t.get-value (. asts 1))))
+                        (do
+                         (set total (t.get-value (. asts 1)))
+                         (for [idx 2 n-args]
+                           (let [cur (t.get-value (. asts idx))]
+                             (set total
+                                  (/ total cur))))
+                          (t.make-number total))))))
+ "list" mal-list
+ "list?" mal-list?
+ "empty?" mal-empty?
+ "count" mal-count
+ "=" mal-=
+ "<" (t.make-fn (fn [asts]
+                  (let [val-1 (t.get-value (. asts 1))
+                        val-2 (t.get-value (. asts 2))]
+                    (t.make-boolean (< val-1 val-2)))))
+ "<=" (t.make-fn (fn [asts]
+                   (let [val-1 (t.get-value (. asts 1))
+                         val-2 (t.get-value (. asts 2))]
+                     (t.make-boolean (<= val-1 val-2)))))
+ ">" (t.make-fn (fn [asts]
+                  (let [val-1 (t.get-value (. asts 1))
+                        val-2 (t.get-value (. asts 2))]
+                    (t.make-boolean (> val-1 val-2)))))
+ ">=" (t.make-fn (fn [asts]
+                   (let [val-1 (t.get-value (. asts 1))
+                         val-2 (t.get-value (. asts 2))]
+                     (t.make-boolean (>= val-1 val-2)))))
+ "pr-str" mal-pr-str
+ "str" mal-str
+ "prn" mal-prn
+ "println" mal-println
+}
diff --git a/impls/fennel/env.fnl b/impls/fennel/env.fnl
index 96755c18..995231bf 100644
--- a/impls/fennel/env.fnl
+++ b/impls/fennel/env.fnl
@@ -2,9 +2,33 @@
 (local u (require :utils))
 
 (fn make-env
-  [outer]
+  [outer binds exprs]
+  (local tbl {})
+  (when binds
+    (local n-binds (length binds))
+    (var found-amp false)
+    (var i 1)
+    (while (and (not found-amp)
+                (<= i n-binds))
+      (local c-bind (. binds i))
+      (if (= (t.get-value c-bind) "&")
+          (set found-amp true)
+          (set i (+ i 1))))
+    (if (not found-amp)
+        (for [j 1 n-binds]
+          (tset tbl
+                (t.get-value (. binds j))
+                (. exprs j)))
+        (do ; houston, there was an ampersand
+          (for [j 1 (- i 1)] ; things before &
+            (tset tbl
+                  (t.get-value (. binds j))
+                  (. exprs j)))
+          (tset tbl ; after &, put things in a list
+                (t.get-value (. binds (+ i 1)))
+                (t.make-list (u.slice exprs i -1))))))
   {:outer outer
-   :data {}})
+   :data tbl})
 
 (fn env-set
   [env sym-ast val-ast]
diff --git a/impls/fennel/step4_if_fn_do.fnl b/impls/fennel/step4_if_fn_do.fnl
new file mode 100644
index 00000000..0e909f87
--- /dev/null
+++ b/impls/fennel/step4_if_fn_do.fnl
@@ -0,0 +1,136 @@
+(local printer (require :printer))
+(local reader (require :reader))
+(local t (require :types))
+(local e (require :env))
+(local core (require :core))
+(local u (require :utils))
+
+(local repl_env
+  (let [env (e.make-env)]
+    (each [name func (pairs core)]
+      (e.env-set env
+                 (t.make-symbol name)
+                 func))
+    env))
+
+(fn READ
+  [code-str]
+  (reader.read_str code-str))
+
+;; forward declaration
+(var EVAL 1)
+
+(fn eval_ast
+  [ast env]
+  (if (t.symbol?* ast)
+      (e.env-get env ast)
+      ;;
+      (t.list?* ast)
+      (t.make-list (u.map (fn [elt-ast]
+                            (EVAL elt-ast env))
+                          (t.get-value ast)))
+      ;;
+      (t.vector?* ast)
+      (t.make-vector (u.map (fn [elt-ast]
+                              (EVAL elt-ast env))
+                            (t.get-value ast)))
+      ;;
+      (t.hash-map?* ast)
+      (t.make-hash-map (u.map (fn [elt-ast]
+                                (EVAL elt-ast env))
+                              (t.get-value ast)))
+      ;;
+      ast))
+
+(set EVAL
+  (fn [ast env]
+      (if (not (t.list?* ast))
+          (eval_ast ast env)
+          ;;
+          (t.empty?* ast)
+          ast
+          ;;
+          (let [ast-elts (t.get-value ast)
+                head-name (t.get-value (. ast-elts 1))]
+            ;; XXX: want to check for symbol, but that screws up logic below
+            (if (= "def!" head-name)
+                (let [def-name (. ast-elts 2)
+                      def-val (EVAL (. ast-elts 3) env)]
+                  (e.env-set env
+                             def-name def-val)
+                  def-val)
+                ;;
+                (= "let*" head-name)
+                (let [new-env (e.make-env env)
+                      bindings (t.get-value (. ast-elts 2))
+                      stop (/ (length bindings) 2)]
+                  (for [idx 1 stop]
+                       (let [b-name (. bindings (- (* 2 idx) 1))
+                             b-val (EVAL (. bindings (* 2 idx)) new-env)]
+                         (e.env-set new-env
+                                    b-name b-val)))
+                  (EVAL (. ast-elts 3) new-env))
+                ;;
+                (= "do" head-name)
+                (let [do-body-evaled (eval_ast (t.make-list
+                                                (u.slice ast-elts 2 -1))
+                                               env)]
+                  (u.last (t.get-value do-body-evaled)))
+                ;;
+                (= "if" head-name)
+                (let [cond-res (EVAL (. ast-elts 2) env)]
+                  (if (or (t.nil?* cond-res)
+                          (t.false?* cond-res))
+                      (let [else-ast (. ast-elts 4)]
+                        (if (not else-ast)
+                            t.mal-nil
+                            (EVAL else-ast env)))
+                      (EVAL (. ast-elts 3) env)))
+                ;;
+                (= "fn*" head-name)
+                (let [args (t.get-value (. ast-elts 2))
+                      body (. ast-elts 3)]
+                  (t.make-fn (fn [params]
+                               (EVAL body
+                                     (e.make-env env args params)))))
+                ;;
+                (let [eval-list (t.get-value (eval_ast ast env))
+                      f (. eval-list 1)
+                      args (u.slice eval-list 2 -1)]
+                  ((t.get-value f) args)))))))
+
+(fn PRINT
+  [ast]
+  (printer.pr_str ast true))
+
+(fn rep
+  [code-str]
+  (PRINT (EVAL (READ code-str) repl_env)))
+
+(rep "(def! not (fn* (a) (if a false true)))")
+
+(fn handle-error
+  [err]
+  (if (t.nil?* err)
+      (print)
+      (= "string" (type err))
+      (print err)
+      (print (.. "Error: " (PRINT err)))))
+
+(var done false)
+
+(while (not done)
+  (io.write "user> ")
+  (io.flush)
+  (let [input (io.read)]
+    (if (not input)
+        (set done true)
+        (xpcall (fn []
+                  (print (rep input)))
+                handle-error))))
+                ;; (fn [exc]
+                ;;   (if (t.nil?* exc)
+                ;;       (print)
+                ;;       (= "string" (type exc))
+                ;;       (print exc)
+                ;;       (print (PRINT exc))))))))
diff --git a/impls/fennel/types.fnl b/impls/fennel/types.fnl
index e854e0f2..0be147d6 100644
--- a/impls/fennel/types.fnl
+++ b/impls/fennel/types.fnl
@@ -45,6 +45,11 @@
   {:tag :hash-map
    :content elts})
 
+(fn make-fn
+  [a-fn]
+  {:tag :fn
+   :content a-fn})
+
 (local mal-true (make-boolean true))
 
 (local mal-false (make-boolean false))
@@ -55,6 +60,10 @@
   [ast]
   (. ast :content))
 
+(fn get-type
+  [ast]
+  (. ast :tag))
+
 ;;
 
 (fn nil?*
@@ -101,6 +110,73 @@
             (vector?* ast))
     (= (length (get-value ast)) 0)))
 
+(fn true?*
+  [ast]
+  (and (boolean?* ast)
+       (= true (get-value ast))))
+
+(fn false?*
+  [ast]
+  (and (boolean?* ast)
+       (= false (get-value ast))))
+
+(fn equals?*
+  [ast-1 ast-2]
+  (let [type-1 (get-type ast-1)
+        type-2 (get-type ast-2)]
+    (if (and (not= type-1 type-2)
+             ;; XXX: not elegant
+             (not (and (list?* ast-1) (vector?* ast-2)))
+             (not (and (list?* ast-2) (vector?* ast-1))))
+      false
+      (let [val-1 (get-value ast-1)
+            val-2 (get-value ast-2)]
+        ;; XXX: when not a collection...
+        (if (and (not (list?* ast-1))
+                 (not (vector?* ast-1))
+                 (not (hash-map?* ast-1)))
+          (= val-1 val-2)
+          (if (not= (length val-1) (length val-2))
+            false
+            (if (and (not (hash-map?* ast-1))
+                     (not (hash-map?* ast-2)))
+              (do
+                (var found-unequal false)
+                (var idx 1)
+                (while (and (not found-unequal)
+                            (<= idx (length val-1)))
+                  (let [v1 (. val-1 idx)
+                        v2 (. val-2 idx)]
+                    (when (not (equals?* v1 v2))
+                      (set found-unequal true))
+                    (set idx (+ idx 1))))
+                (not found-unequal))
+              (if (or (not (hash-map?* ast-1))
+                      (not (hash-map?* ast-2)))
+                false
+                (do
+                 (var found-unequal false)
+                 (var idx-in-1 1)
+                 (while (and (not found-unequal)
+                             (<= idx-in-1 (length val-1)))
+                   (let [k1 (. val-1 idx-in-1)]
+                     (var found-in-2 false)
+                     (var idx-in-2 1)
+                     (while (and (not found-in-2)
+                                 (<= idx-in-2 (length val-2)))
+                       (let [k2 (. val-2 idx-in-2)]
+                         (if (equals?* k1 k2)
+                             (set found-in-2 true)
+                             (set idx-in-2 (+ idx-in-2 2)))))
+                     (if (not found-in-2)
+                         (set found-unequal true)
+                         (let [v1 (. val-1 (+ idx-in-1 1))
+                               v2 (. val-2 (+ idx-in-2 1))]
+                           (if (not (equals?* v1 v2))
+                               (set found-unequal true)
+                               (set idx-in-1 (+ idx-in-1 2)))))))
+                  (not found-unequal))))))))))
+
 {
  :make-nil make-nil
  :make-boolean make-boolean
@@ -111,6 +187,7 @@
  :make-list make-list
  :make-vector make-vector
  :make-hash-map make-hash-map
+ :make-fn make-fn
  ;;
  :mal-nil mal-nil
  :mal-true mal-true
@@ -129,4 +206,7 @@
  :hash-map?* hash-map?*
  ;;
  :empty?* empty?*
+ :true?* true?*
+ :false?* false?*
+ :equals?* equals?*
 }