1 (***********************************************************************)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. All rights reserved. This file is distributed *)
9 (* under the terms of the Q Public License version 1.0. *)
11 (***********************************************************************)
15 (* Output the DFA tables and its entry points *)
22 let output_auto_defs oc
=
23 fprintf oc
"let __ocaml_lex_init_lexbuf lexbuf mem_size =
24 let pos = lexbuf.Lexing.lex_curr_pos in
25 lexbuf.Lexing.lex_mem <- Array.create mem_size (-1) ;
26 lexbuf.Lexing.lex_start_pos <- pos ;
27 lexbuf.Lexing.lex_last_pos <- pos ;
28 lexbuf.Lexing.lex_last_action <- -1
33 "let rec __ocaml_lex_next_char lexbuf =
34 if lexbuf.Lexing.lex_curr_pos >= lexbuf.Lexing.lex_buffer_len then begin
35 if lexbuf.Lexing.lex_eof_reached then
38 lexbuf.Lexing.refill_buff lexbuf ;
39 __ocaml_lex_next_char lexbuf
42 let i = lexbuf.Lexing.lex_curr_pos in
43 let c = lexbuf.Lexing.lex_buffer.[i] in
44 lexbuf.Lexing.lex_curr_pos <- i+1 ;
51 let output_pats oc pats
= List.iter
(fun p
-> fprintf oc
"|%d" p
) pats
53 let output_action oc mems r
=
54 output_memory_actions
" " oc mems
;
58 " lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_last_pos ;\n" ;
59 fprintf oc
" lexbuf.Lexing.lex_last_action\n"
61 fprintf oc
" __ocaml_lex_state%d lexbuf\n" n
67 fprintf oc
"|'%s'" (Char.escaped
(Char.chr
i))
69 let output_clause oc pats mems r
=
71 List.iter
(output_pat oc
) pats
;
73 fprintf oc
" %a ->\n" output_pats pats
; output_action oc mems r
75 let output_default_clause oc mems r
=
76 fprintf oc
" | _ ->\n" ; output_action oc mems r
79 let output_moves oc moves
=
80 let t = Hashtbl.create
17 in
81 let add_move i (m
,mems
) =
82 let mems,r
= try Hashtbl.find
t m
with Not_found
-> mems,[] in
83 Hashtbl.replace
t m
(mems,(i::r
)) in
89 let most_frequent = ref Backtrack
90 and most_mems
= ref []
94 let size_m = List.length pats
in
95 if size_m > !size
then begin
102 (fun m
(mems,pats
) ->
103 if m
<> !most_frequent then output_clause oc
(List.rev pats
) mems m
)
105 output_default_clause oc
!most_mems
!most_frequent
108 let output_tag_actions pref oc mvs
=
109 output_string oc
"(*" ;
111 (fun i -> match i with
112 | SetTag
(t,m
) -> fprintf oc
" t%d <- [%d] ;" t m
113 | EraseTag
t -> fprintf oc
" t%d <- -1 ;" t)
115 output_string oc
" *)\n" ;
117 (fun i -> match i with
119 fprintf oc
"%s%a <- %a ;\n"
120 pref output_mem_access
t output_mem_access m
122 fprintf oc
"%s%a <- -1 ;\n"
123 pref output_mem_access
t)
126 let output_trans pref oc
i trans
=
127 fprintf oc
"%s __ocaml_lex_state%d lexbuf = " pref
i ;
130 output_tag_actions " " oc mvs
;
132 | Shift
(trans
, move
) ->
133 begin match trans
with
134 | Remember
(n
,mvs
) ->
135 output_tag_actions " " oc mvs
;
137 " lexbuf.Lexing.lex_last_pos <- lexbuf.Lexing.lex_curr_pos ;\n" ;
138 fprintf oc
" lexbuf.Lexing.lex_last_action <- %d ;\n" n
141 fprintf oc
" match __ocaml_lex_next_char lexbuf with\n" ;
144 let output_automata oc auto
=
145 output_auto_defs oc
;
146 let n = Array.length auto
in
147 output_trans "let rec" oc
0 auto
.(0) ;
149 output_trans "\nand" oc
i auto
.(i)
154 (* Output the entries *)
156 let output_entry sourcefile ic oc tr e
=
157 let init_num, init_moves
= e
.auto_initial_state
in
158 fprintf oc
"%s %alexbuf =
159 __ocaml_lex_init_lexbuf lexbuf %d; %a
160 let __ocaml_lex_result = __ocaml_lex_state%d lexbuf in
161 lexbuf.Lexing.lex_start_p <- lexbuf.Lexing.lex_curr_p;
162 lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with
163 Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos + lexbuf.Lexing.lex_curr_pos};
164 match __ocaml_lex_result with\n"
165 e
.auto_name output_args e
.auto_args
166 e
.auto_mem_size
(output_memory_actions
" ") init_moves
init_num ;
168 (fun (num
, env
, loc
) ->
170 fprintf oc
"%d ->\n" num
;
171 output_env sourcefile ic oc tr env
;
172 copy_chunk sourcefile ic oc tr loc
true;
175 fprintf oc
" | _ -> raise (Failure \"lexing: empty token\")\n\n\n"
178 (* Main output function *)
180 let output_lexdef sourcefile ic oc tr header entry_points transitions trailer
=
182 copy_chunk sourcefile ic oc tr header
false;
183 output_automata oc transitions
;
184 begin match entry_points
with
186 | entry1
:: entries
->
187 output_string oc
"let rec "; output_entry sourcefile ic oc tr entry1
;
189 (fun e
-> output_string oc
"and "; output_entry sourcefile ic oc tr e
)
191 output_string oc
";;\n\n";
193 copy_chunk sourcefile ic oc tr trailer
false