l4/pkg/ocaml/ocaml/contrib/lex/common.ml

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