ref: df79e7e4c7f40d06925385e94365b5cba554f1fe
parent: 6a277f5b5fd8b91b71aba6352118f004b1f4fc3a
author: smazga <smazga@greymanlabs.com>
date: Thu Aug 27 13:14:32 EDT 2020
macro
--- /dev/null
+++ b/eval.ml
@@ -1,0 +1,134 @@
+module T = Types.Types
+
+let rec quasiquote ast =
+ match ast with
+ | T.List { T.value = [ T.Symbol { T.value = "unquote" }; ast ] } -> ast+ | T.Vector { T.value = [ T.Symbol { T.value = "unquote" }; ast ] } -> ast+ | T.List
+ { T.value =+ T.List { T.value = [ T.Symbol { T.value = "unquote-splicing" }; head ] } :: tail+ }
+ | T.Vector
+ { T.value =+ T.List { T.value = [ T.Symbol { T.value = "unquote-splicing" }; head ] } :: tail+ } -> Types.list [ Types.symbol "concat"; head; quasiquote (Types.list tail) ]
+ | T.List { T.value = head :: tail } | T.Vector { T.value = head :: tail } ->+ Types.list [ Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ]
+ | ast -> Types.list [ Types.symbol "quote"; ast ]
+;;
+
+let rec eval_ast ast env =
+ match ast with
+ | T.Symbol s -> Env.get env ast
+ | T.List { T.value = xs; T.meta } ->+ T.List { T.value = List.map (fun x -> eval x env) xs; T.meta }+ | T.Vector { T.value = xs; T.meta } ->+ T.Vector { T.value = List.map (fun x -> eval x env) xs; T.meta }+ | _ -> ast
+
+and preparse ast env =
+ match ast with
+ | T.List { T.value = s :: args } ->+ (match
+ try Env.get env s with
+ | _ -> T.Nil
+ with
+ | T.Macro { T.value = sym; meta = meta } ->+ let foo = Macro.expand ast env args sym meta in
+ print_endline ("PREPARSE: " ^ (Printer.print foo true)); eval foo env+ | _ -> ast)
+ | _ -> ast
+
+and eval ast env =
+ match preparse ast env with
+ | T.List { T.value = [] } -> ast+ (* Can this be replaced with a define-syntax thing? *)
+ | T.List
+ { T.value = [ T.Symbol { T.value = "define" }; T.List { T.value = arg_list }; body ]+ } ->
+ let sym = List.hd arg_list in
+ let rest = List.tl arg_list in
+ let func =
+ eval
+ (Reader.read
+ ("(lambda ("+ ^ Printer.stringify rest false
+ ^ ") "
+ ^ Printer.print body true
+ ^ ")"))
+ env
+ in
+ Env.set env sym func;
+ func
+ | T.List { T.value = [ T.Symbol { T.value = "define" }; key; expr ] } ->+ let value = eval expr env in
+ Env.set env key value;
+ value
+ | T.List
+ { T.value =+ [ T.Symbol { T.value = "define-syntax" }; keyword; T.List { T.value = macro } ]+ } ->
+ print_endline ("define-syntax: " ^ Printer.print keyword true);+ (match macro with
+ | _ :: literals :: groups ->
+ let macro_entry =
+ Types.macro (Printer.print keyword true) literals (Types.list groups)
+ in
+ Env.set env keyword macro_entry;
+ macro_entry
+ | _ -> T.Nil)
+ | T.List
+ { T.value =+ [ T.Symbol { T.value = "lambda" }; T.Vector { T.value = arg_names }; expr ]+ }
+ | T.List
+ { T.value =+ [ T.Symbol { T.value = "lambda" }; T.List { T.value = arg_names }; expr ]+ } ->
+ Types.proc (function args ->
+ let sub_env = Env.make (Some env) in
+ let rec bind_args a b =
+ match a, b with
+ | [ T.Symbol { T.value = "." }; name ], args ->+ Env.set sub_env name (Types.list args)
+ | name :: names, arg :: args ->
+ Env.set sub_env name arg;
+ bind_args names args
+ | [], [] -> ()
+ | _ -> raise (Reader.Syntax_error "wrong parameter count for lambda")
+ in
+ bind_args arg_names args;
+ eval expr sub_env)
+ (* Can these be replace with define-syntax stuff? *)
+ | T.List
+ { T.value = [ T.Symbol { T.value = "let" }; T.Vector { T.value = bindings }; body ]+ }
+ | T.List
+ { T.value = [ T.Symbol { T.value = "let" }; T.List { T.value = bindings }; body ] }+ ->
+ let sub_env = Env.make (Some env) in
+ let rec bind_pairs = function
+ | T.List { T.value = [ T.Symbol { T.value = sym }; expr ] } :: more ->+ let value = eval expr env in
+ Env.set env (Types.symbol sym) value;
+ bind_pairs more
+ | _ -> ()
+ in
+ bind_pairs bindings;
+ eval body sub_env
+ | T.List { T.value = T.Symbol { T.value = "begin" } :: body } ->+ List.fold_left (fun x expr -> eval expr env) T.Nil body
+ | T.List { T.value = [ T.Symbol { T.value = "if" }; cond; then_expr; else_expr ] } ->+ if Types.to_bool (eval cond env) then eval then_expr env else eval else_expr env
+ | T.List { T.value = [ T.Symbol { T.value = "if" }; cond; then_expr ] } ->+ if Types.to_bool (eval cond env) then eval then_expr env else T.Nil
+ | T.List { T.value = [ T.Symbol { T.value = "quote" }; ast ] } -> ast+ | T.List { T.value = [ T.Symbol { T.value = "quasiquote" }; ast ] } ->+ eval (quasiquote ast) env
+ | T.List _ ->
+ (match eval_ast ast env with
+ | T.List { T.value = T.Proc { T.value = f } :: args } -> f args+ | _ as x ->
+ raise (Reader.Syntax_error ("'" ^ Printer.print x true ^ "' not a function")))+ | _ -> eval_ast ast env
+;;
--- a/m9.ml
+++ b/m9.ml
@@ -10,150 +10,14 @@
make a lisp project (https://github.com/kanaka/mal - thanks
https://github.com/chouser for the fantastic implementation!)
*)
-
module T = Types.Types
let repl_env = Env.make (Some Core.base)
-let rec quasiquote ast =
- match ast with
- | T.List { T.value = [ T.Symbol { T.value = "unquote" }; ast ] } -> ast- | T.Vector { T.value = [ T.Symbol { T.value = "unquote" }; ast ] } -> ast- | T.List
- { T.value =- T.List { T.value = [ T.Symbol { T.value = "unquote-splicing" }; head ] } :: tail- }
- | T.Vector
- { T.value =- T.List { T.value = [ T.Symbol { T.value = "unquote-splicing" }; head ] } :: tail- } -> Types.list [ Types.symbol "concat"; head; quasiquote (Types.list tail) ]
- | T.List { T.value = head :: tail } | T.Vector { T.value = head :: tail } ->- Types.list [ Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ]
- | ast -> Types.list [ Types.symbol "quote"; ast ]
-;;
-
-let rec eval_ast ast env =
- match ast with
- | T.Symbol s -> Env.get env ast
- | T.List { T.value = xs; T.meta } ->- T.List { T.value = List.map (fun x -> eval x env) xs; T.meta }- | T.Vector { T.value = xs; T.meta } ->- T.Vector { T.value = List.map (fun x -> eval x env) xs; T.meta }- | _ -> ast
-
-and preparse ast env =
- match ast with
- | T.List { T.value = s :: args } ->- (match
- try Env.get env s with
- | _ -> T.Nil
- with
- | T.Macro { T.value = sym; meta = meta } ->- Macro.expand ast env args sym meta; ast
- | _ -> ast)
- | _ -> ast
-
-and eval ast env =
- match preparse ast env with
- | T.List { T.value = [] } -> ast- (* Can this be replaced with a define-syntax thing? *)
- | T.List
- { T.value = [ T.Symbol { T.value = "define" }; T.List { T.value = arg_list }; body ]- } ->
- let sym = List.hd arg_list in
- let rest = List.tl arg_list in
- let func =
- eval
- (Reader.read
- ("(lambda ("- ^ Printer.stringify rest false
- ^ ") "
- ^ Printer.print body true
- ^ ")"))
- env
- in
- Env.set env sym func;
- func
- | T.List { T.value = [ T.Symbol { T.value = "define" }; key; expr ] } ->- let value = eval expr env in
- Env.set env key value;
- value
- | T.List
- { T.value =- [ T.Symbol { T.value = "define-syntax" }; keyword; T.List { T.value = macro } ]- } ->
- print_endline ("define-syntax: " ^ Printer.print keyword true);- (match macro with
- | _ :: literals :: groups ->
- let macro_entry =
- Types.macro (Printer.print keyword true) literals (Types.list groups)
- in
- print_endline (" macro_entry: " ^ Printer.print macro_entry true);- print_endline (" literals: " ^ Printer.print literals true);- print_endline (" groups: " ^ Printer.dump groups);- Env.set env keyword macro_entry;
- macro_entry
- | _ -> T.Nil)
- | T.List
- { T.value =- [ T.Symbol { T.value = "lambda" }; T.Vector { T.value = arg_names }; expr ]- }
- | T.List
- { T.value =- [ T.Symbol { T.value = "lambda" }; T.List { T.value = arg_names }; expr ]- } ->
- Types.proc (function args ->
- let sub_env = Env.make (Some env) in
- let rec bind_args a b =
- match a, b with
- | [ T.Symbol { T.value = "." }; name ], args ->- Env.set sub_env name (Types.list args)
- | name :: names, arg :: args ->
- Env.set sub_env name arg;
- bind_args names args
- | [], [] -> ()
- | _ -> raise (Reader.Syntax_error "wrong parameter count for lambda")
- in
- bind_args arg_names args;
- eval expr sub_env)
- (* Can these be replace with define-syntax stuff? *)
- | T.List
- { T.value = [ T.Symbol { T.value = "let" }; T.Vector { T.value = bindings }; body ]- }
- | T.List
- { T.value = [ T.Symbol { T.value = "let" }; T.List { T.value = bindings }; body ] }- ->
- let sub_env = Env.make (Some env) in
- let rec bind_pairs = function
- | T.List { T.value = [ T.Symbol { T.value = sym }; expr ] } :: more ->- let value = eval expr env in
- Env.set env (Types.symbol sym) value;
- bind_pairs more
- | _ -> ()
- in
- bind_pairs bindings;
- eval body sub_env
- | T.List { T.value = T.Symbol { T.value = "begin" } :: body } ->- List.fold_left (fun x expr -> eval expr env) T.Nil body
- | T.List { T.value = [ T.Symbol { T.value = "if" }; cond; then_expr; else_expr ] } ->- if Types.to_bool (eval cond env) then eval then_expr env else eval else_expr env
- | T.List { T.value = [ T.Symbol { T.value = "if" }; cond; then_expr ] } ->- if Types.to_bool (eval cond env) then eval then_expr env else T.Nil
- | T.List { T.value = [ T.Symbol { T.value = "quote" }; ast ] } -> ast- | T.List { T.value = [ T.Symbol { T.value = "quasiquote" }; ast ] } ->- eval (quasiquote ast) env
- | T.List _ ->
- (match eval_ast ast env with
- | T.List { T.value = T.Proc { T.value = f } :: args } -> f args- | _ as x ->
- raise (Reader.Syntax_error ("'" ^ Printer.print x true ^ "' not a function")))- | _ -> eval_ast ast env
-;;
-
let nameplate = "Martian9 Scheme v0.1"
let read str = Reader.read str
let print exp = Printer.print exp true
-let rep str env = print (eval (read str) env)
+let rep str env = print (Eval.eval (read str) env)
let rec main =
try
@@ -162,7 +26,7 @@
repl_env
(Types.symbol "eval")
(Types.proc (function
- | [ ast ] -> eval ast repl_env
+ | [ ast ] -> Eval.eval ast repl_env
| _ -> T.Nil));
ignore
(rep
--- a/macro.ml
+++ b/macro.ml
@@ -1,7 +1,16 @@
module T = Types.Types
+let rec is_matching_pattern sym pattern args matched =
+ match pattern, args with
+ (* literals not handled, yet *)
+ | ph :: pt, ah :: at -> print_endline " LIST <-> LIST";
+ if (ph = "_" || (ph = (Printer.print sym true) && ph = (Printer.print ah true))) then is_matching_pattern sym pt at matched && true else is_matching_pattern sym pt at matched
+ | ph :: pt, [] -> print_endline " LIST <-> []";
+ if (ph = "_" || ph = (Printer.print sym true)) then is_matching_pattern sym pt [] matched && true else false
+ | _, _ -> matched
+
let rec expand ast env args sym meta =
- print_endline (" THIS IS A MACRO: " ^ Printer.print sym true);+ print_endline ("\n\nTHIS IS A MACRO: " ^ Printer.print sym true); print_endline (" META: " ^ Printer.print meta true); print_endline (" ARGS: " ^ Printer.dump args); print_endline (" AST: " ^ Printer.print ast true);@@ -21,38 +30,28 @@
let literals = Types.M9map.find Types.macro_literals m in
let transformers = Types.M9map.find Types.macro_transformers m in
print_endline
- ("--EVAL_MACRO: literals: "+ (" -- EVAL_MACRO: literals: "^ Printer.print literals true
- ^ " transformers: "
+ ^ " transformers: "
^ Printer.print transformers true);
let rec match_transform transforms =
match transforms with
| hd :: tl ->
- print_endline ("__ hd: " ^ Printer.print hd true);- print_endline ("__ args: " ^ Printer.dump args);+ print_endline (" __ hd: " ^ Printer.print hd true);+ print_endline (" __ args: " ^ Printer.dump args);(match hd with
| T.List
{ T.value = [ T.List { T.value = pattern }; T.List { T.value = template } ] }->
- print_endline (" _ multi pattern: " ^ Printer.dump pattern)+ print_endline (" _ multi pattern: " ^ Printer.dump pattern); match_transform tl | T.List { T.value = [ T.List { T.value = pattern }; atom ] } ->- let rec foobar p a pp =
- (match p, a with
- | ph :: pt, ah :: at ->
- print_endline "one"; foobar pt at (pp @ [T.Nil])
- | ph :: pt, [] ->
- print_endline "two"; foobar pt [] (pp @ [T.Nil])
- | _, _ -> print_endline ("three: " ^ Printer.dump pp); pp) in- print_endline ("foobar: " ^ Printer.dump (foobar pattern args []));- print_endline "out";
- (* let tweaked = Str.global_replace (Str.regexp "^_") (Printer.print sym true) (Printer.dump pattern) in
- * print_endline ("tweaked: " ^ tweaked); *)- print_endline (" _ single pattern: " ^ Printer.dump pattern)- | _ -> ());
- match_transform tl
- | [] -> ()
+ print_endline (" _ single pattern: " ^ Printer.dump pattern);+ print_endline ("matched?: " ^ (if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) args true then "yes" else "no"));+ if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) args true then atom else match_transform tl
+ | _ -> ast)
+ | [] -> ast
in
match_transform (Core.seq transformers)
with
- | Not_found -> ())
- | _ -> ()
+ | Not_found -> ast)
+ | _ -> ast
--- a/mkfile
+++ b/mkfile
@@ -8,7 +8,8 @@
reader.ml\
printer.ml\
core.ml\
- macro.ml
+ macro.ml\
+ eval.ml
$BIN:
ocamlc str.cma -g -o $target $FILES m9.ml