Skip to content

Commit

Permalink
Add step 4
Browse files Browse the repository at this point in the history
  • Loading branch information
sogaiu committed Apr 22, 2021
1 parent c916bde commit 9d4c05e
Show file tree
Hide file tree
Showing 4 changed files with 402 additions and 2 deletions.
160 changes: 160 additions & 0 deletions impls/fennel/core.fnl
View file
Original file line number Diff line number Diff line change
@@ -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
}
28 changes: 26 additions & 2 deletions impls/fennel/env.fnl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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]
Expand Down
136 changes: 136 additions & 0 deletions impls/fennel/step4_if_fn_do.fnl
View file
Original file line number Diff line number Diff line change
@@ -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))))))))
Loading

0 comments on commit 9d4c05e

Please sign in to comment.