(* $Id: main.ml 674 2004-06-13 12:33:48Z gerd $
* ----------------------------------------------------------------------
*
*)
open Uni_types
open Ucs2_to_utf8
open Printf
type lextool =
[ `OCAMLLEX | `WLEX | `ULEX ]
type config =
{ mutable char_classes_file : string;
mutable encoding : Netconversion.encoding;
mutable encoding_name : string;
mutable lex_src_file : string;
mutable link_src_file : string;
mutable out_format : lextool;
mutable out_multiple : bool;
mutable out_lex_prefix : string;
mutable out_link_prefix : string;
}
type char_classes =
CC_generic of (definition list * string)
(* regexp definitions, section LET *)
| CC_wlex of (string * string)
(* section CLASSES, section LETS *)
let get_char_classes cfg =
let filename = cfg.char_classes_file in
let cc_sections = Lexpp_file.read_sections filename in
let type_generic = List.mem_assoc "TYPE_GENERIC" cc_sections in
let type_wlex = List.mem_assoc "TYPE_WLEX" cc_sections in
( match type_generic, type_wlex with
false, false ->
failwith ("File " ^ filename ^ ": type indicator is missing");
| true, false
| false, true ->
()
| _, _ ->
failwith ("File " ^ filename ^ ": type indicator is ambiguous");
);
let let_section =
try List.assoc "LET" cc_sections
with Not_found -> failwith ("File " ^ filename ^ ": no LET section") in
match () with
() when type_generic ->
let let_unicode_section =
try List.assoc "LET_UNICODE" cc_sections
with Not_found -> failwith ("File " ^ filename ^ ": no LET_UNICODE section") in
CC_generic(Lexpp_file.parse_char_classes let_unicode_section, let_section);
| () when type_wlex ->
let classes_section =
try List.assoc "CLASSES" cc_sections
with Not_found -> failwith ("File " ^ filename ^ ": no CLASSES section")
in
CC_wlex(classes_section, let_section)
| () ->
assert false (* programming error *)
;;
let recode_char_classes_8bit cfg cc =
(* Works only for 8 bit character encodings. *)
let out_enc = cfg.encoding in
let recode_char n =
try
let s = Netconversion.makechar out_enc n in (* or Not_found *)
if String.length s <> 1 then
failwith("Character " ^ string_of_int n ^
" has a multibyte representation");
Some(Char.code s.[0])
with
Not_found ->
None
in
let rec recode_interval cur_ival cur_code last_code =
if cur_code <= last_code then begin
match recode_char cur_code with
None ->
recode_interval cur_ival (cur_code+1) last_code
| Some p ->
( match cur_ival with
None ->
recode_interval (Some(p,p)) (cur_code+1) last_code
| Some(m,n) ->
if n+1 = p then
recode_interval (Some(m,p)) (cur_code+1) last_code
else
(m,n) :: recode_interval (Some(p,p)) (cur_code+1) last_code
)
end
else
match cur_ival with
None ->
[]
| Some(m,n) ->
[m,n]
in
let rec recode_regexp re =
(* recodes a regexp to a regexp list *)
match re with
Char n ->
( match recode_char n with
Some p -> [Char p]
| None -> []
)
| Interval(m,n) ->
List.map
(fun (m,n) ->
if m=n then Char m else Interval(m,n)
)
(recode_interval None m n)
| Identifier id ->
[Identifier id]
| Concat _ ->
assert false (* not used *)
in
let recode_def { id = id; rel = rel } =
{ id = id; rel = List.flatten (List.map recode_regexp rel) }
in
match cc with
CC_wlex(_,_) ->
assert false
| CC_generic(defs, let_section) ->
CC_generic(List.map recode_def defs, let_section)
;;
let recode_char_classes cfg cc =
(* FUTURE: Use Netconversion.is_ascii_compatible and is_single_byte *)
printf
"[Recoding character classes to %s]\n"
(Netconversion.string_of_encoding cfg.encoding);
flush stdout;
match cfg.encoding with
`Enc_utf8 ->
( match cc with
CC_generic(defs, let_section) ->
CC_generic(List.map ucs2_to_utf8 defs, let_section)
| CC_wlex(_,_) ->
failwith "Char classes of type wlex not compatible with output format"
)
| (`Enc_java | `Enc_utf16 | `Enc_utf16_le | `Enc_utf16_be) ->
failwith "This character encoding is not supported!"
| _ ->
(* May not work... *)
recode_char_classes_8bit cfg cc
;;
let space_re =
Netstring_str.regexp "[ \t\r\n]+" ;;
let name_of_rule rule_str =
(* Extract the name of the rule definition. The name is the first word
* in [rule_str] outside of comments.
* FIXME: Comments containing inner comments or code are not supported.
*)
let rec skip_comments l =
match l with
"*)" :: l' -> l'
| _ :: l' -> skip_comments l'
| [] -> failwith ("Unfinished comment in: " ^ rule_str)
and find_first_word l =
match l with
"(*" :: l' -> find_first_word (skip_comments l')
| w :: l' -> w
| [] -> failwith ("Cannot determine rule name in: " ^ rule_str)
in
let words = Netstring_str.split space_re rule_str in
find_first_word words
;;
type mlltok = Mll_lexer.mlltok
let parse_term str =
let rec norm need_sep term =
match term with
(`Sep s1) :: (`Sep s2) :: term' ->
norm need_sep (`Sep(s1^s2) :: term')
| (`Sep _ as sep) :: term' ->
sep :: norm false term'
| tok :: term' ->
if need_sep then
(`Sep "") :: tok :: norm false term'
else
tok :: norm true term'
| [] ->
[]
in
let rec rem_comments term =
match term with
`Comment _ :: term' ->
rem_comments term'
| tok :: term' ->
tok :: rem_comments term'
| [] ->
[]
in
let lexbuf = Lexing.from_string str in
let term = Mll_lexer.recurse_until `EOF Mll_lexer.definition lexbuf in
norm true (rem_comments term)
;;
let string_of_term (term : mlltok list) =
let buf = Buffer.create 1000 in
let rec print outermost last_tok (term : mlltok list) =
match term with
tok :: term' ->
( match tok with
`Sep s ->
if not outermost || (last_tok <> `EOF && term' <> []) then
Buffer.add_string buf s
(* don't print at the beginning and at the end *)
| `Comment l ->
Buffer.add_char buf ' '
| `Brace(_,l) ->
Buffer.add_char buf '{';
print false `EOF l;
Buffer.add_char buf '}';
| `Paren l ->
Buffer.add_char buf '(';
print false `EOF l;
Buffer.add_char buf ')'
| `Bracket l ->
Buffer.add_char buf '[';
print false `EOF l;
Buffer.add_char buf ']'
| `Stringliteral s ->
Buffer.add_char buf '"';
Buffer.add_string buf s;
Buffer.add_char buf '"';
| `Charliteral s ->
Buffer.add_char buf '\'';
Buffer.add_string buf s;
Buffer.add_char buf '\'';
| `Char c ->
Buffer.add_char buf c
| `Ident name ->
Buffer.add_string buf name
| `EOF
| `E_Brace
| `E_Bracket
| `E_Comment
| `E_Paren ->
()
);
print outermost tok term'
| [] ->
()
in
print true `EOF term;
Buffer.contents buf
;;
let transform_let_to_ulex let_str =
(* Transforms a regexp "let" definition to ulex syntax *)
let term = parse_term let_str in
let rec transform term =
match term with
`Ident "let" :: term' ->
`Sep "\n" :: `Ident "let" :: `Sep " " :: `Ident "regexp" ::
transform term'
| tok :: term' ->
tok :: transform term'
| [] ->
[]
in
string_of_term (transform term)
;;
let transform_rule_to_ulex rule_str =
(* Transforms the rule into ulex syntax *)
let term = parse_term rule_str in
let rec transform term =
match term with
| `Ident "parse" :: term' ->
`Ident "lexer" :: transform term'
| `Brace (_,l) :: term' ->
`Sep " " :: `Char '-' :: `Char '>' :: `Sep " " :: `Paren l ::
transform term'
| tok :: term' ->
tok :: transform term'
| [] ->
[]
in
string_of_term (transform term)
;;
let subst_re = Netstring_str.regexp "[$][{]\\([a-zA-Z0-9_]+\\)[}]";;
let subst_link_pattern lookup link_str =
(* Substitutes the pattern ${name} by the value returned by the function
* [lookup], applied on the name.
*)
Netstring_str.global_substitute
subst_re
(fun r s ->
let name = Netstring_str.matched_group r 1 s in
lookup name
)
link_str
;;
let open_out_ann name =
printf "[writing %s]\n" name;
flush stdout;
let f = open_out name in
output_string f
"(* THIS FILE IS GENERATED BY LEXPP. DO NOT EDIT MANUALLY! *)\n\n";
f
;;
let write_output_files cfg cc =
let lex_src = Lexpp_file.read_sections cfg.lex_src_file in
let link_src = Lexpp_file.read_sections cfg.link_src_file in
let write_header out =
match cc with
CC_generic(defs,let_str) ->
( match cfg.out_format with
`OCAMLLEX ->
output_string out "{\n";
if List.mem_assoc "HEADER" lex_src then (
output_string out (List.assoc "HEADER" lex_src);
);
if List.mem_assoc "HEADER_OCAMLLEX" lex_src then (
output_string out (List.assoc "HEADER_OCAMLLEX" lex_src);
);
output_string out "}\n";
List.iter (Lexpp_file.print_definition out) defs;
output_string out let_str;
if List.mem_assoc "LET" lex_src then
output_string out (List.assoc "LET" lex_src);
| `ULEX ->
if List.mem_assoc "HEADER" lex_src then (
output_string out (List.assoc "HEADER" lex_src);
);
if List.mem_assoc "HEADER_ULEX" lex_src then (
output_string out (List.assoc "HEADER_ULEX" lex_src);
);
List.iter (Lexpp_file.print_ulex_definition out) defs;
output_string out (transform_let_to_ulex let_str);
if List.mem_assoc "LET" lex_src then
let s = List.assoc "LET" lex_src in
output_string out (transform_let_to_ulex s)
| `WLEX ->
failwith "Output format wlex is incompatible with generic char classes"
)
| CC_wlex(classes_str,let_str) ->
if cfg.out_format <> `WLEX then
failwith "This output format is incompatible with wlex char classes";
output_string out classes_str;
output_string out "{\n";
if List.mem_assoc "HEADER" lex_src then (
output_string out (List.assoc "HEADER" lex_src);
);
if List.mem_assoc "HEADER_WLEX" lex_src then (
output_string out (List.assoc "HEADER_WLEX" lex_src);
);
output_string out "}\n";
output_string out let_str;
if List.mem_assoc "LET" lex_src then
output_string out (List.assoc "LET" lex_src);
in
let write_rule out is_first_rule rule_str =
match cfg.out_format with
`OCAMLLEX
| `WLEX ->
if is_first_rule then
output_string out "rule "
else
output_string out "and ";
output_string out rule_str
| `ULEX ->
output_string out "\nlet ";
output_string out (transform_rule_to_ulex rule_str)
in
let suffix =
match cfg.out_format with
`OCAMLLEX
| `WLEX -> ".mll"
| `ULEX -> ".ml"
in
let module_of_rule = Hashtbl.create 10 in
if cfg.out_multiple then begin
let n = ref 1 in
List.iter
(fun (_,rule_str) ->
let rule_name = name_of_rule rule_str in
let mod_name = sprintf "%s_%02d" cfg.out_lex_prefix !n in
Hashtbl.add module_of_rule rule_name mod_name;
let out = open_out_ann (mod_name ^ suffix) in
write_header out;
write_rule out true rule_str;
close_out out;
incr n;
)
(List.filter (fun (name,str) -> name = "RULE") lex_src);
end
else begin
let out = open_out_ann (cfg.out_lex_prefix ^ "_01" ^ suffix) in
write_header out;
let is_first = ref true in
List.iter
(fun (_,rule_str) ->
let rule_name = name_of_rule rule_str in
Hashtbl.add module_of_rule rule_name (cfg.out_lex_prefix ^ "_01");
write_rule out !is_first rule_str;
is_first := false
)
(List.filter (fun (name,str) -> name = "RULE") lex_src);
close_out out
end;
(*
Hashtbl.iter
(fun r m ->
printf "rule %s => module %s\n" r m)
module_of_rule;
*)
let link_str =
try List.assoc "LINK" link_src
with Not_found ->
failwith ("Section LINK is missing in " ^ cfg.link_src_file) in
let lookup name =
if name = "encoding" then
cfg.encoding_name
else
let filename =
try Hashtbl.find module_of_rule name
with Not_found ->
failwith ("No such rule: " ^ name)
in
String.capitalize (Filename.basename filename)
in
let link_str' = subst_link_pattern lookup link_str in
let out = open_out_ann (cfg.out_link_prefix ^ ".ml") in
output_string out link_str';
close_out out
;;
let main() =
let cfg =
{ char_classes_file = "cc.def";
encoding = `Enc_iso88591;
encoding_name = "iso88591";
lex_src_file = "lex.src";
link_src_file = "link.src";
out_format = `OCAMLLEX;
out_multiple = false;
out_lex_prefix = "out";
out_link_prefix = "out_link";
}
in
let pformat s =
match s with
"ocamllex" -> `OCAMLLEX
| "wlex" -> `WLEX
| "ulex" -> `ULEX
| _ -> raise (Arg.Bad ("Unknown output format: " ^ s))
in
Arg.parse
[ "-charclasses", Arg.String (fun s -> cfg.char_classes_file <- s),
"<file> The name of the character classes input file";
"-lexsrc", Arg.String (fun s -> cfg.lex_src_file <- s),
"<file> The name of the lex source input file";
"-linksrc", Arg.String (fun s -> cfg.link_src_file <- s),
"<file> The name of the link source input file";
"-encoding", Arg.String (fun s ->
cfg.encoding <-
Netconversion.encoding_of_string s;
cfg.encoding_name <- s;
),
"<name> The character encoding";
"-outformat", Arg.String (fun s -> cfg.out_format <- pformat s),
"(ocamllex|wlex|ulex) Output format";
"-outlexprefix", Arg.String (fun s -> cfg.out_lex_prefix <- s),
"<prefix> The common prefix of the lexer files";
"-outlinkprefix", Arg.String (fun s -> cfg.out_link_prefix <- s),
"<prefix> The prefix of the link file";
"-multiple", Arg.Unit (fun () -> cfg.out_multiple <- true),
" Generate multiple output files";
]
(fun _ -> raise(Arg.Bad("Bad usage!")))
"usage: lexpp <options>";
let cc = get_char_classes cfg in
let cc' =
match cfg.out_format with
`OCAMLLEX ->
recode_char_classes cfg cc
| _ ->
cc in
write_output_files cfg cc'
;;
main();;
