Preliminary support for hexadecimal notation for FP numbers.

- Primitives:
     caml_float_of_string  extended to recognize "0x" hexa notation
     caml_hexstring_of_float  new primitive
  We do not assume hex floats are supported by the C standard library.
  Instead, conversions hex string <-> float are implemented manually.
- Printf: hex FP output supported with formats %h / %H
- Scanf: remains to be updated (see TODO in stdlib/scanf.ml)


git-svn-id: http://caml.inria.fr/svn/ocaml/branches/hex-float@16257 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

10 files changed, 231 insertions, 66 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index 5775fc43f7..04449a855e 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 98083c596f..868268229c 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 043c76967f..0bc974e5c0 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/byterun/floats.c b/byterun/floats.c
index 544dc06efd..c640ef9938 100644
--- a/byterun/floats.c
+++ b/byterun/floats.c
@@ -17,6 +17,7 @@
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
+#include <limits.h>
 
 #include "caml/alloc.h"
 #include "caml/fail.h"
@@ -93,46 +94,178 @@ CAMLprim value caml_format_float(value fmt, value arg)
   return res;
 }
 
-#if 0
-/*CAMLprim*/ value caml_float_of_substring(value vs, value idx, value l)
+CAMLprim value caml_hexstring_of_float(value arg, value vprec, value vstyle)
 {
-  char parse_buffer[64];
-  char * buf, * src, * dst, * end;
-  mlsize_t len, lenvs;
-  double d;
-  intnat flen = Long_val(l);
-  intnat fidx = Long_val(idx);
+  union { uint64_t i; double d; } u;
+  int sign, exp;
+  uint64_t m;
+  char buffer[64];
+  char * buf, * p;
+  intnat prec;
+  int d;
+  value res;
 
-  lenvs = caml_string_length(vs);
-  len =
-    fidx >= 0 && fidx < lenvs && flen > 0 && flen <= lenvs - fidx
-    ? flen : 0;
-  buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1);
-  src = String_val(vs) + fidx;
-  dst = buf;
-  while (len--) {
-    char c = *src++;
-    if (c != '_') *dst++ = c;
+  /* Allocate output buffer */
+  prec = Long_val(vprec);
+                  /* 12 chars for sign, 0x, decimal point, exponent */
+  buf = (prec + 12 <= 64 ? buffer : caml_stat_alloc(prec + 12));
+  /* Extract sign, mantissa, and exponent */
+  u.d = Double_val(arg);
+  sign = u.i >> 63;
+  exp = (u.i >> 52) & 0x7FF;
+  m = u.i & (((uint64_t) 1 << 52) - 1);
+  /* Put sign */
+  p = buf;
+  if (sign) {
+    *p++ = '-';
+  } else {
+    switch (Int_val(vstyle)) {
+    case '+': *p++ = '+'; break;
+    case ' ': *p++ = ' '; break;
+    }
   }
-  *dst = 0;
-  if (dst == buf) goto error;
-  d = strtod((const char *) buf, &end);
-  if (end != dst) goto error;
-  if (buf != parse_buffer) caml_stat_free(buf);
-  return caml_copy_double(d);
- error:
-  if (buf != parse_buffer) caml_stat_free(buf);
-  caml_failwith("float_of_string");
+  /* Treat special cases */
+  if (exp == 0x7FF) {
+    char * txt;
+    if (m == 0) txt = "infinity"; else txt = "nan";
+    memcpy(p, txt, strlen(txt));
+    p[strlen(txt)] = 0;
+    res = caml_copy_string(buf);
+  } else {
+    /* Output "0x" prefix */
+    *p++ = '0'; *p++ = 'x';
+    /* Normalize exponent and mantissa */
+    if (exp == 0) {
+      if (m != 0) exp = -1022;    /* denormal */
+    } else {
+      exp = exp - 1023;
+      m = m | ((uint64_t) 1 << 52);
+    }
+    /* If a precision is given, and is small, round mantissa accordingly */
+    prec = Long_val(vprec);
+    if (prec >= 0 && prec < 13) {
+      int i = 52 - prec * 4;
+      uint64_t unit = (uint64_t) 1 << i;
+      uint64_t half = unit >> 1;
+      uint64_t mask = unit - 1;
+      uint64_t frac = m & mask;
+      m = m & ~mask;
+      /* Round to nearest, ties to even */
+      if (frac > half || (frac == half && (m & unit) != 0)) {
+        m += unit;
+      }
+    }
+    /* Leading digit */
+    d = m >> 52;
+    *p++ = (d < 10 ? d + '0' : d - 10 + 'a');
+    m = (m << 4) & (((uint64_t) 1 << 56) - 1);
+    /* Fractional digits.  If a precision is given, print that number of
+       digits.  Otherwise, print as many digits as needed to represent
+       the mantissa exactly. */
+    if (prec >= 0 ? prec > 0 : m != 0) {
+      *p++ = '.';
+      while (prec >= 0 ? prec > 0 : m != 0) {
+        d = m >> 52;
+        *p++ = (d < 10 ? d + '0' : d - 10 + 'a');
+        m = (m << 4) & (((uint64_t) 1 << 56) - 1);
+        prec--;
+      }
+    }
+    *p = 0;
+    /* Add exponent */
+    res = caml_alloc_sprintf("%sp%+d", buf, exp);
+  }
+  if (buf != buffer) caml_stat_free(buf);
+  return res;
+}
+
+static int caml_float_of_hex(const char * s, double * res)
+{
+  int64_t m = 0;                /* the mantissa - top 60 bits at most */
+  int n_bits = 0;               /* total number of bits read */
+  int m_bits = 0;               /* number of bits in mantissa */
+  int x_bits = 0;               /* number of bits after mantissa */
+  int dec_point = -1;           /* bit count corresponding to decimal point */
+                                /* -1 if no decimal point seen */
+  int exp = 0;                  /* exponent */
+  char * p;                     /* for converting the exponent */
+
+  while (*s != 0) {
+    char c = *s++;
+    switch (c) {
+    case '_':
+      break;
+    case '.':
+      if (dec_point >= 0) return -1; /* multiple decimal points */
+      dec_point = n_bits;
+      break;
+    case 'p': case 'P': {
+      long e;
+      if (*s == 0) return -1;   /* nothing after exponent mark */
+      e = strtol(s, &p, 10);
+      if (*p != 0) return -1;   /* ill-formed exponent */
+      if (e < INT_MIN || e > INT_MAX) return -1; /* unreasonable exponent */
+      exp = e;
+      s = p;                    /* stop at next loop iteration */
+      break;
+    }
+    default: {                  /* Nonzero digit */
+      int d;
+      if (c >= '0' && c <= '9') d = c - '0';
+      else if (c >= 'A' && c <= 'F') d = c - 'A' + 10;
+      else if (c >= 'a' && c <= 'f') d = c - 'a' + 10;
+      else return -1;           /* bad digit */
+      n_bits += 4;
+      if (d == 0 && m == 0) break; /* leading zeros are skipped */
+      if (m_bits < 60) {
+        /* There is still room in m.  Add this digit to the mantissa. */
+        m = (m << 4) + d;
+        m_bits += 4;
+      } else {
+        /* We've already collected 60 significant bits in m.
+           Now all we care about is whether there is a nonzero bit
+           after. In this case, round m to odd so that the later
+           rounding of m to FP produces the correct result. */
+        if (d != 0) m |= 1;        /* round to odd */
+        x_bits += 4;
+      }
+      break;
+    }
+    }
+  }
+  /* Convert mantissa to FP.  We use a signed conversion because we can
+     (m has 60 bits at most) and because it is faster 
+     on several architectures. */
+  double f = (double) (int64_t) m;
+  /* Adjust exponent to take decimal point and extra digits into account */
+  if (dec_point >= 0) exp = exp + (dec_point - n_bits);
+  exp = exp + x_bits;
+  /* Apply exponent if needed */
+  if (exp != 0) f = ldexp(f, exp);
+  /* Done! */
+  *res = f;
+  return 0;
 }
-#endif
 
 CAMLprim value caml_float_of_string(value vs)
 {
   char parse_buffer[64];
   char * buf, * src, * dst, * end;
   mlsize_t len;
+  int sign;
   double d;
 
+  /* Check for hexadecimal FP constant */
+  src = String_val(vs);
+  sign = 1;
+  if (*src == '-') { sign = -1; src++; }
+  else if (*src == '+') { src++; }; 
+  if (src[0] == '0' && (src[1] == 'x' || src[1] == 'X')) {
+    if (caml_float_of_hex(src + 2, &d) == -1)
+      caml_failwith("float_of_string");
+    return caml_copy_double(sign < 0 ? -d : d);
+  }
+  /* Remove '_' characters before calling strtod () */
   len = caml_string_length(vs);
   buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1);
   src = String_val(vs);
@@ -143,6 +276,7 @@ CAMLprim value caml_float_of_string(value vs)
   }
   *dst = 0;
   if (dst == buf) goto error;
+  /* Convert using strtod */
   d = strtod((const char *) buf, &end);
   if (end != dst) goto error;
   if (buf != parse_buffer) caml_stat_free(buf);
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index e77f0847e6..42a785f043 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -189,20 +189,6 @@ let cvt_nativeint_literal s =
   Nativeint.neg (Nativeint.of_string ("-" ^ String.sub s 0
                                                        (String.length s - 1)))
 
-(* Remove underscores from float literals *)
-
-let remove_underscores s =
-  let l = String.length s in
-  let b = Bytes.create l in
-  let rec remove src dst =
-    if src >= l then
-      if dst >= l then s else Bytes.sub_string b 0 dst
-    else
-      match s.[src] with
-        '_' -> remove (src + 1) dst
-      |  c  -> Bytes.set b dst c; remove (src + 1) (dst + 1)
-  in remove 0 0
-
 (* recover the name from a LABEL or OPTLABEL token *)
 
 let get_label_name lexbuf =
@@ -311,6 +297,11 @@ let float_literal =
   ['0'-'9'] ['0'-'9' '_']*
   ('.' ['0'-'9' '_']* )?
   (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
+let hex_float_literal =
+  '0' ['x' 'X'] 
+  ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
+  ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']*)?
+  (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
 
 rule token = parse
   | "\\" newline {
@@ -354,8 +345,8 @@ rule token = parse
         with Failure _ ->
           raise (Error(Literal_overflow "int", Location.curr lexbuf))
       }
-  | float_literal
-      { FLOAT (remove_underscores(Lexing.lexeme lexbuf)) }
+  | float_literal | hex_float_literal
+      { FLOAT (Lexing.lexeme lexbuf) }
   | int_literal "l"
       { try
           INT32 (cvt_int32_literal (Lexing.lexeme lexbuf))
@@ -371,7 +362,7 @@ rule token = parse
           NATIVEINT (cvt_nativeint_literal (Lexing.lexeme lexbuf))
         with Failure _ ->
           raise (Error(Literal_overflow "nativeint", Location.curr lexbuf)) }
-  | (float_literal | int_literal) identchar+
+  | (float_literal | hex_float_literal | int_literal) identchar+
       { raise (Error(Invalid_literal (Lexing.lexeme lexbuf), Location.curr lexbuf)) }
   | "\""
       { reset_string_buffer();
diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml
index a217895fb8..e01a88d55d 100644
--- a/stdlib/camlinternalFormat.ml
+++ b/stdlib/camlinternalFormat.ml
@@ -197,7 +197,10 @@ type precision_ebb = Precision_EBB : ('a, 'b) precision -> precision_ebb
                                (* Constants *)
 
 (* Default precision for float printing. *)
-let default_float_precision = 6
+let default_float_precision = -6
+  (* For %h and %H formats, a negative precision means "as many digits as
+     necessary".  For the other FP formats, we take the absolute value
+     of the precision, hence 6 digits by default. *)
 
 (******************************************************************************)
                                (* Externals *)
@@ -212,6 +215,8 @@ external format_nativeint: string -> nativeint -> string
   = "caml_nativeint_format"
 external format_int64: string -> int64 -> string
   = "caml_int64_format"
+external hexstring_of_float: float -> int -> char -> string
+  = "caml_hexstring_of_float"
 
 (******************************************************************************)
                      (* Tools to pretty-print formats *)
@@ -266,6 +271,8 @@ let char_of_fconv fconv = match fconv with
   | Float_f | Float_pf | Float_sf -> 'f' | Float_e | Float_pe | Float_se -> 'e'
   | Float_E | Float_pE | Float_sE -> 'E' | Float_g | Float_pg | Float_sg -> 'g'
   | Float_G | Float_pG | Float_sG -> 'G' | Float_F -> 'F'
+  | Float_h | Float_ph | Float_sh -> 'h' | Float_H | Float_pH | Float_sH -> 'H'
+
 
 (* Convert a scanning counter to char. *)
 let char_of_counter counter = match counter with
@@ -407,11 +414,14 @@ let bprint_altint_fmt buf ign_flag iconv pad prec c =
 
 (* Print the optionnal '+' associated to a float conversion. *)
 let bprint_fconv_flag buf fconv = match fconv with
-  | Float_pf | Float_pe | Float_pE | Float_pg | Float_pG ->
+  | Float_pf | Float_pe | Float_pE
+  | Float_pg | Float_pG | Float_ph | Float_pH ->
     buffer_add_char buf '+'
-  | Float_sf | Float_se | Float_sE | Float_sg | Float_sG ->
+  | Float_sf | Float_se | Float_sE
+  | Float_sg | Float_sG | Float_sh | Float_sH ->
     buffer_add_char buf ' '
-  | Float_f | Float_e | Float_E | Float_g | Float_G | Float_F ->
+  | Float_f | Float_e | Float_E
+  | Float_g | Float_G | Float_F | Float_h | Float_H ->
     ()
 
 (* Print a complete float format in a buffer (ex: "%+*.3f"). *)
@@ -1383,22 +1393,34 @@ let convert_int64 iconv n = format_int64 (format_of_iconvL iconv) n
 (* Convert a float to string. *)
 (* Fix special case of "OCaml float format". *)
 let convert_float fconv prec x =
-  let prec = abs prec in
-  let str = format_float (format_of_fconv fconv prec) x in
-  if fconv <> Float_F then str else
-    let len = String.length str in
-    let rec is_valid i =
-      if i = len then false else
-        match str.[i] with
-        | '.' | 'e' | 'E' -> true
-        | _ -> is_valid (i + 1)
-    in
-    match classify_float x with
-    | FP_normal | FP_subnormal | FP_zero ->
-      if is_valid 0 then str else str ^ "."
-    | FP_infinite ->
-      if x < 0.0 then "neg_infinity" else "infinity"
-    | FP_nan -> "nan"
+  match fconv with
+  | Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH ->
+    let sign =
+      match fconv with
+      | Float_ph | Float_pH -> '+'
+      | Float_sh | Float_sH -> ' '
+      | _ -> '-' in
+    let str = hexstring_of_float x prec sign in
+    begin match fconv with
+    | Float_H | Float_pH | Float_sH -> String.uppercase_ascii str
+    | _ -> str
+    end
+  | _ ->
+    let str = format_float (format_of_fconv fconv prec) x in
+    if fconv <> Float_F then str else
+      let len = String.length str in
+      let rec is_valid i =
+        if i = len then false else
+          match str.[i] with
+          | '.' | 'e' | 'E' -> true
+          | _ -> is_valid (i + 1)
+      in
+      match classify_float x with
+      | FP_normal | FP_subnormal | FP_zero ->
+        if is_valid 0 then str else str ^ "."
+      | FP_infinite ->
+        if x < 0.0 then "neg_infinity" else "infinity"
+      | FP_nan -> "nan"
 
 (* Convert a char to a string according to the OCaml lexical convention. *)
 let format_caml_char c =
@@ -2284,7 +2306,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
         let Padprec_fmt_EBB (pad', prec', fmt_rest') =
           make_padprec_fmt_ebb (get_int_pad ()) (get_prec ()) fmt_rest in
         Fmt_EBB (Int64 (iconv, pad', prec', fmt_rest'))
-    | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' ->
+    | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' | 'h' | 'H' ->
       let fconv = compute_float_conv pct_ind str_ind (get_plus ())
         (get_space ()) symb in
       let Fmt_EBB fmt_rest = parse str_ind end_ind in
@@ -2749,6 +2771,12 @@ let fmt_ebb_of_string ?legacy_behavior str =
     | false, false, 'G' -> Float_G
     | false,  true, 'G' -> Float_sG
     |  true, false, 'G' -> Float_pG
+    | false, false, 'h' -> Float_h
+    | false,  true, 'h' -> Float_sh
+    |  true, false, 'h' -> Float_ph
+    | false, false, 'H' -> Float_H
+    | false,  true, 'H' -> Float_sH
+    |  true, false, 'H' -> Float_pH
     | false, false, 'F' -> Float_F
     |  true,  true, _ ->
       if legacy_behavior then
diff --git a/stdlib/camlinternalFormatBasics.ml b/stdlib/camlinternalFormatBasics.ml
index 4e5db73db9..597abbede7 100644
--- a/stdlib/camlinternalFormatBasics.ml
+++ b/stdlib/camlinternalFormatBasics.ml
@@ -23,6 +23,8 @@ type float_conv =
   | Float_g | Float_pg | Float_sg  (*  %g | %+g | % g  *)
   | Float_G | Float_pG | Float_sG  (*  %G | %+G | % G  *)
   | Float_F                        (*  %F              *)
+  | Float_h | Float_ph | Float_sh  (*  %h | %+h | % h  *)
+  | Float_H | Float_pH | Float_sH  (*  %H | %+H | % H  *)
 
 (***)
 
diff --git a/stdlib/camlinternalFormatBasics.mli b/stdlib/camlinternalFormatBasics.mli
index 80866e8332..acf8693762 100644
--- a/stdlib/camlinternalFormatBasics.mli
+++ b/stdlib/camlinternalFormatBasics.mli
@@ -10,6 +10,7 @@ type float_conv =
   | Float_f | Float_pf | Float_sf | Float_e | Float_pe | Float_se
   | Float_E | Float_pE | Float_sE | Float_g | Float_pg | Float_sg
   | Float_G | Float_pG | Float_sG | Float_F
+  | Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH
 
 type char_set = string
 
diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index 948808830c..a623e46af5 100644
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -1163,6 +1163,9 @@ fun ib fmt readers -> match fmt with
                | Float_E | Float_pE | Float_sE | Float_g | Float_pg | Float_sg
                | Float_G | Float_pG | Float_sG), pad, prec, rest) ->
     pad_prec_scanf ib rest readers pad prec scan_float token_float
+  | Float ((Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH),
+           _pad, _prec, _rest) ->
+    assert false (* TODO *)
 
   | Bool rest ->
     let _ = scan_bool ib in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 5134dc942e..31cfa935ee 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -2899,6 +2899,12 @@ and type_format loc str env =
         | Float_G  -> mk_constr "Float_G"  []
         | Float_pG -> mk_constr "Float_pG" []
         | Float_sG -> mk_constr "Float_sG" []
+        | Float_h  -> mk_constr "Float_h"  []
+        | Float_ph -> mk_constr "Float_ph" []
+        | Float_sh -> mk_constr "Float_sh" []
+        | Float_H  -> mk_constr "Float_H"  []
+        | Float_pH -> mk_constr "Float_pH" []
+        | Float_sH -> mk_constr "Float_sH" []
         | Float_F  -> mk_constr "Float_F"  []
       and mk_counter cnt = match cnt with
         | Line_counter  -> mk_constr "Line_counter"  []