From 60945b30181e1dc6adb5976050ced3e8a5573572 Mon Sep 17 00:00:00 2001 From: sogaiu <983021772@users.noreply.github.com> Date: Wed, 25 Nov 2020 10:08:19 +0900 Subject: [PATCH] Add step A --- impls/fennel/core.fnl | 185 ++++++++++++++++++++++ impls/fennel/stepA_mal.fnl | 316 +++++++++++++++++++++++++++++++++++++ impls/fennel/types.fnl | 39 ++++- impls/fennel/utils.fnl | 35 ++++ 4 files changed, 567 insertions(+), 8 deletions(-) create mode 100644 impls/fennel/stepA_mal.fnl diff --git a/impls/fennel/core.fnl b/impls/fennel/core.fnl index f3042d0e..7033c674 100644 --- a/impls/fennel/core.fnl +++ b/impls/fennel/core.fnl @@ -2,6 +2,7 @@ (local u (require :utils)) (local printer (require :printer)) (local reader (require :reader)) +(local fennel (require :fennel)) (local mal-list (t.make-fn @@ -527,6 +528,179 @@ (table.insert item-tbl value))) (t.make-list item-tbl))))))) +(local mal-readline + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "vals takes 1 argument"))) + (let [prompt (t.get-value (. asts 1))] + (io.write prompt) + (io.flush) + (let [input (io.read) + trimmed (string.match input "^%s*(.-)%s*$")] + (if (> (length trimmed) 0) + (t.make-string trimmed) + t.mal-nil)))))) + +(local mal-meta + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "meta takes 1 argument"))) + (let [head-ast (. asts 1)] + (if (or (t.list?* head-ast) + (t.vector?* head-ast) + (t.hash-map?* head-ast) + (t.fn?* head-ast)) + (t.get-md head-ast) + t.mal-nil))))) + +(local mal-with-meta + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "with-meta takes 2 arguments"))) + (let [target-ast (. asts 1) + meta-ast (. asts 2)] + (if (t.list?* target-ast) + (t.make-list (t.get-value target-ast) meta-ast) + ;; + (t.vector?* target-ast) + (t.make-vector (t.get-value target-ast) meta-ast) + ;; + (t.hash-map?* target-ast) + (t.make-hash-map (t.get-value target-ast) meta-ast) + ;; + (t.fn?* target-ast) + (t.clone-with-meta target-ast meta-ast) + ;; + (u.throw* + (t.make-string "Expected list, vector, hash-map, or fn"))))))) + +(local mal-string? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "string? takes 1 argument"))) + (t.make-boolean (t.string?* (. asts 1)))))) + +(local mal-number? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "number? takes 1 argument"))) + (t.make-boolean (t.number?* (. asts 1)))))) + +(local mal-fn? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "fn? takes 1 argument"))) + (let [target-ast (. asts 1)] + (if (and (t.fn?* target-ast) + (not (t.get-is-macro target-ast))) + t.mal-true + t.mal-false))))) + +(local mal-macro? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "macro? requires 1 argument"))) + (let [the-ast (. asts 1)] + (if (t.macro?* the-ast) + t.mal-true + t.mal-false))))) + +(local mal-conj + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "conj takes at least 2 arguments"))) + (let [coll-ast (. asts 1) + item-asts (u.slice asts 2 -1)] + (if (t.nil?* coll-ast) + (t.make-list (u.reverse item-asts)) + ;; + (t.list?* coll-ast) + (t.make-list (u.concat-two (u.reverse item-asts) + (t.get-value coll-ast))) + ;; + (t.vector?* coll-ast) + (t.make-vector (u.concat-two (t.get-value coll-ast) + item-asts)) + ;; + (u.throw* (t.make-string "Expected list, vector, or nil"))))))) + +(local mal-seq + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "seq takes 1 argument"))) + (let [arg-ast (. asts 1)] + (if (t.list?* arg-ast) + (if (t.empty?* arg-ast) + t.mal-nil + arg-ast) + ;; + (t.vector?* arg-ast) + (if (t.empty?* arg-ast) + t.mal-nil + (t.make-list (t.get-value arg-ast))) + ;; + (t.string?* arg-ast) + (let [a-str (t.get-value arg-ast) + str-len (length a-str)] + (if (= str-len 0) + t.mal-nil + (do + (local str-tbl []) + (for [i 1 (length a-str)] + (table.insert str-tbl + (t.make-string (string.sub a-str i i)))) + (t.make-list str-tbl)))) + ;; + (t.nil?* arg-ast) + arg-ast + ;; + (u.throw* + (t.make-string "Expected list, vector, string, or nil"))))))) + +(local mal-time-ms + (t.make-fn + (fn [asts] + (t.make-number (os.clock))))) + +(fn fennel-eval* + [fennel-val] + (if (= "nil" (type fennel-val)) + t.mal-nil + (= "boolean" (type fennel-val)) + (t.make-boolean fennel-val) + (= "string" (type fennel-val)) + (t.make-string fennel-val) + (= "number" (type fennel-val)) + (t.make-number fennel-val) + (= "table" (type fennel-val)) + (t.make-list (u.map fennel-eval* fennel-val)) + (u.throw* + (t.make-string (.. "Unsupported type: " (type fennel-val)))))) + +(local mal-fennel-eval + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "fennel-eval takes 1 argument"))) + (let [head-ast (. asts 1)] + (when (not (t.string?* head-ast)) + (u.throw* (t.make-string + "fennel-eval first argument should be a string"))) + (let [(ok? result) (pcall fennel.eval (t.get-value head-ast))] + (if ok? + (fennel-eval* result) + (u.throw* + (t.make-string (.. "Eval failed: " result))))))))) + {"+" (t.make-fn (fn [asts] (var total 0) (each [i val (ipairs asts)] @@ -626,4 +800,15 @@ "contains?" mal-contains? "keys" mal-keys "vals" mal-vals + "readline" mal-readline + "meta" mal-meta + "with-meta" mal-with-meta + "string?" mal-string? + "number?" mal-number? + "fn?" mal-fn? + "macro?" mal-macro? + "conj" mal-conj + "seq" mal-seq + "time-ms" mal-time-ms + "fennel-eval" mal-fennel-eval } diff --git a/impls/fennel/stepA_mal.fnl b/impls/fennel/stepA_mal.fnl new file mode 100644 index 00000000..9623fa38 --- /dev/null +++ b/impls/fennel/stepA_mal.fnl @@ -0,0 +1,316 @@ +(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)) + +(fn is_macro_call + [ast env] + (when (and (t.list?* ast) + (not (t.empty?* ast))) + (let [head-ast (. (t.get-value ast) 1)] + (when (and (t.symbol?* head-ast) + (e.env-find env head-ast)) + (let [target-ast (e.env-get env head-ast)] + (t.macro?* target-ast)))))) + +(fn macroexpand + [ast env] + (var ast-var ast) + (while (is_macro_call ast-var env) + (let [inner-asts (t.get-value ast-var) + head-ast (. inner-asts 1) + macro-fn (t.get-value (e.env-get env head-ast)) + args (u.slice inner-asts 2 -1)] + (set ast-var (macro-fn args)))) + ast-var) + +;; 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)) + +(fn starts-with + [ast name] + (when (and (t.list?* ast) + (not (t.empty?* ast))) + (let [head-ast (. (t.get-value ast) 1)] + (and (t.symbol?* head-ast) + (= name (t.get-value head-ast)))))) + +(var quasiquote* nil) + +(fn qq-iter + [ast] + (if (t.empty?* ast) + (t.make-list []) + (let [ast-value (t.get-value ast) + elt (. ast-value 1) + acc (qq-iter (t.make-list (u.slice ast-value 2 -1)))] + (if (starts-with elt "splice-unquote") + (t.make-list [(t.make-symbol "concat") + (. (t.get-value elt) 2) + acc]) + (t.make-list [(t.make-symbol "cons") + (quasiquote* elt) + acc]))))) + +(set quasiquote* + (fn [ast] + (if (starts-with ast "unquote") + (. (t.get-value ast) 2) + ;; + (t.list?* ast) + (qq-iter ast) + ;; + (t.vector?* ast) + (t.make-list [(t.make-symbol "vec") (qq-iter ast)]) + ;; + (or (t.symbol?* ast) + (t.hash-map?* ast)) + (t.make-list [(t.make-symbol "quote") ast]) + ;; + ast))) + +(set EVAL + (fn [ast-param env-param] + (var ast ast-param) + (var env env-param) + (var result nil) + (while (not result) + (if (not (t.list?* ast)) + (set result (eval_ast ast env)) + (do + (set ast (macroexpand ast env)) + (if (not (t.list?* ast)) + (set result (eval_ast ast env)) + (if (t.empty?* ast) + (set result ast) + (let [ast-elts (t.get-value ast) + head-name (t.get-value (. ast-elts 1))] + ;; XXX: want to check for symbol, but... + (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) + (set result def-val)) + ;; + (= "defmacro!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env) + macro-ast (t.macrofy def-val)] + (e.env-set env + def-name macro-ast) + (set result macro-ast)) + ;; + (= "macroexpand" head-name) + (set result (macroexpand (. ast-elts 2) env)) + ;; + (= "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))) + ;; tco + (set ast (. ast-elts 3)) + (set env new-env)) + ;; + (= "quote" head-name) + ;; tco + (set result (. ast-elts 2)) + ;; + (= "quasiquoteexpand" head-name) + ;; tco + (set result (quasiquote* (. ast-elts 2))) + ;; + (= "quasiquote" head-name) + ;; tco + (set ast (quasiquote* (. ast-elts 2))) + ;; + (= "try*" head-name) + (set result + (let [(ok? res) + (pcall EVAL (. ast-elts 2) env)] + (if (not ok?) + (let [maybe-catch-ast (. ast-elts 3)] + (if (not maybe-catch-ast) + (u.throw* res) + (if (not (starts-with maybe-catch-ast + "catch*")) + (u.throw* + (t.make-string + "Expected catch* form")) + (let [catch-asts + (t.get-value + maybe-catch-ast)] + (if (< (length catch-asts) 2) + (u.throw* + (t.make-string + (.. "catch* requires at " + "least 2 " + "arguments"))) + (let [catch-sym-ast + (. catch-asts 2) + catch-body-ast + (. catch-asts 3)] + (EVAL catch-body-ast + (e.make-env + env + [catch-sym-ast] + [res])))))))) + res))) + ;; + (= "do" head-name) + (let [most-forms (u.slice ast-elts 2 -2) ;; XXX + last-body-form (u.last ast-elts) + res-ast (eval_ast + (t.make-list most-forms) env)] + ;; tco + (set ast last-body-form)) + ;; + (= "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) + ;; tco + (set result t.mal-nil) + (set ast else-ast))) + ;; tco + (set ast (. ast-elts 3)))) + ;; + (= "fn*" head-name) + (let [params (t.get-value (. ast-elts 2)) + body (. ast-elts 3)] + ;; tco + (set result + (t.make-fn + (fn [args] + (EVAL body + (e.make-env env params args))) + body params env false nil))) + ;; + (let [eval-list (t.get-value (eval_ast ast env)) + f (. eval-list 1) + args (u.slice eval-list 2 -1)] + (let [body (t.get-ast f)] ;; tco + (if body + (do + (set ast body) + (set env + (e.make-env (t.get-env f) + (t.get-params f) + args))) + (set result + ((t.get-value f) args)))))))))))) + result)) + +(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)))") + +(e.env-set repl_env + (t.make-symbol "eval") + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* + (t.make-string "eval takes 1 argument"))) + (EVAL (u.first asts) repl_env)))) + +(rep + (.. "(def! load-file " + " (fn* (f) " + " (eval " + " (read-string " + " (str \"(do \" (slurp f) \"\nnil)\")))))")) + +(rep + (.. "(defmacro! cond " + " (fn* (& xs) " + " (if (> (count xs) 0) " + " (list 'if (first xs) " + " (if (> (count xs) 1) " + " (nth xs 1) " + " (throw \"odd number of forms to cond\")) " + " (cons 'cond (rest (rest xs)))))))")) + +(e.env-set repl_env + (t.make-symbol "*host-language*") + (t.make-string "fennel")) + +(e.env-set repl_env + (t.make-symbol "*ARGV*") + (t.make-list (u.map t.make-string (u.slice arg 2 -1)))) + +(fn handle-error + [err] + (if (t.nil?* err) + (print) + (= "string" (type err)) + (print err) + (print (.. "Error: " (PRINT err))))) + +(if (<= 1 (length arg)) + (xpcall (fn [] + (rep (.. "(load-file \"" (. arg 1) "\")"))) ;; XXX: escaping? + handle-error) + (do + (rep "(println (str \"Mal [\" *host-language* \"]\"))") + (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)))))) diff --git a/impls/fennel/types.fnl b/impls/fennel/types.fnl index e66764bb..c2831300 100644 --- a/impls/fennel/types.fnl +++ b/impls/fennel/types.fnl @@ -31,29 +31,37 @@ (local mal-nil (make-nil)) (fn make-list - [elts] + [elts md] + (local md (if md md mal-nil)) {:tag :list - :content elts}) + :content elts + :md md}) (fn make-vector - [elts] + [elts md] + (local md (if md md mal-nil)) {:tag :vector - :content elts}) + :content elts + :md md}) (fn make-hash-map - [elts] + [elts md] + (local md (if md md mal-nil)) {:tag :hash-map - :content elts}) + :content elts + :md md}) (fn make-fn - [a-fn ast params env is-macro] + [a-fn ast params env is-macro md] (local is-macro (if is-macro is-macro false)) + (local md (if md md mal-nil)) {:tag :fn :content a-fn :ast ast :params params :env env - :is-macro is-macro}) + :is-macro is-macro + :md md}) (fn make-atom [ast] @@ -74,6 +82,10 @@ [ast] (. ast :tag)) +(fn get-md + [ast] + (. ast :md)) + ;; (fn get-is-macro @@ -154,6 +166,15 @@ :is-macro true) macro-ast) +(fn clone-with-meta + [fn-ast meta-ast] + (local new-fn-ast {}) + (each [k v (pairs fn-ast)] + (tset new-fn-ast k v)) + (tset new-fn-ast + :md meta-ast) + new-fn-ast) + ;; (fn set-atom-value! @@ -266,6 +287,7 @@ :mal-false mal-false ;; :get-value get-value + :get-md get-md :get-is-macro get-is-macro :get-ast get-ast :get-params get-params @@ -285,6 +307,7 @@ :macro?* macro?* ;; :macrofy macrofy + :clone-with-meta clone-with-meta ;; :set-atom-value! set-atom-value! :deref* deref* diff --git a/impls/fennel/utils.fnl b/impls/fennel/utils.fnl index db7cc509..c74a07e7 100644 --- a/impls/fennel/utils.fnl +++ b/impls/fennel/utils.fnl @@ -93,10 +93,45 @@ ) +(fn reverse + [tbl] + (local new-tbl []) + (for [i (length tbl) 1 -1] + (table.insert new-tbl (. tbl i))) + new-tbl) + +(comment + + (reverse [:a :b :c]) + ;; => ["c" "b" "a"] + + ) + +(fn concat-two + [tbl-1 tbl-2] + (local new-tbl []) + (each [i elt (ipairs tbl-1)] + (table.insert new-tbl elt)) + (each [i elt (ipairs tbl-2)] + (table.insert new-tbl elt)) + new-tbl) + +(comment + + (concat-two [:a :b :c] [:d :e :f]) + ;; => ["a" "b" "c" "d" "e" "f"] + + (concat-two {1 :a 2 :b 3 :c} {1 :d 2 :e 3 :f}) + ;; => ["a" "b" "c" "d" "e" "f"] + + ) + { :throw* throw* :slice slice :first first :last last :map map + :reverse reverse + :concat-two concat-two }