1
1
mirror of https://github.com/kanaka/mal.git synced 2024-08-17 01:30:26 +03:00

Add step A

This commit is contained in:
sogaiu 2020-11-25 10:08:19 +09:00
parent 63b6884380
commit 60945b3018
4 changed files with 567 additions and 8 deletions

View File

@ -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
}

316
impls/fennel/stepA_mal.fnl Normal file
View File

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

View File

@ -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*

View File

@ -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
}