shithub: martian9

Download patch

ref: dd3012ec25538fc83f12e81520f0470fcc9020fa
parent: 8b4ebe50739d76ce9591716e394ca68194f22245
author: McKay Marston <[email protected]>
date: Wed Nov 25 17:07:16 EST 2020 

checkpoint before tokenizing


--- a/core.ml
+++ b/core.ml
@@ -18,8 +18,8 @@
 let mk_bool x = T.Bool x
 
 let seq = function
-  | T.List { T.value = xs } -> xs
-  | T.Vector { T.value = xs } -> xs
+  | T.List { T.value = xs; meta = _ } -> xs
+  | T.Vector { T.value = xs; meta = _ } -> xs
   | _ -> []
 ;;
 
@@ -88,14 +88,15 @@
     env
     (Types.symbol "empty?")
     (Types.proc (function
-        | [ T.List { T.value = [] } ] -> T.Bool true
-        | [ T.Vector { T.value = [] } ] -> T.Bool true
+        | [ T.List { T.value = []; meta = _ } ] -> T.Bool true
+        | [ T.Vector { T.value = []; meta = _ } ] -> T.Bool true
         | _ -> T.Bool false));
   Env.set
     env
     (Types.symbol "count")
     (Types.proc (function
-        | [ T.List { T.value = xs } ] | [ T.Vector { T.value = xs } ] -> Types.number (float_of_int (List.length xs))
+        | [ T.List { T.value = xs; meta = _ } ] | [ T.Vector { T.value = xs; meta = _ } ] ->
+          Types.number (float_of_int (List.length xs))
         | _ -> Types.number 0.));
   Env.set
     env
--- a/env.ml
+++ b/env.ml
@@ -13,7 +13,7 @@
 let set env sym value =
   match sym with
   | T.Symbol { T.value = key; T.meta = _ } ->
-    (* print_endline ("Env.set: " ^ key); *) env.data := Data.add key value !(env.data)
+     (* print_endline ("Env.set: " ^ key); *) env.data := Data.add key value !(env.data)
   | _ -> raise (Invalid_argument "set: not a symbol")
 ;;
 
--- a/eval.ml
+++ b/eval.ml
@@ -2,12 +2,17 @@
 
 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 } ->
+  | T.List { T.value = [ T.Symbol { T.value = "unquote"; meta = _ }; ast ]; meta = _ } -> ast
+  | T.Vector { T.value = [ T.Symbol { T.value = "unquote"; meta = _ }; ast ]; meta = _ } -> ast
+  | T.List
+      { T.value = T.List { T.value = [ T.Symbol { T.value = "unquote-splicing"; meta = _ }; head ]; meta = _ } :: tail
+      ; meta = _
+      }
+  | T.Vector
+      { T.value = T.List { T.value = [ T.Symbol { T.value = "unquote-splicing"; meta = _ }; head ]; meta = _ } :: tail
+      ; meta = _
+      } -> Types.list [ Types.symbol "concat"; head; quasiquote (Types.list tail) ]
+  | T.List { T.value = head :: tail; meta = _ } | T.Vector { T.value = head :: tail; meta = _ } ->
     Types.list [ Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ]
   | ast -> Types.list [ Types.symbol "quote"; ast ]
 ;;
@@ -15,7 +20,7 @@
 let rec eval_ast ast env =
   (* print_endline ("EVAL_AST: " ^ Printer.print ast true); *)
   match ast with
-  | T.Symbol s -> Env.get env ast
+  | T.Symbol _ -> Env.get env ast
   | T.List { T.value = xs; T.meta } ->
     (match
        try Env.get env (List.hd xs) with
@@ -28,9 +33,12 @@
 and eval ast env =
   print_endline ("AST: " ^ Printer.print ast true);
   match ast with
-  | T.List { T.value = [] } -> ast
+  | T.List { T.value = []; meta = _ } -> 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 ] } ->
+  | T.List
+      { T.value = [ T.Symbol { T.value = "define"; meta = _ }; T.List { T.value = arg_list; meta = _ }; body ]
+      ; meta = _
+      } ->
     let sym = List.hd arg_list in
     let rest = List.tl arg_list in
     let func =
@@ -37,20 +45,34 @@
       eval (Reader.read ("(lambda (" ^ Printer.stringify rest false ^ ") " ^ Printer.print body true ^ ")")) env
     in
     print_endline ("DEFINE: " ^ Printer.print sym true);
-    print_endline ("  => " ^ "(lambda (" ^ Printer.stringify rest false ^ ") " ^ Printer.print body true ^ ")");
+    print_endline
+      ("  => "
+      ^ "(define "
+      ^ Printer.print sym true
+      ^ " (lambda ("
+      ^ Printer.stringify rest false
+      ^ ") "
+      ^ Printer.print body true
+      ^ "))");
     Env.set env sym func;
     func
-  | T.List { T.value = [ T.Symbol { T.value = "define" }; key; expr ] } ->
+  | T.List { T.value = [ T.Symbol { T.value = "define"; meta = _ }; key; expr ]; meta = _ } ->
     let value = eval expr env in
     Env.set env key value;
     value
-  | 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 ] } ->
+  | T.List
+      { T.value = [ T.Symbol { T.value = "lambda"; meta = _ }; T.Vector { T.value = arg_names; meta = _ }; expr ]
+      ; meta = _
+      }
+  | T.List
+      { T.value = [ T.Symbol { T.value = "lambda"; meta = _ }; T.List { T.value = arg_names; meta = _ }; expr ]
+      ; meta = _
+      } ->
     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)
+          | [ T.Symbol { T.value = "."; meta = _ }; name ], args -> Env.set sub_env name (Types.list args)
           | name :: names, arg :: args ->
             Env.set sub_env name arg;
             bind_args names args
@@ -67,11 +89,16 @@
         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 ] } ->
+  | T.List
+      { T.value = [ T.Symbol { T.value = "let"; meta = _ }; T.Vector { T.value = bindings; meta = _ }; body ]
+      ; meta = _
+      }
+  | T.List
+      { T.value = [ T.Symbol { T.value = "let"; meta = _ }; T.List { T.value = bindings; meta = _ }; body ]; meta = _ }
+    ->
     let sub_env = Env.make (Some env) in
     let rec bind_pairs = function
-      | T.List { T.value = [ T.Symbol { T.value = sym }; expr ] } :: more ->
+      | T.List { T.value = [ T.Symbol { T.value = sym; meta = _ }; expr ]; meta = _ } :: more ->
         let value = eval expr env in
         Env.set env (Types.symbol sym) value;
         bind_pairs more
@@ -79,18 +106,18 @@
     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 ] } ->
+  | T.List { T.value = T.Symbol { T.value = "begin"; meta = _ } :: body; meta = _ } ->
+    List.fold_left (fun _ expr -> eval expr env) T.Nil body
+  | T.List { T.value = [ T.Symbol { T.value = "if"; meta = _ }; cond; then_expr; else_expr ]; meta = _ } ->
     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 ] } ->
+  | T.List { T.value = [ T.Symbol { T.value = "if"; meta = _ }; cond; then_expr ]; meta = _ } ->
     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 { T.value = [ T.Symbol { T.value = "quote"; meta = _ }; ast ]; meta = _ } -> ast
+  | T.List { T.value = [ T.Symbol { T.value = "quasiquote"; meta = _ }; ast ]; meta = _ } -> eval (quasiquote ast) env
   | T.List _ ->
     (match eval_ast ast env with
-    | T.List { T.value = T.Proc { T.value = f } :: args } -> f args
-    | T.List { T.value = T.Macro { T.value = _ } :: macro :: _ } ->
+    | T.List { T.value = T.Proc { T.value = f; meta = _ } :: args; meta = _ } -> f args
+    | T.List { T.value = T.Macro { T.value = _; meta = _ } :: macro :: _; meta = _ } ->
       print_endline "MACRO EVALUATION";
       eval macro env
     | _ as x -> raise (Utils.Syntax_error ("'" ^ Printer.print x true ^ "' not a function")))
--- a/m9.ml
+++ b/m9.ml
@@ -13,12 +13,13 @@
 module T = Types.Types
 
 let repl_env = Env.make (Some Core.base)
-let nameplate = "Martian9 Scheme v0.1"
+let nameplate = "Martian9 Scheme v0.2"
 let read str = Reader.read str
 let print exp = Printer.print exp true
 let rep str env = print (Eval.eval (read str) env)
 
-let rec main =
+let main =
+  print_endline nameplate;
   try
     Core.init Core.base;
     Env.set
--- a/macro.ml
+++ b/macro.ml
@@ -95,26 +95,27 @@
 ;;
 
 let sanitize_macro pattern template =
-  try
-    ignore (Str.search_forward (Str.regexp "...") (Printer.stringify pattern true) 0);
-    let substitution = Printer.print (gen_sym "x") true in
-    let pattern_str =
-      Str.global_replace
-        (Str.regexp "\\.\\.\\.")
-        substitution
-        (Printer.stringify pattern true)
-    in
-    let template_str =
-      Str.global_replace
-        (Str.regexp "\\.\\.\\.")
-        substitution
-        (Printer.stringify template true)
-    in
-    (* let args_str = Printer.stringify args true in *)
-    (* print_endline ("ellipsis: template: " ^ template_str ^ "  args: " ^ args_str); *)
-    "(" ^ pattern_str ^ ") " ^ template_str ^ ")"
-  with
-  | Not_found -> "(" ^ Printer.dump pattern ^ ") " ^ Printer.dump template ^ ")"
+  let sanitized =
+    try
+      ignore (Str.search_forward (Str.regexp "...") (Printer.stringify pattern true) 0);
+      let substitution = Printer.print (gen_sym "x") true in
+      let pattern_str =
+        Str.global_replace
+          (Str.regexp "\\.\\.\\.")
+          substitution
+          (Printer.stringify pattern true)
+      in
+      let template_str =
+        Str.global_replace
+          (Str.regexp "\\.\\.\\.")
+          substitution
+          (Printer.stringify template true)
+      in
+      "(" ^ pattern_str ^ ") (" ^ template_str ^ ")"
+    with
+    | Not_found -> "(" ^ Printer.dump pattern ^ ") (" ^ Printer.dump template ^ ")"
+  in
+  print_endline ("SANITIZED: " ^ sanitized); sanitized
 ;;
 
 let parse ast _ =
@@ -131,15 +132,12 @@
   (* | T.List { T.value = [ T.List { T.value = pattern; meta = _ }; T.List {T.value = [ transform ]; meta = _ } ]; meta = _ } -> *)
   | T.List { T.value = [ T.List { T.value = pattern; meta = _ }; T.List { T.value = transform; meta = _ } ]; meta = _ }
     ->
-    let args = ref [] in
-    for _ = 1 to 5 do
-      args := !args @ [ gen_sym prefix ];
-      print_endline ("HAXXOR: " ^ prefix ^ ":: " ^ Printer.dump pattern ^ " :: " ^ Printer.dump transform);
-      clauses := !clauses @ [ sanitize_macro pattern transform !args ]
-    done
+    print_endline ("HAXXOR: " ^ prefix ^ ":: " ^ Printer.dump pattern ^ " :: " ^ Printer.dump transform);
+    clauses := !clauses @ [ sanitize_macro pattern transform ]
   (* needs to match ((_) #t) : LIST(LIST() ATOM) *)
   | T.List { T.value = [ T.List { T.value = pattern; meta = _ }; atom ]; meta = _ } ->
-    print_endline ("FOUND CLAUSE WITH ATOM: " ^ Printer.print atom true ^ "   pattern: " ^ Printer.dump pattern)
+     print_endline ("FOUND CLAUSE WITH ATOM: " ^ Printer.print atom true ^ "   pattern: " ^ Printer.dump pattern);
+     clauses := !clauses @ [ sanitize_macro pattern [ atom ] ]
   | _ as x -> print_endline ("nope: " ^ Printer.print x true));
   !clauses
 ;;
@@ -168,21 +166,21 @@
   sanitize_clauses clauses
 ;;
 
-let generate_variants sym _ patterns =
+let generate_variants sym _ clauses =
   let symbol = Printer.print sym true in
   let variants = ref Types.M9map.empty in
   let rec register_variants clauses =
     let new_sym = gen_sym symbol in
     match clauses with
-    | [ pattern ] ->
-      variants := Types.M9map.add new_sym pattern !variants;
+    | [ clause ] ->
+      variants := Types.M9map.add new_sym clause !variants;
       !variants
-    | pattern :: rest ->
-      variants := Types.M9map.add new_sym pattern !variants;
+    | clause :: rest ->
+      variants := Types.M9map.add new_sym clause !variants;
       register_variants rest
-    | _ -> raise (Utils.Syntax_error "macro pattern registration botch")
+    | _ -> raise (Utils.Syntax_error "macro clause registration botch")
   in
-  register_variants patterns
+  register_variants clauses
 ;;
 
 let match_variant macro args =
--- a/notes.org
+++ b/notes.org
@@ -1,3 +1,5 @@
+* Current work
+Need to take advantage of ellipsis() to handle generating extras
 * First things:
 ** DONE Remove kw_macro
 We determine what's a macro based on "syntax-rules" (so we need to make sure that's always there)
--- a/reader.ml
+++ b/reader.ml
@@ -40,6 +40,7 @@
 ;;
 
 let fix_pattern sym pattern =
+  print_endline(" fix_pattern: " ^ pattern ^ "  sym: " ^ Printer.print sym true);
   let tokenized_pattern = tokenize pattern in
   let new_pattern = ref [] in
   let rec replace_token tokens =
@@ -54,7 +55,8 @@
       replace_token rest
     | _ -> raise (Utils.Syntax_error "unable to fix pattern")
   in
-  replace_token (List.hd tokenized_pattern :: "define" :: List.tl tokenized_pattern)
+  let trimmed = List.tl tokenized_pattern in
+  replace_token (["("; "define"; List.hd trimmed; "("; "lambda"; "("] @ List.tl trimmed @ [ ")"; ")" ])
 ;;
 
 let read_atom token =
@@ -134,11 +136,13 @@
     print_endline ("  sym: " ^ Printer.print sym true);
     print_endline ("    rest: " ^ Printer.dump rest);
     (match rest with
-    | [ T.List { T.value = T.Symbol { T.value = "syntax-rules"; meta = _ } :: literals :: clauses; meta = _ } ] ->
-      let sanitized_clauses = Macro.generate_patterns sym clauses in
-      print_endline ("sanitized: " ^ String.concat " " (List.map (fun x -> String.concat " " x) sanitized_clauses));
+     | [ T.List { T.value = T.Symbol { T.value = "syntax-rules"; meta = _ } :: literals :: clauses; meta = _ } ] ->
+        List.iter (fun x -> print_endline("<<<<< " ^ String.concat "." x)) (Macro.generate_patterns sym clauses);
+      let sanitized_clauses = List.map (fun x -> (read_form x).form) (Macro.generate_patterns sym clauses) in
+      (* print_endline ("sanitized: " ^ String.concat " " (List.map (fun x -> String.concat " " x) sanitized_clauses)); *)
+      print_endline ("sanitized: " ^ Printer.dump sanitized_clauses);
       let variants = Macro.generate_variants sym literals sanitized_clauses in
-      let macro_entry = Types.macro sym literals (Types.list clauses) variants in
+      let macro_entry = Types.macro sym literals (Types.list sanitized_clauses) variants in
       Env.set registered_macros sym macro_entry;
       Types.M9map.iter
         (fun k v ->