l4/pkg/ocaml/contrib/stdlib/buffer.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*   Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt  *)
   6 (*                                                                     *)
   7 (*  Copyright 1999 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../LICENSE.     *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id: buffer.ml 9340 2009-09-16 15:52:46Z xclerc $ *)
  15
  16 (* Extensible buffers *)
  17
  18 type t =
  19  {mutable buffer : string;
  20   mutable position : int;
  21   mutable length : int;
  22   initial_buffer : string}
  23
  24 let create n =
  25  let n = if n < 1 then 1 else n in
  26  let n = if n > Sys.max_string_length then Sys.max_string_length else n in
  27  let s = String.create n in
  28  {buffer = s; position = 0; length = n; initial_buffer = s}
  29
  30 let contents b = String.sub b.buffer 0 b.position
  31
  32 let sub b ofs len =
  33   if ofs < 0 || len < 0 || ofs > b.position - len
  34   then invalid_arg "Buffer.sub"
  35   else begin
  36     let r = String.create len in
  37     String.blit b.buffer ofs r 0 len;
  38     r
  39   end
  40 ;;
  41
  42 let blit src srcoff dst dstoff len =
  43   if len < 0 || srcoff < 0 || srcoff > src.position - len
  44              || dstoff < 0 || dstoff > (String.length dst) - len
  45   then invalid_arg "Buffer.blit"
  46   else
  47     String.blit src.buffer srcoff dst dstoff len
  48 ;;
  49
  50 let nth b ofs =
  51   if ofs < 0 || ofs >= b.position then
  52    invalid_arg "Buffer.nth"
  53   else String.get b.buffer ofs
  54 ;;
  55
  56 let length b = b.position
  57
  58 let clear b = b.position <- 0
  59
  60 let reset b =
  61   b.position <- 0; b.buffer <- b.initial_buffer;
  62   b.length <- String.length b.buffer
  63
  64 let resize b more =
  65   let len = b.length in
  66   let new_len = ref len in
  67   while b.position + more > !new_len do new_len := 2 * !new_len done;
  68   if !new_len > Sys.max_string_length then begin
  69     if b.position + more <= Sys.max_string_length
  70     then new_len := Sys.max_string_length
  71     else failwith "Buffer.add: cannot grow buffer"
  72   end;
  73   let new_buffer = String.create !new_len in
  74   String.blit b.buffer 0 new_buffer 0 b.position;
  75   b.buffer <- new_buffer;
  76   b.length <- !new_len
  77
  78 let add_char b c =
  79   let pos = b.position in
  80   if pos >= b.length then resize b 1;
  81   b.buffer.[pos] <- c;
  82   b.position <- pos + 1
  83
  84 let add_substring b s offset len =
  85   if offset < 0 || len < 0 || offset > String.length s - len
  86   then invalid_arg "Buffer.add_substring";
  87   let new_position = b.position + len in
  88   if new_position > b.length then resize b len;
  89   String.blit s offset b.buffer b.position len;
  90   b.position <- new_position
  91
  92 let add_string b s =
  93   let len = String.length s in
  94   let new_position = b.position + len in
  95   if new_position > b.length then resize b len;
  96   String.blit s 0 b.buffer b.position len;
  97   b.position <- new_position
  98
  99 let add_buffer b bs =
 100   add_substring b bs.buffer 0 bs.position
 101
 102 let add_channel b ic len =
 103   if b.position + len > b.length then resize b len;
 104   really_input ic b.buffer b.position len;
 105   b.position <- b.position + len
 106
 107 let output_buffer oc b =
 108   output oc b.buffer 0 b.position
 109
 110 let closing = function
 111   | '(' -> ')'
 112   | '{' -> '}'
 113   | _ -> assert false;;
 114
 115 (* opening and closing: open and close characters, typically ( and )
 116    k: balance of opening and closing chars
 117    s: the string where we are searching
 118    start: the index where we start the search. *)
 119 let advance_to_closing opening closing k s start =
 120   let rec advance k i lim =
 121     if i >= lim then raise Not_found else
 122     if s.[i] = opening then advance (k + 1) (i + 1) lim else
 123     if s.[i] = closing then
 124       if k = 0 then i else advance (k - 1) (i + 1) lim
 125     else advance k (i + 1) lim in
 126   advance k start (String.length s);;
 127
 128 let advance_to_non_alpha s start =
 129   let rec advance i lim =
 130     if i >= lim then lim else
 131     match s.[i] with
 132     | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' |
 133       'é'|'à'|'á'|'è'|'ù'|'â'|'ê'|
 134       'î'|'ô'|'û'|'ë'|'ï'|'ü'|'ç'|
 135       'É'|'À'|'Á'|'È'|'Ù'|'Â'|'Ê'|
 136       'Î'|'Ô'|'Û'|'Ë'|'Ï'|'Ü'|'Ç' ->
 137       advance (i + 1) lim
 138     | _ -> i in
 139   advance start (String.length s);;
 140
 141 (* We are just at the beginning of an ident in s, starting at start. *)
 142 let find_ident s start lim =
 143   if start >= lim then raise Not_found else
 144   match s.[start] with
 145   (* Parenthesized ident ? *)
 146   | '(' | '{' as c ->
 147      let new_start = start + 1 in
 148      let stop = advance_to_closing c (closing c) 0 s new_start in
 149      String.sub s new_start (stop - start - 1), stop + 1
 150   (* Regular ident *)
 151   | _ ->
 152      let stop = advance_to_non_alpha s (start + 1) in
 153      String.sub s start (stop - start), stop;;
 154
 155 (* Substitute $ident, $(ident), or ${ident} in s,
 156     according to the function mapping f. *)
 157 let add_substitute b f s =
 158   let lim = String.length s in
 159   let rec subst previous i =
 160     if i < lim then begin
 161       match s.[i] with
 162       | '$' as current when previous = '\\' ->
 163          add_char b current;
 164          subst ' ' (i + 1)
 165       | '$' ->
 166          let j = i + 1 in
 167          let ident, next_i = find_ident s j lim in
 168          add_string b (f ident);
 169          subst ' ' next_i
 170       | current when previous == '\\' ->
 171          add_char b '\\';
 172          add_char b current;
 173          subst ' ' (i + 1)
 174       | '\\' as current ->
 175          subst current (i + 1)
 176       | current ->
 177          add_char b current;
 178          subst current (i + 1)
 179     end else
 180     if previous = '\\' then add_char b previous in
 181   subst ' ' 0;;