forked from colinbenner/ocaml-llvm
/
output.ml
140 lines (122 loc) · 5.12 KB
/
output.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Output the DFA tables and its entry points *)
open Printf
open Syntax
open Lexgen
open Compact
open Common
(* To output an array of short ints, encoded as a string *)
let output_byte oc b =
output_char oc '\\';
output_char oc (Char.chr(48 + b / 100));
output_char oc (Char.chr(48 + (b / 10) mod 10));
output_char oc (Char.chr(48 + b mod 10))
let output_array oc v =
output_string oc " \"";
for i = 0 to Array.length v - 1 do
output_byte oc (v.(i) land 0xFF);
output_byte oc ((v.(i) asr 8) land 0xFF);
if i land 7 = 7 then output_string oc "\\\n "
done;
output_string oc "\""
let output_byte_array oc v =
output_string oc " \"";
for i = 0 to Array.length v - 1 do
output_byte oc (v.(i) land 0xFF);
if i land 15 = 15 then output_string oc "\\\n "
done;
output_string oc "\""
(* Output the tables *)
let output_tables oc tbl =
output_string oc "let __ocaml_lex_tables = {\n";
fprintf oc " Lexing.lex_base = \n%a;\n" output_array tbl.tbl_base;
fprintf oc " Lexing.lex_backtrk = \n%a;\n" output_array tbl.tbl_backtrk;
fprintf oc " Lexing.lex_default = \n%a;\n" output_array tbl.tbl_default;
fprintf oc " Lexing.lex_trans = \n%a;\n" output_array tbl.tbl_trans;
fprintf oc " Lexing.lex_check = \n%a;\n" output_array tbl.tbl_check;
fprintf oc " Lexing.lex_base_code = \n%a;\n" output_array tbl.tbl_base_code;
fprintf oc " Lexing.lex_backtrk_code = \n%a;\n"
output_array tbl.tbl_backtrk_code;
fprintf oc " Lexing.lex_default_code = \n%a;\n"
output_array tbl.tbl_default_code;
fprintf oc " Lexing.lex_trans_code = \n%a;\n"
output_array tbl.tbl_trans_code;
fprintf oc " Lexing.lex_check_code = \n%a;\n"
output_array tbl.tbl_check_code;
fprintf oc " Lexing.lex_code = \n%a;\n" output_byte_array tbl.tbl_code;
output_string oc "}\n\n"
(* Output the entries *)
let output_entry sourcefile ic oc oci e =
let init_num, init_moves = e.auto_initial_state in
fprintf oc "%s %alexbuf =
%a%a __ocaml_lex_%s_rec %alexbuf %d\n"
e.auto_name
output_args e.auto_args
(fun oc x ->
if x > 0 then
fprintf oc "lexbuf.Lexing.lex_mem <- Array.create %d (-1) ; " x)
e.auto_mem_size
(output_memory_actions " ") init_moves
e.auto_name
output_args e.auto_args
init_num;
fprintf oc "and __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state =\n"
e.auto_name output_args e.auto_args ;
fprintf oc " match Lexing.%sengine"
(if e.auto_mem_size == 0 then "" else "new_");
fprintf oc " __ocaml_lex_tables __ocaml_lex_state lexbuf with\n ";
List.iter
(fun (num, env, loc) ->
fprintf oc " | ";
fprintf oc "%d ->\n" num;
output_env oc env;
copy_chunk sourcefile ic oc oci loc true;
fprintf oc "\n")
e.auto_actions;
fprintf oc " | n -> lexbuf.Lexing.refill_buff lexbuf; \
__ocaml_lex_%s_rec %alexbuf n\n\n"
e.auto_name output_args e.auto_args
(* Main output function *)
exception Table_overflow
let output_lexdef sourcefile ic oc oci header tables entry_points trailer =
if not !Common.quiet_mode then
Printf.printf "%d states, %d transitions, table size %d bytes\n"
(Array.length tables.tbl_base)
(Array.length tables.tbl_trans)
(2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk +
Array.length tables.tbl_default + Array.length tables.tbl_trans +
Array.length tables.tbl_check));
let size_groups =
(2 * (Array.length tables.tbl_base_code +
Array.length tables.tbl_backtrk_code +
Array.length tables.tbl_default_code +
Array.length tables.tbl_trans_code +
Array.length tables.tbl_check_code) +
Array.length tables.tbl_code) in
if size_groups > 0 && not !Common.quiet_mode then
Printf.printf "%d additional bytes used for bindings\n" size_groups ;
flush stdout;
if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow;
copy_chunk sourcefile ic oc oci header false;
output_tables oc tables;
begin match entry_points with
[] -> ()
| entry1 :: entries ->
output_string oc "let rec "; output_entry sourcefile ic oc oci entry1;
List.iter
(fun e -> output_string oc "and "; output_entry sourcefile ic oc oci e)
entries;
output_string oc ";;\n\n";
end;
copy_chunk sourcefile ic oc oci trailer false