ref: 60993540fa2f1383724705faf0796202250c63f6
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 _ 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= _} ->
(* 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
@ [ "(("
^ String.concat " " (List.map (fun x -> Printer.to_string x) pattern)
^ ") " ^ Printer.to_string 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 sanitize_clauses sym clauses =
(* ((_) #t) ((_ test) test) ((_ test1 test2 ...) (if test1 (_ test2 ...) #f)) *)
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 ^ " <|> " ^ String.concat " " (hack_ellipsis prefix clause)) ;
sanitized := !sanitized @ [hack_ellipsis prefix clause] ;
!sanitized
| clause :: rest ->
print_endline
(" CLAUSE: " ^ Printer.print clause true ^ " <|> " ^ String.concat " " (hack_ellipsis prefix clause)) ;
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