shithub: martian9

Download patch

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