ref: 5597ed0a108af923f112a4ca6336071f71bae6bd
parent: 689862826175d1b783f98018c1484c78396a33aa
author: McKay Marston <[email protected]>
date: Wed Oct 14 19:37:07 EDT 2020
getting so close
--- a/eval.ml
+++ b/eval.ml
@@ -78,13 +78,13 @@
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 } ] } ->- (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 = "define-syntax" }; keyword; T.List { T.value = macro } ] } ->+ * (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 ->
--- a/macro.ml
+++ b/macro.ml
@@ -8,7 +8,7 @@
| n -> int_of_char '0' + n - 26 - 26
in
let gen _ = String.make 1 (char_of_int (gen ())) in
- root ^ String.concat "" (Array.to_list (Array.init 5 gen))
+ Types.symbol (root ^ String.concat "" (Array.to_list (Array.init 5 gen)))
;;
let rec is_matching_pattern sym pattern args matched =
@@ -50,7 +50,7 @@
(* add arguments *)
print_endline ("ADD " ^ string_of_int missing ^ " arguments");for i = 1 to missing do
- ellipsis_substitutions := !ellipsis_substitutions @ [ gen_sym "x" ]
+ ellipsis_substitutions := !ellipsis_substitutions @ [ (Printer.print (gen_sym "x") true) ]
done;
let pattern_str =
Str.global_replace
@@ -199,21 +199,21 @@
| macro :: tokens -> print_endline (" macro: " ^ macro);;
-let add_variant sym variant env =
- let new_variant = gen_sym sym in
- match
- try Env.get env (Types.symbol sym) with
- | _ -> T.Nil
- with
- | T.Macro { T.value = sym; meta } ->- (match meta with
- | T.Map { T.value = m } ->- let variants = ref (Types.M9map.find Types.macro_variants m) in
- Types.M9map.add (Types.symbol new_variant) variant !variants;
- print_endline ("ADD_VARIANT: " ^ new_variant ^ ": " ^ Printer.print meta true);- print_endline (" variants: " ^ Printer.print !variants true)- | _ -> raise (Utils.Runtime_error ("macro " ^ (Printer.print sym true) ^ " is missing its variants")))- | _ -> raise (Utils.Syntax_error "add_variant botch")
+(* let add_variant sym variant env =
+ * let new_variant = gen_sym sym in
+ * match
+ * try Env.get env (Types.symbol sym) with
+ * | _ -> T.Nil
+ * with
+ * | T.Macro { T.value = sym; meta } ->+ * (match meta with
+ * | T.Map { T.value = m } ->+ * let variants = ref (Types.M9map.find Types.macro_variants m) in
+ * Types.M9map.add new_variant variant !variants;
+ * print_endline ("ADD_VARIANT: " ^ (Printer.print new_variant true) ^ ": " ^ Printer.print meta true);+ * print_endline (" variants: " ^ Printer.print !variants true)+ * | _ -> raise (Utils.Runtime_error ("macro " ^ (Printer.print sym true) ^ " is missing its variants")))+ * | _ -> raise (Utils.Syntax_error "add_variant botch") *)
;;
(* let macro = Env.get env (Types.symbol sym) in
@@ -227,27 +227,19 @@
* Types.M9map.add Types.macro_variants (new_variant :: variants) meta
* | _ -> raise (Utils.Runtime_error ("wayward variant of " ^ sym ^ ": " ^ variant)) *)-let register_macro macro sym literals patterns env =
+let generate_variants sym literals patterns =
+ let symbol = (Printer.print sym true) in
+ let variants = ref Types.M9map.empty in
let rec register_variants clauses =
match clauses with
| [ pattern ] ->
- print_endline (" " ^ sym ^ ": -> pattern: " ^ pattern);- add_variant sym pattern env
+ variants := Types.M9map.add (gen_sym symbol) pattern !variants;
+ !variants
| pattern :: rest ->
- print_endline (" " ^ sym ^ ": pattern: " ^ pattern);- print_endline (" " ^ sym ^ ": rest: " ^ String.concat " " rest);- (* add_variant sym pattern env; *)
- register_variants rest
+ variants := Types.M9map.add (gen_sym symbol) pattern !variants;
+ register_variants rest
| _ -> raise (Utils.Syntax_error "macro pattern registration botch")
in
- (match
- try Env.get env (Types.symbol sym) with
- | _ -> T.Nil
- with
- | T.Nil ->
- print_endline ("new macro: " ^ sym);- Env.set env (Types.symbol sym) macro
- | _ -> ());
register_variants patterns
;;
--- a/reader.ml
+++ b/reader.ml
@@ -66,6 +66,24 @@
;;
let rec read_list eol list_reader =
+ if (List.length list_reader.tokens > 1) && (List.hd list_reader.tokens) = "("+ then
+ (match
+ try Env.get registered_macros (Types.symbol (List.nth list_reader.tokens 1)) with
+ | _ -> T.Nil
+ with
+ | T.Macro { T.value = sym; meta } ->+ print_endline("FOUND A MACRO! " ^ Printer.print sym true);+ print_endline(" tokens: " ^ String.concat " " list_reader.tokens);+ let rec collect_args tokens args =
+ match tokens with
+ | t :: [] -> args @ [t]
+ | t :: ts -> if t = eol then args else collect_args ts args @ [t]
+ | _ -> []
+ in
+ let args = collect_args (List.tl list_reader.tokens) [] in
+ print_endline(" ### " ^ String.concat " " args)+ | _ -> ());
match list_reader.tokens with
| [] -> raise (Utils.Syntax_error ("unterminated '" ^ eol ^ "'"))| token :: tokens ->
@@ -93,29 +111,19 @@
let list_reader = read_list ")" { list_form = []; tokens } in print_endline ("MACRO: " ^ Printer.dump list_reader.list_form);(match list_reader.list_form with
- (* | sym :: T.List { T.value = [ T.Symbol { T.value = "syntax-rules" }; clause ] } -> *)| sym :: rest ->
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" } :: literals :: clauses } ] ->- let symbol = Printer.print sym true in
- print_endline (" clauses: " ^ Printer.dump clauses);- let macro_entry = Types.macro symbol literals (Types.list clauses) in
- Macro.register_macro
- macro_entry
- symbol
- literals
- (List.map (fun x -> Printer.print x true) clauses)
- registered_macros
- | _ -> raise (Utils.Syntax_error "read_macro botch"))
+ | [ T.List { T.value = T.Symbol { T.value = "syntax-rules" } :: literals :: clauses } ] ->+ let variants = Macro.generate_variants sym literals clauses in
+ print_endline (" variants: " ^ (Printer.print (Types.map variants) true));+ let macro_entry = Types.macro sym literals (Types.list clauses) variants in
+ Env.set registered_macros sym macro_entry;
+ Types.M9map.iter (fun k v -> print_endline (" >> " ^ Printer.print k true ^ ": " ^ Printer.print v true)) variants;+ print_endline(" >>>>>> MACRO: " ^ Printer.print macro_entry true)+ | _ -> raise (Utils.Syntax_error "read_macro botch"))
| _ as x -> print_endline (" rest: " ^ Printer.dump x));- (* | T.List { T.value = [ T.Symbol { T.value = "define-syntax" }; keyword; T.List { T.value = macro } ] } ->- * (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) *)
{ form = Types.list list_reader.list_form; tokens = list_reader.tokens }and read_form all_tokens =
--- a/types.ml
+++ b/types.ml
@@ -72,11 +72,11 @@
let record x = Types.Record { Types.value = x; meta = Types.Nil } let number x = Types.Number { Types.value = x; meta = Types.Bool (is_float x) }-let macro sym literals transformers =
+let macro sym literals transformers variants =
let meta = ref M9map.empty in
meta
:= M9map.add macro_literals literals !meta
|> M9map.add macro_transformers transformers
- |> M9map.add macro_variants (map M9map.empty);
- Types.Macro { Types.value = symbol sym; meta = map !meta }+ |> M9map.add macro_variants (map variants);
+ Types.Macro { Types.value = sym; meta = map !meta };;