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