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

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   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.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: outputbis.ml 7815 2007-01-29 16:44:16Z maranget $ *)
  14
  15 (* Output the DFA tables and its entry points *)
  16
  17 open Printf
  18 open Syntax
  19 open Lexgen
  20 open Common
  21
  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
  29
  30 " ;
  31
  32   output_string oc
  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
  36       256
  37     else begin
  38       lexbuf.Lexing.refill_buff lexbuf ;
  39       __ocaml_lex_next_char lexbuf
  40     end
  41   end else begin
  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 ;
  45     Char.code c
  46   end
  47
  48 "
  49
  50
  51 let output_pats oc pats = List.iter (fun p -> fprintf oc "|%d" p) pats
  52
  53 let output_action oc mems r =
  54   output_memory_actions "    " oc mems ;
  55   match r with
  56   | Backtrack ->
  57     fprintf oc
  58       "    lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_last_pos ;\n" ;
  59     fprintf oc "    lexbuf.Lexing.lex_last_action\n"
  60   | Goto n ->
  61     fprintf oc "    __ocaml_lex_state%d lexbuf\n" n
  62
  63 let output_pat oc i =
  64   if i >= 256 then
  65     fprintf oc "|eof"
  66   else
  67     fprintf oc "|'%s'" (Char.escaped (Char.chr i))
  68
  69 let output_clause oc pats mems r =
  70   fprintf oc "(* " ;
  71   List.iter (output_pat oc) pats ;
  72   fprintf oc " *)\n" ;
  73   fprintf oc "  %a ->\n" output_pats pats ;  output_action oc mems r
  74
  75 let output_default_clause oc mems r =
  76   fprintf oc "  | _ ->\n" ; output_action oc mems r
  77
  78
  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
  84
  85   for i = 0 to 256 do
  86     add_move i moves.(i)
  87   done ;
  88
  89   let most_frequent = ref Backtrack
  90   and most_mems = ref []
  91   and size = ref 0 in
  92   Hashtbl.iter
  93     (fun m (mems,pats) ->
  94       let size_m = List.length pats in
  95       if size_m > !size then begin
  96         most_frequent := m ;
  97         most_mems := mems ;
  98         size := size_m
  99       end)
 100     t ;
 101   Hashtbl.iter
 102     (fun m (mems,pats) ->
 103       if m <> !most_frequent then output_clause oc (List.rev pats) mems m)
 104     t ;
 105   output_default_clause oc !most_mems !most_frequent
 106
 107
 108 let output_tag_actions pref oc mvs =
 109   output_string oc "(*" ;
 110   List.iter
 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)
 114     mvs ;
 115   output_string oc " *)\n" ;
 116   List.iter
 117     (fun i ->  match i with
 118     | SetTag (t,m) ->
 119         fprintf oc "%s%a <- %a ;\n"
 120           pref output_mem_access t output_mem_access m
 121     | EraseTag t ->
 122         fprintf oc "%s%a <- -1 ;\n"
 123           pref output_mem_access t)
 124     mvs
 125
 126 let output_trans pref oc i trans =
 127   fprintf oc "%s __ocaml_lex_state%d lexbuf = " pref i ;
 128   match trans with
 129   | Perform (n,mvs) ->
 130       output_tag_actions "  " oc mvs ;
 131       fprintf oc "  %d\n" n
 132   | Shift (trans, move) ->
 133       begin match trans with
 134       | Remember (n,mvs) ->
 135           output_tag_actions "  " oc mvs ;
 136           fprintf oc
 137             "  lexbuf.Lexing.lex_last_pos <- lexbuf.Lexing.lex_curr_pos ;\n" ;
 138           fprintf oc "  lexbuf.Lexing.lex_last_action <- %d ;\n" n
 139       | No_remember -> ()
 140       end ;
 141       fprintf oc "  match __ocaml_lex_next_char lexbuf with\n" ;
 142       output_moves oc move
 143
 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) ;
 148   for i = 1 to n-1 do
 149     output_trans "\nand" oc i auto.(i)
 150   done ;
 151   output_char oc '\n'
 152
 153
 154 (* Output the entries *)
 155
 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 ;
 167   List.iter
 168     (fun (num, env, loc) ->
 169       fprintf oc "  | ";
 170       fprintf oc "%d ->\n" num;
 171       output_env sourcefile ic oc tr env ;
 172       copy_chunk sourcefile ic oc tr loc true;
 173       fprintf oc "\n")
 174     e.auto_actions;
 175   fprintf oc "  | _ -> raise (Failure \"lexing: empty token\")\n\n\n"
 176
 177
 178 (* Main output function *)
 179
 180 let output_lexdef sourcefile ic oc tr header entry_points transitions trailer =
 181
 182   copy_chunk sourcefile ic oc tr header false;
 183   output_automata oc transitions ;
 184   begin match entry_points with
 185     [] -> ()
 186   | entry1 :: entries ->
 187       output_string oc "let rec "; output_entry sourcefile ic oc tr entry1;
 188       List.iter
 189         (fun e -> output_string oc "and "; output_entry sourcefile ic oc tr e)
 190         entries;
 191       output_string oc ";;\n\n";
 192   end;
 193   copy_chunk sourcefile ic oc tr trailer false