1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*             Luc Maranget, projet Moscova,                              *)
6(*                          INRIA Rocquencourt                            *)
7(*                                                                        *)
8(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
9(*     en Automatique.                                                    *)
10(*                                                                        *)
11(*   All rights reserved.  This file is distributed under the terms of    *)
12(*   the GNU Lesser General Public License version 2.1, with the          *)
13(*   special exception on linking described in the file LICENSE.          *)
14(*                                                                        *)
15(**************************************************************************)
16
17open Printf
18open Syntax
19open Lexgen
20
21
22(* To copy the ML code fragments *)
23
24type line_tracker = {
25  file : string;
26  oc : out_channel;
27  ic : in_channel;
28  mutable cur_line : int;
29};;
30
31let open_tracker file oc = {
32  file = file;
33  oc = oc;
34  ic = open_in_bin file;
35  cur_line = 1;
36};;
37
38let close_tracker tr = close_in_noerr tr.ic;;
39
40let update_tracker tr =
41  fprintf tr.oc "\n";
42  flush tr.oc;
43  let cr_seen = ref false in
44  try while true do
45    match input_char tr.ic with
46    | '\010' when not !cr_seen -> tr.cur_line <- tr.cur_line + 1;
47    | '\013' -> cr_seen := true; tr.cur_line <- tr.cur_line + 1;
48    | _ -> cr_seen := false;
49  done with End_of_file ->
50  fprintf tr.oc "# %d \"%s\"\n" (tr.cur_line+1) tr.file;
51;;
52
53let copy_buffer = Bytes.create 1024
54
55let copy_chars_unix ic oc start stop =
56  let n = ref (stop - start) in
57  while !n > 0 do
58    let m = input ic copy_buffer 0 (min !n 1024) in
59    output oc copy_buffer 0 m;
60    n := !n - m
61  done
62
63let copy_chars_win32 ic oc start stop =
64  for _i = start to stop - 1 do
65    let c = input_char ic in
66    if c <> '\r' then output_char oc c
67  done
68
69let copy_chars =
70  match Sys.os_type with
71    "Win32" | "Cygwin" -> copy_chars_win32
72  | _       -> copy_chars_unix
73
74let copy_chunk ic oc trl loc add_parens =
75  if loc.start_pos < loc.end_pos || add_parens then begin
76    fprintf oc "# %d \"%s\"\n" loc.start_line loc.loc_file;
77    if add_parens then begin
78      for _i = 1 to loc.start_col - 1 do output_char oc ' ' done;
79      output_char oc '(';
80    end else begin
81      for _i = 1 to loc.start_col do output_char oc ' ' done;
82    end;
83    seek_in ic loc.start_pos;
84    copy_chars ic oc loc.start_pos loc.end_pos;
85    if add_parens then output_char oc ')';
86    update_tracker trl;
87  end
88
89(* Various memory actions *)
90
91let output_mem_access oc i = fprintf oc "lexbuf.Lexing.lex_mem.(%d)" i
92
93let output_memory_actions pref oc = function
94  | []  -> ()
95  | mvs ->
96      output_string oc "(* " ;
97  fprintf oc "L=%d " (List.length mvs) ;
98  List.iter
99    (fun mv -> match mv with
100    | Copy (tgt, src) ->
101        fprintf oc "[%d] <- [%d] ;" tgt src
102    | Set tgt ->
103        fprintf oc "[%d] <- p ; " tgt)
104    mvs ;
105  output_string oc " *)\n" ;
106  List.iter
107    (fun mv -> match mv with
108    | Copy (tgt, src) ->
109        fprintf oc
110          "%s%a <- %a ;\n"
111          pref output_mem_access tgt output_mem_access src
112    | Set tgt ->
113        fprintf oc "%s%a <- lexbuf.Lexing.lex_curr_pos ;\n"
114          pref output_mem_access tgt)
115    mvs
116
117let output_base_mem oc = function
118  | Mem i -> output_mem_access oc i
119  | Start -> fprintf oc "lexbuf.Lexing.lex_start_pos"
120  | End   -> fprintf oc  "lexbuf.Lexing.lex_curr_pos"
121
122let output_tag_access oc = function
123  | Sum (a,0) ->
124      output_base_mem oc a
125  | Sum (a,i) ->
126      fprintf oc "(%a + %d)" output_base_mem a i
127
128let output_env ic oc tr env =
129  let pref = ref "let" in
130  match env with
131  | [] -> ()
132  | _  ->
133      (* Probably, we are better with variables sorted
134         in apparition order *)
135      let env =
136        List.sort
137          (fun ((_,p1),_) ((_,p2),_) ->
138            Pervasives.compare p1.start_pos  p2.start_pos)
139          env in
140
141      List.iter
142        (fun ((_,pos),v) ->
143          fprintf oc "%s\n" !pref ;
144          copy_chunk ic oc tr pos false ;
145          begin match v with
146          | Ident_string (o,nstart,nend) ->
147              fprintf oc
148                "= Lexing.sub_lexeme%s lexbuf %a %a"
149                (if o then "_opt" else "")
150                output_tag_access nstart output_tag_access nend
151          | Ident_char (o,nstart) ->
152              fprintf oc
153                "= Lexing.sub_lexeme_char%s lexbuf %a"
154                (if o then "_opt" else "")
155                output_tag_access nstart
156          end ;
157          pref := "\nand")
158        env ;
159      fprintf oc " in\n"
160
161(* Output the user arguments *)
162let output_args oc args =
163  List.iter (fun x -> (output_string oc x; output_char oc ' ')) args
164
165let output_refill_handler ic oc oci = function
166  | None -> false
167  | Some location ->
168    output_string oc "let __ocaml_lex_refill : \
169                      (Lexing.lexbuf -> 'a) -> (Lexing.lexbuf -> 'a) =\n";
170    copy_chunk ic oc oci location true;
171    true
172
173(* quiet flag *)
174let quiet_mode = ref false;;
175