ocaml/stdlib/scanf.ml

(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
(*                                                                     *)
(*  Copyright 2002 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$ *)

(** Formatted input functions. *)

let bad_input ib s =
  let i = Scanning.char_count ib in
  failwith
    (Printf.sprintf
      "scanf: bad input at char number %i, while scanning %s" i s);;

let bad_input_buff ib = failwith "scanf: bad input";;

let bad_format fmt i fc =
  invalid_arg
    (Printf.sprintf
       "scanf: bad format %c, at char number %i of format %s" fc i fmt);;

(* Extracting tokens from ouput token buffer. *)
let token_int ib =
  let s = Scanning.token ib in
  try Pervasives.int_of_string s
  with Failure "int_of_string" -> bad_input ib s;;

let token_bool ib =
  match Scanning.token ib with
  | "true" -> true
  | "false" -> false
  | s -> bad_input ib ("a boolean, found " ^ s);;

let token_char ib =
  (Scanning.token ib).[0];;

let token_float ib =
  let s = Scanning.token ib in
  float_of_string s;;

let token_string = Scanning.token;;

(* To scan native ints, int32 and int64 integers.
We cannot access to convertion to from strings: Nativeint.of_string,
Int32.of_string, and Int64.of_string, since those module are not
available to scanf. However, we can bind and use the primitives that are
available in the runtime. *)

external nativeint_of_string: string -> nativeint = "nativeint_of_string";;
external int32_of_string : string -> int32 = "int32_of_string";;
external int64_of_string : string -> int64 = "int64_of_string";;

let token_nativeint ib =
  let s = Scanning.token ib in
  nativeint_of_string s;;

let token_int32 ib =
  let s = Scanning.token ib in
  int32_of_string s;;

let token_int64 ib =
  let s = Scanning.token ib in
  int64_of_string s;;

(* Scanning numbers. *)

let scan_sign max ib =
  let c = Scanning.peek_char ib in
  match c with
  | '+' -> Scanning.store_char ib c max
  | '-' -> Scanning.store_char ib c max
  | c -> max;;

(* Decimal case is optimized. *)
let rec scan_decimal_digits max ib =
  if max = 0 || Scanning.end_of_input ib then max else
  match Scanning.peek_char ib with
  | '0' .. '9' as c ->
      let max = Scanning.store_char ib c max in
      scan_decimal_digits max ib
  | c -> max;;

(* Other cases uses a predicate argument to scan_digits. *)
let rec scan_digits digitp max ib =
  if max = 0 || Scanning.end_of_input ib then max else
  match Scanning.peek_char ib with
  | c when digitp c ->
     let max = Scanning.store_char ib c max in
     scan_digits digitp max ib
  | _ -> max;;

let scan_binary_digits =
  let is_binary = function
  | '0' .. '1' -> true
  | _ -> false in
  scan_digits is_binary;;

let scan_octal_digits =
  let is_octal = function
  | '0' .. '8' -> true
  | _ -> false in
  scan_digits is_octal;;

let scan_hexadecimal_digits =
  let is_hexa = function
  | '0' .. '9' | 'a' .. 'f' -> true
  | _ -> false in
  scan_digits is_hexa;;

let scan_Hexadecimal_digits =
  let is_Hexa = function
  | '0' .. '9' | 'A' .. 'F' -> true
  | _ -> false in
  scan_digits is_Hexa;;

(* Decimal integers. *)
let scan_unsigned_decimal_int max ib =
  if max = 0 || Scanning.end_of_input ib then bad_input ib "an int" else
  scan_decimal_digits max ib;;

let scan_optionally_signed_decimal_int max ib =
  let max = scan_sign max ib in
  scan_unsigned_decimal_int max ib;;

(* Scan an unsigned integer that could be given in any (common) basis.
   If digits are prefixed by 0b for one of x, X, o, b the number is
   assumed to be written respectively in hexadecimal, hexadecimal,
   octal, or binary. *)
let scan_unsigned_int max ib =
  match Scanning.peek_char ib with
  | '0' as c ->
      let max = Scanning.store_char ib c max in
      if max = 0 || Scanning.end_of_input ib then max else
      let c = Scanning.peek_char ib in
      begin match c with
      | 'x' -> scan_hexadecimal_digits (Scanning.store_char ib c max) ib
      | 'X' -> scan_Hexadecimal_digits (Scanning.store_char ib c max) ib
      | 'o' -> scan_octal_digits (Scanning.store_char ib c max) ib
      | 'b' -> scan_binary_digits (Scanning.store_char ib c max) ib
      | c -> scan_decimal_digits max ib end
  | c -> scan_decimal_digits max ib;;

let scan_optionally_signed_int max ib =
  let max = scan_sign max ib in
  if max = 0 || Scanning.end_of_input ib then bad_input ib "an int" else
  scan_unsigned_int max ib;;

let scan_int c max ib =
  match c with
  | 'd' -> scan_optionally_signed_decimal_int max ib
  | 'i' -> scan_optionally_signed_int max ib
  | 'o' -> scan_octal_digits max ib 
  | 'u' -> scan_unsigned_decimal_int max ib
  | 'x' -> scan_hexadecimal_digits max ib
  | 'X' -> scan_Hexadecimal_digits max ib
  | c -> assert false;;

(* Scanning floating point numbers. *)
let scan_frac_part max ib = scan_unsigned_decimal_int max ib;;

let scan_exp_part max ib =
  if max = 0 || Scanning.end_of_input ib then max else
  let c = Scanning.peek_char ib in
  match c with
  | 'e' | 'E' as c ->
     scan_optionally_signed_int (Scanning.store_char ib c max) ib
  | _ -> max;;

let scan_float max ib =
  let max = scan_optionally_signed_decimal_int max ib in
  if max = 0 || Scanning.end_of_input ib then max else
  let c = Scanning.peek_char ib in
  match c with
  | '.' ->
     let max = Scanning.store_char ib c max in
     let max = scan_frac_part max ib in
     scan_exp_part max ib
  | c -> scan_exp_part max ib;;

let scan_string stp max ib =
  let rec loop max =
    if max = 0 || Scanning.end_of_input ib then max else
    let c = Scanning.peek_char ib in
    if stp = [] then
      match c with
      | ' ' | '\t' | '\n' | '\r' -> max
      | c -> loop (Scanning.store_char ib c max) else
    if List.mem c stp then max else loop (Scanning.store_char ib c max) in 
   loop max;;

let scan_char max ib =
  if max = 0 || Scanning.end_of_input ib then bad_input ib "a char" else
  let c = Scanning.peek_char ib in
  Scanning.store_char ib c max;;

let read_char max ib =
  let max = scan_char max ib in
  token_char ib;;

let scan_bool max ib =
  let m =
    match Scanning.peek_char ib with
    | 't' -> 4
    | 'f' -> 5
    | _ -> 0 in
  scan_string [] (min max m) ib;;

let read_bool max ib =
  let max = scan_bool max ib in
  token_bool ib;;

type char_set = Pos_set of string | Neg_set of string;;

let read_char_set fmt i =
  let lim = String.length fmt - 1 in

  let rec find_in_set i j =
    if j > lim then bad_format fmt j fmt.[lim - 1] else
    match fmt.[j] with
    | ']' -> String.sub fmt i (j - i), j
    | c -> find_in_set i (j + 1)

  and find_set_sign i =
    if i > lim then bad_format fmt i fmt.[lim - 1] else
    match fmt.[i] with
    | '^' -> let set, i = find_set (i + 1) in i, Neg_set set
    | _ -> let set, i = find_set i in i, Pos_set set

  and find_set i =
    if i > lim then bad_format fmt i fmt.[lim - 1] else
    match fmt.[i] with
    | ']' -> find_in_set i (i + 1)
    | c -> find_in_set i i in

  find_set_sign i;;

let make_setp stp char_set =
  let make_predv set =
    let v = Array.make 256 false in
    let lim = String.length set - 1 in
    let rec loop b i =
      if i <= lim then
      match set.[i] with
      | '-' when b ->
         (* if i = 0 then b is false (since the initial call is loop false 0)
          hence i >= 1 and the following is safe. *) 
          let c1 = set.[i - 1] in
          let i = i + 1 in
          if i > lim then loop false (i - 1) else
          let c2 = set.[i] in
          for j = int_of_char c1 to int_of_char c2 do v.(j) <- true done;
          loop false (i + 1)
      | c -> v.(int_of_char set.[i]) <- true; loop true (i + 1) in
    loop false 0;
    v in
  match char_set with
  | Pos_set set ->
      let v = make_predv set in
      List.iter (fun c -> v.(int_of_char c) <- false) stp;
      (fun c -> v.(int_of_char c))
  | Neg_set set ->
      let v = make_predv set in
      List.iter (fun c -> v.(int_of_char c) <- true) stp;
      (fun c -> not (v.(int_of_char c)));;

let scan_chars_in_char_set stp char_set max ib =
  let setp = make_setp stp char_set in
  let rec loop max ib =
    if max = 0 || Scanning.end_of_input ib then max else
    let c = Scanning.peek_char ib in
    if setp c then loop (Scanning.store_char ib c max) ib else max in
  loop max ib;;

let rec skip_whites ib =
  if not (Scanning.end_of_input ib) then
  match Scanning.peek_char ib with
  | ' ' | '\r' | '\t' | '\n' -> Scanning.next_char ib; skip_whites ib
  | _ -> ();;

(* Main scanning function:
   it takes an input buffer, a format and a function.
   Then it scans the format and the buffer in parallel to find out
   values as specified by the format. When it founds some it applies it
   to function f in turn and continue. *) 
let scanf_fun ib (fmt : ('a, 'b, 'c) format) f =
  let fmt = (Obj.magic fmt : string) in
  let lim = String.length fmt - 1 in

  let return v = Obj.magic v () in
  let delay f x () = Obj.magic f x in
  let stack f = delay (return f) in

  let rec scan spc f i =
    if i > lim then return f else
    match fmt.[i] with
    | '%' -> scan_width spc f (i + 1)
    | '@' as t ->
        let i = i + 1 in
        if i > lim then bad_format fmt (i - 1) t else begin
        match fmt.[i] with
        | fc when Scanning.end_of_input ib -> bad_input_buff ib
        | '@' as fc when Scanning.peek_char ib = fc ->
           Scanning.next_char ib; scan spc f (i + 1)
        | fc when Scanning.peek_char ib = fc ->
           Scanning.next_char ib; scan false f (i + 1)
        | fc -> bad_input_buff ib end
    | ' ' | '\r' | '\t' | '\n' -> skip_whites ib; scan spc f (i + 1)
    | fc when Scanning.end_of_input ib -> bad_input_buff ib
    | fc when Scanning.peek_char ib = fc ->
        Scanning.next_char ib; scan spc f (i + 1)
    | fc -> bad_input_buff ib

  and scan_width spc f i =
    if i > lim then bad_format fmt i '%' else
    match fmt.[i] with
    | '0' .. '9' as c ->
         let rec read_width accu i =
           if i > lim then accu, i else
           match fmt.[i] with
           | '0' .. '9' as c ->
               let accu = 10 * accu + (int_of_char c - int_of_char '0') in
               read_width accu (i + 1)
           | _ -> accu, i in
         let max, j = read_width 0 i in
         scan_conversion spc max f j
    | _ -> scan_conversion spc max_int f i

  and scan_conversion spc max f i =
    if i > lim then bad_format fmt i fmt.[lim - 1] else
    match fmt.[i] with
    | 'c' ->
        let x = read_char max ib in
        scan true (stack f x) (i + 1)
    | c ->
       if spc then skip_whites ib;
       match c with
       | fc when Scanning.end_of_input ib -> bad_input_buff ib
       | '%' as fc when Scanning.peek_char ib = fc ->
           Scanning.next_char ib; scan true f (i + 1)
       | '%' as fc -> bad_input_buff ib
       | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
           let x = scan_int c max ib in
           scan true (stack f (token_int ib)) (i + 1)
       | 'f' | 'g' | 'G' | 'e' | 'E' ->
           let x = scan_float max ib in
           scan true (stack f (token_float ib)) (i + 1)
       | 's' ->
           let i, stp = scan_stoppers (i + 1) in
           let x = scan_string stp max ib in
           scan true (stack f (token_string ib)) (i + 1)
       | 'b' ->
           let x = read_bool 4 ib in
           scan true (stack f x) (i + 1)
       | '[' ->
           let i, char_set = read_char_set fmt (i + 1) in
           let i, stp = scan_stoppers (i + 1) in
           let x = scan_chars_in_char_set stp char_set max ib in
           scan true (stack f (token_string ib)) (i + 1)
       | 'l' | 'n' | 'L' as t ->
           let i = i + 1 in
           if i > lim then bad_format fmt (i - 1) t else begin
           match fmt.[i] with
           | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as c ->
              let x = scan_int c max ib in
              begin match t with
              | 'l' -> scan true (stack f (token_int32 ib)) (i + 1)
              | 'L' -> scan true (stack f (token_int64 ib)) (i + 1)
              | _ -> scan true (stack f (token_nativeint ib)) (i + 1) end
           | fc -> bad_format fmt i fc end
       | 'N' ->
           let x = Scanning.char_count ib in
           scan true (stack f x) (i + 1)
       | c -> bad_format fmt i c

  and scan_stoppers i =
    if i > lim then i - 1, [] else
    match fmt.[i] with
    | '@' when i < lim -> let i = i + 1 in i, [fmt.[i]]
    | _ -> i - 1, [] in

  Scanning.reset_token ib;
  scan true (fun () -> f) 0;;

let bscanf ib =
 (Obj.magic scanf_fun :
  Scanning.scanbuf ->
  ('a, Scanning.scanbuf, 'b) format ->
  ('a -> 'b)) ib;;

let fscanf ic fmt =
  let ib = Scanning.from_channel ic in
  bscanf ib fmt;;

let scanf fmt = fscanf stdin fmt;;

let sscanf s fmt =
  let ib = Scanning.from_string s in
  bscanf ib fmt;;