ref: 5597ed0a108af923f112a4ca6336071f71bae6bd
dir: /macro.ml/
module T = Types.Types
let gen_sym root =
let gen () =
match Random.int (26 + 26 + 10) with
| n when n < 26 -> int_of_char 'a' + n
| n when n < 26 + 26 -> int_of_char 'A' + n - 26
| n -> int_of_char '0' + n - 26 - 26
in
let gen _ = String.make 1 (char_of_int (gen ())) in
Types.symbol (root ^ String.concat "" (Array.to_list (Array.init 5 gen)))
;;
let rec is_matching_pattern sym pattern args matched =
match pattern, args with
(* literals and ellipses not handled, yet *)
| ph :: pt, ah :: at ->
(* print_endline " LIST <-> LIST"; *)
if ph = "_" || (ph = Printer.print sym true && sym = ah)
then is_matching_pattern sym pt at matched && true
else (* print_endline (" ------> " ^ ph ^ " vs " ^ Printer.print ah true); *)
is_matching_pattern sym pt at matched
| ph :: pt, [] ->
(* print_endline " LIST <-> []";
* print_endline (" ph: " ^ ph);
* print_endline (" pt: " ^ String.concat "|" pt); *)
if ph = "_" || ph = Printer.print sym true
then is_matching_pattern sym pt [] matched && true
else ph = "..." || List.hd pt = "..."
| [], ah :: at ->
(* print_endline " [] <-> LIST"; *)
false
| _, _ -> matched
;;
let rec ellipsis pattern template args =
let has_ellipsis =
try
ignore (Str.search_forward (Str.regexp "...") (Printer.stringify pattern true) 0);
true
with
| Not_found -> false
in
let ellipsis_substitutions = ref [] in
let missing = List.length args - List.length pattern + if has_ellipsis then 1 else 0 in
print_endline ("missing: " ^ string_of_int missing);
(* print_endline (" NEED TO ADD " ^ string_of_int missing ^ " PLACEHOLDERS"); *)
match missing with
| _ when missing = 0 || missing > 0 ->
(* add arguments *)
print_endline ("ADD " ^ string_of_int missing ^ " arguments");
for i = 1 to missing do
ellipsis_substitutions := !ellipsis_substitutions @ [ (Printer.print (gen_sym "x") true) ]
done;
let pattern_str =
Str.global_replace
(Str.regexp "\\.\\.\\.")
(String.concat " " !ellipsis_substitutions)
(Printer.stringify pattern true)
in
let template_str =
Str.global_replace
(Str.regexp "\\.\\.\\.")
(String.concat " " !ellipsis_substitutions)
(Printer.print template true)
in
(* let args_str = Printer.stringify args true in *)
(* print_endline ("ellipsis: template: " ^ template_str ^ " args: " ^ args_str); *)
"(" ^ pattern_str ^ ") " ^ template_str ^ ")"
| _ when missing < 0 ->
(* remove ellipsis and arg *)
print_endline "REMOVE arguments";
(* let rgx = Str.regexp "[a-zA-Z0-9]+ \\.\\.\\." in *)
let rgx = Str.regexp "[a-zA-Z0-9]+ \\.\\.\\." in
let pattern_str = Str.global_replace rgx "" (Printer.stringify pattern true) in
let template_str = Str.global_replace rgx "" (Printer.stringify pattern true) in
print_endline (" pattern: " ^ Printer.dump pattern);
print_endline (" pattern_str: " ^ pattern_str);
print_endline (" template: " ^ Printer.print template true);
print_endline (" template_str: " ^ template_str);
print_endline ("(" ^ pattern_str ^ ") " ^ template_str ^ ")");
"(" ^ pattern_str ^ ") " ^ template_str ^ ")"
| _ -> "(" ^ Printer.dump pattern ^ ") " ^ Printer.print template true ^ ")"
;;
(* let lambdaize pattern template args =
* match pattern, args with
* | ph :: pt, ah :: at :: rest ->
* let expr = "((lambda " ^ ellipsis pt template args ^ Printer.stringify args false ^ ")" in
* print_endline (" lambdaize list list: " ^ expr);
* Reader.read expr
* | ph :: pt, ah :: at ->
* let expr =
* "((lambda ("
* ^ Printer.stringify pt true
* ^ ")"
* ^ Printer.print template true
* ^ ")"
* ^ Printer.stringify args true
* ^ ")"
* in
* print_endline (" lambdaize short list: " ^ expr);
* Reader.read expr
* | ph :: pt, [] ->
* let expr = "((lambda (" ^ Printer.stringify pt false ^ ") " ^ Printer.print template false ^ "))" in
* print_endline (" lambdaize empty list: " ^ expr);
* Reader.read expr
* | _ ->
* print_endline "lambdaize: empty";
* Reader.read ("((lambda () " ^ Printer.print template true ^ "))")
* ;; *)
(* let rec expand ast env args sym meta =
* 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);
* match meta with
* | T.Map { T.value = m } ->
* ((\* let literals = Types.M9map.find Types.macro_literals m in *\)
* try
* let transformers = Types.M9map.find Types.macro_transformers m in
* print_endline
* (" -- EVAL_MACRO: "
* (\* ^ " literals: "
* * ^ Printer.print literals true *\)
* ^ " transformers: "
* ^ Printer.print transformers true);
* let rec match_transform transforms =
* match transforms with
* | hd :: tl ->
* (\* print_endline (" transform: " ^ Printer.print hd true); *\)
* (match hd with
* | T.List { T.value = [ T.List { T.value = pattern }; T.List { T.value = template } ] } ->
* (\* print_endline " MULTI";
* * print_endline (" - template: " ^ Printer.dump template); *\)
* print_endline
* (" matched (m)?: "
* ^ (if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
* then "yes"
* else "no")
* ^ " ::> "
* ^ Printer.dump pattern);
* if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
* then lambdaize pattern (Types.list template) args
* else match_transform tl
* | T.List { T.value = [ T.List { T.value = pattern }; atom ] } ->
* (\* print_endline " SINGLE"; *\)
* print_endline
* (" matched (s)?: "
* ^ (if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
* then "yes"
* else "no")
* ^ " ::> "
* ^ Printer.dump pattern);
* if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
* then lambdaize pattern atom args
* else match_transform tl
* | _ -> raise (Utils.Syntax_error "Unknown"))
* (\* errors? *\)
* | [] -> raise (Utils.Syntax_error ("No matching transform for macro: '" ^ Printer.print sym true))
* in
* match_transform (Core.seq transformers)
* with
* | Not_found -> raise (Utils.Syntax_error ("'" ^ Printer.print sym true ^ "' is not a known macro")))
* | _ -> raise (Utils.Syntax_error "syntax error with defined macro")
* ;; *)
(* let rec parse ast env args sym meta =
* print_endline("\n\nREADING MACRO: " ^ Printer.print sym true);
* match meta with
* | T.Map { T.value = m } ->
* (try
* let transformers = Types.M9map.find Types.macro_transformers m in
* let rec match_transform transforms =
* match transforms with
* | hd :: tl ->
* (match hd with
* | T.List { T.value = [ T.List { T.value = pattern }; T.List {T.value = template } ] } ->
* if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
* then lambdaize pattern (Types.list template) args
* else match_transform tl
* | T.List { T.value = [ T.List { T.value = pattern }; atom ] } ->
* if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
* then lambdaize pattern atom args
* else match_transform tl
* | _ -> raise (Utils.Syntax_error "no transform match"))
* | [] -> raise (Utils.Syntax_error ("No matching transform for macro: '" ^ Printer.print sym true))
* in
* match_transform (Core.seq transformers)
* with
* | Not_found -> raise (Utils.Syntax_error ("'" ^ Printer.print sym true ^ "' is not a known macro")))
* | _ -> raise (Utils.Syntax_error "syntax error with defined macro") *)
let rec parse ast macros =
print_endline ("\n\nREADING MACRO: " ^ String.concat " " ast);
match ast with
| [] -> raise End_of_file
| 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 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
* let variants = Types.M9map.find Types.macro_variants macro.meta *)
(* match
* try Env.get env (Types.symbol sym) with
* | _ -> T.Nil
* with
* | T.Macro { T.value = sym; meta } ->
* let variants = Types.M9map.find Types.macro_variants meta in
* Types.M9map.add Types.macro_variants (new_variant :: variants) meta
* | _ -> raise (Utils.Runtime_error ("wayward variant of " ^ sym ^ ": " ^ variant)) *)
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 ] ->
variants := Types.M9map.add (gen_sym symbol) pattern !variants;
!variants
| pattern :: rest ->
variants := Types.M9map.add (gen_sym symbol) pattern !variants;
register_variants rest
| _ -> raise (Utils.Syntax_error "macro pattern registration botch")
in
register_variants patterns
;;
(* match meta with
* | T.Map { T.value = m } ->
* (try
* let transformers = Types.M9map.find Types.macro_transformers m in
* let rec match_transform transforms =
* match transforms with
* | hd :: tl ->
* (match hd with
* | T.List { T.value = [ T.List { T.value = pattern }; T.List {T.value = template } ] } ->
* if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
* then lambdaize pattern (Types.list template) args
* else match_transform tl
* | T.List { T.value = [ T.List { T.value = pattern }; atom ] } ->
* if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
* then lambdaize pattern atom args
* else match_transform tl
* | _ -> raise (Utils.Syntax_error "no transform match"))
* | [] -> raise (Utils.Syntax_error ("No matching transform for macro: '" ^ Printer.print sym true))
* in
* match_transform (Core.seq transformers)
* with
* | Not_found -> raise (Utils.Syntax_error ("'" ^ Printer.print sym true ^ "' is not a known macro")))
* | _ -> raise (Utils.Syntax_error "syntax error with defined macro") *)