Skip to content

Commit

Permalink
refactor bindings
Browse files Browse the repository at this point in the history
  • Loading branch information
@fabjan @kanaka
fabjan authored and kanaka committed May 2, 2021
1 parent e0925d5 commit 79962a1
Show file tree
Hide file tree
Showing 5 changed files with 30 additions and 44 deletions.
13 changes: 5 additions & 8 deletions impls/sml/step4_if_fn_do.sml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,23 +29,20 @@ and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b
and evalFn e [(LIST binds),body] = makeFn e binds body
| evalFn e [(VECTOR binds),body] = makeFn e binds body
| evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body"
and makeFn e binds body = FN (fn (exprs) => eval (bind' binds exprs (inside e)) body)
and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body)

and evalApply e (FN f) args = f (map (eval e) args)
| evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (LIST args))

and evalSymbol e s = valOrElse (lookup e s)
(fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found"))

and bind (SYMBOL s::v::rest) e = (def s (eval e v) e; bind rest e)
| bind [] e = e
and bind (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (LIST (map (eval e) (v::vs))) e; e)
| bind [SYMBOL "&", SYMBOL s] e = (def s (LIST []) e; e)
| bind (SYMBOL s::v::rest) e = (def s (eval e v) e; bind rest e)
| bind [] e = e
| bind _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs"

and bind' [SYMBOL "&", SYMBOL s] vs e = (def s (LIST (map (eval e) vs)) e; e)
| bind' (SYMBOL s::bs) (v::vs) e = (def s (eval e v) e; bind' bs vs e)
| bind' [] _ e = e
| bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs"

fun print f =
prReadableStr f

Expand Down
13 changes: 5 additions & 8 deletions impls/sml/step6_file.sml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,23 +29,20 @@ and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b
and evalFn e [(LIST binds),body] = makeFn e binds body
| evalFn e [(VECTOR binds),body] = makeFn e binds body
| evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body"
and makeFn e binds body = FN (fn (exprs) => eval (bind' binds exprs (inside e)) body)
and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body)

and evalApply e (FN f) args = f (map (eval e) args)
| evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (LIST args))

and evalSymbol e s = valOrElse (lookup e s)
(fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found"))

and bind (SYMBOL s::v::rest) e = (def s (eval e v) e; bind rest e)
| bind [] e = e
and bind (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (LIST (map (eval e) (v::vs))) e; e)
| bind [SYMBOL "&", SYMBOL s] e = (def s (LIST []) e; e)
| bind (SYMBOL s::v::rest) e = (def s (eval e v) e; bind rest e)
| bind [] e = e
| bind _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs"

and bind' [SYMBOL "&", SYMBOL s] vs e = (def s (LIST (map (eval e) vs)) e; e)
| bind' (SYMBOL s::bs) (v::vs) e = (def s (eval e v) e; bind' bs vs e)
| bind' [] _ e = e
| bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs"

fun print f =
prReadableStr f

Expand Down
13 changes: 5 additions & 8 deletions impls/sml/step7_quote.sml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,7 +32,7 @@ and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b
and evalFn e [(LIST binds),body] = makeFn e binds body
| evalFn e [(VECTOR binds),body] = makeFn e binds body
| evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body"
and makeFn e binds body = FN (fn (exprs) => eval (bind' binds exprs (inside e)) body)
and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body)

and evalQuote e [x] = x
| evalQuote _ _ = raise NotApplicable "quote needs one argument"
Expand All @@ -53,15 +53,12 @@ and evalApply e (FN f) args = f (map (eval e) args)
and evalSymbol e s = valOrElse (lookup e s)
(fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found"))

and bind (SYMBOL s::v::rest) e = (def s (eval e v) e; bind rest e)
| bind [] e = e
and bind (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (LIST (map (eval e) (v::vs))) e; e)
| bind [SYMBOL "&", SYMBOL s] e = (def s (LIST []) e; e)
| bind (SYMBOL s::v::rest) e = (def s (eval e v) e; bind rest e)
| bind [] e = e
| bind _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs"

and bind' [SYMBOL "&", SYMBOL s] vs e = (def s (LIST (map (eval e) vs)) e; e)
| bind' (SYMBOL s::bs) (v::vs) e = (def s (eval e v) e; bind' bs vs e)
| bind' [] _ e = e
| bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs"

fun print f =
prReadableStr f

Expand Down
30 changes: 11 additions & 19 deletions impls/sml/step8_macros.sml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,8 +22,8 @@ and eval' e (LIST (SYMBOL "def!"::args)) = evalDef e args
and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end
| evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate"

and evalLet e [LIST bs, ast] = eval (bindLet bs (inside e)) ast
| evalLet e [VECTOR bs, ast] = eval (bindLet bs (inside e)) ast
and evalLet e [LIST bs, ast] = let val e = inside e in eval (bind (eval e) bs e) ast end
| evalLet e [VECTOR bs, ast] = let val e = inside e in eval (bind (eval e) bs e) ast end
| evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate"

and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs
Expand All @@ -36,7 +36,7 @@ and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b
and evalFn e [(LIST binds),body] = makeFn e binds body
| evalFn e [(VECTOR binds),body] = makeFn e binds body
| evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body"
and makeFn e binds body = FN (fn (exprs) => eval (bindFn binds exprs (inside e)) body)
and makeFn e binds body = FN (fn (exprs) => eval (bind (eval e) (interleave binds exprs) (inside e)) body)

and evalQuote e [x] = x
| evalQuote _ _ = raise NotApplicable "quote needs one argument"
Expand All @@ -54,7 +54,7 @@ and quasiFolder (LIST [SYMBOL "splice-unquote", x], acc) = [SYMBOL "concat", x,
and evalDefmacro e [SYMBOL s, LIST [SYMBOL "fn*", LIST binds, body]] = let val m = makeMacro e binds body in (def s m e; m) end
| evalDefmacro e [SYMBOL s, LIST [SYMBOL "fn*", VECTOR binds, body]] = let val m = makeMacro e binds body in (def s m e; m) end
| evalDefmacro _ _ = raise NotApplicable "defmacro! needs a name, a list of bindings, and a body"
and makeMacro e binds body = MACRO (fn (exprs) => eval (bindMacro binds exprs (inside e)) body)
and makeMacro e binds body = MACRO (fn (exprs) => eval (bind identity (interleave binds exprs) (inside e)) body)

and expandMacro e [(ast as LIST (SYMBOL s::args))] = (case lookup e s of SOME (MACRO m) => m args | _ => ast)
| expandMacro _ [ast] = ast
Expand All @@ -66,19 +66,11 @@ and evalApply e (FN f) args = f (map (eval e) args)
and evalSymbol e s = valOrElse (lookup e s)
(fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found"))

and bindLet (SYMBOL s::v::rest) e = (def s (eval e v) e; bindLet rest e)
| bindLet [] e = e
| bindLet _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs"

and bindFn [SYMBOL "&", SYMBOL s] vs e = (def s (LIST (map (eval e) vs)) e; e)
| bindFn (SYMBOL s::bs) (v::vs) e = (def s (eval e v) e; bindFn bs vs e)
| bindFn [] _ e = e
| bindFn _ _ _ = raise NotApplicable "bindings must be a pair of symbol/form lists"

and bindMacro [SYMBOL "&", SYMBOL s] vs e = (def s (LIST vs) e; e)
| bindMacro (SYMBOL s::bs) (v::vs) e = (def s v e; bindMacro bs vs e)
| bindMacro [] _ e = e
| bindMacro _ _ _ = raise NotApplicable "bindings must be a pair of symbol/form lists"
and bind evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (LIST (map evl (v::vs))) e; e)
| bind _ [SYMBOL "&", SYMBOL s] e = (def s (LIST []) e; e)
| bind evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind evl rest e)
| bind _ [] e = e
| bind _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs"

fun print f =
prReadableStr f
Expand All @@ -88,7 +80,7 @@ fun rep e s =
handle Nothing => ""
| e => "ERROR: " ^ (exnMessage e)

val initEnv = ENV (NS (ref [])) |> bindLet coreNs
val initEnv = ENV (NS (ref [])) |> bind identity coreNs

fun repl e =
let open TextIO
Expand Down Expand Up @@ -124,7 +116,7 @@ val prelude = " \
\ (cons 'cond (rest (rest xs)))))))"

fun main () = (
bindLet [
bind identity [
SYMBOL "eval",
FN (fn ([x]) => eval initEnv x
| _ => raise NotApplicable "'eval' requires one argument")
Expand Down
5 changes: 4 additions & 1 deletion impls/sml/util.sml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,10 @@ fun valIfNone _ (SOME a) = a
| valIfNone b _ = b ()

fun interleave (x::xs) (y::ys) = x :: y :: interleave xs ys
| interleave _ _ = []
| interleave [] ys = ys
| interleave xs [] = xs

fun identity x = x

fun triml k s = String.extract (s, k, NONE)

Expand Down

0 comments on commit 79962a1

Please sign in to comment.