mirror of
https://github.com/kanaka/mal.git
synced 2024-08-16 17:20:23 +03:00
Add step 6
This commit is contained in:
sogaiu
parent
e667abecf3
commit
02e6068f75
@ -1,6 +1,7 @@
|
||||
(local t (require :types))
|
||||
(local u (require :utils))
|
||||
(local printer (require :printer))
|
||||
(local reader (require :reader))
|
||||
|
||||
(local mal-list
|
||||
(t.make-fn
|
||||
@ -92,6 +93,72 @@
|
||||
(print (table.concat buf))
|
||||
t.mal-nil)))
|
||||
|
||||
(local mal-read-string
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(when (< (length asts) 1)
|
||||
(u.throw* (t.make-string "read-string takes 1 argument")))
|
||||
(let [res (reader.read_str (t.get-value (. asts 1)))]
|
||||
(if res
|
||||
res
|
||||
(u.throw* (t.make-string "No code content")))))))
|
||||
|
||||
(local mal-slurp
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(when (< (length asts) 1)
|
||||
(u.throw* (t.make-string "slurp takes 1 argument")))
|
||||
(let [a-str (t.get-value (. asts 1))]
|
||||
;; XXX: error handling?
|
||||
(with-open [f (io.open a-str)]
|
||||
;; XXX: escaping?
|
||||
(t.make-string (f:read "*a")))))))
|
||||
|
||||
(local mal-atom
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(when (< (length asts) 1)
|
||||
(u.throw* (t.make-string "atom takes 1 argument")))
|
||||
(t.make-atom (. asts 1)))))
|
||||
|
||||
(local mal-atom?
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(when (< (length asts) 1)
|
||||
(u.throw* (t.make-string "atom? takes 1 argument")))
|
||||
(if (t.atom?* (. asts 1))
|
||||
t.mal-true
|
||||
t.mal-false))))
|
||||
|
||||
(local mal-deref
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(when (< (length asts) 1)
|
||||
(u.throw* (t.make-string "deref takes 1 argument")))
|
||||
(let [ast (. asts 1)]
|
||||
(t.deref* ast)))))
|
||||
|
||||
(local mal-reset!
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(when (< (length asts) 2)
|
||||
(u.throw* (t.make-string "reset! takes 2 arguments")))
|
||||
(let [atom-ast (. asts 1)
|
||||
val-ast (. asts 2)]
|
||||
(t.reset!* atom-ast val-ast)))))
|
||||
|
||||
(local mal-swap!
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(when (< (length asts) 2)
|
||||
(u.throw* (t.make-string "swap! takes at least 2 arguments")))
|
||||
(let [atom-ast (. asts 1)
|
||||
fn-ast (. asts 2)
|
||||
args-asts (u.slice asts 3 -1)
|
||||
args-tbl [(t.deref* atom-ast) (table.unpack args-asts)]]
|
||||
(t.reset!* atom-ast
|
||||
((t.get-value fn-ast) args-tbl))))))
|
||||
|
||||
{"+" (t.make-fn (fn [asts]
|
||||
(var total 0)
|
||||
(each [i val (ipairs asts)]
|
||||
@ -157,4 +224,11 @@
|
||||
"str" mal-str
|
||||
"prn" mal-prn
|
||||
"println" mal-println
|
||||
"read-string" mal-read-string
|
||||
"slurp" mal-slurp
|
||||
"atom" mal-atom
|
||||
"atom?" mal-atom?
|
||||
"deref" mal-deref
|
||||
"reset!" mal-reset!
|
||||
"swap!" mal-swap!
|
||||
}
|
||||
|
||||
@ -68,7 +68,13 @@
|
||||
(set remove true))
|
||||
(when remove
|
||||
(table.remove buf))
|
||||
(table.insert buf "}")))
|
||||
(table.insert buf "}"))
|
||||
;;
|
||||
(t.atom?* ast)
|
||||
(do
|
||||
(table.insert buf "(atom ")
|
||||
(code* (t.get-value ast) buf print_readably)
|
||||
(table.insert buf ")")))
|
||||
buf))
|
||||
|
||||
(fn pr_str
|
||||
|
||||
175
impls/fennel/step6_file.fnl
Normal file
175
impls/fennel/step6_file.fnl
Normal file
@ -0,0 +1,175 @@
|
||||
(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-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))
|
||||
;;
|
||||
(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 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)
|
||||
(set result 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)))
|
||||
;; tco
|
||||
(set ast (. ast-elts 3))
|
||||
(set env new-env))
|
||||
;;
|
||||
(= "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)))
|
||||
;;
|
||||
(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)
|
||||
;; XXX
|
||||
(error "eval takes 1 arguments"))
|
||||
(EVAL (u.first asts) repl_env))))
|
||||
|
||||
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))")
|
||||
|
||||
(e.env-set repl_env
|
||||
(t.make-symbol "*ARGV*")
|
||||
(t.make-list (u.map t.make-string (u.slice arg 2))))
|
||||
|
||||
(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
|
||||
(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))))))))))
|
||||
@ -53,36 +53,15 @@
|
||||
:params params
|
||||
:env env})
|
||||
|
||||
(fn make-atom
|
||||
[ast]
|
||||
{:tag :atom
|
||||
:content ast})
|
||||
|
||||
(local mal-true (make-boolean true))
|
||||
|
||||
(local mal-false (make-boolean false))
|
||||
|
||||
;;
|
||||
|
||||
(fn get-value
|
||||
[ast]
|
||||
(. ast :content))
|
||||
|
||||
(fn get-type
|
||||
[ast]
|
||||
(. ast :tag))
|
||||
|
||||
;;
|
||||
|
||||
(fn get-ast
|
||||
[ast]
|
||||
(. ast :ast))
|
||||
|
||||
(fn get-params
|
||||
[ast]
|
||||
(. ast :params))
|
||||
|
||||
(fn get-env
|
||||
[ast]
|
||||
(. ast :env))
|
||||
|
||||
;;
|
||||
|
||||
(fn nil?*
|
||||
[ast]
|
||||
(= :nil (. ast :tag)))
|
||||
@ -123,6 +102,53 @@
|
||||
[ast]
|
||||
(= :fn (. ast :tag)))
|
||||
|
||||
(fn atom?*
|
||||
[ast]
|
||||
(= :atom (. ast :tag)))
|
||||
|
||||
;;
|
||||
|
||||
(fn get-value
|
||||
[ast]
|
||||
(. ast :content))
|
||||
|
||||
(fn get-type
|
||||
[ast]
|
||||
(. ast :tag))
|
||||
|
||||
;;
|
||||
|
||||
(fn get-ast
|
||||
[ast]
|
||||
(. ast :ast))
|
||||
|
||||
(fn get-params
|
||||
[ast]
|
||||
(. ast :params))
|
||||
|
||||
(fn get-env
|
||||
[ast]
|
||||
(. ast :env))
|
||||
|
||||
;;
|
||||
|
||||
(fn set-atom-value!
|
||||
[atom-ast value-ast]
|
||||
(tset atom-ast
|
||||
:content value-ast))
|
||||
|
||||
(fn deref*
|
||||
[ast]
|
||||
(if (not (atom?* ast))
|
||||
;; XXX
|
||||
(error (.. "Expected atom, got: " (get-type ast)))
|
||||
(get-value ast)))
|
||||
|
||||
(fn reset!*
|
||||
[atom-ast val-ast]
|
||||
(set-atom-value! atom-ast val-ast)
|
||||
val-ast)
|
||||
|
||||
;;
|
||||
|
||||
(fn empty?*
|
||||
@ -209,16 +235,12 @@
|
||||
:make-vector make-vector
|
||||
:make-hash-map make-hash-map
|
||||
:make-fn make-fn
|
||||
:make-atom make-atom
|
||||
;;
|
||||
:mal-nil mal-nil
|
||||
:mal-true mal-true
|
||||
:mal-false mal-false
|
||||
;;
|
||||
:get-value get-value
|
||||
:get-ast get-ast
|
||||
:get-params get-params
|
||||
:get-env get-env
|
||||
;;
|
||||
:nil?* nil?*
|
||||
:boolean?* boolean?*
|
||||
:number?* number?*
|
||||
@ -229,6 +251,16 @@
|
||||
:vector?* vector?*
|
||||
:hash-map?* hash-map?*
|
||||
:fn?* fn?*
|
||||
:atom?* atom?*
|
||||
;;
|
||||
:get-value get-value
|
||||
:get-ast get-ast
|
||||
:get-params get-params
|
||||
:get-env get-env
|
||||
;;
|
||||
:set-atom-value! set-atom-value!
|
||||
:deref* deref*
|
||||
:reset!* reset!*
|
||||
;;
|
||||
:empty?* empty?*
|
||||
:true?* true?*
|
||||
|
||||
Loading…
Reference in New Issue
Block a user