1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* The lexer generator. Command-line parsing. *)
17
18 open Syntax
19
20 let ml_automata = ref false
21 let source_name = ref None
22 let output_name = ref None
23
24 let usage = "usage: ocamllex [options] sourcefile"
25
26 let print_version_string () =
27 print_string "The OCaml lexer generator, version ";
28 print_string Sys.ocaml_version ; print_newline();
29 exit 0
30
31 let print_version_num () =
32 print_endline Sys.ocaml_version;
33 exit 0;
34 ;;
35
36 let specs =
37 ["-ml", Arg.Set ml_automata,
38 " Output code that does not use the Lexing module built-in automata \
39 interpreter";
40 "-o", Arg.String (fun x -> output_name := Some x),
41 " <file> Set output file name to <file>";
42 "-q", Arg.Set Common.quiet_mode, " Do not display informational messages";
43 "-v", Arg.Unit print_version_string, " Print version and exit";
44 "-version", Arg.Unit print_version_string, " Print version and exit";
45 "-vnum", Arg.Unit print_version_num, " Print version number and exit";
46 ]
47
48 let _ =
49 Arg.parse
50 specs
51 (fun name -> source_name := Some name)
52 usage
53
54
55 let main () =
56
57 let source_name = match !source_name with
58 | None -> Arg.usage specs usage ; exit 2
59 | Some name -> name in
60 let dest_name = match !output_name with
61 | Some name -> name
62 | None ->
63 if Filename.check_suffix source_name ".mll" then
64 Filename.chop_suffix source_name ".mll" ^ ".ml"
65 else
66 source_name ^ ".ml" in
67
68 let ic = open_in_bin source_name in
69 let oc = open_out dest_name in
70 let tr = Common.open_tracker dest_name oc in
71 let lexbuf = Lexing.from_channel ic in
72 lexbuf.Lexing.lex_curr_p <-
73 {Lexing.pos_fname = source_name; Lexing.pos_lnum = 1;
74 Lexing.pos_bol = 0; Lexing.pos_cnum = 0};
75 try
76 let def = Parser.lexer_definition Lexer.main lexbuf in
77 let (entries, transitions) = Lexgen.make_dfa def.entrypoints in
78 if !ml_automata then begin
79 Outputbis.output_lexdef
80 ic oc tr
81 def.header def.refill_handler entries transitions def.trailer
82 end else begin
83 let tables = Compact.compact_tables transitions in
84 Output.output_lexdef ic oc tr
85 def.header def.refill_handler tables entries def.trailer
86 end;
87 close_in ic;
88 close_out oc;
89 Common.close_tracker tr;
90 with exn ->
91 let bt = Printexc.get_raw_backtrace () in
92 close_in ic;
93 close_out oc;
94 Common.close_tracker tr;
95 Sys.remove dest_name;
96 begin match exn with
97 | Cset.Bad ->
98 let p = Lexing.lexeme_start_p lexbuf in
99 Printf.fprintf stderr
100 "File \"%s\", line %d, character %d: character set expected.\n"
101 p.Lexing.pos_fname p.Lexing.pos_lnum
102 (p.Lexing.pos_cnum - p.Lexing.pos_bol)
103 | Parsing.Parse_error ->
104 let p = Lexing.lexeme_start_p lexbuf in
105 Printf.fprintf stderr
106 "File \"%s\", line %d, character %d: syntax error.\n"
107 p.Lexing.pos_fname p.Lexing.pos_lnum
108 (p.Lexing.pos_cnum - p.Lexing.pos_bol)
109 | Lexer.Lexical_error(msg, file, line, col) ->
110 Printf.fprintf stderr
111 "File \"%s\", line %d, character %d: %s.\n"
112 file line col msg
113 | Lexgen.Memory_overflow ->
114 Printf.fprintf stderr
115 "File \"%s\":\n Position memory overflow, too many bindings\n"
116 source_name
117 | Output.Table_overflow ->
118 Printf.fprintf stderr
119 "File \"%s\":\ntransition table overflow, automaton is too big\n"
120 source_name
121 | _ ->
122 Printexc.raise_with_backtrace exn bt
123 end;
124 exit 3
125
126 let _ = (* Printexc.catch *) main (); exit 0
127