ref: 4f535f4a39ed10d5aef7a2f568c02fa3b40775ff
dir: martian9/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 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 rest
| [] -> !sanitized in
sanitize 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 rec collect_args tokens args =
match tokens with
| [t] -> args @ [t]
| t :: ts -> if t = ")" then args else collect_args ts args @ [t]
| _ -> []
let match_variant original_sym macro args =
let args = if List.hd args = original_sym then List.tl args else args in
let vmatch = ref "" in
(* print_endline (" >>>> match_variant: " ^ Printer.to_string macro) ; *)
print_endline (" >>>> match_variant with args: " ^ String.concat " " args) ;
( 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.to_string k ^ ": " ^ Printer.to_string v) ;
let wrong = Utils.tokenize (Printer.to_string v) in
( match wrong with
| "(" :: "define" :: sym :: "(" :: "lambda" :: rest -> (
print_endline (" SYM: " ^ sym ^ " REST: " ^ String.concat " " rest) ;
let new_args = collect_args (List.tl rest) [] in
print_endline
( " ARGS: " ^ String.concat " " new_args ^ " ["
^ string_of_int (List.length new_args)
^ "] args: " ^ String.concat " " args ^ " ["
^ string_of_int (List.length args)
^ "]" ) ;
match (List.length new_args, List.length args) with
| 0, 0
|1, 1 ->
vmatch := sym
| x, y when x = y -> vmatch := sym
| _, _ -> ()
(* if List.length new_args = List.length args - 1 then vmatch := sym *) )
| _ -> print_endline "no rest" ) ;
print_endline (" >>>> sym: " ^ Printer.to_string k) ;
print_endline (" >>>> args: " ^ String.concat " " args) ;
print_endline (" >>>> v: " ^ Printer.to_string v) )
variant_list
| _ -> () )
| _ -> () ) ;
!vmatch