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 (* Output the DFA tables and its entry points *)
17
18 open Printf
19 open Lexgen
20 open Compact
21 open Common
22
23 (* To output an array of short ints, encoded as a string *)
24
25 let output_byte oc b =
26 output_char oc '\\';
27 output_char oc (Char.chr(48 + b / 100));
28 output_char oc (Char.chr(48 + (b / 10) mod 10));
29 output_char oc (Char.chr(48 + b mod 10))
30
31 let output_array oc v =
32 output_string oc " \"";
33 for i = 0 to Array.length v - 1 do
34 output_byte oc (v.(i) land 0xFF);
35 output_byte oc ((v.(i) asr 8) land 0xFF);
36 if i land 7 = 7 then output_string oc "\\\n "
37 done;
38 output_string oc "\""
39
40 let output_byte_array oc v =
41 output_string oc " \"";
42 for i = 0 to Array.length v - 1 do
43 output_byte oc (v.(i) land 0xFF);
44 if i land 15 = 15 then output_string oc "\\\n "
45 done;
46 output_string oc "\""
47
48 (* Output the tables *)
49
50 let output_tables oc tbl =
51 output_string oc "let __ocaml_lex_tables = {\n";
52
53 fprintf oc " Lexing.lex_base =\n%a;\n" output_array tbl.tbl_base;
54 fprintf oc " Lexing.lex_backtrk =\n%a;\n" output_array tbl.tbl_backtrk;
55 fprintf oc " Lexing.lex_default =\n%a;\n" output_array tbl.tbl_default;
56 fprintf oc " Lexing.lex_trans =\n%a;\n" output_array tbl.tbl_trans;
57 fprintf oc " Lexing.lex_check =\n%a;\n" output_array tbl.tbl_check;
58 fprintf oc " Lexing.lex_base_code =\n%a;\n" output_array tbl.tbl_base_code;
59
60 fprintf oc " Lexing.lex_backtrk_code =\n%a;\n"
61 output_array tbl.tbl_backtrk_code;
62 fprintf oc " Lexing.lex_default_code =\n%a;\n"
63 output_array tbl.tbl_default_code;
64 fprintf oc " Lexing.lex_trans_code =\n%a;\n"
65 output_array tbl.tbl_trans_code;
66 fprintf oc " Lexing.lex_check_code =\n%a;\n"
67 output_array tbl.tbl_check_code;
68 fprintf oc " Lexing.lex_code =\n%a;\n" output_byte_array tbl.tbl_code;
69
70 output_string oc "}\n\n"
71
72
73 (* Output the entries *)
74
75 let output_entry some_mem_code ic oc has_refill oci e =
76 let init_num, init_moves = e.auto_initial_state in
77 (* Will use "memory" instructions when (1) some memory instructions are
78 here and (2) this entry point needs memory. *)
79 let some_mem_code = some_mem_code && e.auto_mem_size > 0 in
80 fprintf oc
81 "%s %alexbuf =\
82 \n %a%a __ocaml_lex_%s_rec %alexbuf %d\n"
83 e.auto_name
84 output_args e.auto_args
85 (fun oc x ->
86 if some_mem_code then
87 fprintf oc "lexbuf.Lexing.lex_mem <- Array.make %d (-1);" x)
88 e.auto_mem_size
89 (output_memory_actions " ") init_moves
90 e.auto_name
91 output_args e.auto_args
92 init_num;
93 fprintf oc "and __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state =\n"
94 e.auto_name output_args e.auto_args;
95 fprintf oc " match Lexing.%sengine"
96 (if some_mem_code then "new_" else "");
97 fprintf oc " __ocaml_lex_tables __ocaml_lex_state lexbuf with\n ";
98 List.iter
99 (fun (num, env, loc) ->
100 fprintf oc " | ";
101 fprintf oc "%d ->\n" num;
102 output_env ic oc oci env;
103 copy_chunk ic oc oci loc true;
104 fprintf oc "\n")
105 e.auto_actions;
106 if has_refill then
107 fprintf oc
108 " | __ocaml_lex_state -> __ocaml_lex_refill\
109 \n (fun lexbuf -> lexbuf.Lexing.refill_buff lexbuf;\
110 \n __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state) lexbuf\n\n"
111 e.auto_name output_args e.auto_args
112 else
113 fprintf oc
114 " | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf;\
115 \n __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state\n\n"
116 e.auto_name output_args e.auto_args
117
118 (* Main output function *)
119
120 exception Table_overflow
121
122 let output_lexdef ic oc oci header rh tables entry_points trailer =
123 if not !Common.quiet_mode then
124 Printf.printf "%d states, %d transitions, table size %d bytes\n"
125 (Array.length tables.tbl_base)
126 (Array.length tables.tbl_trans)
127 (2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk +
128 Array.length tables.tbl_default + Array.length tables.tbl_trans +
129 Array.length tables.tbl_check));
130 let size_groups =
131 (2 * (Array.length tables.tbl_base_code +
132 Array.length tables.tbl_backtrk_code +
133 Array.length tables.tbl_default_code +
134 Array.length tables.tbl_trans_code +
135 Array.length tables.tbl_check_code) +
136 Array.length tables.tbl_code) in
137 if size_groups > 0 && not !Common.quiet_mode then
138 Printf.printf "%d additional bytes used for bindings\n" size_groups;
139 flush stdout;
140 if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow;
141 copy_chunk ic oc oci header false;
142 let has_refill = output_refill_handler ic oc oci rh in
143 output_tables oc tables;
144 let some_mem_code = Array.length tables.tbl_code > 0 in
145 begin match entry_points with
146 [] -> ()
147 | entry1 :: entries ->
148 output_string oc "let rec ";
149 output_entry some_mem_code ic oc has_refill oci entry1;
150 List.iter
151 (fun e ->
152 output_string oc "and ";
153 output_entry some_mem_code ic oc has_refill oci e)
154 entries;
155 output_string oc ";;\n\n";
156 end;
157 copy_chunk ic oc oci trailer false
158