mirror of
https://github.com/kanaka/mal.git
synced 2024-09-11 13:55:55 +03:00
Add step 9
This commit is contained in:
parent
b281556baf
commit
63b6884380
@ -228,6 +228,305 @@
|
|||||||
(t.make-list [])
|
(t.make-list [])
|
||||||
(t.make-list (u.slice (t.get-value coll-or-nil-ast) 2 -1)))))))
|
(t.make-list (u.slice (t.get-value coll-or-nil-ast) 2 -1)))))))
|
||||||
|
|
||||||
|
(local mal-throw
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "throw takes 1 argument")))
|
||||||
|
(u.throw* (. asts 1)))))
|
||||||
|
|
||||||
|
;; (apply F A B [C D]) is equivalent to (F A B C D)
|
||||||
|
(local mal-apply
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(let [n-asts (length asts)]
|
||||||
|
(when (< n-asts 1)
|
||||||
|
(u.throw* (t.make-string "apply takes at least 1 argument")))
|
||||||
|
(let [the-fn (t.get-value (. asts 1))] ; e.g. F
|
||||||
|
(if (= n-asts 1)
|
||||||
|
(the-fn [])
|
||||||
|
(= n-asts 2)
|
||||||
|
(the-fn [(table.unpack (t.get-value (. asts 2)))])
|
||||||
|
(let [args-asts (u.slice asts 2 -2) ; e.g. [A B]
|
||||||
|
last-asts (t.get-value (u.last asts)) ; e.g. [C D]
|
||||||
|
fn-args-tbl []]
|
||||||
|
(each [i elt (ipairs args-asts)]
|
||||||
|
(table.insert fn-args-tbl elt))
|
||||||
|
(each [i elt (ipairs last-asts)]
|
||||||
|
(table.insert fn-args-tbl elt))
|
||||||
|
(the-fn fn-args-tbl))))))))
|
||||||
|
|
||||||
|
(local mal-map
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 2)
|
||||||
|
(u.throw* (t.make-string "map takes at least 2 arguments")))
|
||||||
|
(let [the-fn (t.get-value (. asts 1))
|
||||||
|
coll (t.get-value (. asts 2))]
|
||||||
|
(t.make-list (u.map #(the-fn [$]) coll))))))
|
||||||
|
|
||||||
|
(local mal-nil?
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "nil? takes 1 argument")))
|
||||||
|
(if (t.nil?* (. asts 1))
|
||||||
|
t.mal-true
|
||||||
|
t.mal-false))))
|
||||||
|
|
||||||
|
(local mal-true?
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "true? takes 1 argument")))
|
||||||
|
(if (t.true?* (. asts 1))
|
||||||
|
t.mal-true
|
||||||
|
t.mal-false))))
|
||||||
|
|
||||||
|
(local mal-false?
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "false? takes 1 argument")))
|
||||||
|
(if (t.false?* (. asts 1))
|
||||||
|
t.mal-true
|
||||||
|
t.mal-false))))
|
||||||
|
|
||||||
|
(local mal-symbol?
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "symbol? takes 1 argument")))
|
||||||
|
(if (t.symbol?* (. asts 1))
|
||||||
|
t.mal-true
|
||||||
|
t.mal-false))))
|
||||||
|
|
||||||
|
(local mal-symbol
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "symbol takes 1 argument")))
|
||||||
|
;; XXX: check that type is string?
|
||||||
|
(t.make-symbol (t.get-value (. asts 1))))))
|
||||||
|
|
||||||
|
(local mal-keyword
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "keyword takes 1 argument")))
|
||||||
|
(let [arg-ast (. asts 1)]
|
||||||
|
(if (t.keyword?* arg-ast)
|
||||||
|
arg-ast
|
||||||
|
;;
|
||||||
|
(t.string?* arg-ast)
|
||||||
|
(t.make-keyword (.. ":" (t.get-value arg-ast)))
|
||||||
|
;;
|
||||||
|
(u.throw* (t.make-string "Expected string")))))))
|
||||||
|
|
||||||
|
(local mal-keyword?
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "keyword? takes 1 argument")))
|
||||||
|
(if (t.keyword?* (. asts 1))
|
||||||
|
t.mal-true
|
||||||
|
t.mal-false))))
|
||||||
|
|
||||||
|
(local mal-vector
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(t.make-vector asts))))
|
||||||
|
|
||||||
|
(local mal-vector?
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "vector? takes 1 argument")))
|
||||||
|
(if (t.vector?* (. asts 1))
|
||||||
|
t.mal-true
|
||||||
|
t.mal-false))))
|
||||||
|
|
||||||
|
(local mal-sequential?
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "sequential? takes 1 argument")))
|
||||||
|
(if (or (t.list?* (. asts 1))
|
||||||
|
(t.vector?* (. asts 1)))
|
||||||
|
t.mal-true
|
||||||
|
t.mal-false))))
|
||||||
|
|
||||||
|
(local mal-map?
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "map? takes 1 argument")))
|
||||||
|
(if (t.hash-map?* (. asts 1))
|
||||||
|
t.mal-true
|
||||||
|
t.mal-false))))
|
||||||
|
|
||||||
|
(local mal-hash-map
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (= 1 (% (length asts) 2))
|
||||||
|
(u.throw* (t.make-string
|
||||||
|
"hash-map takes an even number of arguments")))
|
||||||
|
(t.make-hash-map asts))))
|
||||||
|
|
||||||
|
(local mal-assoc
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 3)
|
||||||
|
(u.throw* (t.make-string "assoc takes at least 3 arguments")))
|
||||||
|
(let [head-ast (. asts 1)]
|
||||||
|
(when (not (or (t.hash-map?* head-ast)
|
||||||
|
(t.nil?* head-ast)))
|
||||||
|
(u.throw* (t.make-string
|
||||||
|
"assoc first argument should be a hash-map or nil")))
|
||||||
|
(if (t.nil?* head-ast)
|
||||||
|
t.mal-nil
|
||||||
|
(let [item-tbl []
|
||||||
|
kv-asts (u.slice asts 2 -1)
|
||||||
|
hash-items (t.get-value head-ast)]
|
||||||
|
(for [i 1 (/ (length hash-items) 2)]
|
||||||
|
(let [key (. hash-items (- (* 2 i) 1))]
|
||||||
|
(var idx 1)
|
||||||
|
(var found false)
|
||||||
|
(while (and (not found)
|
||||||
|
(<= idx (length kv-asts)))
|
||||||
|
(if (t.equals?* key (. kv-asts idx))
|
||||||
|
(set found true)
|
||||||
|
(set idx (+ idx 2))))
|
||||||
|
(if (not found)
|
||||||
|
(do
|
||||||
|
(table.insert item-tbl key)
|
||||||
|
(table.insert item-tbl (. hash-items (* 2 i))))
|
||||||
|
(do
|
||||||
|
(table.insert item-tbl key)
|
||||||
|
(table.insert item-tbl (. kv-asts (+ idx 1)))
|
||||||
|
(table.remove kv-asts (+ idx 1))
|
||||||
|
(table.remove kv-asts idx)))))
|
||||||
|
(each [i elt (ipairs kv-asts)]
|
||||||
|
(table.insert item-tbl elt))
|
||||||
|
(t.make-hash-map item-tbl)))))))
|
||||||
|
|
||||||
|
(local mal-dissoc
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 2)
|
||||||
|
(u.throw* (t.make-string "dissoc takes at least 2 arguments")))
|
||||||
|
(let [head-ast (. asts 1)]
|
||||||
|
(when (not (or (t.hash-map?* head-ast)
|
||||||
|
(t.nil?* head-ast)))
|
||||||
|
(u.throw* (t.make-string
|
||||||
|
"dissoc first argument should be a hash-map or nil")))
|
||||||
|
(if (t.nil?* head-ast)
|
||||||
|
t.mal-nil
|
||||||
|
(let [item-tbl []
|
||||||
|
key-asts (u.slice asts 2 -1)
|
||||||
|
hash-items (t.get-value head-ast)]
|
||||||
|
(for [i 1 (/ (length hash-items) 2)]
|
||||||
|
(let [key (. hash-items (- (* 2 i) 1))]
|
||||||
|
(var idx 1)
|
||||||
|
(var found false)
|
||||||
|
(while (and (not found)
|
||||||
|
(<= idx (length key-asts)))
|
||||||
|
(if (t.equals?* key (. key-asts idx))
|
||||||
|
(set found true)
|
||||||
|
(set idx (+ idx 1))))
|
||||||
|
(when (not found)
|
||||||
|
(table.insert item-tbl key)
|
||||||
|
(table.insert item-tbl (. hash-items (* 2 i))))))
|
||||||
|
(t.make-hash-map item-tbl)))))))
|
||||||
|
|
||||||
|
(local mal-get
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 2)
|
||||||
|
(u.throw* (t.make-string "get takes 2 arguments")))
|
||||||
|
(let [head-ast (. asts 1)]
|
||||||
|
(when (not (or (t.hash-map?* head-ast)
|
||||||
|
(t.nil?* head-ast)))
|
||||||
|
(u.throw* (t.make-string
|
||||||
|
"get first argument should be a hash-map or nil")))
|
||||||
|
(if (t.nil?* head-ast)
|
||||||
|
t.mal-nil
|
||||||
|
(let [hash-items (t.get-value head-ast)
|
||||||
|
key-ast (. asts 2)]
|
||||||
|
(var idx 1)
|
||||||
|
(var found false)
|
||||||
|
(while (and (not found)
|
||||||
|
(<= idx (length hash-items)))
|
||||||
|
(if (t.equals?* key-ast (. hash-items idx))
|
||||||
|
(set found true)
|
||||||
|
(set idx (+ idx 1))))
|
||||||
|
(if found
|
||||||
|
(. hash-items (+ idx 1))
|
||||||
|
t.mal-nil)))))))
|
||||||
|
|
||||||
|
(local mal-contains?
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 2)
|
||||||
|
(u.throw* (t.make-string "contains? takes 2 arguments")))
|
||||||
|
(let [head-ast (. asts 1)]
|
||||||
|
(when (not (or (t.hash-map?* head-ast)
|
||||||
|
(t.nil?* head-ast)))
|
||||||
|
(u.throw* (t.make-string
|
||||||
|
"contains? first argument should be a hash-map or nil")))
|
||||||
|
(if (t.nil?* head-ast)
|
||||||
|
t.mal-nil
|
||||||
|
(let [hash-items (t.get-value head-ast)
|
||||||
|
key-ast (. asts 2)]
|
||||||
|
(var idx 1)
|
||||||
|
(var found false)
|
||||||
|
(while (and (not found)
|
||||||
|
(<= idx (length hash-items)))
|
||||||
|
(if (t.equals?* key-ast (. hash-items idx))
|
||||||
|
(set found true)
|
||||||
|
(set idx (+ idx 1))))
|
||||||
|
(if found
|
||||||
|
t.mal-true
|
||||||
|
t.mal-false)))))))
|
||||||
|
|
||||||
|
(local mal-keys
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "keys takes 1 argument")))
|
||||||
|
(let [head-ast (. asts 1)]
|
||||||
|
(when (not (or (t.hash-map?* head-ast)
|
||||||
|
(t.nil?* head-ast)))
|
||||||
|
(u.throw* (t.make-string
|
||||||
|
"keys first argument should be a hash-map or nil")))
|
||||||
|
(if (t.nil?* head-ast)
|
||||||
|
t.mal-nil
|
||||||
|
(let [item-tbl []
|
||||||
|
hash-items (t.get-value head-ast)]
|
||||||
|
(for [i 1 (/ (length hash-items) 2)]
|
||||||
|
(let [key (. hash-items (- (* 2 i) 1))]
|
||||||
|
(table.insert item-tbl key)))
|
||||||
|
(t.make-list item-tbl)))))))
|
||||||
|
|
||||||
|
(local mal-vals
|
||||||
|
(t.make-fn
|
||||||
|
(fn [asts]
|
||||||
|
(when (< (length asts) 1)
|
||||||
|
(u.throw* (t.make-string "vals takes 1 argument")))
|
||||||
|
(let [head-ast (. asts 1)]
|
||||||
|
(when (not (or (t.hash-map?* head-ast)
|
||||||
|
(t.nil?* head-ast)))
|
||||||
|
(u.throw* (t.make-string
|
||||||
|
"vals first argument should be a hash-map or nil")))
|
||||||
|
(if (t.nil?* head-ast)
|
||||||
|
t.mal-nil
|
||||||
|
(let [item-tbl []
|
||||||
|
hash-items (t.get-value head-ast)]
|
||||||
|
(for [i 1 (/ (length hash-items) 2)]
|
||||||
|
(let [value (. hash-items (* 2 i))]
|
||||||
|
(table.insert item-tbl value)))
|
||||||
|
(t.make-list item-tbl)))))))
|
||||||
|
|
||||||
{"+" (t.make-fn (fn [asts]
|
{"+" (t.make-fn (fn [asts]
|
||||||
(var total 0)
|
(var total 0)
|
||||||
(each [i val (ipairs asts)]
|
(each [i val (ipairs asts)]
|
||||||
@ -306,4 +605,25 @@
|
|||||||
"nth" mal-nth
|
"nth" mal-nth
|
||||||
"first" mal-first
|
"first" mal-first
|
||||||
"rest" mal-rest
|
"rest" mal-rest
|
||||||
|
"throw" mal-throw
|
||||||
|
"apply" mal-apply
|
||||||
|
"map" mal-map
|
||||||
|
"nil?" mal-nil?
|
||||||
|
"true?" mal-true?
|
||||||
|
"false?" mal-false?
|
||||||
|
"symbol?" mal-symbol?
|
||||||
|
"symbol" mal-symbol
|
||||||
|
"keyword" mal-keyword
|
||||||
|
"keyword?" mal-keyword?
|
||||||
|
"vector" mal-vector
|
||||||
|
"vector?" mal-vector?
|
||||||
|
"sequential?" mal-sequential?
|
||||||
|
"map?" mal-map?
|
||||||
|
"hash-map" mal-hash-map
|
||||||
|
"assoc" mal-assoc
|
||||||
|
"dissoc" mal-dissoc
|
||||||
|
"get" mal-get
|
||||||
|
"contains?" mal-contains?
|
||||||
|
"keys" mal-keys
|
||||||
|
"vals" mal-vals
|
||||||
}
|
}
|
||||||
|
311
impls/fennel/step9_try.fnl
Normal file
311
impls/fennel/step9_try.fnl
Normal file
@ -0,0 +1,311 @@
|
|||||||
|
(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)))
|
||||||
|
;;
|
||||||
|
(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 "*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
|
||||||
|
(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))))))
|
Loading…
Reference in New Issue
Block a user