New branch binary-annot by Fabrice Le Fessant from r10789

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/binary-annot@10790 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 239 insertions, 0 deletions

diff --git a/ocaml-binary-annot/stdlib/lexing.ml b/ocaml-binary-annot/stdlib/lexing.ml
new file mode 100644
index 0000000000..9e01415265
--- /dev/null
+++ b/ocaml-binary-annot/stdlib/lexing.ml
@@ -0,0 +1,239 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* The run-time library for lexers generated by camllex *)
+
+type position = {
+  pos_fname : string;
+  pos_lnum : int;
+  pos_bol : int;
+  pos_cnum : int;
+}
+
+let dummy_pos = {
+  pos_fname = "";
+  pos_lnum = 0;
+  pos_bol = 0;
+  pos_cnum = -1;
+}
+
+type lexbuf =
+  { refill_buff : lexbuf -> unit;
+    mutable lex_buffer : string;
+    mutable lex_buffer_len : int;
+    mutable lex_abs_pos : int;
+    mutable lex_start_pos : int;
+    mutable lex_curr_pos : int;
+    mutable lex_last_pos : int;
+    mutable lex_last_action : int;
+    mutable lex_eof_reached : bool;
+    mutable lex_mem : int array;
+    mutable lex_start_p : position;
+    mutable lex_curr_p : position;
+  }
+
+type lex_tables =
+  { lex_base: string;
+    lex_backtrk: string;
+    lex_default: string;
+    lex_trans: string;
+    lex_check: string;
+    lex_base_code : string;
+    lex_backtrk_code : string;
+    lex_default_code : string;
+    lex_trans_code : string;
+    lex_check_code : string;
+    lex_code: string;}
+
+external c_engine : lex_tables -> int -> lexbuf -> int = "caml_lex_engine"
+external c_new_engine : lex_tables -> int -> lexbuf -> int
+                      = "caml_new_lex_engine"
+
+let engine tbl state buf =
+  let result = c_engine tbl state buf in
+  if result >= 0 then begin
+    buf.lex_start_p <- buf.lex_curr_p;
+    buf.lex_curr_p <- {buf.lex_curr_p
+                       with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos};
+  end;
+  result
+;;
+
+let new_engine tbl state buf =
+  let result = c_new_engine tbl state buf in
+  if result >= 0 then begin
+    buf.lex_start_p <- buf.lex_curr_p;
+    buf.lex_curr_p <- {buf.lex_curr_p
+                       with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos};
+  end;
+  result
+;;
+
+let lex_refill read_fun aux_buffer lexbuf =
+  let read =
+    read_fun aux_buffer (String.length aux_buffer) in
+  let n =
+    if read > 0
+    then read
+    else (lexbuf.lex_eof_reached <- true; 0) in
+  (* Current state of the buffer:
+        <-------|---------------------|----------->
+        |  junk |      valid data     |   junk    |
+        ^       ^                     ^           ^
+        0    start_pos             buffer_end    String.length buffer
+  *)
+  if lexbuf.lex_buffer_len + n > String.length lexbuf.lex_buffer then begin
+    (* There is not enough space at the end of the buffer *)
+    if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n
+       <= String.length lexbuf.lex_buffer
+    then begin
+      (* But there is enough space if we reclaim the junk at the beginning
+         of the buffer *)
+      String.blit lexbuf.lex_buffer lexbuf.lex_start_pos
+                  lexbuf.lex_buffer 0
+                  (lexbuf.lex_buffer_len - lexbuf.lex_start_pos)
+    end else begin
+      (* We must grow the buffer.  Doubling its size will provide enough
+         space since n <= String.length aux_buffer <= String.length buffer.
+         Watch out for string length overflow, though. *)
+      let newlen =
+        min (2 * String.length lexbuf.lex_buffer) Sys.max_string_length in
+      if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n > newlen
+      then failwith "Lexing.lex_refill: cannot grow buffer";
+      let newbuf = String.create newlen in
+      (* Copy the valid data to the beginning of the new buffer *)
+      String.blit lexbuf.lex_buffer lexbuf.lex_start_pos
+                  newbuf 0
+                  (lexbuf.lex_buffer_len - lexbuf.lex_start_pos);
+      lexbuf.lex_buffer <- newbuf
+    end;
+    (* Reallocation or not, we have shifted the data left by
+       start_pos characters; update the positions *)
+    let s = lexbuf.lex_start_pos in
+    lexbuf.lex_abs_pos <- lexbuf.lex_abs_pos + s;
+    lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - s;
+    lexbuf.lex_start_pos <- 0;
+    lexbuf.lex_last_pos <- lexbuf.lex_last_pos - s;
+    lexbuf.lex_buffer_len <- lexbuf.lex_buffer_len - s ;
+    let t = lexbuf.lex_mem in
+    for i = 0 to Array.length t-1 do
+      let v = t.(i) in
+      if v >= 0 then
+        t.(i) <- v-s
+    done
+  end;
+  (* There is now enough space at the end of the buffer *)
+  String.blit aux_buffer 0
+              lexbuf.lex_buffer lexbuf.lex_buffer_len
+              n;
+  lexbuf.lex_buffer_len <- lexbuf.lex_buffer_len + n
+
+let zero_pos = {
+  pos_fname = "";
+  pos_lnum = 1;
+  pos_bol = 0;
+  pos_cnum = 0;
+};;
+
+let from_function f =
+  { refill_buff = lex_refill f (String.create 512);
+    lex_buffer = String.create 1024;
+    lex_buffer_len = 0;
+    lex_abs_pos = 0;
+    lex_start_pos = 0;
+    lex_curr_pos = 0;
+    lex_last_pos = 0;
+    lex_last_action = 0;
+    lex_mem = [||];
+    lex_eof_reached = false;
+    lex_start_p = zero_pos;
+    lex_curr_p = zero_pos;
+  }
+
+let from_channel ic =
+  from_function (fun buf n -> input ic buf 0 n)
+
+let from_string s =
+  { refill_buff = (fun lexbuf -> lexbuf.lex_eof_reached <- true);
+    lex_buffer = s ^ "";
+    lex_buffer_len = String.length s;
+    lex_abs_pos = 0;
+    lex_start_pos = 0;
+    lex_curr_pos = 0;
+    lex_last_pos = 0;
+    lex_last_action = 0;
+    lex_mem = [||];
+    lex_eof_reached = true;
+    lex_start_p = zero_pos;
+    lex_curr_p = zero_pos;
+  }
+
+let lexeme lexbuf =
+  let len = lexbuf.lex_curr_pos - lexbuf.lex_start_pos in
+  let s = String.create len in
+  String.unsafe_blit lexbuf.lex_buffer lexbuf.lex_start_pos s 0 len;
+  s
+
+let sub_lexeme lexbuf i1 i2 =
+  let len = i2-i1 in
+  let s = String.create len in
+  String.unsafe_blit lexbuf.lex_buffer i1 s 0 len;
+  s
+
+let sub_lexeme_opt lexbuf i1 i2 =
+  if i1 >= 0 then begin
+    let len = i2-i1 in
+    let s = String.create len in
+    String.unsafe_blit lexbuf.lex_buffer i1 s 0 len;
+    Some s
+  end else begin
+    None
+  end
+
+let sub_lexeme_char lexbuf i = lexbuf.lex_buffer.[i]
+
+let sub_lexeme_char_opt lexbuf i =
+  if i >= 0 then
+    Some lexbuf.lex_buffer.[i]
+  else
+    None
+
+
+let lexeme_char lexbuf i =
+  String.get lexbuf.lex_buffer (lexbuf.lex_start_pos + i)
+
+let lexeme_start lexbuf = lexbuf.lex_start_p.pos_cnum;;
+let lexeme_end lexbuf = lexbuf.lex_curr_p.pos_cnum;;
+
+let lexeme_start_p lexbuf = lexbuf.lex_start_p;;
+let lexeme_end_p lexbuf = lexbuf.lex_curr_p;;
+
+let new_line lexbuf =
+  let lcp = lexbuf.lex_curr_p in
+  lexbuf.lex_curr_p <- { lcp with
+    pos_lnum = lcp.pos_lnum + 1;
+    pos_bol = lcp.pos_cnum;
+  }
+;;
+
+
+(* Discard data left in lexer buffer. *)
+
+let flush_input lb =
+  lb.lex_curr_pos <- 0;
+  lb.lex_abs_pos <- 0;
+  lb.lex_curr_p <- {lb.lex_curr_p with pos_cnum = 0};
+  lb.lex_buffer_len <- 0;
+;;