mirror of
https://github.com/kanaka/mal.git
synced 2024-08-16 17:20:23 +03:00
Add step 4
This commit is contained in:
sogaiu
parent
c916bde23d
commit
9d4c05e0eb
160
impls/fennel/core.fnl
Normal file
160
impls/fennel/core.fnl
Normal file
@ -0,0 +1,160 @@
|
||||
(local t (require :types))
|
||||
(local u (require :utils))
|
||||
(local printer (require :printer))
|
||||
|
||||
(local mal-list
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(t.make-list asts))))
|
||||
|
||||
(local mal-list?
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(when (< (length asts) 1)
|
||||
(u.throw* (t.make-string "list? takes 1 argument")))
|
||||
(t.make-boolean (t.list?* (. asts 1))))))
|
||||
|
||||
(local mal-empty?
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(when (< (length asts) 1)
|
||||
(u.throw* (t.make-string "empty? takes 1 argument")))
|
||||
(let [arg-ast (. asts 1)]
|
||||
(if (t.nil?* arg-ast)
|
||||
t.mal-true
|
||||
(t.make-boolean (t.empty?* arg-ast)))))))
|
||||
|
||||
(local mal-count
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(when (< (length asts) 1)
|
||||
(u.throw* (t.make-string "count takes 1 argument")))
|
||||
(let [arg-ast (. asts 1)]
|
||||
(if (t.nil?* arg-ast)
|
||||
(t.make-number 0)
|
||||
(t.make-number (length (t.get-value arg-ast))))))))
|
||||
|
||||
(local mal-=
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(when (< (length asts) 2)
|
||||
(u.throw* (t.make-string "= takes 2 arguments")))
|
||||
(let [ast-1 (. asts 1)
|
||||
ast-2 (. asts 2)]
|
||||
(if (t.equals?* ast-1 ast-2)
|
||||
t.mal-true
|
||||
t.mal-false)))))
|
||||
|
||||
(local mal-pr-str
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(local buf [])
|
||||
(when (> (length asts) 0)
|
||||
(each [i ast (ipairs asts)]
|
||||
(table.insert buf (printer.pr_str ast true))
|
||||
(table.insert buf " "))
|
||||
;; remove extra space at end
|
||||
(table.remove buf))
|
||||
(t.make-string (table.concat buf)))))
|
||||
|
||||
(local mal-str
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(local buf [])
|
||||
(when (> (length asts) 0)
|
||||
(each [i ast (ipairs asts)]
|
||||
(table.insert buf (printer.pr_str ast false))))
|
||||
(t.make-string (table.concat buf)))))
|
||||
|
||||
(local mal-prn
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(local buf [])
|
||||
(when (> (length asts) 0)
|
||||
(each [i ast (ipairs asts)]
|
||||
(table.insert buf (printer.pr_str ast true))
|
||||
(table.insert buf " "))
|
||||
;; remove extra space at end
|
||||
(table.remove buf))
|
||||
(print (table.concat buf))
|
||||
t.mal-nil)))
|
||||
|
||||
(local mal-println
|
||||
(t.make-fn
|
||||
(fn [asts]
|
||||
(local buf [])
|
||||
(when (> (length asts) 0)
|
||||
(each [i ast (ipairs asts)]
|
||||
(table.insert buf (printer.pr_str ast false))
|
||||
(table.insert buf " "))
|
||||
;; remove extra space at end
|
||||
(table.remove buf))
|
||||
(print (table.concat buf))
|
||||
t.mal-nil)))
|
||||
|
||||
{"+" (t.make-fn (fn [asts]
|
||||
(var total 0)
|
||||
(each [i val (ipairs asts)]
|
||||
(set total
|
||||
(+ total (t.get-value val))))
|
||||
(t.make-number total)))
|
||||
"-" (t.make-fn (fn [asts]
|
||||
(var total 0)
|
||||
(let [n-args (length asts)]
|
||||
(if (= 0 n-args)
|
||||
(t.make-number 0)
|
||||
(= 1 n-args)
|
||||
(t.make-number (- 0 (t.get-value (. asts 1))))
|
||||
(do
|
||||
(set total (t.get-value (. asts 1)))
|
||||
(for [idx 2 n-args]
|
||||
(let [cur (t.get-value (. asts idx))]
|
||||
(set total
|
||||
(- total cur))))
|
||||
(t.make-number total))))))
|
||||
"*" (t.make-fn (fn [asts]
|
||||
(var total 1)
|
||||
(each [i val (ipairs asts)]
|
||||
(set total
|
||||
(* total (t.get-value val))))
|
||||
(t.make-number total)))
|
||||
"/" (t.make-fn (fn [asts]
|
||||
(var total 1)
|
||||
(let [n-args (length asts)]
|
||||
(if (= 0 n-args)
|
||||
(t.make-number 1)
|
||||
(= 1 n-args)
|
||||
(t.make-number (/ 1 (t.get-value (. asts 1))))
|
||||
(do
|
||||
(set total (t.get-value (. asts 1)))
|
||||
(for [idx 2 n-args]
|
||||
(let [cur (t.get-value (. asts idx))]
|
||||
(set total
|
||||
(/ total cur))))
|
||||
(t.make-number total))))))
|
||||
"list" mal-list
|
||||
"list?" mal-list?
|
||||
"empty?" mal-empty?
|
||||
"count" mal-count
|
||||
"=" mal-=
|
||||
"<" (t.make-fn (fn [asts]
|
||||
(let [val-1 (t.get-value (. asts 1))
|
||||
val-2 (t.get-value (. asts 2))]
|
||||
(t.make-boolean (< val-1 val-2)))))
|
||||
"<=" (t.make-fn (fn [asts]
|
||||
(let [val-1 (t.get-value (. asts 1))
|
||||
val-2 (t.get-value (. asts 2))]
|
||||
(t.make-boolean (<= val-1 val-2)))))
|
||||
">" (t.make-fn (fn [asts]
|
||||
(let [val-1 (t.get-value (. asts 1))
|
||||
val-2 (t.get-value (. asts 2))]
|
||||
(t.make-boolean (> val-1 val-2)))))
|
||||
">=" (t.make-fn (fn [asts]
|
||||
(let [val-1 (t.get-value (. asts 1))
|
||||
val-2 (t.get-value (. asts 2))]
|
||||
(t.make-boolean (>= val-1 val-2)))))
|
||||
"pr-str" mal-pr-str
|
||||
"str" mal-str
|
||||
"prn" mal-prn
|
||||
"println" mal-println
|
||||
}
|
||||
@ -2,9 +2,33 @@
|
||||
(local u (require :utils))
|
||||
|
||||
(fn make-env
|
||||
[outer]
|
||||
[outer binds exprs]
|
||||
(local tbl {})
|
||||
(when binds
|
||||
(local n-binds (length binds))
|
||||
(var found-amp false)
|
||||
(var i 1)
|
||||
(while (and (not found-amp)
|
||||
(<= i n-binds))
|
||||
(local c-bind (. binds i))
|
||||
(if (= (t.get-value c-bind) "&")
|
||||
(set found-amp true)
|
||||
(set i (+ i 1))))
|
||||
(if (not found-amp)
|
||||
(for [j 1 n-binds]
|
||||
(tset tbl
|
||||
(t.get-value (. binds j))
|
||||
(. exprs j)))
|
||||
(do ; houston, there was an ampersand
|
||||
(for [j 1 (- i 1)] ; things before &
|
||||
(tset tbl
|
||||
(t.get-value (. binds j))
|
||||
(. exprs j)))
|
||||
(tset tbl ; after &, put things in a list
|
||||
(t.get-value (. binds (+ i 1)))
|
||||
(t.make-list (u.slice exprs i -1))))))
|
||||
{:outer outer
|
||||
:data {}})
|
||||
:data tbl})
|
||||
|
||||
(fn env-set
|
||||
[env sym-ast val-ast]
|
||||
|
||||
136
impls/fennel/step4_if_fn_do.fnl
Normal file
136
impls/fennel/step4_if_fn_do.fnl
Normal file
@ -0,0 +1,136 @@
|
||||
(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 env]
|
||||
(if (not (t.list?* ast))
|
||||
(eval_ast ast env)
|
||||
;;
|
||||
(t.empty?* ast)
|
||||
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)
|
||||
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)))
|
||||
(EVAL (. ast-elts 3) new-env))
|
||||
;;
|
||||
(= "do" head-name)
|
||||
(let [do-body-evaled (eval_ast (t.make-list
|
||||
(u.slice ast-elts 2 -1))
|
||||
env)]
|
||||
(u.last (t.get-value do-body-evaled)))
|
||||
;;
|
||||
(= "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)
|
||||
t.mal-nil
|
||||
(EVAL else-ast env)))
|
||||
(EVAL (. ast-elts 3) env)))
|
||||
;;
|
||||
(= "fn*" head-name)
|
||||
(let [args (t.get-value (. ast-elts 2))
|
||||
body (. ast-elts 3)]
|
||||
(t.make-fn (fn [params]
|
||||
(EVAL body
|
||||
(e.make-env env args params)))))
|
||||
;;
|
||||
(let [eval-list (t.get-value (eval_ast ast env))
|
||||
f (. eval-list 1)
|
||||
args (u.slice eval-list 2 -1)]
|
||||
((t.get-value f) args)))))))
|
||||
|
||||
(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)))")
|
||||
|
||||
(fn handle-error
|
||||
[err]
|
||||
(if (t.nil?* err)
|
||||
(print)
|
||||
(= "string" (type err))
|
||||
(print err)
|
||||
(print (.. "Error: " (PRINT err)))))
|
||||
|
||||
(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))))))))
|
||||
@ -45,6 +45,11 @@
|
||||
{:tag :hash-map
|
||||
:content elts})
|
||||
|
||||
(fn make-fn
|
||||
[a-fn]
|
||||
{:tag :fn
|
||||
:content a-fn})
|
||||
|
||||
(local mal-true (make-boolean true))
|
||||
|
||||
(local mal-false (make-boolean false))
|
||||
@ -55,6 +60,10 @@
|
||||
[ast]
|
||||
(. ast :content))
|
||||
|
||||
(fn get-type
|
||||
[ast]
|
||||
(. ast :tag))
|
||||
|
||||
;;
|
||||
|
||||
(fn nil?*
|
||||
@ -101,6 +110,73 @@
|
||||
(vector?* ast))
|
||||
(= (length (get-value ast)) 0)))
|
||||
|
||||
(fn true?*
|
||||
[ast]
|
||||
(and (boolean?* ast)
|
||||
(= true (get-value ast))))
|
||||
|
||||
(fn false?*
|
||||
[ast]
|
||||
(and (boolean?* ast)
|
||||
(= false (get-value ast))))
|
||||
|
||||
(fn equals?*
|
||||
[ast-1 ast-2]
|
||||
(let [type-1 (get-type ast-1)
|
||||
type-2 (get-type ast-2)]
|
||||
(if (and (not= type-1 type-2)
|
||||
;; XXX: not elegant
|
||||
(not (and (list?* ast-1) (vector?* ast-2)))
|
||||
(not (and (list?* ast-2) (vector?* ast-1))))
|
||||
false
|
||||
(let [val-1 (get-value ast-1)
|
||||
val-2 (get-value ast-2)]
|
||||
;; XXX: when not a collection...
|
||||
(if (and (not (list?* ast-1))
|
||||
(not (vector?* ast-1))
|
||||
(not (hash-map?* ast-1)))
|
||||
(= val-1 val-2)
|
||||
(if (not= (length val-1) (length val-2))
|
||||
false
|
||||
(if (and (not (hash-map?* ast-1))
|
||||
(not (hash-map?* ast-2)))
|
||||
(do
|
||||
(var found-unequal false)
|
||||
(var idx 1)
|
||||
(while (and (not found-unequal)
|
||||
(<= idx (length val-1)))
|
||||
(let [v1 (. val-1 idx)
|
||||
v2 (. val-2 idx)]
|
||||
(when (not (equals?* v1 v2))
|
||||
(set found-unequal true))
|
||||
(set idx (+ idx 1))))
|
||||
(not found-unequal))
|
||||
(if (or (not (hash-map?* ast-1))
|
||||
(not (hash-map?* ast-2)))
|
||||
false
|
||||
(do
|
||||
(var found-unequal false)
|
||||
(var idx-in-1 1)
|
||||
(while (and (not found-unequal)
|
||||
(<= idx-in-1 (length val-1)))
|
||||
(let [k1 (. val-1 idx-in-1)]
|
||||
(var found-in-2 false)
|
||||
(var idx-in-2 1)
|
||||
(while (and (not found-in-2)
|
||||
(<= idx-in-2 (length val-2)))
|
||||
(let [k2 (. val-2 idx-in-2)]
|
||||
(if (equals?* k1 k2)
|
||||
(set found-in-2 true)
|
||||
(set idx-in-2 (+ idx-in-2 2)))))
|
||||
(if (not found-in-2)
|
||||
(set found-unequal true)
|
||||
(let [v1 (. val-1 (+ idx-in-1 1))
|
||||
v2 (. val-2 (+ idx-in-2 1))]
|
||||
(if (not (equals?* v1 v2))
|
||||
(set found-unequal true)
|
||||
(set idx-in-1 (+ idx-in-1 2)))))))
|
||||
(not found-unequal))))))))))
|
||||
|
||||
{
|
||||
:make-nil make-nil
|
||||
:make-boolean make-boolean
|
||||
@ -111,6 +187,7 @@
|
||||
:make-list make-list
|
||||
:make-vector make-vector
|
||||
:make-hash-map make-hash-map
|
||||
:make-fn make-fn
|
||||
;;
|
||||
:mal-nil mal-nil
|
||||
:mal-true mal-true
|
||||
@ -129,4 +206,7 @@
|
||||
:hash-map?* hash-map?*
|
||||
;;
|
||||
:empty?* empty?*
|
||||
:true?* true?*
|
||||
:false?* false?*
|
||||
:equals?* equals?*
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user