mirror of
https://github.com/kanaka/mal.git
synced 2024-10-27 14:52:16 +03:00
115 lines
2.5 KiB
Plaintext
115 lines
2.5 KiB
Plaintext
(import ./reader)
|
|
(import ./printer)
|
|
(import ./types :as t)
|
|
(import ./env :as e)
|
|
|
|
(defn READ
|
|
[code-str]
|
|
(reader/read_str code-str))
|
|
|
|
(defn arith-fn
|
|
[op]
|
|
(fn [ast-1 ast-2]
|
|
(t/make-number (op (t/get-value ast-1)
|
|
(t/get-value ast-2)))))
|
|
|
|
(def repl_env
|
|
(let [env (e/make-env)]
|
|
(e/env-set env (t/make-symbol "+") (arith-fn +))
|
|
(e/env-set env (t/make-symbol "-") (arith-fn -))
|
|
(e/env-set env (t/make-symbol "*") (arith-fn *))
|
|
(e/env-set env (t/make-symbol "/") (arith-fn /))
|
|
env))
|
|
|
|
(var EVAL nil)
|
|
|
|
(defn eval_ast
|
|
[ast env]
|
|
(cond
|
|
(t/symbol?* ast)
|
|
(e/env-get env ast)
|
|
#
|
|
(t/hash-map?* ast)
|
|
(t/make-hash-map (struct ;(map |(EVAL $0 env)
|
|
(kvs (t/get-value ast)))))
|
|
#
|
|
(t/list?* ast)
|
|
(t/make-list (map |(EVAL $0 env)
|
|
(t/get-value ast)))
|
|
#
|
|
(t/vector?* ast)
|
|
(t/make-vector (map |(EVAL $0 env)
|
|
(t/get-value ast)))
|
|
#
|
|
ast))
|
|
|
|
(varfn EVAL
|
|
[ast env]
|
|
(cond
|
|
(not (t/list?* ast))
|
|
(eval_ast ast env)
|
|
#
|
|
(t/empty?* ast)
|
|
ast
|
|
#
|
|
(let [ast-head (first (t/get-value ast))
|
|
head-name (t/get-value ast-head)]
|
|
(case head-name
|
|
"def!"
|
|
(let [def-name (in (t/get-value ast) 1)
|
|
def-val (EVAL (in (t/get-value ast) 2) env)]
|
|
(e/env-set env
|
|
def-name def-val)
|
|
def-val)
|
|
#
|
|
"let*"
|
|
(let [new-env (e/make-env env)
|
|
bindings (t/get-value (in (t/get-value ast) 1))]
|
|
(each [let-name let-val] (partition 2 bindings)
|
|
(e/env-set new-env
|
|
let-name (EVAL let-val new-env)))
|
|
(EVAL (in (t/get-value ast) 2) new-env))
|
|
#
|
|
(let [eval-list (t/get-value (eval_ast ast env))
|
|
f (first eval-list)
|
|
args (drop 1 eval-list)]
|
|
(apply f args))))))
|
|
|
|
(defn PRINT
|
|
[value]
|
|
(printer/pr_str value true))
|
|
|
|
(defn rep
|
|
[code-str]
|
|
(PRINT (EVAL (READ code-str) repl_env)))
|
|
|
|
# getline gives problems
|
|
(defn getstdin [prompt buf]
|
|
(file/write stdout prompt)
|
|
(file/flush stdout)
|
|
(file/read stdin :line buf))
|
|
|
|
(defn handle-error
|
|
[err]
|
|
(cond
|
|
(t/nil?* err)
|
|
(print)
|
|
##
|
|
(string? err)
|
|
(print err)
|
|
##
|
|
(print (string "Error: " (PRINT err)))))
|
|
|
|
(defn main
|
|
[& args]
|
|
(var buf nil)
|
|
(while true
|
|
(set buf @"")
|
|
(getstdin "user> " buf)
|
|
(if (= 0 (length buf))
|
|
(break)
|
|
(try
|
|
(print (rep buf))
|
|
([err]
|
|
(handle-error err))))))
|