shithub: martian9

Info  •  Files  •  Log  •  Branches

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 ->