GPR#268: Hexadecimal notation for floating-point numbers

Merge of branch 'hex-float'.

- Add support in byterun/floats.c for conversions between floats and strings in hex notation. We cannot rely on the C standard library here because Microsoft consistently fails at supporting hex notation as standardized in C99. Instead, the conversions are implemented from scratch.
- Add support in the lexer so that hex float literals are recognized in OCaml sources.
- Add support in formats. The ISO C99 format letters for hex floats are %a and %A, but %a is already taken. I chose %h and %H, which are rejected today as bad formats (hence no backward incompatibility) and don't mean anything in C either (h is a modifier, not a format letter).
- Add support in printf. All the trimmings are there in the implementation of %h and %H, including sign modifier and fixed precision.
- Benoit Vaugon contributed support in scanf.

Resolved conflicts:
	boot/ocamlc
	boot/ocamldep
	boot/ocamllex
	parsing/lexer.mll

13 files changed, 304 insertions, 67 deletions

diff --git a/Changes b/Changes
index 526fd095fc..1af74fe2c9 100644
--- a/Changes
+++ b/Changes
@@ -46,6 +46,10 @@ Language features:
   attribute is applied on predefined exception constructors which
   take an purely informational (with no stability guarantee) message.
   (Alain Frisch)
+- GPR#268: hexadecimal notation for floating-point literals
+  In OCaml source code, FP literals can be written using the hexadecimal
+  notation 0x<mantissa in hex>p<exponent> from ISO C99.
+  (Xavier Leroy)
 - GPR#173: [@inline] and [@inlined] attributes (for function declarations
   and call sites respectively) to control inlining
   (Pierre Chambart, Mark Shinwell)
@@ -156,6 +160,9 @@ Standard library:
   (report and fix by Jeremy Yallop)
 - GPR#265: new implementation of Queue avoiding Obj.magic
   (Jérémie Dimino)
+- GPR#268: '%h' and '%H' modifiers for printf and scanf to support
+  floating-point numbers in hexadecimal notation
+  (Xavier Leroy, Benoît Vaugon)
 - GPR#272: Switch classify_float to [@@unboxed] (Alain Frisch)
 - Improve speed of classify_float by not going through fpclassify()
   (Alain Frisch, Xavier Leroy)
diff --git a/boot/ocamlc b/boot/ocamlc
index ba32993f0b..48e6a8e0ac 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 4a47869bcc..6885e9bb49 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 911786114f..02644ee9d7 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/byterun/floats.c b/byterun/floats.c
index 91af6c13dd..c89f81bfbf 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"
@@ -97,46 +98,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);
@@ -147,6 +280,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 7957a3b2a4..de331e328b 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 =
@@ -313,6 +299,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 {
@@ -356,8 +347,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))
@@ -373,7 +364,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)) }
   | "\""
diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml
index 8d9f8d3450..ae0e133655 100644
--- a/stdlib/camlinternalFormat.ml
+++ b/stdlib/camlinternalFormat.ml
@@ -214,7 +214,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 *)
@@ -229,6 +232,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 *)
@@ -283,6 +288,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
@@ -424,11 +431,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"). *)
@@ -1409,22 +1419,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 =
@@ -2412,7 +2434,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
@@ -2878,6 +2900,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 60a74524ec..837b2bd870 100644
--- a/stdlib/camlinternalFormatBasics.ml
+++ b/stdlib/camlinternalFormatBasics.ml
@@ -36,6 +36,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 ee0235661b..817f4410c5 100644
--- a/stdlib/camlinternalFormatBasics.mli
+++ b/stdlib/camlinternalFormatBasics.mli
@@ -23,6 +23,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/printf.mli b/stdlib/printf.mli
index db3f0a9bd4..70d50ea285 100644
--- a/stdlib/printf.mli
+++ b/stdlib/printf.mli
@@ -55,6 +55,9 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
      in the style [d.ddd e+-dd] (mantissa and exponent).
    - [g] or [G]: convert a floating-point argument to decimal notation,
      in style [f] or [e], [E] (whichever is more compact).
+   - [h] or [H]: convert a floating-point argument to hexadecimal notation,
+     in the style [0xh.hhhh e+-dd] (hexadecimal mantissa, exponent in
+     decimal and denotes a power of 2).
    - [B]: convert a boolean argument to the string [true] or [false]
    - [b]: convert a boolean argument (deprecated; do not use in new
      programs).
diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index 3abcf47c1c..9f00387669 100644
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -475,6 +475,10 @@ let bad_float () =
   bad_input "no dot or exponent part found in float token"
 ;;
 
+let bad_hex_float () =
+  bad_input "not a valid float in hexadecimal notation"
+;;
+
 let character_mismatch_err c ci =
   Printf.sprintf "looking for %C, found %C" c ci
 ;;
@@ -825,6 +829,63 @@ let scan_caml_float width precision ib =
   | _ -> bad_float ()
 ;;
 
+let check_case_insensitive_string width ib error str =
+  let lowercase c = match c with
+    | 'A' .. 'Z' -> char_of_int (int_of_char c - int_of_char 'A' + int_of_char 'a')
+    | _ -> c in
+  let len = String.length str in
+  let width = ref width in
+  for i = 0 to len - 1 do
+    let c = Scanning.peek_char ib in
+    if lowercase c <> lowercase str.[i] then error ();
+    if !width = 0 then error ();
+    width := Scanning.store_char !width ib c;
+  done;
+  !width
+
+let scan_hex_float width precision ib =
+  if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+  let width = scan_sign width ib in
+  if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+  match Scanning.peek_char ib with
+  | '0' as c -> (
+    let width = Scanning.store_char width ib c in
+    if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+    let width = check_case_insensitive_string width ib bad_hex_float "x" in
+    if width = 0 || Scanning.end_of_input ib then width else
+      let width = match Scanning.peek_char ib with
+        | '.' | 'p' | 'P' -> width
+        | _ -> scan_hexadecimal_int width ib in
+      if width = 0 || Scanning.end_of_input ib then width else
+        let width = match Scanning.peek_char ib with
+          | '.' as c -> (
+            let width = Scanning.store_char width ib c in
+            if width = 0 || Scanning.end_of_input ib then width else
+              match Scanning.peek_char ib with
+              | 'p' | 'P' -> width
+              | _ ->
+                let precision = min width precision in
+                width - (precision - scan_hexadecimal_int precision ib)
+          )
+          | _ -> width in
+        if width = 0 || Scanning.end_of_input ib then width else
+          match Scanning.peek_char ib with
+          | 'p' | 'P' as c ->
+            let width = Scanning.store_char width ib c in
+            if width = 0 then bad_hex_float ();
+            scan_optionally_signed_decimal_int width ib
+          | _ -> width
+  )
+  | 'n' | 'N' as c ->
+    let width = Scanning.store_char width ib c in
+    if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+    check_case_insensitive_string width ib bad_hex_float "an"
+  | 'i' | 'I' as c ->
+    let width = Scanning.store_char width ib c in
+    if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+    check_case_insensitive_string width ib bad_hex_float "nfinity"
+  | _ -> bad_hex_float ()
+
 (* Scan a regular string:
    stops when encountering a space, if no scanning indication has been given;
    otherwise, stops when encountering the characters in the scanning
@@ -1223,7 +1284,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) ->
+    pad_prec_scanf ib rest readers pad prec scan_hex_float token_float
   | Bool rest ->
     let _ = scan_bool ib in
     let b = token_bool ib in
diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli
index 2b0d562873..3c5f390d45 100644
--- a/stdlib/scanf.mli
+++ b/stdlib/scanf.mli
@@ -312,6 +312,8 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner
     - [f], [e], [E], [g], [G]: reads an optionally signed
       floating-point number in decimal notation, in the style [dddd.ddd
       e/E+-dd].
+    - [h], [H]: reads an optionally signed floating-point number
+      in hexadecimal notation.
     - [F]: reads a floating point number according to the lexical
       conventions of OCaml (hence the decimal point is mandatory if the
       exponent part is not mentioned).
diff --git a/typing/typecore.ml b/typing/typecore.ml
index cf7c2ed1a8..b36c4879bf 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -3006,6 +3006,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"  []