ref: dd3012ec25538fc83f12e81520f0470fcc9020fa
dir: /macro.ml/
(* The ⟨pattern⟩ in a ⟨syntax rule⟩ is a list ⟨pattern⟩ whose first element is an identifier.
* A ⟨pattern⟩ is either an identifier, a constant, or one of the following
* (⟨pattern⟩ ...)
* ((_) #t) => ⟨pattern⟩: (_), ...: #t
* (⟨pattern⟩ ⟨pattern⟩ ... . ⟨pattern⟩)
* (⟨pattern⟩ ... ⟨pattern⟩ ⟨ellipsis⟩ ⟨pattern⟩ ...) (⟨pattern⟩ ... ⟨pattern⟩ ⟨ellipsis⟩ ⟨pattern⟩ ... . ⟨pattern⟩)
* #(⟨pattern⟩ ...) => same, only vector
* #(⟨pattern⟩ ... ⟨pattern⟩ ⟨ellipsis⟩ ⟨pattern⟩ ...)
*)
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 = "..."
| [], _ :: _ ->
(* print_endline " [] <-> LIST"; *)
false
| _, _ -> matched
;;
let 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 ("args: " ^ String.concat " " (List.map (fun x -> Printer.print x true) args));
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 _ = 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.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 ^ ")"
(* | _ 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.dump template);
* print_endline (" template_str: " ^ template_str);
* print_endline ("(" ^ pattern_str ^ ") " ^ template_str ^ ")");
* "(" ^ pattern_str ^ ") " ^ template_str ^ ")" *)
| _ -> "(" ^ Printer.dump pattern ^ ") " ^ Printer.dump template ^ ")"
;;
let sanitize_macro pattern 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 _ =
print_endline ("\n\nREADING MACRO: " ^ String.concat " " ast);
match ast with
| [] -> raise End_of_file
| macro :: _ -> print_endline (" macro: " ^ macro)
;;
let hack_ellipsis prefix clause =
let clauses = ref [] in
(match clause with
(* ((_ test1 test2 ...) (if test1 (_ test2 ...) #f)) *)
(* | 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 = _ }
->
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);
clauses := !clauses @ [ sanitize_macro pattern [ atom ] ]
| _ as x -> print_endline ("nope: " ^ Printer.print x true));
!clauses
;;
(* print_endline (" head: " ^ Printer.print (List.hd clause) true);
* print_endline (" tail: " ^ Printer.dump (List.tl clause)); *)
(* print_endline ("H4CK3LL!P5!5: " ^ Printer.print (gen_sym prefix) true ^ ": " ^ Printer.dump clause); *)
(* print_endline ("H4CK3LL!P5!5: " ^ Printer.print (gen_sym prefix) true ^ ": " ^ Printer.print clause true); *)
(* clause *)
(* this is a dirty hack *)
let generate_patterns sym clauses =
let prefix = Printer.print sym true in
let sanitized = ref [] in
let rec sanitize_clauses unsanitized =
match unsanitized with
| [ clause ] ->
print_endline ("CLAUSE: " ^ Printer.print clause true);
sanitized := !sanitized @ [ hack_ellipsis prefix clause ];
!sanitized
| clause :: rest ->
sanitized := !sanitized @ [ hack_ellipsis prefix clause ];
sanitize_clauses rest
| [] -> !sanitized
in
sanitize_clauses clauses
;;
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
| [ clause ] ->
variants := Types.M9map.add new_sym clause !variants;
!variants
| clause :: rest ->
variants := Types.M9map.add new_sym clause !variants;
register_variants rest
| _ -> raise (Utils.Syntax_error "macro clause registration botch")
in
register_variants clauses
;;
let match_variant macro args =
let vmatch = ref "" in
(match macro with
| T.Map { T.value = meta; meta = _ } ->
(match Types.M9map.find Types.macro_variants meta with
| T.Map { T.value = variant_list; meta = _ } ->
Types.M9map.iter
(fun k v ->
print_endline (Printer.print k true ^ ": " ^ Printer.print v true);
match v with
| T.List { T.value = T.List { T.value = x; meta = _ } :: z; meta = _ } ->
print_endline
(" >>>> ["
^ string_of_int (List.length args)
^ "|"
^ string_of_int (List.length x)
^ "] "
^ Printer.dump x
^ " :: "
^ Printer.dump z);
if List.length args = List.length x then vmatch := Printer.print (List.hd x) true
| _ -> ())
variant_list
| _ -> ())
| _ -> ());
!vmatch
;;