ref: 7bcded464070dc7573edcdaa2c6f451d3f20b78d
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
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 @ [ gen_sym "x" ]
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 true
^ "))" 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 (Reader.Syntax_error "Unknown"))
(* errors? *)
| [] -> raise (Reader.Syntax_error ("No matching transform for macro: '" ^ Printer.print sym true))
in
match_transform (Core.seq transformers)
with
| Not_found -> raise (Reader.Syntax_error ("'" ^ Printer.print sym true ^ "' is not a known macro")))
| _ -> raise (Reader.Syntax_error "syntax error with defined macro")
;;