Upgrade to Flocq 4.0.

36 files changed, 4637 insertions, 2875 deletions

diff --git a/Makefile b/Makefile
index 2bc39c33..103a6cb3 100644
--- a/Makefile
+++ b/Makefile
@@ -84,13 +84,12 @@ GPATH=$(DIRS)
 
 ifeq ($(LIBRARY_FLOCQ),local)
 FLOCQ=\
-  SpecFloatCompat.v \
   Raux.v Zaux.v Defs.v Digits.v Float_prop.v FIX.v FLT.v FLX.v FTZ.v \
   Generic_fmt.v Round_pred.v Round_NE.v Ulp.v Core.v \
-  Bracket.v Div.v Operations.v Round.v Sqrt.v \
+  Bracket.v Div.v Operations.v Plus.v Round.v Sqrt.v \
   Div_sqrt_error.v Mult_error.v Plus_error.v \
   Relative.v Sterbenz.v Round_odd.v Double_rounding.v \
-  Binary.v Bits.v
+  BinarySingleNaN.v Binary.v Bits.v
 else
 FLOCQ=
 endif
diff --git a/extraction/extraction.v b/extraction/extraction.v
index 8c2a52a2..2319be17 100644
--- a/extraction/extraction.v
+++ b/extraction/extraction.v
@@ -148,7 +148,12 @@ Extraction Blacklist List String Int.
 Extract Inlined Constant Defs.F2R => "fun _ -> assert false".
 Extract Inlined Constant Binary.FF2R => "fun _ -> assert false".
 Extract Inlined Constant Binary.B2R => "fun _ -> assert false".
-Extract Inlined Constant Binary.round_mode => "fun _ -> assert false".
+Extract Inlined Constant BinarySingleNaN.round_mode => "fun _ -> assert false".
+Extract Inlined Constant BinarySingleNaN.SF2R => "fun _ -> assert false".
+Extract Inlined Constant BinarySingleNaN.B2R => "fun _ -> assert false".
+Extract Inlined Constant Binary.BSN.round_mode => "fun _ -> assert false".
+Extract Inlined Constant Binary.BSN.SF2R => "fun _ -> assert false".
+Extract Inlined Constant Binary.BSN.B2R => "fun _ -> assert false".
 Extract Inlined Constant Bracket.inbetween_loc => "fun _ -> assert false".
 
 (* Needed in Coq 8.4 to avoid problems with Function definitions. *)
diff --git a/flocq/Calc/Bracket.v b/flocq/Calc/Bracket.v
index 838cadfa..9ab55165 100644
--- a/flocq/Calc/Bracket.v
+++ b/flocq/Calc/Bracket.v
@@ -19,13 +19,14 @@ COPYING file for more details.
 
 (** * Locations: where a real number is positioned with respect to its rounded-down value in an arbitrary format. *)
 
-From Coq Require Import Lia.
-Require Import Raux Defs Float_prop.
-Require Import SpecFloatCompat.
+From Coq Require Import ZArith Reals Lia.
+From Coq Require SpecFloat.
 
-Notation location := location (only parsing).
-Notation loc_Exact := loc_Exact (only parsing).
-Notation loc_Inexact := loc_Inexact (only parsing).
+Require Import Zaux Raux Defs Float_prop.
+
+Notation location := SpecFloat.location (only parsing).
+Notation loc_Exact := SpecFloat.loc_Exact (only parsing).
+Notation loc_Inexact := SpecFloat.loc_Inexact (only parsing).
 
 Section Fcalc_bracket.
 
@@ -533,16 +534,35 @@ Qed.
 
 End Fcalc_bracket_step.
 
-Section Fcalc_bracket_scale.
+Section Bracket_plus.
 
-Lemma inbetween_mult_aux :
-  forall x d s,
-  ((x * s + d * s) / 2 = (x + d) / 2 * s)%R.
+Theorem inbetween_plus_compat :
+  forall x d u l t,
+  inbetween x d u l ->
+  inbetween (x + t) (d + t) (u + t) l.
 Proof.
-intros x d s.
-field.
+intros x d u l t [Hx|l' Hx Hl] ; constructor.
+now rewrite Hx.
+now split ; apply Rplus_lt_compat_r.
+replace ((x + t + (d + t)) / 2)%R with ((x + d) / 2 + t)%R by field.
+now rewrite Rcompare_plus_r.
 Qed.
 
+Theorem inbetween_plus_reg :
+  forall x d u l t,
+  inbetween (x + t) (d + t) (u + t) l ->
+  inbetween x d u l.
+Proof.
+intros x d u l t H.
+generalize (inbetween_plus_compat _ _ _ _ (Ropp t) H).
+assert (K: forall y, (y + t + -t = y)%R) by (intros y ; ring).
+now rewrite 3!K.
+Qed.
+
+End Bracket_plus.
+
+Section Fcalc_bracket_scale.
+
 Theorem inbetween_mult_compat :
   forall x d u l s,
   (0 < s)%R ->
@@ -552,7 +572,7 @@ Proof.
 intros x d u l s Hs [Hx|l' Hx Hl] ; constructor.
 now rewrite Hx.
 now split ; apply Rmult_lt_compat_r.
-rewrite inbetween_mult_aux.
+replace ((x * s + d * s) / 2)%R with ((x + d) / 2 * s)%R by field.
 now rewrite Rcompare_mult_r.
 Qed.
 
@@ -562,12 +582,11 @@ Theorem inbetween_mult_reg :
   inbetween (x * s) (d * s) (u * s) l ->
   inbetween x d u l.
 Proof.
-intros x d u l s Hs [Hx|l' Hx Hl] ; constructor.
-apply Rmult_eq_reg_r with (1 := Hx).
-now apply Rgt_not_eq.
-now split ; apply Rmult_lt_reg_r with s.
-rewrite <- Rcompare_mult_r with (1 := Hs).
-now rewrite inbetween_mult_aux in Hl.
+intros x d u l s Hs H.
+generalize (inbetween_mult_compat _ _ _ _ _ (Rinv_0_lt_compat s Hs) H).
+assert (K: forall y, (y * s * /s = y)%R).
+{ intros y. field. now apply Rgt_not_eq. }
+now rewrite 3!K.
 Qed.
 
 End Fcalc_bracket_scale.
diff --git a/flocq/Calc/Div.v b/flocq/Calc/Div.v
index 48e3bb51..88d99a1f 100644
--- a/flocq/Calc/Div.v
+++ b/flocq/Calc/Div.v
@@ -19,8 +19,9 @@ COPYING file for more details.
 
 (** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *)
 
-From Coq Require Import Lia.
-Require Import Raux Defs Generic_fmt Float_prop Digits Bracket.
+From Coq Require Import ZArith Reals Lia.
+
+Require Import Zaux Raux Defs Generic_fmt Float_prop Digits Bracket.
 
 Set Implicit Arguments.
 Set Strongly Strict Implicit.
diff --git a/flocq/Calc/Operations.v b/flocq/Calc/Operations.v
index ac93d412..bcc93f6a 100644
--- a/flocq/Calc/Operations.v
+++ b/flocq/Calc/Operations.v
@@ -19,8 +19,9 @@ COPYING file for more details.
 
 (** * Basic operations on floats: alignment, addition, multiplication *)
 
-From Coq Require Import Lia.
-Require Import Raux Defs Float_prop.
+From Coq Require Import ZArith Reals Lia.
+
+Require Import Zaux Raux Defs Float_prop.
 
 Set Implicit Arguments.
 Set Strongly Strict Implicit.
diff --git a/flocq/Calc/Plus.v b/flocq/Calc/Plus.v
new file mode 100644
index 00000000..bd338af8
--- /dev/null
+++ b/flocq/Calc/Plus.v
@@ -0,0 +1,171 @@
+(**
+This file is part of the Flocq formalization of floating-point
+arithmetic in Coq: http://flocq.gforge.inria.fr/
+
+Copyright (C) 2010-2021 Sylvie Boldo
+#<br />#
+Copyright (C) 2010-2021 Guillaume Melquiond
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+COPYING file for more details.
+*)
+
+(** * Helper function and theorem for computing the rounded sum of two floating-point numbers. *)
+
+From Coq Require Import ZArith Reals Lia.
+
+Require Import Core Bracket Operations Round.
+
+Section Plus.
+
+Variable beta : radix.
+Notation bpow e := (bpow beta e).
+
+Variable fexp : Z -> Z.
+
+Context { monotone_exp : Monotone_exp fexp }.
+
+Definition Fplus_core m1 e1 m2 e2 e :=
+  let k := (e - e2)%Z in
+  let '(m2', _, l) :=
+    if Zlt_bool 0 k then truncate_aux beta (m2, e2, loc_Exact) k
+    else (m2 * Zpower beta (-k), e, loc_Exact)%Z in
+  let m1' := (m1 * Zpower beta (e1 - e))%Z in
+  (m1' + m2', l)%Z.
+
+Theorem Fplus_core_correct :
+  forall m1 e1 m2 e2 e,
+  (e <= e1)%Z ->
+  let '(m, l) := Fplus_core m1 e1 m2 e2 e in
+  inbetween_float beta m e (F2R (Float beta m1 e1) + F2R (Float beta m2 e2)) l.
+Proof.
+intros m1 e1 m2 e2 e He1.
+unfold Fplus_core.
+case Zlt_bool_spec ; intros He2.
+- unfold truncate_aux.
+  unfold inbetween_float, F2R. simpl.
+  rewrite 3!plus_IZR.
+  rewrite Rplus_assoc.
+  rewrite 2!Rmult_plus_distr_r.
+  replace (IZR (m1 * Zpower beta (e1 - e)) * bpow e)%R with (IZR m1 * bpow e1)%R.
+  2: {
+    rewrite mult_IZR, IZR_Zpower by lia.
+    rewrite Rmult_assoc, <- bpow_plus.
+    apply (f_equal (fun v => IZR m1 * bpow v)%R).
+    ring.
+  }
+  rewrite <- 3!(Rplus_comm _ (IZR m1 * bpow e1)).
+  apply inbetween_plus_compat.
+  set (k := (e - e2)%Z).
+  rewrite <- (plus_IZR _ 1).
+  replace e with (e2 + k)%Z by (unfold k ; ring).
+  apply inbetween_float_new_location.
+  exact He2.
+  now constructor 1.
+- constructor 1.
+  unfold F2R. simpl.
+  rewrite plus_IZR, Rmult_plus_distr_r.
+  rewrite 2!mult_IZR, 2!IZR_Zpower by lia.
+  rewrite 2!Rmult_assoc, <- 2!bpow_plus.
+  apply (f_equal2 (fun v w => IZR m1 * bpow v + IZR m2 * bpow w)%R) ; ring.
+Qed.
+
+Definition Fplus (f1 f2 : float beta) :=
+  let (m1, e1) := f1 in
+  let (m2, e2) := f2 in
+  if Zeq_bool m1 0 then
+    (m2, e2, loc_Exact)
+  else if Zeq_bool m2 0 then
+    (m1, e1, loc_Exact)
+  else
+  let p1 := (Zdigits beta m1 + e1)%Z in
+  let p2 := (Zdigits beta m2 + e2)%Z in
+  if Zle_bool 2 (Z.abs (p1 - p2)) then
+    let e := Z.min (Z.max e1 e2) (fexp (Z.max p1 p2 - 1)) in
+    let (m, l) :=
+      if Zlt_bool e1 e then
+        Fplus_core m2 e2 m1 e1 e
+      else
+        Fplus_core m1 e1 m2 e2 e in
+    (m, e, l)
+  else
+    let (m, e) := Fplus f1 f2 in
+    (m, e, loc_Exact).
+
+Theorem Fplus_correct :
+  forall x y,
+  let '(m, e, l) := Fplus x y in
+  (l = loc_Exact \/ e <= cexp beta fexp (F2R x + F2R y))%Z /\
+  inbetween_float beta m e (F2R x + F2R y) l.
+Proof.
+intros [m1 e1] [m2 e2].
+unfold Fplus.
+case Zeq_bool_spec ; intros Hm1.
+{ rewrite Hm1.
+  split.
+  now left.
+  rewrite F2R_0, Rplus_0_l.
+  now constructor 1. }
+case Zeq_bool_spec ; intros Hm2.
+{ rewrite Hm2.
+  split.
+  now left.
+  rewrite F2R_0, Rplus_0_r.
+  now constructor 1. }
+set (p1 := (Zdigits beta m1 + e1)%Z).
+set (p2 := (Zdigits beta m2 + e2)%Z).
+set (e := Z.min (Z.max e1 e2) (fexp (Z.max p1 p2 - 1))).
+case Zle_bool_spec ; intros Hp ; cycle 1.
+{ rewrite <- F2R_plus.
+  destruct Operations.Fplus as [m' e'].
+  split.
+  now left.
+  now constructor 1. }
+set (z := (F2R _ + F2R _)%R).
+assert (Hz: (e <= cexp beta fexp z)%Z).
+{ apply Z.le_trans with (fexp (Z.max p1 p2 - 1)).
+  apply Z.le_min_r.
+  unfold cexp.
+  apply monotone_exp.
+  unfold z.
+  revert Hp.
+  unfold p1, p2.
+  rewrite <- 2!mag_F2R_Zdigits by easy.
+  clear -Hm1 Hm2.
+  destruct (Zle_or_lt (mag beta (F2R (Float beta m1 e1))) (mag beta (F2R (Float beta m2 e2)))) as [Hp'|Hp'].
+  - rewrite Z.max_r by easy.
+    rewrite Z.abs_neq by (clear -Hp'; lia).
+    rewrite Rplus_comm.
+    intros H.
+    apply mag_plus_ge.
+    now apply F2R_neq_0.
+    clear -H ; lia.
+  - rewrite Z.max_l, Z.abs_eq by (clear -Hp'; lia).
+    intros H.
+    apply mag_plus_ge.
+    now apply F2R_neq_0.
+    clear -H ; lia. }
+case Zlt_bool_spec ; intros He.
+- assert (He': (e <= e2)%Z) by (clear -He ; lia).
+  generalize (Fplus_core_correct m2 e2 m1 e1 e He').
+  rewrite Rplus_comm.
+  fold z.
+  destruct Fplus_core as [m' l].
+  refine (fun H => conj _ H).
+  now right.
+- assert (He': (e <= e1)%Z) by (clear -He ; lia).
+  generalize (Fplus_core_correct m1 e1 m2 e2 e He').
+  fold z.
+  destruct Fplus_core as [m' l].
+  refine (fun H => conj _ H).
+  now right.
+Qed.
+
+End Plus.
diff --git a/flocq/Calc/Round.v b/flocq/Calc/Round.v
index 704a1ab2..40da2f08 100644
--- a/flocq/Calc/Round.v
+++ b/flocq/Calc/Round.v
@@ -19,7 +19,8 @@ COPYING file for more details.
 
 (** * Helper function for computing the rounded value of a real number. *)
 
-From Coq Require Import Lia.
+From Coq Require Import ZArith Reals Lia.
+
 Require Import Core Digits Float_prop Bracket.
 
 Section Fcalc_round.
diff --git a/flocq/Calc/Sqrt.v b/flocq/Calc/Sqrt.v
index 4d267d21..3c885bba 100644
--- a/flocq/Calc/Sqrt.v
+++ b/flocq/Calc/Sqrt.v
@@ -19,8 +19,9 @@ COPYING file for more details.
 
 (** * Helper functions and theorems for computing the rounded square root of a floating-point number. *)
 
-From Coq Require Import Lia.
-Require Import Raux Defs Digits Generic_fmt Float_prop Bracket.
+From Coq Require Import ZArith Reals Lia.
+
+Require Import Zaux Raux Defs Digits Generic_fmt Float_prop Bracket.
 
 Set Implicit Arguments.
 Set Strongly Strict Implicit.
diff --git a/flocq/Core/Core.v b/flocq/Core/Core.v
index 78a140e1..6ec5728e 100644
--- a/flocq/Core/Core.v
+++ b/flocq/Core/Core.v
@@ -18,5 +18,4 @@ COPYING file for more details.
 *)
 
 (** To ease the import *)
-Require Export Raux Defs Float_prop Round_pred Generic_fmt Round_NE.
-Require Export FIX FLX FLT Ulp.
+Require Export Zaux Raux Defs Digits Float_prop Round_pred Generic_fmt Round_NE FIX FLX FLT Ulp.
diff --git a/flocq/Core/Defs.v b/flocq/Core/Defs.v
index 27342df9..4a199e01 100644
--- a/flocq/Core/Defs.v
+++ b/flocq/Core/Defs.v
@@ -18,7 +18,10 @@ COPYING file for more details.
 *)
 
 (** * Basic definitions: float and rounding property *)
-Require Import Raux.
+
+From Coq Require Import ZArith Reals.
+
+Require Import Raux Zaux.
 
 Section Def.
 
diff --git a/flocq/Core/Digits.v b/flocq/Core/Digits.v
index a18ff8d6..b491b436 100644
--- a/flocq/Core/Digits.v
+++ b/flocq/Core/Digits.v
@@ -18,12 +18,12 @@ COPYING file for more details.
 *)
 
 From Coq Require Import Lia ZArith Zquot.
+From Coq Require SpecFloat.
 
 Require Import Zaux.
-Require Import SpecFloatCompat.
 
-Notation digits2_pos := digits2_pos (only parsing).
-Notation Zdigits2 := Zdigits2 (only parsing).
+Notation digits2_pos := SpecFloat.digits2_pos (only parsing).
+Notation Zdigits2 := SpecFloat.Zdigits2 (only parsing).
 
 (** Number of bits (radix 2) of a positive integer.
 
@@ -594,12 +594,12 @@ destruct (Zle_or_lt k2' k) as [Hk''|Hk''].
 now apply Zdigit_slice_out.
 rewrite Zdigit_slice by now split.
 apply Zdigit_slice_out.
-zify ; lia.
-rewrite Zdigit_slice by (zify ; lia).
+lia.
+rewrite Zdigit_slice by lia.
 rewrite (Zdigit_slice n (k1 + k1')) by now split.
 rewrite Zdigit_slice.
 now rewrite Zplus_assoc.
-zify ; lia.
+lia.
 unfold Zslice.
 rewrite Z.min_r.
 now rewrite Zle_bool_false.
@@ -821,6 +821,18 @@ Proof.
 now intros [|n|n].
 Qed.
 
+Theorem Zdigits_opp :
+  forall n, Zdigits (Z.opp n) = Zdigits n.
+Proof.
+now intros [|n|n].
+Qed.
+
+Theorem Zdigits_cond_Zopp :
+  forall s n, Zdigits (cond_Zopp s n) = Zdigits n.
+Proof.
+now intros [|] [|n|n].
+Qed.
+
 Theorem Zdigits_gt_0 :
   forall n, n <> Z0 -> (0 < Zdigits n)%Z.
 Proof.
@@ -933,7 +945,7 @@ intros x y Zx Hxy.
 assert (Hx := Zdigits_correct x).
 assert (Hy := Zdigits_correct y).
 apply (Zpower_lt_Zpower beta).
-zify ; lia.
+lia.
 Qed.
 
 Theorem lt_Zdigits :
diff --git a/flocq/Core/FIX.v b/flocq/Core/FIX.v
index 779d94cb..e365951a 100644
--- a/flocq/Core/FIX.v
+++ b/flocq/Core/FIX.v
@@ -19,8 +19,9 @@ COPYING file for more details.
 
 (** * Fixed-point format *)
 
-From Coq Require Import Lia.
-Require Import Raux Defs Round_pred Generic_fmt Ulp Round_NE.
+From Coq Require Import ZArith Reals Lia.
+
+Require Import Zaux Raux Defs Round_pred Generic_fmt Ulp Round_NE.
 
 Section RND_FIX.
 
diff --git a/flocq/Core/FLT.v b/flocq/Core/FLT.v
index 7301328d..ee0b5d90 100644
--- a/flocq/Core/FLT.v
+++ b/flocq/Core/FLT.v
@@ -18,9 +18,10 @@ COPYING file for more details.
 *)
 
 (** * Floating-point format with gradual underflow *)
-Require Import Raux Defs Round_pred Generic_fmt Float_prop.
-Require Import FLX FIX Ulp Round_NE.
-Require Import Psatz.
+
+From Coq Require Import ZArith Reals Psatz.
+
+Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop FLX FIX Ulp Round_NE.
 
 Section RND_FLT.
 
@@ -336,7 +337,7 @@ rewrite <- bpow_plus.
 right; apply f_equal.
 replace (e - 1 + (1 - prec))%Z with (e - prec)%Z by ring.
 apply Z.max_l; simpl.
-assert (emin+prec-1 < e)%Z; try lia.
+cut (emin+prec-1 < e)%Z. lia.
 apply lt_bpow with beta.
 apply Rle_lt_trans with (1:=Hx).
 now apply He.
diff --git a/flocq/Core/FLX.v b/flocq/Core/FLX.v
index 78bffba5..c1abf639 100644
--- a/flocq/Core/FLX.v
+++ b/flocq/Core/FLX.v
@@ -18,9 +18,10 @@ COPYING file for more details.
 *)
 
 (** * Floating-point format without underflow *)
-Require Import Raux Defs Round_pred Generic_fmt Float_prop.
-Require Import FIX Ulp Round_NE.
-Require Import Psatz.
+
+From Coq Require Import ZArith Reals Psatz.
+
+Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop FIX Ulp Round_NE.
 
 Section RND_FLX.
 
diff --git a/flocq/Core/FTZ.v b/flocq/Core/FTZ.v
index d6bae6ea..e2c7ebad 100644
--- a/flocq/Core/FTZ.v
+++ b/flocq/Core/FTZ.v
@@ -19,9 +19,9 @@ COPYING file for more details.
 
 (** * Floating-point format with abrupt underflow *)
 
-From Coq Require Import Lia.
-Require Import Raux Defs Round_pred Generic_fmt.
-Require Import Float_prop Ulp FLX.
+From Coq Require Import ZArith Reals Lia.
+
+Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop Ulp FLX.
 
 Section RND_FTZ.
 
diff --git a/flocq/Core/Float_prop.v b/flocq/Core/Float_prop.v
index a1f48d04..36a2a315 100644
--- a/flocq/Core/Float_prop.v
+++ b/flocq/Core/Float_prop.v
@@ -19,8 +19,9 @@ COPYING file for more details.
 
 (** * Basic properties of floating-point formats: lemmas about mantissa, exponent... *)
 
-From Coq Require Import Lia.
-Require Import Raux Defs Digits.
+From Coq Require Import ZArith Reals Lia.
+
+Require Import Zaux Raux Defs Digits.
 
 Section Float_prop.
 
@@ -381,10 +382,9 @@ rewrite <-IZR_Zpower. 2: now apply Zle_left.
 now apply IZR_lt.
 elim Zlt_not_le with (1 := Hm).
 simpl.
-cut (e' - e < 0)%Z. 2: lia.
-clear.
-case (e' - e)%Z ; try easy.
-intros p _.
+assert (H: (e' - e < 0)%Z) by lia.
+clear -H.
+destruct (e' - e)%Z ; try easy.
 apply Zabs_pos.
 Qed.
 
diff --git a/flocq/Core/Generic_fmt.v b/flocq/Core/Generic_fmt.v
index af1bf3c1..b3b71b19 100644
--- a/flocq/Core/Generic_fmt.v
+++ b/flocq/Core/Generic_fmt.v
@@ -19,8 +19,9 @@ COPYING file for more details.
 
 (** * What is a real number belonging to a format, and many properties. *)
 
-From Coq Require Import Lia.
-Require Import Raux Defs Round_pred Float_prop.
+From Coq Require Import ZArith Reals Lia.
+
+Require Import Zaux Raux Defs Round_pred Float_prop.
 
 Section Generic.
 
@@ -427,7 +428,7 @@ rewrite Gx.
 replace (Ztrunc (scaled_mantissa x)) with Z0.
 apply F2R_0.
 cut (Z.abs (Ztrunc (scaled_mantissa x)) < 1)%Z.
-clear ; zify ; lia.
+clear ; lia.
 apply lt_IZR.
 rewrite abs_IZR.
 now rewrite <- scaled_mantissa_generic.
@@ -1804,7 +1805,7 @@ Theorem Znearest_imp :
 Proof.
 intros x n Hd.
 cut (Z.abs (Znearest x - n) < 1)%Z.
-clear ; zify ; lia.
+clear ; lia.
 apply lt_IZR.
 rewrite abs_IZR, minus_IZR.
 replace (IZR (Znearest x) - IZR n)%R with (- (x - IZR (Znearest x)) + (x - IZR n))%R by ring.
diff --git a/flocq/Core/Raux.v b/flocq/Core/Raux.v
index 221d84d6..a418bf19 100644
--- a/flocq/Core/Raux.v
+++ b/flocq/Core/Raux.v
@@ -18,9 +18,10 @@ COPYING file for more details.
 *)
 
 (** * Missing definitions/lemmas *)
-Require Import Psatz.
-Require Export Reals ZArith.
-Require Export Zaux.
+
+From Coq Require Import Psatz Reals ZArith.
+
+Require Import Zaux.
 
 Section Rmissing.
 
@@ -1317,9 +1318,9 @@ rewrite Ropp_inv_permute with (1 := Zy').
 rewrite <- 2!opp_IZR.
 rewrite <- Zmod_opp_opp.
 apply H.
-clear -Hy. lia.
+clear -Hy ; lia.
 apply H.
-clear -Zy Hy. lia.
+clear -Zy Hy ; lia.
 (* *)
 split.
 pattern (IZR (x / y)) at 1 ; rewrite <- Rplus_0_r.
@@ -1912,7 +1913,7 @@ apply bpow_le.
 now apply Zlt_le_weak.
 apply IZR_le.
 clear -Zm.
-zify ; lia.
+lia.
 Qed.
 
 Lemma mag_mult :
@@ -2040,6 +2041,33 @@ replace (ex - 1 - 1)%Z with (ex - 2)%Z by ring.
 now apply Rabs_ge; right.
 Qed.
 
+Theorem mag_plus_ge :
+  forall x y,
+  (x <> 0)%R ->
+  (mag y <= mag x - 2)%Z ->
+  (mag x - 1 <= mag (x + y))%Z.
+Proof.
+intros x y Zx.
+destruct (Req_dec y 0) as [Zy|Zy].
+{ intros _.
+  rewrite Zy, Rplus_0_r.
+  lia. }
+rewrite <- (mag_abs x), <- (mag_abs y).
+intros Hm.
+assert (H: Rabs x <> Rabs y).
+{ intros H.
+  apply Zlt_not_le with (2 := Hm).
+  rewrite H.
+  lia. }
+apply mag_minus_lb in Hm ; try now apply Rabs_pos_lt.
+apply Z.le_trans with (1 := Hm).
+apply mag_le_abs.
+now apply Rminus_eq_contra.
+rewrite <- (Ropp_involutive y).
+rewrite Rabs_Ropp.
+apply Rabs_triang_inv2.
+Qed.
+
 Lemma mag_div :
   forall x y : R,
   x <> 0%R -> y <> 0%R ->
@@ -2335,8 +2363,7 @@ refine (Rle_not_lt _ _ (lub (/ (INR (S N) + 1))%R _) _).
   intros Hy.
   refine (H _ _ Py).
   apply INR_lt in Hy.
-  clear -Hy HyN.
-  lia.
+  clear -Hy HyN ; lia.
   now apply Rlt_le, Rinv_0_lt_compat.
 rewrite S_INR, HN.
 ring_simplify (IZR (up (/ l)) - 1 + 1)%R.
diff --git a/flocq/Core/Round_NE.v b/flocq/Core/Round_NE.v
index b7387a62..6a6fb0fb 100644
--- a/flocq/Core/Round_NE.v
+++ b/flocq/Core/Round_NE.v
@@ -19,8 +19,9 @@ COPYING file for more details.
 
 (** * Rounding to nearest, ties to even: existence, unicity... *)
 
-From Coq Require Import Lia.
-Require Import Raux Defs Round_pred Generic_fmt Float_prop Ulp.
+From Coq Require Import ZArith Reals Lia.
+
+Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop Ulp.
 
 Notation ZnearestE := (Znearest (fun x => negb (Z.even x))).
 
diff --git a/flocq/Core/Round_pred.v b/flocq/Core/Round_pred.v
index b7b6778f..c811aec8 100644
--- a/flocq/Core/Round_pred.v
+++ b/flocq/Core/Round_pred.v
@@ -18,6 +18,9 @@ COPYING file for more details.
 *)
 
 (** * Roundings: properties and/or functions *)
+
+From Coq Require Import Reals.
+
 Require Import Raux Defs.
 
 Section RND_prop.
diff --git a/flocq/Core/Ulp.v b/flocq/Core/Ulp.v
index c42b3e65..2459e35b 100644
--- a/flocq/Core/Ulp.v
+++ b/flocq/Core/Ulp.v
@@ -18,8 +18,10 @@ COPYING file for more details.
 *)
 
 (** * Unit in the Last Place: our definition using fexp and its properties, successor and predecessor *)
-Require Import Reals Psatz.
-Require Import Raux Defs Round_pred Generic_fmt Float_prop.
+
+From Coq Require Import ZArith Reals Psatz.
+
+Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop.
 
 Section Fcore_ulp.
 
@@ -1100,7 +1102,7 @@ exfalso ; lra.
 intros n Hn H.
 assert (fexp (mag beta eps) = fexp n).
 apply valid_exp; try assumption.
-assert(mag beta eps-1 < fexp n)%Z;[idtac|lia].
+cut (mag beta eps-1 < fexp n)%Z. lia.
 apply lt_bpow with beta.
 apply Rle_lt_trans with (2:=proj2 H).
 destruct (mag beta eps) as (e,He).
@@ -1165,7 +1167,7 @@ lra.
 intros n Hn H.
 assert (fexp (mag beta eps) = fexp n).
 apply valid_exp; try assumption.
-assert(mag beta eps-1 < fexp n)%Z;[idtac|lia].
+cut (mag beta eps-1 < fexp n)%Z. lia.
 apply lt_bpow with beta.
 apply Rle_lt_trans with (2:=H).
 destruct (mag beta eps) as (e,He).
@@ -1919,7 +1921,7 @@ rewrite ulp_neq_0; trivial.
 apply f_equal.
 unfold cexp.
 apply valid_exp; trivial.
-assert (mag beta x -1 < fexp n)%Z;[idtac|lia].
+cut (mag beta x -1 < fexp n)%Z. lia.
 apply lt_bpow with beta.
 destruct (mag beta x) as (e,He).
 simpl.
diff --git a/flocq/Core/Zaux.v b/flocq/Core/Zaux.v
index 5ca3971f..b14c4e93 100644
--- a/flocq/Core/Zaux.v
+++ b/flocq/Core/Zaux.v
@@ -18,11 +18,10 @@ COPYING file for more details.
 *)
 
 From Coq Require Import ZArith Lia Zquot.
+From Coq Require SpecFloat.
 
-Require Import SpecFloatCompat.
-
-Notation cond_Zopp := cond_Zopp (only parsing).
-Notation iter_pos := iter_pos (only parsing).
+Notation cond_Zopp := SpecFloat.cond_Zopp (only parsing).
+Notation iter_pos := SpecFloat.iter_pos (only parsing).
 
 Section Zmissing.
 
@@ -535,6 +534,39 @@ now apply He.
 now intros _ _.
 Qed.
 
+Theorem Zeq_bool_diag :
+  forall x, Zeq_bool x x = true.
+Proof.
+intros x.
+now apply Zeq_bool_true.
+Qed.
+
+Theorem Zeq_bool_opp :
+  forall x y,
+  Zeq_bool (Z.opp x) y = Zeq_bool x (Z.opp y).
+Proof.
+intros x y.
+case Zeq_bool_spec.
+- intros <-.
+  apply eq_sym, Zeq_bool_true.
+  apply eq_sym, Z.opp_involutive.
+- intros H.
+  case Zeq_bool_spec.
+  2: easy.
+  intros ->.
+  contradict H.
+  apply Z.opp_involutive.
+Qed.
+
+Theorem Zeq_bool_opp' :
+  forall x y,
+  Zeq_bool (Z.opp x) (Z.opp y) = Zeq_bool x y.
+Proof.
+intros x y.
+rewrite Zeq_bool_opp.
+apply f_equal, Z.opp_involutive.
+Qed.
+
 End Zeq_bool.
 
 Section Zle_bool.
@@ -575,6 +607,32 @@ now apply Z.le_lt_trans with y.
 apply refl_equal.
 Qed.
 
+Theorem Zle_bool_opp_l :
+  forall x y,
+  Zle_bool (Z.opp x) y = Zle_bool (Z.opp y) x.
+Proof.
+intros x y.
+case Zle_bool_spec ; intros Hxy ;
+  case Zle_bool_spec ; intros Hyx ; try easy ; lia.
+Qed.
+
+Theorem Zle_bool_opp :
+  forall x y,
+  Zle_bool (Z.opp x) (Z.opp y) = Zle_bool y x.
+Proof.
+intros x y.
+now rewrite Zle_bool_opp_l, Z.opp_involutive.
+Qed.
+
+Theorem Zle_bool_opp_r :
+  forall x y,
+  Zle_bool x (Z.opp y) = Zle_bool y (Z.opp x).
+Proof.
+intros x y.
+rewrite <- (Z.opp_involutive x) at 1.
+apply Zle_bool_opp.
+Qed.
+
 End Zle_bool.
 
 Section Zlt_bool.
@@ -635,6 +693,33 @@ now rewrite Zle_bool_false.
 now rewrite Zle_bool_true.
 Qed.
 
+Theorem Zlt_bool_opp_l :
+  forall x y,
+  Zlt_bool (Z.opp x) y = Zlt_bool (Z.opp y) x.
+Proof.
+intros x y.
+rewrite <- 2! negb_Zle_bool.
+apply f_equal, Zle_bool_opp_r.
+Qed.
+
+Theorem Zlt_bool_opp_r :
+  forall x y,
+  Zlt_bool x (Z.opp y) = Zlt_bool y (Z.opp x).
+Proof.
+intros x y.
+rewrite <- 2! negb_Zle_bool.
+apply f_equal, Zle_bool_opp_l.
+Qed.
+
+Theorem Zlt_bool_opp :
+  forall x y,
+  Zlt_bool (Z.opp x) (Z.opp y) = Zlt_bool y x.
+Proof.
+intros x y.
+rewrite <- 2! negb_Zle_bool.
+apply f_equal, Zle_bool_opp.
+Qed.
+
 End Zlt_bool.
 
 Section Zcompare.
@@ -717,6 +802,15 @@ now apply Zlt_le_weak.
 now apply Z.abs_eq.
 Qed.
 
+Theorem Zeq_bool_cond_Zopp :
+  forall s m n,
+  Zeq_bool (cond_Zopp s m) n = Zeq_bool m (cond_Zopp s n).
+Proof.
+intros [|] m n ; simpl.
+apply Zeq_bool_opp.
+easy.
+Qed.
+
 End cond_Zopp.
 
 Section fast_pow_pos.
diff --git a/flocq/IEEE754/Binary.v b/flocq/IEEE754/Binary.v
index 4516f0a0..335d9b38 100644
--- a/flocq/IEEE754/Binary.v
+++ b/flocq/IEEE754/Binary.v
@@ -18,8 +18,17 @@ COPYING file for more details.
 *)
 
 (** * IEEE-754 arithmetic *)
-Require Import Core Digits Round Bracket Operations Div Sqrt Relative.
-Require Import Psatz.
+
+From Coq Require Import ZArith Reals Psatz SpecFloat.
+
+Require Import Core Round Bracket Operations Div Sqrt Relative BinarySingleNaN.
+
+Module BSN := BinarySingleNaN.
+
+Arguments BSN.B754_zero {prec emax}.
+Arguments BSN.B754_infinity {prec emax}.
+Arguments BSN.B754_nan {prec emax}.
+Arguments BSN.B754_finite {prec emax}.
 
 Section AnyRadix.
 
@@ -29,12 +38,106 @@ Inductive full_float :=
   | F754_nan (s : bool) (m : positive)
   | F754_finite (s : bool) (m : positive) (e : Z).
 
+Definition FF2SF x :=
+  match x with
+  | F754_zero s => S754_zero s
+  | F754_infinity s => S754_infinity s
+  | F754_nan _ _ => S754_nan
+  | F754_finite s m e => S754_finite s m e
+  end.
+
 Definition FF2R beta x :=
   match x with
   | F754_finite s m e => F2R (Float beta (cond_Zopp s (Zpos m)) e)
   | _ => 0%R
   end.
 
+Lemma SF2R_FF2SF :
+  forall beta x,
+  SF2R beta (FF2SF x) = FF2R beta x.
+Proof.
+now intros beta [s|s|s m|s m e].
+Qed.
+
+Definition SF2FF x :=
+  match x with
+  | S754_zero s => F754_zero s
+  | S754_infinity s => F754_infinity s
+  | S754_nan => F754_nan false xH
+  | S754_finite s m e => F754_finite s m e
+  end.
+
+Lemma FF2SF_SF2FF :
+  forall x,
+  FF2SF (SF2FF x) = x.
+Proof.
+now intros [s|s| |s m e].
+Qed.
+
+Lemma FF2R_SF2FF :
+  forall beta x,
+  FF2R beta (SF2FF x) = SF2R beta x.
+Proof.
+now intros beta [s|s| |s m e].
+Qed.
+
+Definition is_nan_FF f :=
+  match f with
+  | F754_nan _ _ => true
+  | _ => false
+  end.
+
+Lemma is_nan_SF2FF :
+  forall x,
+  is_nan_FF (SF2FF x) = is_nan_SF x.
+Proof.
+now intros [s|s| |s m e].
+Qed.
+
+Lemma is_nan_FF2SF :
+  forall x,
+  is_nan_SF (FF2SF x) = is_nan_FF x.
+Proof.
+now intros [s|s|s m|s m e].
+Qed.
+
+Lemma SF2FF_FF2SF :
+  forall x,
+  is_nan_FF x = false ->
+  SF2FF (FF2SF x) = x.
+Proof.
+now intros [s|s|s m|s m e] H.
+Qed.
+
+Definition sign_FF x :=
+  match x with
+  | F754_nan s _ => s
+  | F754_zero s => s
+  | F754_infinity s => s
+  | F754_finite s _ _ => s
+  end.
+
+Definition is_finite_FF f :=
+  match f with
+  | F754_finite _ _ _ => true
+  | F754_zero _ => true
+  | _ => false
+  end.
+
+Lemma is_finite_SF2FF :
+  forall x,
+  is_finite_FF (SF2FF x) = is_finite_SF x.
+Proof.
+now intros [| | |].
+Qed.
+
+Lemma sign_SF2FF :
+  forall x,
+  sign_FF (SF2FF x) = sign_SF x.
+Proof.
+now intros [| | |].
+Qed.
+
 End AnyRadix.
 
 Section Binary.
@@ -46,22 +149,22 @@ Arguments exist {A} {P}.
     For instance, binary32 is defined by [prec = 24] and [emax = 128]. *)
 Variable prec emax : Z.
 Context (prec_gt_0_ : Prec_gt_0 prec).
-Hypothesis Hmax : (prec < emax)%Z.
+Context (prec_lt_emax_ : Prec_lt_emax prec emax).
 
-Let emin := (3 - emax - prec)%Z.
-Let fexp := FLT_exp emin prec.
+Notation emin := (emin prec emax) (only parsing).
+Notation fexp := (fexp prec emax) (only parsing).
 Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec.
 Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec.
 
-Definition canonical_mantissa m e :=
-  Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e.
+Notation canonical_mantissa := (canonical_mantissa prec emax).
 
-Definition bounded m e :=
-  andb (canonical_mantissa m e) (Zle_bool e (emax - prec)).
+Notation bounded := (SpecFloat.bounded prec emax).
 
 Definition nan_pl pl :=
   Zlt_bool (Zpos (digits2_pos pl)) prec.
 
+Notation valid_binary_SF := (valid_binary prec emax).
+
 Definition valid_binary x :=
   match x with
   | F754_finite _ m e => bounded m e
@@ -69,6 +172,14 @@ Definition valid_binary x :=
   | _ => true
   end.
 
+Lemma valid_binary_SF2FF :
+  forall x,
+  is_nan_SF x = false ->
+  valid_binary (SF2FF x) = valid_binary_SF x.
+Proof.
+now intros [sx|sx| |sx mx ex] H.
+Qed.
+
 (** Basic type used for representing binary FP numbers.
     Note that there is exactly one such object per FP datum. *)
 
@@ -80,6 +191,14 @@ Inductive binary_float :=
   | B754_finite (s : bool) (m : positive) (e : Z) :
     bounded m e = true -> binary_float.
 
+Definition B2BSN (x : binary_float) : BSN.binary_float prec emax :=
+  match x with
+  | B754_zero s => BSN.B754_zero s
+  | B754_infinity s => BSN.B754_infinity s
+  | B754_nan _ _ _ => BSN.B754_nan
+  | B754_finite s m e H => BSN.B754_finite s m e H
+  end.
+
 Definition FF2B x :=
   match x as x return valid_binary x = true -> binary_float with
   | F754_finite s m e => B754_finite s m e
@@ -102,6 +221,42 @@ Definition B2R f :=
   | _ => 0%R
   end.
 
+Definition B2SF (x : binary_float) :=
+  match x with
+  | B754_finite s m e _ => S754_finite s m e
+  | B754_infinity s => S754_infinity s
+  | B754_zero s => S754_zero s
+  | B754_nan _ _ _ => S754_nan
+  end.
+
+Lemma B2SF_B2BSN :
+  forall x,
+  BSN.B2SF (B2BSN x) = B2SF x.
+Proof.
+now intros [sx|sx|sx px Px|sx mx ex Bx].
+Qed.
+
+Lemma B2SF_FF2B :
+  forall x Bx,
+  B2SF (FF2B x Bx) = FF2SF x.
+Proof.
+now intros [sx|sx|sx px|sx mx ex] Bx.
+Qed.
+
+Lemma B2R_B2BSN :
+  forall x, BSN.B2R (B2BSN x) = B2R x.
+Proof.
+intros x.
+now destruct x.
+Qed.
+
+Lemma FF2SF_B2FF :
+  forall x,
+  FF2SF (B2FF x) = B2SF x.
+Proof.
+now intros [sx|sx|sx plx|sx mx ex].
+Qed.
+
 Theorem FF2R_B2FF :
   forall x,
   FF2R radix2 (B2FF x) = B2R x.
@@ -239,6 +394,13 @@ Definition is_finite_strict f :=
   | _ => false
   end.
 
+Lemma is_finite_strict_B2BSN :
+  forall x, BSN.is_finite_strict (B2BSN x) = is_finite_strict x.
+Proof.
+intros x.
+now destruct x.
+Qed.
+
 Theorem B2R_inj:
   forall x y : binary_float,
   is_finite_strict x = true ->
@@ -287,14 +449,6 @@ Definition Bsign x :=
   | B754_finite s _ _ _ => s
   end.
 
-Definition sign_FF x :=
-  match x with
-  | F754_nan s _ => s
-  | F754_zero s => s
-  | F754_infinity s => s
-  | F754_finite s _ _ => s
-  end.
-
 Theorem Bsign_FF2B :
   forall x H,
   Bsign (FF2B x H) = sign_FF x.
@@ -309,12 +463,12 @@ Definition is_finite f :=
   | _ => false
   end.
 
-Definition is_finite_FF f :=
-  match f with
-  | F754_finite _ _ _ => true
-  | F754_zero _ => true
-  | _ => false
-  end.
+Lemma is_finite_B2BSN :
+  forall x, BSN.is_finite (B2BSN x) = is_finite x.
+Proof.
+intros x.
+now destruct x.
+Qed.
 
 Theorem is_finite_FF2B :
   forall x Hx,
@@ -323,11 +477,11 @@ Proof.
 now intros [| | |].
 Qed.
 
-Theorem is_finite_FF_B2FF :
+Theorem is_finite_B2FF :
   forall x,
   is_finite_FF (B2FF x) = is_finite x.
 Proof.
-now intros [| |? []|].
+now intros [| | |].
 Qed.
 
 Theorem B2R_Bsign_inj:
@@ -356,11 +510,12 @@ Definition is_nan f :=
   | _ => false
   end.
 
-Definition is_nan_FF f :=
-  match f with
-  | F754_nan _ _ => true
-  | _ => false
-  end.
+Lemma is_nan_B2BSN :
+  forall x,
+  BSN.is_nan (B2BSN x) =  is_nan x.
+Proof.
+now intros [s|s|s p H|s m e H].
+Qed.
 
 Theorem is_nan_FF2B :
   forall x Hx,
@@ -369,7 +524,7 @@ Proof.
 now intros [| | |].
 Qed.
 
-Theorem is_nan_FF_B2FF :
+Theorem is_nan_B2FF :
   forall x,
   is_nan_FF (B2FF x) = is_nan x.
 Proof.
@@ -383,12 +538,12 @@ Definition build_nan (x : { x | is_nan x = true }) : binary_float.
 Proof.
 apply (B754_nan (Bsign (proj1_sig x)) (get_nan_pl (proj1_sig x))).
 destruct x as [x H].
+assert (K: false = true -> nan_pl 1 = true) by (intros K ; now elim Bool.diff_false_true).
 simpl.
 revert H.
-assert (H: false = true -> nan_pl 1 = true) by now destruct (nan_pl 1).
-destruct x; try apply H.
+destruct x as [sx|sx|sx px Px|sx mx ex Bx]; try apply K.
 intros _.
-apply e.
+apply Px.
 Defined.
 
 Theorem build_nan_correct :
@@ -417,6 +572,103 @@ Proof.
 easy.
 Qed.
 
+Definition BSN2B (nan : {x : binary_float | is_nan x = true }) (x : BSN.binary_float prec emax) : binary_float :=
+  match x with
+  | BSN.B754_nan => build_nan nan
+  | BSN.B754_zero s => B754_zero s
+  | BSN.B754_infinity s => B754_infinity s
+  | BSN.B754_finite s m e H => B754_finite s m e H
+  end.
+
+Lemma B2BSN_BSN2B :
+  forall nan x,
+  B2BSN (BSN2B nan x) = x.
+Proof.
+now intros nan [s|s| |s m e H].
+Qed.
+
+Lemma B2R_BSN2B :
+  forall nan x, B2R (BSN2B nan x) = BSN.B2R x.
+Proof.
+now intros nan [s|s| |s m e H].
+Qed.
+
+Lemma is_finite_BSN2B :
+  forall nan x, is_finite (BSN2B nan x) = BSN.is_finite x.
+Proof.
+now intros nan [s|s| |s m e H].
+Qed.
+
+Lemma is_nan_BSN2B :
+  forall nan x, is_nan (BSN2B nan x) = BSN.is_nan x.
+Proof.
+now intros nan [s|s| |s m e H].
+Qed.
+
+Lemma Bsign_B2BSN :
+  forall x, is_nan x = false -> BSN.Bsign (B2BSN x) = Bsign x.
+Proof.
+now intros [s|s| |s m e H].
+Qed.
+
+Lemma Bsign_BSN2B :
+  forall nan x, BSN.is_nan x = false ->
+  Bsign (BSN2B nan x) = BSN.Bsign x.
+Proof.
+now intros nan [s|s| |s m e H].
+Qed.
+
+Definition BSN2B' (x : BSN.binary_float prec emax) : BSN.is_nan x = false -> binary_float.
+Proof.
+destruct x as [sx|sx| |sx mx ex Bx] ; intros H.
+exact (B754_zero sx).
+exact (B754_infinity sx).
+now elim Bool.diff_true_false.
+exact (B754_finite sx mx ex Bx).
+Defined.
+
+Lemma B2BSN_BSN2B' :
+  forall x Nx,
+  B2BSN (BSN2B' x Nx) = x.
+Proof.
+now intros [s|s| |s m e H] Nx.
+Qed.
+
+Lemma B2R_BSN2B' :
+  forall x Nx,
+  B2R (BSN2B' x Nx) = BSN.B2R x.
+Proof.
+now intros [sx|sx| |sx mx ex Bx] Nx.
+Qed.
+
+Lemma B2FF_BSN2B' :
+  forall x Nx,
+  B2FF (BSN2B' x Nx) = SF2FF (BSN.B2SF x).
+Proof.
+now intros [sx|sx| |sx mx ex Bx] Nx.
+Qed.
+
+Lemma Bsign_BSN2B' :
+  forall x Nx,
+  Bsign (BSN2B' x Nx) = BSN.Bsign x.
+Proof.
+now intros [sx|sx| |sx mx ex Bx] Nx.
+Qed.
+
+Lemma is_finite_BSN2B' :
+  forall x Nx,
+  is_finite (BSN2B' x Nx) = BSN.is_finite x.
+Proof.
+now intros [sx|sx| |sx mx ex Bx] Nx.
+Qed.
+
+Lemma is_nan_BSN2B' :
+  forall x Nx,
+  is_nan (BSN2B' x Nx) = false.
+Proof.
+now intros [sx|sx| |sx mx ex Bx] Nx.
+Qed.
+
 Definition erase (x : binary_float) : binary_float.
 Proof.
 destruct x as [s|s|s pl H|s m e H].
@@ -533,85 +785,19 @@ Qed.
 [Some c] means ordered as per [c]; [None] means unordered. *)
 
 Definition Bcompare (f1 f2 : binary_float) : option comparison :=
-  match f1, f2 with
-  | B754_nan _ _ _,_ | _,B754_nan _ _ _ => None
-  | B754_infinity s1, B754_infinity s2 =>
-    Some match s1, s2 with
-    | true, true => Eq
-    | false, false => Eq
-    | true, false => Lt
-    | false, true => Gt
-    end
-  | B754_infinity s, _ => Some (if s then Lt else Gt)
-  | _, B754_infinity s => Some (if s then Gt else Lt)
-  | B754_finite s _ _ _, B754_zero _ => Some (if s then Lt else Gt)
-  | B754_zero _, B754_finite s _ _ _ => Some (if s then Gt else Lt)
-  | B754_zero _, B754_zero _ => Some Eq
-  | B754_finite s1 m1 e1 _, B754_finite s2 m2 e2 _ =>
-    Some match s1, s2 with
-    | true, false => Lt
-    | false, true => Gt
-    | false, false =>
-      match Z.compare e1 e2 with
-      | Lt => Lt
-      | Gt => Gt
-      | Eq => Pcompare m1 m2 Eq
-      end
-    | true, true =>
-      match Z.compare e1 e2 with
-      | Lt => Gt
-      | Gt => Lt
-      | Eq => CompOpp (Pcompare m1 m2 Eq)
-      end
-    end
-  end.
+  BSN.Bcompare (B2BSN f1) (B2BSN f2).
 
 Theorem Bcompare_correct :
   forall f1 f2,
   is_finite f1 = true -> is_finite f2 = true ->
   Bcompare f1 f2 = Some (Rcompare (B2R f1) (B2R f2)).
 Proof.
-  Ltac apply_Rcompare :=
-    match goal with
-      | [ |- Lt = Rcompare _ _ ] => symmetry; apply Rcompare_Lt
-      | [ |- Eq = Rcompare _ _ ] => symmetry; apply Rcompare_Eq
-      | [ |- Gt = Rcompare _ _ ] => symmetry; apply Rcompare_Gt
-    end.
-  unfold Bcompare; intros f1 f2 H1 H2.
-  destruct f1, f2; try easy; apply f_equal; clear H1 H2.
-  now rewrite Rcompare_Eq.
-  destruct s0 ; apply_Rcompare.
-  now apply F2R_lt_0.
-  now apply F2R_gt_0.
-  destruct s ; apply_Rcompare.
-  now apply F2R_lt_0.
-  now apply F2R_gt_0.
-  simpl.
-  apply andb_prop in e0; destruct e0; apply (canonical_canonical_mantissa false) in H.
-  apply andb_prop in e2; destruct e2; apply (canonical_canonical_mantissa false) in H1.
-  pose proof (Zcompare_spec e e1); unfold canonical, Fexp in H1, H.
-  assert (forall m1 m2 e1 e2,
-    let x := (IZR (Zpos m1) * bpow radix2 e1)%R in
-    let y := (IZR (Zpos m2) * bpow radix2 e2)%R in
-    (cexp radix2 fexp x < cexp radix2 fexp y)%Z -> (x < y)%R).
-  {
-  intros; apply Rnot_le_lt; intro; apply (mag_le radix2) in H5.
-  apply Zlt_not_le with (1 := H4).
-  now apply fexp_monotone.
-  now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)).
-  }
-  assert (forall m1 m2 e1 e2, (IZR (- Zpos m1) * bpow radix2 e1 < IZR (Zpos m2) * bpow radix2 e2)%R).
-  {
-  intros; apply (Rlt_trans _ 0%R).
-  now apply (F2R_lt_0 _ (Float radix2 (Zneg m1) e0)).
-  now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)).
-  }
-  unfold F2R, Fnum, Fexp.
-  destruct s, s0; try (now apply_Rcompare; apply H5); inversion H3;
-    try (apply_Rcompare; apply H4; rewrite H, H1 in H7; assumption);
-    try (apply_Rcompare; do 2 rewrite opp_IZR, Ropp_mult_distr_l_reverse;
-      apply Ropp_lt_contravar; apply H4; rewrite H, H1 in H7; assumption);
-    rewrite H7, Rcompare_mult_r, Rcompare_IZR by (apply bpow_gt_0); reflexivity.
+  intros f1 f2 H1 H2.
+  unfold Bcompare.
+  rewrite BSN.Bcompare_correct.
+  now rewrite 2!B2R_B2BSN.
+  now rewrite is_finite_B2BSN.
+  now rewrite is_finite_B2BSN.
 Qed.
 
 Theorem Bcompare_swap :
@@ -619,12 +805,7 @@ Theorem Bcompare_swap :
   Bcompare y x = match Bcompare x y with Some c => Some (CompOpp c) | None => None end.
 Proof.
   intros.
-  destruct x as [ ? | [] | ? ? | [] mx ex Bx ];
-  destruct y as [ ? | [] | ? ? | [] my ey By ]; simpl; try easy.
-- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy.
-  now rewrite (Pcompare_antisym mx my).
-- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy.
-  now rewrite Pcompare_antisym.
+  apply BSN.Bcompare_swap.
 Qed.
 
 Theorem bounded_le_emax_minus_prec :
@@ -633,44 +814,7 @@ Theorem bounded_le_emax_minus_prec :
   (F2R (Float radix2 (Zpos mx) ex)
    <= bpow radix2 emax - bpow radix2 (emax - prec))%R.
 Proof.
-intros mx ex Hx.
-destruct (andb_prop _ _ Hx) as (H1,H2).
-generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1.
-generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2.
-generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex).
-destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex).
-unfold mag_val.
-intros H.
-elim Ex; [|now apply Rgt_not_eq, F2R_gt_0]; intros _.
-rewrite <-F2R_Zabs; simpl; clear Ex; intros Ex.
-generalize (Rmult_lt_compat_r (bpow radix2 (-ex)) _ _ (bpow_gt_0 _ _) Ex).
-unfold F2R; simpl; rewrite Rmult_assoc, <-!bpow_plus.
-rewrite H; [|intro H'; discriminate H'].
-rewrite <-Z.add_assoc, Z.add_opp_diag_r, Z.add_0_r, Rmult_1_r.
-rewrite <-(IZR_Zpower _ _ (Zdigits_ge_0 _ _)); clear Ex; intro Ex.
-generalize (Zlt_le_succ _ _ (lt_IZR _ _ Ex)); clear Ex; intro Ex.
-generalize (IZR_le _ _ Ex).
-rewrite succ_IZR; clear Ex; intro Ex.
-generalize (Rplus_le_compat_r (-1) _ _ Ex); clear Ex; intro Ex.
-ring_simplify in Ex; revert Ex.
-rewrite (IZR_Zpower _ _ (Zdigits_ge_0 _ _)); intro Ex.
-generalize (Rmult_le_compat_r (bpow radix2 ex) _ _ (bpow_ge_0 _ _) Ex).
-intro H'; apply (Rle_trans _ _ _ H').
-rewrite Rmult_minus_distr_r, Rmult_1_l, <-bpow_plus.
-revert H1; unfold fexp, FLT_exp; intro H1.
-generalize (Z.le_max_l (Z.pos (digits2_pos mx) + ex - prec) emin).
-rewrite H1; intro H1'.
-generalize (proj1 (Z.le_sub_le_add_r _ _ _) H1').
-rewrite Zpos_digits2_pos; clear H1'; intro H1'.
-apply (Rle_trans _ _ _ (Rplus_le_compat_r _ _ _ (bpow_le _ _ _ H1'))).
-replace emax with (emax - prec - ex + (ex + prec))%Z at 1 by ring.
-replace (emax - prec)%Z with (emax - prec - ex + ex)%Z at 2 by ring.
-do 2 rewrite (bpow_plus _ (emax - prec - ex)).
-rewrite <-Rmult_minus_distr_l.
-rewrite <-(Rmult_1_l (_ + _)).
-apply Rmult_le_compat_r.
-{ apply Rle_0_minus, bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. }
-change 1%R with (bpow radix2 0); apply bpow_le; lia.
+now apply BSN.bounded_le_emax_minus_prec.
 Qed.
 
 Theorem bounded_lt_emax :
@@ -678,26 +822,7 @@ Theorem bounded_lt_emax :
   bounded mx ex = true ->
   (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R.
 Proof.
-intros mx ex Hx.
-destruct (andb_prop _ _ Hx) as (H1,H2).
-generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1.
-generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2.
-generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex).
-destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex).
-unfold mag_val.
-intros H.
-apply Rlt_le_trans with (bpow radix2 e').
-change (Zpos mx) with (Z.abs (Zpos mx)).
-rewrite F2R_Zabs.
-apply Ex.
-apply Rgt_not_eq.
-now apply F2R_gt_0.
-apply bpow_le.
-rewrite H. 2: discriminate.
-revert H1. clear -H2.
-rewrite Zpos_digits2_pos.
-unfold fexp, FLT_exp.
-intros ; zify ; lia.
+now apply bounded_lt_emax.
 Qed.
 
 Theorem bounded_ge_emin :
@@ -705,47 +830,25 @@ Theorem bounded_ge_emin :
   bounded mx ex = true ->
   (bpow radix2 emin <= F2R (Float radix2 (Zpos mx) ex))%R.
 Proof.
-intros mx ex Hx.
-destruct (andb_prop _ _ Hx) as [H1 _].
-apply Zeq_bool_eq in H1.
-generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex).
-destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as [e' Ex].
-unfold mag_val.
-intros H.
-assert (H0 : Zpos mx <> 0%Z) by easy.
-rewrite Rabs_pos_eq in Ex by now apply F2R_ge_0.
-refine (Rle_trans _ _ _ _ (proj1 (Ex _))).
-2: now apply F2R_neq_0.
-apply bpow_le.
-rewrite H by easy.
-revert H1.
-rewrite Zpos_digits2_pos.
-generalize (Zdigits radix2 (Zpos mx)) (Zdigits_gt_0 radix2 (Zpos mx) H0).
-unfold fexp, FLT_exp.
-clear -prec_gt_0_.
-unfold Prec_gt_0 in prec_gt_0_.
-clearbody emin.
-intros ; zify ; lia.
+now apply bounded_ge_emin.
 Qed.
 
 Theorem abs_B2R_le_emax_minus_prec :
   forall x,
   (Rabs (B2R x) <= bpow radix2 emax - bpow radix2 (emax - prec))%R.
 Proof.
-intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ;
-  [rewrite Rabs_R0 ; apply Rle_0_minus, bpow_le ;
-   revert prec_gt_0_; unfold Prec_gt_0; lia..|].
-rewrite <- F2R_Zabs, abs_cond_Zopp.
-now apply bounded_le_emax_minus_prec.
+intros x.
+rewrite <- B2R_B2BSN.
+now apply abs_B2R_le_emax_minus_prec.
 Qed.
 
 Theorem abs_B2R_lt_emax :
   forall x,
   (Rabs (B2R x) < bpow radix2 emax)%R.
 Proof.
-intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; try ( rewrite Rabs_R0 ; apply bpow_gt_0 ).
-rewrite <- F2R_Zabs, abs_cond_Zopp.
-now apply bounded_lt_emax.
+intros x.
+rewrite <- B2R_B2BSN.
+now apply abs_B2R_lt_emax.
 Qed.
 
 Theorem abs_B2R_ge_emin :
@@ -753,14 +856,10 @@ Theorem abs_B2R_ge_emin :
   is_finite_strict x = true ->
   (bpow radix2 emin <= Rabs (B2R x))%R.
 Proof.
-intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; try discriminate.
-intros; case sx; simpl.
-- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl.
-  rewrite Rabs_pos_eq; [|apply bpow_ge_0].
-  now apply bounded_ge_emin.
-- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl.
-  rewrite Rabs_pos_eq; [|apply bpow_ge_0].
-  now apply bounded_ge_emin.
+intros x.
+rewrite <- is_finite_strict_B2BSN.
+rewrite <- B2R_B2BSN.
+now apply abs_B2R_ge_emin.
 Qed.
 
 Theorem bounded_canonical_lt_emax :
@@ -769,160 +868,13 @@ Theorem bounded_canonical_lt_emax :
   (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R ->
   bounded mx ex = true.
 Proof.
-intros mx ex Cx Bx.
-apply andb_true_intro.
-split.
-unfold canonical_mantissa.
-unfold canonical, Fexp in Cx.
-rewrite Cx at 2.
-rewrite Zpos_digits2_pos.
-unfold cexp.
-rewrite mag_F2R_Zdigits. 2: discriminate.
-now apply -> Zeq_is_eq_bool.
-apply Zle_bool_true.
-unfold canonical, Fexp in Cx.
-rewrite Cx.
-unfold cexp, fexp, FLT_exp.
-destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). simpl.
-apply Z.max_lub.
-cut (e' - 1 < emax)%Z. clear ; lia.
-apply lt_bpow with radix2.
-apply Rle_lt_trans with (2 := Bx).
-change (Zpos mx) with (Z.abs (Zpos mx)).
-rewrite F2R_Zabs.
-apply Ex.
-apply Rgt_not_eq.
-now apply F2R_gt_0.
-unfold emin.
-generalize (prec_gt_0 prec).
-clear -Hmax ; lia.
+intros mx ex.
+now apply bounded_canonical_lt_emax.
 Qed.
 
 (** Truncation *)
 
-Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }.
-
-Definition shr_1 mrs :=
-  let '(Build_shr_record m r s) := mrs in
-  let s := orb r s in
-  match m with
-  | Z0 => Build_shr_record Z0 false s
-  | Zpos xH => Build_shr_record Z0 true s
-  | Zpos (xO p) => Build_shr_record (Zpos p) false s
-  | Zpos (xI p) => Build_shr_record (Zpos p) true s
-  | Zneg xH => Build_shr_record Z0 true s
-  | Zneg (xO p) => Build_shr_record (Zneg p) false s
-  | Zneg (xI p) => Build_shr_record (Zneg p) true s
-  end.
-
-Definition loc_of_shr_record mrs :=
-  match mrs with
-  | Build_shr_record _ false false => loc_Exact
-  | Build_shr_record _ false true => loc_Inexact Lt
-  | Build_shr_record _ true false => loc_Inexact Eq
-  | Build_shr_record _ true true => loc_Inexact Gt
-  end.
-
-Definition shr_record_of_loc m l :=
-  match l with
-  | loc_Exact => Build_shr_record m false false
-  | loc_Inexact Lt => Build_shr_record m false true
-  | loc_Inexact Eq => Build_shr_record m true false
-  | loc_Inexact Gt => Build_shr_record m true true
-  end.
-
-Theorem shr_m_shr_record_of_loc :
-  forall m l,
-  shr_m (shr_record_of_loc m l) = m.
-Proof.
-now intros m [|[| |]].
-Qed.
-
-Theorem loc_of_shr_record_of_loc :
-  forall m l,
-  loc_of_shr_record (shr_record_of_loc m l) = l.
-Proof.
-now intros m [|[| |]].
-Qed.
-
-Definition shr mrs e n :=
-  match n with
-  | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z)
-  | _ => (mrs, e)
-  end.
-
-Lemma inbetween_shr_1 :
-  forall x mrs e,
-  (0 <= shr_m mrs)%Z ->
-  inbetween_float radix2 (shr_m mrs) e x (loc_of_shr_record mrs) ->
-  inbetween_float radix2 (shr_m (shr_1 mrs)) (e + 1) x (loc_of_shr_record (shr_1 mrs)).
-Proof.
-intros x mrs e Hm Hl.
-refine (_ (new_location_even_correct (F2R (Float radix2 (shr_m (shr_1 mrs)) (e + 1))) (bpow radix2 e) 2 _ _ _ x (if shr_r (shr_1 mrs) then 1 else 0) (loc_of_shr_record mrs) _ _)) ; try easy.
-2: apply bpow_gt_0.
-2: now case (shr_r (shr_1 mrs)) ; split.
-change 2%R with (bpow radix2 1).
-rewrite <- bpow_plus.
-rewrite (Zplus_comm 1), <- (F2R_bpow radix2 (e + 1)).
-unfold inbetween_float, F2R. simpl.
-rewrite plus_IZR, Rmult_plus_distr_r.
-replace (new_location_even 2 (if shr_r (shr_1 mrs) then 1%Z else 0%Z) (loc_of_shr_record mrs)) with (loc_of_shr_record (shr_1 mrs)).
-easy.
-clear -Hm.
-destruct mrs as (m, r, s).
-now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
-rewrite (F2R_change_exp radix2 e).
-2: apply Zle_succ.
-unfold F2R. simpl.
-rewrite <- 2!Rmult_plus_distr_r, <- 2!plus_IZR.
-rewrite Zplus_assoc.
-replace (shr_m (shr_1 mrs) * 2 ^ (e + 1 - e) + (if shr_r (shr_1 mrs) then 1%Z else 0%Z))%Z with (shr_m mrs).
-exact Hl.
-ring_simplify (e + 1 - e)%Z.
-change (2^1)%Z with 2%Z.
-rewrite Zmult_comm.
-clear -Hm.
-destruct mrs as (m, r, s).
-now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
-Qed.
-
-Theorem inbetween_shr :
-  forall x m e l n,
-  (0 <= m)%Z ->
-  inbetween_float radix2 m e x l ->
-  let '(mrs, e') := shr (shr_record_of_loc m l) e n in
-  inbetween_float radix2 (shr_m mrs) e' x (loc_of_shr_record mrs).
-Proof.
-intros x m e l n Hm Hl.
-destruct n as [|n|n].
-now destruct l as [|[| |]].
-2: now destruct l as [|[| |]].
-unfold shr.
-rewrite iter_pos_nat.
-rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
-induction (nat_of_P n).
-simpl.
-rewrite Zplus_0_r.
-now destruct l as [|[| |]].
-rewrite iter_nat_S.
-rewrite inj_S.
-unfold Z.succ.
-rewrite Zplus_assoc.
-revert IHn0.
-apply inbetween_shr_1.
-clear -Hm.
-induction n0.
-now destruct l as [|[| |]].
-rewrite iter_nat_S.
-revert IHn0.
-generalize (iter_nat shr_1 n0 (shr_record_of_loc m l)).
-clear.
-intros (m, r, s) Hm.
-now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
-Qed.
-
-Definition shr_fexp m e l :=
-  shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e).
+Notation shr_fexp := (shr_fexp prec emax) (only parsing).
 
 Theorem shr_truncate :
   forall m e l,
@@ -930,103 +882,30 @@ Theorem shr_truncate :
   shr_fexp m e l =
   let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e').
 Proof.
-intros m e l Hm.
-case_eq (truncate radix2 fexp (m, e, l)).
-intros (m', e') l'.
-unfold shr_fexp.
-rewrite Zdigits2_Zdigits.
-case_eq (fexp (Zdigits radix2 m + e) - e)%Z.
-(* *)
-intros He.
-unfold truncate.
-rewrite He.
-simpl.
-intros H.
-now inversion H.
-(* *)
-intros p Hp.
-assert (He: (e <= fexp (Zdigits radix2 m + e))%Z).
-clear -Hp ; zify ; lia.
-destruct (inbetween_float_ex radix2 m e l) as (x, Hx).
-generalize (inbetween_shr x m e l (fexp (Zdigits radix2 m + e) - e) Hm Hx).
-assert (Hx0 : (0 <= x)%R).
-apply Rle_trans with (F2R (Float radix2 m e)).
-now apply F2R_ge_0.
-exact (proj1 (inbetween_float_bounds _ _ _ _ _ Hx)).
-case_eq (shr (shr_record_of_loc m l) e (fexp (Zdigits radix2 m + e) - e)).
-intros mrs e'' H3 H4 H1.
-generalize (truncate_correct radix2 _ x m e l Hx0 Hx (or_introl _ He)).
-rewrite H1.
-intros (H2,_).
-rewrite <- Hp, H3.
-assert (e'' = e').
-change (snd (mrs, e'') = snd (fst (m',e',l'))).
-rewrite <- H1, <- H3.
-unfold truncate.
-now rewrite Hp.
-rewrite H in H4 |- *.
-apply (f_equal (fun v => (v, _))).
-destruct (inbetween_float_unique _ _ _ _ _ _ _ H2 H4) as (H5, H6).
-rewrite H5, H6.
-case mrs.
-now intros m0 [|] [|].
-(* *)
-intros p Hp.
-unfold truncate.
-rewrite Hp.
-simpl.
-intros H.
-now inversion H.
+intros m e l.
+now apply shr_truncate.
 Qed.
 
 (** Rounding modes *)
 
-Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA.
-
-Definition round_mode m :=
-  match m with
-  | mode_NE => ZnearestE
-  | mode_ZR => Ztrunc
-  | mode_DN => Zfloor
-  | mode_UP => Zceil
-  | mode_NA => ZnearestA
-  end.
-
-Definition choice_mode m sx mx lx :=
-  match m with
-  | mode_NE => cond_incr (round_N (negb (Z.even mx)) lx) mx
-  | mode_ZR => mx
-  | mode_DN => cond_incr (round_sign_DN sx lx) mx
-  | mode_UP => cond_incr (round_sign_UP sx lx) mx
-  | mode_NA => cond_incr (round_N true lx) mx
-  end.
+Definition binary_overflow m s :=
+  SF2FF (binary_overflow prec emax m s).
 
-Global Instance valid_rnd_round_mode : forall m, Valid_rnd (round_mode m).
+Lemma eq_binary_overflow_FF2SF :
+  forall x m s,
+  FF2SF x = BSN.binary_overflow prec emax m s ->
+  x = binary_overflow m s.
 Proof.
-destruct m ; unfold round_mode ; auto with typeclass_instances.
+intros x m s H.
+unfold binary_overflow.
+rewrite <- H.
+apply eq_sym, SF2FF_FF2SF.
+rewrite <- is_nan_FF2SF, H.
+apply is_nan_binary_overflow.
 Qed.
 
-Definition overflow_to_inf m s :=
-  match m with
-  | mode_NE => true
-  | mode_NA => true
-  | mode_ZR => false
-  | mode_UP => negb s
-  | mode_DN => s
-  end.
-
-Definition binary_overflow m s :=
-  if overflow_to_inf m s then F754_infinity s
-  else F754_finite s (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end) (emax - prec).
-
 Definition binary_round_aux mode sx mx ex lx :=
-  let '(mrs', e') := shr_fexp mx ex lx in
-  let '(mrs'', e'') := shr_fexp (choice_mode mode sx (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in
-  match shr_m mrs'' with
-  | Z0 => F754_zero sx
-  | Zpos m => if Zle_bool e'' (emax - prec) then F754_finite sx m e'' else binary_overflow mode sx
-  | _ => F754_nan false xH (* dummy *)
-  end.
+  SF2FF (binary_round_aux prec emax mode sx mx ex lx).
 
 Theorem binary_round_aux_correct' :
   forall mode x mx ex lx,
@@ -1040,174 +919,17 @@ Theorem binary_round_aux_correct' :
     is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0
   else
     z = binary_overflow mode (Rlt_bool x 0).
-Proof with auto with typeclass_instances.
-intros m x mx ex lx Px Bx Ex z.
-unfold binary_round_aux in z.
-revert z.
-rewrite shr_truncate.
-refine (_ (round_trunc_sign_any_correct' _ _ (round_mode m) (choice_mode m) _ x mx ex lx Bx (or_introl _ Ex))).
-rewrite <- cexp_abs in Ex.
-refine (_ (truncate_correct_partial' _ fexp _ _ _ _ _ Bx Ex)).
-destruct (truncate radix2 fexp (mx, ex, lx)) as ((m1, e1), l1).
-rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc.
-set (m1' := choice_mode m (Rlt_bool x 0) m1 l1).
-intros (H1a,H1b) H1c.
-rewrite H1c.
-assert (Hm: (m1 <= m1')%Z).
-(* . *)
-unfold m1', choice_mode, cond_incr.
-case m ;
-  try apply Z.le_refl ;
-  match goal with |- (m1 <= if ?b then _ else _)%Z =>
-    case b ; [ apply Zle_succ | apply Z.le_refl ] end.
-assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)).
-(* . *)
-rewrite <- (Z.abs_eq m1').
-replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')).
-rewrite F2R_Zabs.
-now apply f_equal.
-apply abs_cond_Zopp.
-apply Z.le_trans with (2 := Hm).
-apply Zlt_succ_le.
-apply gt_0_F2R with radix2 e1.
-apply Rle_lt_trans with (1 := Rabs_pos x).
-exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)).
-(* . *)
-assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact).
-now apply inbetween_Exact.
-destruct m1' as [|m1'|m1'].
-(* . m1' = 0 *)
-rewrite shr_truncate. 2: apply Z.le_refl.
-generalize (truncate_0 radix2 fexp e1 loc_Exact).
-destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2).
-rewrite shr_m_shr_record_of_loc.
-intros Hm2.
-rewrite Hm2.
-repeat split.
-rewrite Rlt_bool_true.
-repeat split.
-apply sym_eq.
-case Rlt_bool ; apply F2R_0.
-rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0.
-apply bpow_gt_0.
-(* . 0 < m1' *)
-assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z).
-rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs.
-2: discriminate.
-rewrite H1b.
-rewrite cexp_abs.
-fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)).
-apply cexp_round_ge...
-rewrite H1c.
-case (Rlt_bool x 0).
-apply Rlt_not_eq.
-now apply F2R_lt_0.
-apply Rgt_not_eq.
-now apply F2R_gt_0.
-refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)).
-2: now rewrite Hr ; apply F2R_gt_0.
-refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)).
-2: discriminate.
-rewrite shr_truncate. 2: easy.
-destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2).
-rewrite shr_m_shr_record_of_loc.
-intros (H3,H4) (H2,_).
-destruct m2 as [|m2|m2].
-elim Rgt_not_eq with (2 := H3).
-rewrite F2R_0.
-now apply F2R_gt_0.
-rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs.
-simpl Z.abs.
-case_eq (Zle_bool e2 (emax - prec)) ; intros He2.
-assert (bounded m2 e2 = true).
-apply andb_true_intro.
-split.
-unfold canonical_mantissa.
-apply Zeq_bool_true.
-rewrite Zpos_digits2_pos.
-rewrite <- mag_F2R_Zdigits.
-apply sym_eq.
-now rewrite H3 in H4.
-discriminate.
-exact He2.
-apply (conj H).
-rewrite Rlt_bool_true.
-repeat split.
-apply F2R_cond_Zopp.
-now apply bounded_lt_emax.
-rewrite (Rlt_bool_false _ (bpow radix2 emax)).
-refine (conj _ (refl_equal _)).
-unfold binary_overflow.
-case overflow_to_inf.
-apply refl_equal.
-unfold valid_binary, bounded.
-rewrite Zle_bool_refl.
-rewrite Bool.andb_true_r.
-apply Zeq_bool_true.
-rewrite Zpos_digits2_pos.
-replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec.
-unfold fexp, FLT_exp, emin.
-generalize (prec_gt_0 prec).
-clear -Hmax ; zify ; lia.
-change 2%Z with (radix_val radix2).
-case_eq (Zpower radix2 prec - 1)%Z.
-simpl Zdigits.
-generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)).
-clear ; lia.
-intros p Hp.
-apply Zle_antisym.
-cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; lia.
-apply Zdigits_gt_Zpower.
-simpl Z.abs. rewrite <- Hp.
-cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; lia.
-apply lt_IZR.
-rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak.
-apply bpow_lt.
-apply Zlt_pred.
-now apply Zlt_0_le_0_pred.
-apply Zdigits_le_Zpower.
-simpl Z.abs. rewrite <- Hp.
-apply Zlt_pred.
-intros p Hp.
-generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)).
-clear -Hp ; zify ; lia.
-apply Rnot_lt_le.
-intros Hx.
-generalize (refl_equal (bounded m2 e2)).
-unfold bounded at 2.
-rewrite He2.
-rewrite Bool.andb_false_r.
-rewrite bounded_canonical_lt_emax with (2 := Hx).
-discriminate.
-unfold canonical.
-now rewrite <- H3.
-elim Rgt_not_eq with (2 := H3).
-apply Rlt_trans with R0.
-now apply F2R_lt_0.
-now apply F2R_gt_0.
-rewrite <- Hr.
-apply generic_format_abs...
-apply generic_format_round...
-(* . not m1' < 0 *)
-elim Rgt_not_eq with (2 := Hr).
-apply Rlt_le_trans with R0.
-now apply F2R_lt_0.
-apply Rabs_pos.
-(* *)
-now apply Rabs_pos_lt.
-(* all the modes are valid *)
-clear. case m.
-exact inbetween_int_NE_sign.
-exact inbetween_int_ZR_sign.
-exact inbetween_int_DN_sign.
-exact inbetween_int_UP_sign.
-exact inbetween_int_NA_sign.
-(* *)
-apply inbetween_float_bounds in Bx.
-apply Zlt_succ_le.
-eapply gt_0_F2R.
-apply Rle_lt_trans with (2 := proj2 Bx).
-apply Rabs_pos.
+Proof.
+intros mode x mx ex lx Px Bx Ex.
+generalize (binary_round_aux_correct' prec emax _ _ mode x mx ex lx Px Bx Ex).
+unfold binary_round_aux.
+destruct (Rlt_bool (Rabs _) _).
+- now destruct BSN.binary_round_aux as [sz|sz| |sz mz ez].
+- intros [_ ->].
+  split.
+  rewrite valid_binary_SF2FF by apply is_nan_binary_overflow.
+  now apply binary_overflow_correct.
+  easy.
 Qed.
 
 Theorem binary_round_aux_correct :
@@ -1221,239 +943,23 @@ Theorem binary_round_aux_correct :
     is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0
   else
     z = binary_overflow mode (Rlt_bool x 0).
-Proof with auto with typeclass_instances.
-intros m x mx ex lx Bx Ex z.
-unfold binary_round_aux in z.
-revert z.
-rewrite shr_truncate. 2: easy.
-refine (_ (round_trunc_sign_any_correct _ _ (round_mode m) (choice_mode m) _ x (Zpos mx) ex lx Bx (or_introl _ Ex))).
-refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Bx Ex)).
-destruct (truncate radix2 fexp (Zpos mx, ex, lx)) as ((m1, e1), l1).
-rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc.
-set (m1' := choice_mode m (Rlt_bool x 0) m1 l1).
-intros (H1a,H1b) H1c.
-rewrite H1c.
-assert (Hm: (m1 <= m1')%Z).
-(* . *)
-unfold m1', choice_mode, cond_incr.
-case m ;
-  try apply Z.le_refl ;
-  match goal with |- (m1 <= if ?b then _ else _)%Z =>
-    case b ; [ apply Zle_succ | apply Z.le_refl ] end.
-assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)).
-(* . *)
-rewrite <- (Z.abs_eq m1').
-replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')).
-rewrite F2R_Zabs.
-now apply f_equal.
-apply abs_cond_Zopp.
-apply Z.le_trans with (2 := Hm).
-apply Zlt_succ_le.
-apply gt_0_F2R with radix2 e1.
-apply Rle_lt_trans with (1 := Rabs_pos x).
-exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)).
-(* . *)
-assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact).
-now apply inbetween_Exact.
-destruct m1' as [|m1'|m1'].
-(* . m1' = 0 *)
-rewrite shr_truncate. 2: apply Z.le_refl.
-generalize (truncate_0 radix2 fexp e1 loc_Exact).
-destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2).
-rewrite shr_m_shr_record_of_loc.
-intros Hm2.
-rewrite Hm2.
-repeat split.
-rewrite Rlt_bool_true.
-repeat split.
-apply sym_eq.
-case Rlt_bool ; apply F2R_0.
-rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0.
-apply bpow_gt_0.
-(* . 0 < m1' *)
-assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z).
-rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs.
-2: discriminate.
-rewrite H1b.
-rewrite cexp_abs.
-fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)).
-apply cexp_round_ge...
-rewrite H1c.
-case (Rlt_bool x 0).
-apply Rlt_not_eq.
-now apply F2R_lt_0.
-apply Rgt_not_eq.
-now apply F2R_gt_0.
-refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)).
-2: now rewrite Hr ; apply F2R_gt_0.
-refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)).
-2: discriminate.
-rewrite shr_truncate. 2: easy.
-destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2).
-rewrite shr_m_shr_record_of_loc.
-intros (H3,H4) (H2,_).
-destruct m2 as [|m2|m2].
-elim Rgt_not_eq with (2 := H3).
-rewrite F2R_0.
-now apply F2R_gt_0.
-rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs.
-simpl Z.abs.
-case_eq (Zle_bool e2 (emax - prec)) ; intros He2.
-assert (bounded m2 e2 = true).
-apply andb_true_intro.
-split.
-unfold canonical_mantissa.
-apply Zeq_bool_true.
-rewrite Zpos_digits2_pos.
-rewrite <- mag_F2R_Zdigits.
-apply sym_eq.
-now rewrite H3 in H4.
-discriminate.
-exact He2.
-apply (conj H).
-rewrite Rlt_bool_true.
-repeat split.
-apply F2R_cond_Zopp.
-now apply bounded_lt_emax.
-rewrite (Rlt_bool_false _ (bpow radix2 emax)).
-refine (conj _ (refl_equal _)).
-unfold binary_overflow.
-case overflow_to_inf.
-apply refl_equal.
-unfold valid_binary, bounded.
-rewrite Zle_bool_refl.
-rewrite Bool.andb_true_r.
-apply Zeq_bool_true.
-rewrite Zpos_digits2_pos.
-replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec.
-unfold fexp, FLT_exp, emin.
-generalize (prec_gt_0 prec).
-clear -Hmax ; zify ; lia.
-change 2%Z with (radix_val radix2).
-case_eq (Zpower radix2 prec - 1)%Z.
-simpl Zdigits.
-generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)).
-clear ; lia.
-intros p Hp.
-apply Zle_antisym.
-cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; lia.
-apply Zdigits_gt_Zpower.
-simpl Z.abs. rewrite <- Hp.
-cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; lia.
-apply lt_IZR.
-rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak.
-apply bpow_lt.
-apply Zlt_pred.
-now apply Zlt_0_le_0_pred.
-apply Zdigits_le_Zpower.
-simpl Z.abs. rewrite <- Hp.
-apply Zlt_pred.
-intros p Hp.
-generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)).
-clear -Hp ; zify ; lia.
-apply Rnot_lt_le.
-intros Hx.
-generalize (refl_equal (bounded m2 e2)).
-unfold bounded at 2.
-rewrite He2.
-rewrite Bool.andb_false_r.
-rewrite bounded_canonical_lt_emax with (2 := Hx).
-discriminate.
-unfold canonical.
-now rewrite <- H3.
-elim Rgt_not_eq with (2 := H3).
-apply Rlt_trans with R0.
-now apply F2R_lt_0.
-now apply F2R_gt_0.
-rewrite <- Hr.
-apply generic_format_abs...
-apply generic_format_round...
-(* . not m1' < 0 *)
-elim Rgt_not_eq with (2 := Hr).
-apply Rlt_le_trans with R0.
-now apply F2R_lt_0.
-apply Rabs_pos.
-(* *)
-apply Rlt_le_trans with (2 := proj1 (inbetween_float_bounds _ _ _ _ _ Bx)).
-now apply F2R_gt_0.
-(* all the modes are valid *)
-clear. case m.
-exact inbetween_int_NE_sign.
-exact inbetween_int_ZR_sign.
-exact inbetween_int_DN_sign.
-exact inbetween_int_UP_sign.
-exact inbetween_int_NA_sign.
+Proof.
+intros mode x mx ex lx Bx Ex.
+generalize (binary_round_aux_correct prec emax _ _ mode x mx ex lx Bx Ex).
+unfold binary_round_aux.
+destruct (Rlt_bool (Rabs _) _).
+- now destruct BSN.binary_round_aux as [sz|sz| |sz mz ez].
+- intros [_ ->].
+  split.
+  rewrite valid_binary_SF2FF by apply is_nan_binary_overflow.
+  now apply binary_overflow_correct.
+  easy.
 Qed.
 
 (** Multiplication *)
 
-Lemma Bmult_correct_aux :
-  forall m sx mx ex (Hx : bounded mx ex = true) sy my ey (Hy : bounded my ey = true),
-  let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
-  let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in
-  let z := binary_round_aux m (xorb sx sy) (Zpos (mx * my)) (ex + ey) loc_Exact in
-  valid_binary z = true /\
-  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then
-    FF2R radix2 z = round radix2 fexp (round_mode m) (x * y) /\
-    is_finite_FF z = true /\ sign_FF z = xorb sx sy
-  else
-    z = binary_overflow m (xorb sx sy).
-Proof.
-intros m sx mx ex Hx sy my ey Hy x y.
-unfold x, y.
-rewrite <- F2R_mult.
-simpl.
-replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx) * cond_Zopp sy (Zpos my)) (ex + ey))) 0).
-apply binary_round_aux_correct.
-constructor.
-rewrite <- F2R_abs.
-apply F2R_eq.
-rewrite Zabs_Zmult.
-now rewrite 2!abs_cond_Zopp.
-(* *)
-change (Zpos (mx * my)) with (Zpos mx * Zpos my)%Z.
-assert (forall m e, bounded m e = true -> fexp (Zdigits radix2 (Zpos m) + e) = e)%Z.
-clear. intros m e Hb.
-destruct (andb_prop _ _ Hb) as (H,_).
-apply Zeq_bool_eq.
-now rewrite <- Zpos_digits2_pos.
-generalize (H _ _ Hx) (H _ _ Hy).
-clear x y sx sy Hx Hy H.
-unfold fexp, FLT_exp.
-refine (_ (Zdigits_mult_ge radix2 (Zpos mx) (Zpos my) _ _)) ; try discriminate.
-refine (_ (Zdigits_gt_0 radix2 (Zpos mx) _) (Zdigits_gt_0 radix2 (Zpos my) _)) ; try discriminate.
-generalize (Zdigits radix2 (Zpos mx)) (Zdigits radix2 (Zpos my)) (Zdigits radix2 (Zpos mx * Zpos my)).
-clear -Hmax.
-unfold emin.
-intros dx dy dxy Hx Hy Hxy.
-zify ; intros ; subst.
-lia.
-(* *)
-case sx ; case sy.
-apply Rlt_bool_false.
-now apply F2R_ge_0.
-apply Rlt_bool_true.
-now apply F2R_lt_0.
-apply Rlt_bool_true.
-now apply F2R_lt_0.
-apply Rlt_bool_false.
-now apply F2R_ge_0.
-Qed.
-
 Definition Bmult mult_nan m x y :=
-  match x, y with
-  | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (mult_nan x y)
-  | B754_infinity sx, B754_infinity sy => B754_infinity (xorb sx sy)
-  | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy)
-  | B754_finite sx _ _ _, B754_infinity sy => B754_infinity (xorb sx sy)
-  | B754_infinity _, B754_zero _ => build_nan (mult_nan x y)
-  | B754_zero _, B754_infinity _ => build_nan (mult_nan x y)
-  | B754_finite sx _ _ _, B754_zero sy => B754_zero (xorb sx sy)
-  | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy)
-  | B754_zero sx, B754_zero sy => B754_zero (xorb sx sy)
-  | B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
-    FF2B _ (proj1 (Bmult_correct_aux m sx mx ex Hx sy my ey Hy))
-  end.
+  BSN2B (mult_nan x y) (Bmult m (B2BSN x) (B2BSN y)).
 
 Theorem Bmult_correct :
   forall mult_nan m x y,
@@ -1465,106 +971,39 @@ Theorem Bmult_correct :
   else
     B2FF (Bmult mult_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
 Proof.
-intros mult_nan m [sx|sx|sx plx Hplx|sx mx ex Hx] [sy|sy|sy ply Hply|sy my ey Hy] ;
-  try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | now auto with typeclass_instances ] ).
-simpl.
-case Bmult_correct_aux.
-intros H1.
-case Rlt_bool.
-intros (H2, (H3, H4)).
-split.
-now rewrite B2R_FF2B.
-split.
-now rewrite is_finite_FF2B.
-rewrite Bsign_FF2B. auto.
-intros H2.
-now rewrite B2FF_FF2B.
+intros mult_nan mode x y.
+generalize (Bmult_correct prec emax _ _ mode (B2BSN x) (B2BSN y)).
+replace (BSN.Bmult _ _ _) with (B2BSN (Bmult mult_nan mode x y)) by apply B2BSN_BSN2B.
+intros H.
+destruct x as [sx|sx|sx plx Hplx|sx mx ex Hx] ;
+  destruct y as [sy|sy|sy ply Hply|sy my ey Hy] ;
+  try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ try easy | apply bpow_gt_0 | now auto with typeclass_instances ]).
+revert H.
+rewrite 2!B2R_B2BSN.
+destruct Rlt_bool.
+- now destruct Bmult.
+- intros H.
+  apply eq_binary_overflow_FF2SF.
+  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
 Qed.
 
 (** Normalization and rounding *)
 
-Definition shl_align mx ex ex' :=
-  match (ex' - ex)%Z with
-  | Zneg d => (shift_pos d mx, ex')
-  | _ => (mx, ex)
-  end.
-
-Theorem shl_align_correct :
-  forall mx ex ex',
-  let (mx', ex'') := shl_align mx ex ex' in
-  F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex'') /\
-  (ex'' <= ex')%Z.
-Proof.
-intros mx ex ex'.
-unfold shl_align.
-case_eq (ex' - ex)%Z.
-(* d = 0 *)
-intros H.
-repeat split.
-rewrite Zminus_eq with (1 := H).
-apply Z.le_refl.
-(* d > 0 *)
-intros d Hd.
-repeat split.
-replace ex' with (ex' - ex + ex)%Z by ring.
-rewrite Hd.
-pattern ex at 1 ; rewrite <- Zplus_0_l.
-now apply Zplus_le_compat_r.
-(* d < 0 *)
-intros d Hd.
-rewrite shift_pos_correct, Zmult_comm.
-change (Zpower_pos 2 d) with (Zpower radix2 (Zpos d)).
-change (Zpos d) with (Z.opp (Zneg d)).
-rewrite <- Hd.
-split.
-replace (- (ex' - ex))%Z with (ex - ex')%Z by ring.
-apply F2R_change_exp.
-apply Zle_0_minus_le.
-replace (ex - ex')%Z with (- (ex' - ex))%Z by ring.
-now rewrite Hd.
-apply Z.le_refl.
-Qed.
-
-Theorem snd_shl_align :
-  forall mx ex ex',
-  (ex' <= ex)%Z ->
-  snd (shl_align mx ex ex') = ex'.
-Proof.
-intros mx ex ex' He.
-unfold shl_align.
-case_eq (ex' - ex)%Z ; simpl.
-intros H.
-now rewrite Zminus_eq with (1 := H).
-intros p.
-clear -He ; zify ; lia.
-intros.
-apply refl_equal.
-Qed.
-
 Definition shl_align_fexp mx ex :=
   shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)).
 
-Theorem shl_align_fexp_correct :
+Lemma shl_align_fexp_correct :
   forall mx ex,
   let (mx', ex') := shl_align_fexp mx ex in
   F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex') /\
   (ex' <= fexp (Zdigits radix2 (Zpos mx') + ex'))%Z.
 Proof.
 intros mx ex.
-unfold shl_align_fexp.
-generalize (shl_align_correct mx ex (fexp (Zpos (digits2_pos mx) + ex))).
-rewrite Zpos_digits2_pos.
-case shl_align.
-intros mx' ex' (H1, H2).
-split.
-exact H1.
-rewrite <- mag_F2R_Zdigits. 2: easy.
-rewrite <- H1.
-now rewrite mag_F2R_Zdigits.
+apply shl_align_fexp_correct.
 Qed.
 
 Definition binary_round m sx mx ex :=
-  let '(mz, ez) := shl_align_fexp mx ex in binary_round_aux m sx (Zpos mz) ez loc_Exact.
+  SF2FF (binary_round prec emax m sx mx ex).
 
 Theorem binary_round_correct :
   forall m sx mx ex,
@@ -1578,32 +1017,21 @@ Theorem binary_round_correct :
   else
     z = binary_overflow m sx.
 Proof.
-intros m sx mx ex.
+intros mode sx mx ex.
+generalize (binary_round_correct prec emax _ _ mode sx mx ex).
+simpl.
 unfold binary_round.
-generalize (shl_align_fexp_correct mx ex).
-destruct (shl_align_fexp mx ex) as (mz, ez).
-intros (H1, H2).
-set (x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex)).
-replace sx with (Rlt_bool x 0).
-apply binary_round_aux_correct.
-constructor.
-unfold x.
-now rewrite <- F2R_Zabs, abs_cond_Zopp.
-exact H2.
-unfold x.
-case sx.
-apply Rlt_bool_true.
-now apply F2R_lt_0.
-apply Rlt_bool_false.
-now apply F2R_ge_0.
+destruct Rlt_bool.
+- now destruct BSN.binary_round.
+- intros [H1 ->].
+  split.
+  rewrite valid_binary_SF2FF by apply is_nan_binary_overflow.
+  now apply binary_overflow_correct.
+  easy.
 Qed.
 
 Definition binary_normalize mode m e szero :=
-  match m with
-  | Z0 => B754_zero szero
-  | Zpos m => FF2B _ (proj1 (binary_round_correct mode false m e))
-  | Zneg m => FF2B _ (proj1 (binary_round_correct mode true m e))
-  end.
+  BSN2B' _ (is_nan_binary_normalize prec emax _ _ mode m e szero).
 
 Theorem binary_normalize_correct :
   forall m mx ex szero,
@@ -1618,72 +1046,22 @@ Theorem binary_normalize_correct :
       end
   else
     B2FF (binary_normalize m mx ex szero) = binary_overflow m (Rlt_bool (F2R (Float radix2 mx ex)) 0).
-Proof with auto with typeclass_instances.
-intros m mx ez szero.
-destruct mx as [|mz|mz] ; simpl.
-rewrite F2R_0, round_0, Rabs_R0, Rlt_bool_true...
-split... split...
-rewrite Rcompare_Eq...
-apply bpow_gt_0.
-(* . mz > 0 *)
-generalize (binary_round_correct m false mz ez).
-simpl.
-case Rlt_bool_spec.
-intros _ (Vz, (Rz, (Rz', Rz''))).
-split.
-now rewrite B2R_FF2B.
-split.
-now rewrite is_finite_FF2B.
-rewrite Bsign_FF2B, Rz''.
-rewrite Rcompare_Gt...
-apply F2R_gt_0.
-simpl. zify; lia.
-intros Hz' (Vz, Rz).
-rewrite B2FF_FF2B, Rz.
-apply f_equal.
-apply sym_eq.
-apply Rlt_bool_false.
-now apply F2R_ge_0.
-(* . mz < 0 *)
-generalize (binary_round_correct m true mz ez).
+Proof.
+intros mode mx ex szero.
+generalize (binary_normalize_correct prec emax _ _ mode mx ex szero).
+replace (BSN.binary_normalize _ _ _ _ _ _ _ _) with (B2BSN (binary_normalize mode mx ex szero)) by apply B2BSN_BSN2B'.
 simpl.
-case Rlt_bool_spec.
-intros _ (Vz, (Rz, (Rz', Rz''))).
-split.
-now rewrite B2R_FF2B.
-split.
-now rewrite is_finite_FF2B.
-rewrite Bsign_FF2B, Rz''.
-rewrite Rcompare_Lt...
-apply F2R_lt_0.
-simpl. zify; lia.
-intros Hz' (Vz, Rz).
-rewrite B2FF_FF2B, Rz.
-apply f_equal.
-apply sym_eq.
-apply Rlt_bool_true.
-now apply F2R_lt_0.
+destruct Rlt_bool.
+- now destruct binary_normalize.
+- intros H.
+  apply eq_binary_overflow_FF2SF.
+  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
 Qed.
 
 (** Addition *)
 
 Definition Bplus plus_nan m x y :=
-  match x, y with
-  | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (plus_nan x y)
-  | B754_infinity sx, B754_infinity sy =>
-    if Bool.eqb sx sy then x else build_nan (plus_nan x y)
-  | B754_infinity _, _ => x
-  | _, B754_infinity _ => y
-  | B754_zero sx, B754_zero sy =>
-    if Bool.eqb sx sy then x else
-    match m with mode_DN => B754_zero true | _ => B754_zero false end
-  | B754_zero _, _ => y
-  | _, B754_zero _ => x
-  | B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
-    let ez := Z.min ex ey in
-    binary_normalize m (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez)))))
-      ez (match m with mode_DN => true | _ => false end)
-  end.
+  BSN2B (plus_nan x y) (Bplus m (B2BSN x) (B2BSN y)).
 
 Theorem Bplus_correct :
   forall plus_nan m x y,
@@ -1702,170 +1080,25 @@ Theorem Bplus_correct :
   else
     (B2FF (Bplus plus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y).
 Proof with auto with typeclass_instances.
-intros plus_nan m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy.
-(* *)
-rewrite Rplus_0_r, round_0, Rabs_R0, Rlt_bool_true...
-simpl.
-rewrite Rcompare_Eq by auto.
-destruct sx, sy; try easy; now case m.
-apply bpow_gt_0.
-(* *)
-rewrite Rplus_0_l, round_generic, Rlt_bool_true...
-split... split...
-simpl. unfold F2R.
-erewrite <- Rmult_0_l, Rcompare_mult_r.
-rewrite Rcompare_IZR with (y:=0%Z).
-destruct sy...
-apply bpow_gt_0.
-apply abs_B2R_lt_emax.
-apply generic_format_B2R.
-(* *)
-rewrite Rplus_0_r, round_generic, Rlt_bool_true...
-split... split...
-simpl. unfold F2R.
-erewrite <- Rmult_0_l, Rcompare_mult_r.
-rewrite Rcompare_IZR with (y:=0%Z).
-destruct sx...
-apply bpow_gt_0.
-apply abs_B2R_lt_emax.
-apply generic_format_B2R.
-(* *)
-clear Fx Fy.
-simpl.
-set (szero := match m with mode_DN => true | _ => false end).
-set (ez := Z.min ex ey).
-set (mz := (cond_Zopp sx (Zpos (fst (shl_align mx ex ez))) + cond_Zopp sy (Zpos (fst (shl_align my ey ez))))%Z).
-assert (Hp: (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) +
-  F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey))%R = F2R (Float radix2 mz ez)).
-rewrite 2!F2R_cond_Zopp.
-generalize (shl_align_correct mx ex ez).
-generalize (shl_align_correct my ey ez).
-generalize (snd_shl_align mx ex ez (Z.le_min_l ex ey)).
-generalize (snd_shl_align my ey ez (Z.le_min_r ex ey)).
-destruct (shl_align mx ex ez) as (mx', ex').
-destruct (shl_align my ey ez) as (my', ey').
-simpl.
-intros H1 H2.
-rewrite H1, H2.
-clear H1 H2.
-intros (H1, _) (H2, _).
-rewrite H1, H2.
-clear H1 H2.
-rewrite <- 2!F2R_cond_Zopp.
-unfold F2R. simpl.
-now rewrite <- Rmult_plus_distr_r, <- plus_IZR.
-rewrite Hp.
-assert (Sz: (bpow radix2 emax <= Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mz ez))))%R -> sx = Rlt_bool (F2R (Float radix2 mz ez)) 0 /\ sx = sy).
-(* . *)
-rewrite <- Hp.
-intros Bz.
-destruct (Bool.bool_dec sx sy) as [Hs|Hs].
-(* .. *)
-refine (conj _ Hs).
-rewrite Hs.
-apply sym_eq.
-case sy.
-apply Rlt_bool_true.
-rewrite <- (Rplus_0_r 0).
-apply Rplus_lt_compat.
-now apply F2R_lt_0.
-now apply F2R_lt_0.
-apply Rlt_bool_false.
-rewrite <- (Rplus_0_r 0).
-apply Rplus_le_compat.
-now apply F2R_ge_0.
-now apply F2R_ge_0.
-(* .. *)
-elim Rle_not_lt with (1 := Bz).
-generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy).
-intros Bx By (Hx',_) (Hy',_).
-generalize (canonical_canonical_mantissa sx _ _ Hx') (canonical_canonical_mantissa sy _ _ Hy').
-clear -Bx By Hs prec_gt_0_.
-intros Cx Cy.
-destruct sx.
-(* ... *)
-destruct sy.
-now elim Hs.
-clear Hs.
-apply Rabs_lt.
-split.
-apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)).
-rewrite F2R_Zopp.
-now apply Ropp_lt_contravar.
-apply round_ge_generic...
-now apply generic_format_canonical.
-pattern (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)) at 1 ; rewrite <- Rplus_0_r.
-apply Rplus_le_compat_l.
-now apply F2R_ge_0.
-apply Rle_lt_trans with (2 := By).
-apply round_le_generic...
-now apply generic_format_canonical.
-rewrite <- (Rplus_0_l (F2R (Float radix2 (Zpos my) ey))).
-apply Rplus_le_compat_r.
-now apply F2R_le_0.
-(* ... *)
-destruct sy.
-2: now elim Hs.
-clear Hs.
-apply Rabs_lt.
-split.
-apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)).
-rewrite F2R_Zopp.
-now apply Ropp_lt_contravar.
-apply round_ge_generic...
-now apply generic_format_canonical.
-pattern (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)) at 1 ; rewrite <- Rplus_0_l.
-apply Rplus_le_compat_r.
-now apply F2R_ge_0.
-apply Rle_lt_trans with (2 := Bx).
-apply round_le_generic...
-now apply generic_format_canonical.
-rewrite <- (Rplus_0_r (F2R (Float radix2 (Zpos mx) ex))).
-apply Rplus_le_compat_l.
-now apply F2R_le_0.
-(* . *)
-generalize (binary_normalize_correct m mz ez szero).
-case Rlt_bool_spec.
-split; try easy. split; try easy.
-destruct (Rcompare_spec (F2R (beta:=radix2) {| Fnum := mz; Fexp := ez |}) 0); try easy.
-rewrite H1 in Hp.
-apply Rplus_opp_r_uniq in Hp.
-rewrite <- F2R_Zopp in Hp.
-eapply canonical_unique in Hp.
-inversion Hp. destruct sy, sx, m; try discriminate H3; easy.
-apply canonical_canonical_mantissa.
-apply Bool.andb_true_iff in Hy. easy.
-replace (-cond_Zopp sx (Z.pos mx))%Z with (cond_Zopp (negb sx) (Z.pos mx))
-  by (destruct sx; auto).
-apply canonical_canonical_mantissa.
-apply Bool.andb_true_iff in Hx. easy.
-intros Hz' Vz.
-specialize (Sz Hz').
-split.
-rewrite Vz.
-now apply f_equal.
-apply Sz.
+intros plus_nan mode x y Fx Fy.
+rewrite <- is_finite_B2BSN in Fx, Fy.
+generalize (Bplus_correct prec emax _ _ mode _ _ Fx Fy).
+replace (BSN.Bplus _ _ _) with (B2BSN (Bplus plus_nan mode x y)) by apply B2BSN_BSN2B.
+rewrite 2!B2R_B2BSN.
+rewrite (Bsign_B2BSN x) by (clear -Fx ; now destruct x).
+rewrite (Bsign_B2BSN y) by (clear -Fy ; now destruct y).
+destruct Rlt_bool.
+- now destruct Bplus.
+- intros [H1 H2].
+  refine (conj _ H2).
+  apply eq_binary_overflow_FF2SF.
+  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
 Qed.
 
 (** Subtraction *)
 
 Definition Bminus minus_nan m x y :=
-  match x, y with
-  | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (minus_nan x y)
-  | B754_infinity sx, B754_infinity sy =>
-    if Bool.eqb sx (negb sy) then x else build_nan (minus_nan x y)
-  | B754_infinity _, _ => x
-  | _, B754_infinity sy => B754_infinity (negb sy)
-  | B754_zero sx, B754_zero sy =>
-    if Bool.eqb sx (negb sy) then x else
-    match m with mode_DN => B754_zero true | _ => B754_zero false end
-  | B754_zero _, B754_finite sy my ey Hy => B754_finite (negb sy) my ey Hy
-  | _, B754_zero _ => x
-  | B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
-    let ez := Z.min ex ey in
-    binary_normalize m (Zminus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez)))))
-      ez (match m with mode_DN => true | _ => false end)
-  end.
+  BSN2B (minus_nan x y) (Bminus m (B2BSN x) (B2BSN y)).
 
 Theorem Bminus_correct :
   forall minus_nan m x y,
@@ -1884,77 +1117,35 @@ Theorem Bminus_correct :
   else
     (B2FF (Bminus minus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = negb (Bsign y)).
 Proof with auto with typeclass_instances.
-intros minus_nan m x y Fx Fy.
-generalize (Bplus_correct minus_nan m x (Bopp (fun n => minus_nan n (B754_zero false)) y) Fx).
-rewrite is_finite_Bopp, B2R_Bopp.
-intros H.
-specialize (H Fy).
-replace (negb (Bsign y)) with (Bsign (Bopp (fun n => minus_nan n (B754_zero false)) y)).
-destruct x as [| | |sx mx ex Hx], y as [| | |sy my ey Hy] ; try easy.
-unfold Bminus, Zminus.
-now rewrite <- cond_Zopp_negb.
-now destruct y as [ | | | ].
+intros minus_nan mode x y Fx Fy.
+rewrite <- is_finite_B2BSN in Fx, Fy.
+generalize (Bminus_correct prec emax _ _ mode _ _ Fx Fy).
+replace (BSN.Bminus _ _ _) with (B2BSN (Bminus minus_nan mode x y)) by apply B2BSN_BSN2B.
+rewrite 2!B2R_B2BSN.
+rewrite (Bsign_B2BSN x) by (clear -Fx ; now destruct x).
+rewrite (Bsign_B2BSN y) by (clear -Fy ; now destruct y).
+destruct Rlt_bool.
+- now destruct Bminus.
+- intros [H1 H2].
+  refine (conj _ H2).
+  apply eq_binary_overflow_FF2SF.
+  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
 Qed.
 
 (** Fused Multiply-Add *)
 
-Definition Bfma_szero m (x y z: binary_float) : bool :=
-  let s_xy := xorb (Bsign x) (Bsign y) in  (* sign of product x*y *)
-  if Bool.eqb s_xy (Bsign z) then s_xy
-  else match m with mode_DN => true | _ => false end.
+Definition Bfma_szero m (x y z : binary_float) :=
+  Bfma_szero prec emax m (B2BSN x) (B2BSN y) (B2BSN z).
 
 Definition Bfma fma_nan m (x y z: binary_float) :=
-  match x, y with
-  | B754_nan _ _ _, _ | _, B754_nan _ _ _
-  | B754_infinity _, B754_zero _
-  | B754_zero _, B754_infinity _ =>
-      (* Multiplication produces NaN *)
-      build_nan (fma_nan x y z)
-  | B754_infinity sx, B754_infinity sy
-  | B754_infinity sx, B754_finite sy _ _ _
-  | B754_finite sx _ _ _, B754_infinity sy =>
-      let s := xorb sx sy in
-      (* Multiplication produces infinity with sign [s] *)
-      match z with
-      | B754_nan _ _ _ => build_nan (fma_nan x y z)
-      | B754_infinity sz =>
-          if Bool.eqb s sz then z else build_nan (fma_nan x y z)
-      | _ => B754_infinity s
-      end
-  | B754_finite sx _ _ _, B754_zero sy
-  | B754_zero sx, B754_finite sy _ _ _
-  | B754_zero sx, B754_zero sy =>
-      (* Multiplication produces zero *)
-      match z with
-      | B754_nan _ _ _ => build_nan (fma_nan x y z)
-      | B754_zero _ => B754_zero (Bfma_szero m x y z)
-      | _ => z
-      end
-  | B754_finite sx mx ex _, B754_finite sy my ey _ =>
-      (* Multiplication produces a finite, non-zero result *)
-      match z with
-      | B754_nan _ _ _ => build_nan (fma_nan x y z)
-      | B754_infinity sz => z
-      | B754_zero _ =>
-         let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in
-         let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in
-         let '(Float _ mr er) := Fmult X Y in
-         binary_normalize m mr er (Bfma_szero m x y z)
-      | B754_finite sz mz ez _ =>
-         let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in
-         let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in
-         let Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez in
-         let '(Float _ mr er) := Fplus (Fmult X Y) Z in
-         binary_normalize m mr er (Bfma_szero m x y z)
-      end
-  end.
+  BSN2B (fma_nan x y z) (Bfma m (B2BSN x) (B2BSN y) (B2BSN z)).
 
 Theorem Bfma_correct:
   forall fma_nan m x y z,
-  let res := (B2R x * B2R y + B2R z)%R in
   is_finite x = true ->
   is_finite y = true ->
   is_finite z = true ->
+  let res := (B2R x * B2R y + B2R z)%R in
   if Rlt_bool (Rabs (round radix2 fexp (round_mode m) res)) (bpow radix2 emax) then
     B2R (Bfma fma_nan m x y z) = round radix2 fexp (round_mode m) res /\
     is_finite (Bfma fma_nan m x y z) = true /\
@@ -1967,179 +1158,23 @@ Theorem Bfma_correct:
   else
     B2FF (Bfma fma_nan m x y z) = binary_overflow m (Rlt_bool res 0).
 Proof.
-  intros. pattern (Bfma fma_nan m x y z).
-  match goal with |- ?p ?x => set (PROP := p) end.
-  set (szero := Bfma_szero m x y z).
-  assert (BINORM: forall mr er, F2R (Float radix2 mr er) = res ->
-       PROP (binary_normalize m mr er szero)).
-  { intros mr er E.
-    specialize (binary_normalize_correct m mr er szero).
-    change (FLT_exp (3 - emax - prec) prec) with fexp. rewrite E. tauto.
-  }
-  set (add_zero :=
-    match z with
-    | B754_nan _ _ _ => build_nan (fma_nan x y z)
-    | B754_zero sz => B754_zero szero
-    | _ => z
-    end).
-  assert (ADDZERO: B2R x = 0%R \/ B2R y = 0%R -> PROP add_zero).
-  {
-    intros Z.
-    assert (RES: res = B2R z).
-    { unfold res. destruct Z as [E|E]; rewrite E, ?Rmult_0_l, ?Rmult_0_r, Rplus_0_l; auto. }
-    unfold PROP, add_zero; destruct z as [ sz | sz | sz plz | sz mz ez Bz]; try discriminate.
-  - simpl in RES; rewrite RES; rewrite round_0 by apply valid_rnd_round_mode.
-    rewrite Rlt_bool_true. split. reflexivity. split. reflexivity.
-    rewrite Rcompare_Eq by auto. reflexivity.
-    rewrite Rabs_R0; apply bpow_gt_0.
-  - rewrite RES, round_generic, Rlt_bool_true.
-    split. reflexivity. split. reflexivity.
-    unfold B2R. destruct sz.
-    rewrite Rcompare_Lt. auto. apply F2R_lt_0. reflexivity.
-    rewrite Rcompare_Gt. auto. apply F2R_gt_0. reflexivity.
-    apply abs_B2R_lt_emax. apply valid_rnd_round_mode. apply generic_format_B2R.
-  }
-  destruct x as [ sx | sx | sx plx | sx mx ex Bx];
-  destruct y as [ sy | sy | sy ply | sy my ey By];
-  try discriminate.
-- apply ADDZERO; auto.
-- apply ADDZERO; auto.
-- apply ADDZERO; auto.
-- destruct z as [ sz | sz | sz plz | sz mz ez Bz]; try discriminate; unfold Bfma.
-+ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex).
-  set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey).
-  destruct (Fmult X Y) as [mr er] eqn:FRES.
-  apply BINORM. unfold res. rewrite <- FRES, F2R_mult, Rplus_0_r. auto.
-+ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex).
-  set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey).
-  set (Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez).
-  destruct (Fplus (Fmult X Y) Z) as [mr er] eqn:FRES.
-  apply BINORM. unfold res. rewrite <- FRES, F2R_plus, F2R_mult. auto.
+intros fma_nan mode x y z Fx Fy Fz.
+rewrite <- is_finite_B2BSN in Fx, Fy, Fz.
+generalize (Bfma_correct prec emax _ _ mode _ _ _ Fx Fy Fz).
+replace (BSN.Bfma _ _ _ _) with (B2BSN (Bfma fma_nan mode x y z)) by apply B2BSN_BSN2B.
+rewrite 3!B2R_B2BSN.
+cbv zeta.
+destruct Rlt_bool.
+- now destruct Bfma.
+- intros H.
+  apply eq_binary_overflow_FF2SF.
+  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
 Qed.
 
 (** Division *)
 
-Definition Fdiv_core_binary m1 e1 m2 e2 :=
-  let d1 := Zdigits2 m1 in
-  let d2 := Zdigits2 m2 in
-  let e' := Z.min (fexp (d1 + e1 - (d2 + e2))) (e1 - e2) in
-  let s := (e1 - e2 - e')%Z in
-  let m' :=
-    match s with
-    | Zpos _  => Z.shiftl m1 s
-    | Z0 => m1
-    | Zneg _ => Z0
-    end in
-  let '(q, r) :=  Zfast_div_eucl m' m2 in
-  (q, e', new_location m2 r loc_Exact).
-
-Lemma Bdiv_correct_aux :
-  forall m sx mx ex sy my ey,
-  let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
-  let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in
-  let z :=
-    let '(mz, ez, lz) := Fdiv_core_binary (Zpos mx) ex (Zpos my) ey in
-    binary_round_aux m (xorb sx sy) mz ez lz in
-  valid_binary z = true /\
-  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then
-    FF2R radix2 z = round radix2 fexp (round_mode m) (x / y) /\
-    is_finite_FF z = true /\ sign_FF z = xorb sx sy
-  else
-    z = binary_overflow m (xorb sx sy).
-Proof.
-intros m sx mx ex sy my ey.
-unfold Fdiv_core_binary.
-rewrite 2!Zdigits2_Zdigits.
-set (e' := Z.min _ _).
-generalize (Fdiv_core_correct radix2 (Zpos mx) ex (Zpos my) ey e' eq_refl eq_refl).
-unfold Fdiv_core.
-rewrite Zle_bool_true by apply Z.le_min_r.
-match goal with |- context [Zfast_div_eucl ?m _] => set (mx' := m) end.
-assert (mx' = Zpos mx * Zpower radix2 (ex - ey - e'))%Z as <-.
-{ unfold mx'.
-  destruct (ex - ey - e')%Z as [|p|p].
-  now rewrite Zmult_1_r.
-  now rewrite Z.shiftl_mul_pow2.
-  easy. }
-clearbody mx'.
-rewrite Zfast_div_eucl_correct.
-destruct Z.div_eucl as [q r].
-intros Bz.
-assert (xorb sx sy = Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) *
-  / F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey)) 0) as ->.
-{ apply eq_sym.
-case sy ; simpl.
-change (Zneg my) with (Z.opp (Zpos my)).
-rewrite F2R_Zopp.
-rewrite <- Ropp_inv_permute.
-rewrite Ropp_mult_distr_r_reverse.
-case sx ; simpl.
-apply Rlt_bool_false.
-rewrite <- Ropp_mult_distr_l_reverse.
-apply Rmult_le_pos.
-rewrite <- F2R_opp.
-now apply F2R_ge_0.
-apply Rlt_le.
-apply Rinv_0_lt_compat.
-now apply F2R_gt_0.
-apply Rlt_bool_true.
-rewrite <- Ropp_0.
-apply Ropp_lt_contravar.
-apply Rmult_lt_0_compat.
-now apply F2R_gt_0.
-apply Rinv_0_lt_compat.
-now apply F2R_gt_0.
-apply Rgt_not_eq.
-now apply F2R_gt_0.
-case sx.
-apply Rlt_bool_true.
-rewrite F2R_Zopp.
-rewrite Ropp_mult_distr_l_reverse.
-rewrite <- Ropp_0.
-apply Ropp_lt_contravar.
-apply Rmult_lt_0_compat.
-now apply F2R_gt_0.
-apply Rinv_0_lt_compat.
-now apply F2R_gt_0.
-apply Rlt_bool_false.
-apply Rmult_le_pos.
-now apply F2R_ge_0.
-apply Rlt_le.
-apply Rinv_0_lt_compat.
-now apply F2R_gt_0. }
-unfold Rdiv.
-apply binary_round_aux_correct'.
-- apply Rmult_integral_contrapositive_currified.
-  now apply F2R_neq_0 ; case sx.
-  apply Rinv_neq_0_compat.
-  now apply F2R_neq_0 ; case sy.
-- rewrite Rabs_mult, Rabs_Rinv.
-  now rewrite <- 2!F2R_Zabs, 2!abs_cond_Zopp.
-  now apply F2R_neq_0 ; case sy.
-- rewrite <- cexp_abs, Rabs_mult, Rabs_Rinv.
-  rewrite 2!F2R_cond_Zopp, 2!abs_cond_Ropp, <- Rabs_Rinv.
-  rewrite <- Rabs_mult, cexp_abs.
-  apply Z.le_trans with (1 := Z.le_min_l _ _).
-  apply FLT_exp_monotone.
-  now apply mag_div_F2R.
-  now apply F2R_neq_0.
-  now apply F2R_neq_0 ; case sy.
-Qed.
-
 Definition Bdiv div_nan m x y :=
-  match x, y with
-  | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (div_nan x y)
-  | B754_infinity sx, B754_infinity sy => build_nan (div_nan x y)
-  | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy)
-  | B754_finite sx _ _ _, B754_infinity sy => B754_zero (xorb sx sy)
-  | B754_infinity sx, B754_zero sy => B754_infinity (xorb sx sy)
-  | B754_zero sx, B754_infinity sy => B754_zero (xorb sx sy)
-  | B754_finite sx _ _ _, B754_zero sy => B754_infinity (xorb sx sy)
-  | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy)
-  | B754_zero sx, B754_zero sy => build_nan (div_nan x y)
-  | B754_finite sx mx ex _, B754_finite sy my ey _ =>
-    FF2B _ (proj1 (Bdiv_correct_aux m sx mx ex sy my ey))
-  end.
+  BSN2B (div_nan x y) (Bdiv m (B2BSN x) (B2BSN y)).
 
 Theorem Bdiv_correct :
   forall div_nan m x y,
@@ -2152,164 +1187,25 @@ Theorem Bdiv_correct :
   else
     B2FF (Bdiv div_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
 Proof.
-intros div_nan m x [sy|sy|sy ply|sy my ey Hy] Zy ; try now elim Zy.
-revert x.
+intros div_nan mode x y Zy.
+rewrite <- B2R_B2BSN in Zy.
+generalize (Bdiv_correct prec emax _ _ mode (B2BSN x) _ Zy).
+replace (BSN.Bdiv _ _ _) with (B2BSN (Bdiv div_nan mode x y)) by apply B2BSN_BSN2B.
 unfold Rdiv.
-intros [sx|sx|sx plx Hx|sx mx ex Hx] ;
-  try ( rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | auto with typeclass_instances ] ).
-simpl.
-case Bdiv_correct_aux.
-intros H1.
-unfold Rdiv.
-case Rlt_bool.
-intros (H2, (H3, H4)).
-split.
-now rewrite B2R_FF2B.
-split.
-now rewrite is_finite_FF2B.
-rewrite Bsign_FF2B. congruence.
-intros H2.
-now rewrite B2FF_FF2B.
+destruct y as [sy|sy|sy ply|sy my ey Hy] ; try now elim Zy.
+destruct x as [sx|sx|sx plx Hx|sx mx ex Hx] ;
+  try ( simpl ; rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | auto with typeclass_instances ] ).
+destruct Rlt_bool.
+- now destruct Bdiv.
+- intros H.
+  apply eq_binary_overflow_FF2SF.
+  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
 Qed.
 
 (** Square root *)
 
-Definition Fsqrt_core_binary m e :=
-  let d := Zdigits2 m in
-  let e' := Z.min (fexp (Z.div2 (d + e + 1))) (Z.div2 e) in
-  let s := (e - 2 * e')%Z in
-  let m' :=
-    match s with
-    | Zpos p => Z.shiftl m s
-    | Z0 => m
-    | Zneg _ => Z0
-    end in
-  let (q, r) := Z.sqrtrem m' in
-  let l :=
-    if Zeq_bool r 0 then loc_Exact
-    else loc_Inexact (if Zle_bool r q then Lt else Gt) in
-  (q, e', l).
-
-Lemma Bsqrt_correct_aux :
-  forall m mx ex (Hx : bounded mx ex = true),
-  let x := F2R (Float radix2 (Zpos mx) ex) in
-  let z :=
-    let '(mz, ez, lz) := Fsqrt_core_binary (Zpos mx) ex in
-    binary_round_aux m false mz ez lz in
-  valid_binary z = true /\
-  FF2R radix2 z = round radix2 fexp (round_mode m) (sqrt x) /\
-  is_finite_FF z = true /\ sign_FF z = false.
-Proof with auto with typeclass_instances.
-intros m mx ex Hx.
-unfold Fsqrt_core_binary.
-rewrite Zdigits2_Zdigits.
-set (e' := Z.min _ _).
-assert (2 * e' <= ex)%Z as He.
-{ assert (e' <= Z.div2 ex)%Z by apply Z.le_min_r.
-  rewrite (Zdiv2_odd_eqn ex).
-  destruct Z.odd ; lia. }
-generalize (Fsqrt_core_correct radix2 (Zpos mx) ex e' eq_refl He).
-unfold Fsqrt_core.
-set (mx' := match (ex - 2 * e')%Z with Z0 => _ | _ => _ end).
-assert (mx' = Zpos mx * Zpower radix2 (ex - 2 * e'))%Z as <-.
-{ unfold mx'.
-  destruct (ex - 2 * e')%Z as [|p|p].
-  now rewrite Zmult_1_r.
-  now rewrite Z.shiftl_mul_pow2.
-  easy. }
-clearbody mx'.
-destruct Z.sqrtrem as [mz r].
-set (lz := if Zeq_bool r 0 then _ else _).
-clearbody lz.
-intros Bz.
-refine (_ (binary_round_aux_correct' m (sqrt (F2R (Float radix2 (Zpos mx) ex))) mz e' lz _ _ _)) ; cycle 1.
-  now apply Rgt_not_eq, sqrt_lt_R0, F2R_gt_0.
-  rewrite Rabs_pos_eq.
-  exact Bz.
-  apply sqrt_ge_0.
-  apply Z.le_trans with (1 := Z.le_min_l _ _).
-  apply FLT_exp_monotone.
-  rewrite mag_sqrt_F2R by easy.
-  apply Z.le_refl.
-rewrite Rlt_bool_false by apply sqrt_ge_0.
-rewrite Rlt_bool_true.
-easy.
-rewrite Rabs_pos_eq.
-refine (_ (relative_error_FLT_ex radix2 emin prec (prec_gt_0 prec) (round_mode m) (sqrt (F2R (Float radix2 (Zpos mx) ex))) _)).
-fold fexp.
-intros (eps, (Heps, Hr)).
-rewrite Hr.
-assert (Heps': (Rabs eps < 1)%R).
-apply Rlt_le_trans with (1 := Heps).
-fold (bpow radix2 0).
-apply bpow_le.
-generalize (prec_gt_0 prec).
-clear ; lia.
-apply Rsqr_incrst_0.
-3: apply bpow_ge_0.
-rewrite Rsqr_mult.
-rewrite Rsqr_sqrt.
-2: now apply F2R_ge_0.
-unfold Rsqr.
-apply Rmult_ge_0_gt_0_lt_compat.
-apply Rle_ge.
-apply Rle_0_sqr.
-apply bpow_gt_0.
-now apply bounded_lt_emax.
-apply Rlt_le_trans with 4%R.
-apply (Rsqr_incrst_1 _ 2).
-apply Rplus_lt_compat_l.
-apply (Rabs_lt_inv _ _ Heps').
-rewrite <- (Rplus_opp_r 1).
-apply Rplus_le_compat_l.
-apply Rlt_le.
-apply (Rabs_lt_inv _ _ Heps').
-now apply IZR_le.
-change 4%R with (bpow radix2 2).
-apply bpow_le.
-generalize (prec_gt_0 prec).
-clear -Hmax ; lia.
-apply Rmult_le_pos.
-apply sqrt_ge_0.
-rewrite <- (Rplus_opp_r 1).
-apply Rplus_le_compat_l.
-apply Rlt_le.
-apply (Rabs_lt_inv _ _ Heps').
-rewrite Rabs_pos_eq.
-2: apply sqrt_ge_0.
-apply Rsqr_incr_0.
-2: apply bpow_ge_0.
-2: apply sqrt_ge_0.
-rewrite Rsqr_sqrt.
-2: now apply F2R_ge_0.
-apply Rle_trans with (bpow radix2 emin).
-unfold Rsqr.
-rewrite <- bpow_plus.
-apply bpow_le.
-unfold emin.
-clear -Hmax ; lia.
-apply generic_format_ge_bpow with fexp.
-intros.
-apply Z.le_max_r.
-now apply F2R_gt_0.
-apply generic_format_canonical.
-apply (canonical_canonical_mantissa false).
-apply (andb_prop _ _ Hx).
-apply round_ge_generic...
-apply generic_format_0.
-apply sqrt_ge_0.
-Qed.
-
 Definition Bsqrt sqrt_nan m x :=
-  match x with
-  | B754_nan sx plx _ => build_nan (sqrt_nan x)
-  | B754_infinity false => x
-  | B754_infinity true => build_nan (sqrt_nan x)
-  | B754_finite true _ _ _ => build_nan (sqrt_nan x)
-  | B754_zero _ => x
-  | B754_finite sx mx ex Hx =>
-    FF2B _ (proj1 (Bsqrt_correct_aux m mx ex Hx))
-  end.
+  BSN2B (sqrt_nan x) (Bsqrt m (B2BSN x)).
 
 Theorem Bsqrt_correct :
   forall sqrt_nan m x,
@@ -2317,126 +1213,71 @@ Theorem Bsqrt_correct :
   is_finite (Bsqrt sqrt_nan m x) = match x with B754_zero _ => true | B754_finite false _ _ _ => true | _ => false end /\
   (is_nan (Bsqrt sqrt_nan m x) = false -> Bsign (Bsqrt sqrt_nan m x) = Bsign x).
 Proof.
-intros sqrt_nan m [sx|[|]|sx plx Hplx|sx mx ex Hx] ;
-  try ( simpl ; rewrite sqrt_0, round_0, ?B2R_build_nan, ?is_finite_build_nan, ?is_nan_build_nan ; intuition auto with typeclass_instances ; easy).
-simpl.
-case Bsqrt_correct_aux.
-intros H1 (H2, (H3, H4)).
-case sx.
-rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan.
-refine (conj _ (conj (refl_equal false) _)).
-apply sym_eq.
-unfold sqrt.
-case Rcase_abs.
-intros _.
-apply round_0.
-auto with typeclass_instances.
+intros sqrt_nan mode x.
+generalize (Bsqrt_correct prec emax _ _ mode (B2BSN x)).
+replace (BSN.Bsqrt _ _) with (B2BSN (Bsqrt sqrt_nan mode x)) by apply B2BSN_BSN2B.
 intros H.
-elim Rge_not_lt with (1 := H).
-now apply F2R_lt_0.
-easy.
-split.
-now rewrite B2R_FF2B.
-split.
-now rewrite is_finite_FF2B.
-intros _.
-now rewrite Bsign_FF2B.
+destruct x as [sx|[|]|sx plx Hplx|sx mx ex Hx] ; try easy.
+now destruct Bsqrt.
 Qed.
 
 (** A few values *)
 
-Definition Bone := FF2B _ (proj1 (binary_round_correct mode_NE false 1 0)).
+Definition Bone :=
+  BSN2B' _ (@is_nan_Bone prec emax _ _).
 
 Theorem Bone_correct : B2R Bone = 1%R.
 Proof.
-unfold Bone; simpl.
-set (Hr := binary_round_correct _ _ _ _).
-unfold Hr; rewrite B2R_FF2B.
-destruct Hr as (Vz, Hr).
-revert Hr.
-fold emin; simpl.
-rewrite round_generic; [|now apply valid_rnd_N|].
-- unfold F2R; simpl; rewrite Rmult_1_r.
-  rewrite Rlt_bool_true.
-  + now intros (Hr, Hr'); rewrite Hr.
-  + rewrite Rabs_pos_eq; [|lra].
-    change 1%R with (bpow radix2 0); apply bpow_lt.
-    unfold Prec_gt_0 in prec_gt_0_; lia.
-- apply generic_format_F2R; intros _.
-  unfold cexp, fexp, FLT_exp, F2R; simpl; rewrite Rmult_1_r, mag_1.
-  unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
+unfold Bone.
+rewrite B2R_BSN2B'.
+apply Bone_correct.
 Qed.
 
 Lemma is_finite_Bone : is_finite Bone = true.
 Proof.
-generalize Bone_correct; case Bone; simpl;
- try (intros; reflexivity); intros; exfalso; lra.
+unfold Bone.
+rewrite is_finite_BSN2B'.
+apply is_finite_Bone.
 Qed.
 
 Lemma Bsign_Bone : Bsign Bone = false.
 Proof.
-generalize Bone_correct; case Bone; simpl;
-  try (intros; exfalso; lra); intros s' m e _.
-case s'; [|now intro]; unfold F2R; simpl.
-intro H; exfalso; revert H; apply Rlt_not_eq, (Rle_lt_trans _ 0); [|lra].
-rewrite <-Ropp_0, <-(Ropp_involutive (_ * _)); apply Ropp_le_contravar.
-rewrite Ropp_mult_distr_l; apply Rmult_le_pos; [|now apply bpow_ge_0].
-unfold IZR; rewrite <-INR_IPR; generalize (INR_pos m); lra.
-Qed.
-
-Lemma Bmax_float_proof :
-  valid_binary
-    (F754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec))
-  = true.
-Proof.
-unfold valid_binary, bounded; apply andb_true_intro; split.
-- unfold canonical_mantissa; apply Zeq_bool_true.
-  set (p := Z.pos (digits2_pos _)).
-  assert (H : p = prec).
-  { unfold p; rewrite Zpos_digits2_pos, Pos2Z.inj_sub.
-    - rewrite shift_pos_correct, Z.mul_1_r.
-      assert (P2pm1 : (0 <= 2 ^ prec - 1)%Z).
-      { apply (Zplus_le_reg_r _ _ 1); ring_simplify.
-        change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
-        apply Zpower_le; unfold Prec_gt_0 in prec_gt_0_; lia. }
-      apply Zdigits_unique;
-        rewrite Z.pow_pos_fold, Z2Pos.id; [|exact prec_gt_0_]; simpl; split.
-      + rewrite (Z.abs_eq _ P2pm1).
-        replace prec with (prec - 1 + 1)%Z at 2 by ring.
-        rewrite Zpower_plus; [| unfold Prec_gt_0 in prec_gt_0_; lia|lia].
-        simpl; unfold Z.pow_pos; simpl.
-        assert (1 <= 2 ^ (prec - 1))%Z; [|lia].
-        change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
-        apply Zpower_le; simpl; unfold Prec_gt_0 in prec_gt_0_; lia.
-      + now rewrite Z.abs_eq; [lia|].
-    - change (_ < _)%positive
-        with (Z.pos 1 < Z.pos (shift_pos (Z.to_pos prec) 1))%Z.
-      rewrite shift_pos_correct, Z.mul_1_r, Z.pow_pos_fold.
-      rewrite Z2Pos.id; [|exact prec_gt_0_].
-      change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
-      apply Zpower_lt; unfold Prec_gt_0 in prec_gt_0_; lia. }
-  unfold fexp, FLT_exp; rewrite H, Z.max_l; [ring|].
-  unfold Prec_gt_0 in prec_gt_0_; unfold emin; lia.
-- apply Zle_bool_true; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
-Qed.
-
-Definition Bmax_float := FF2B _ Bmax_float_proof.
+unfold Bone.
+rewrite Bsign_BSN2B'.
+apply Bsign_Bone.
+Qed.
+
+Definition Bmax_float :=
+  BSN2B' Bmax_float eq_refl.
 
 (** Extraction/modification of mantissa/exponent *)
 
 Definition Bnormfr_mantissa x :=
-  match x with
-  | B754_finite _ mx ex _ =>
-    if Z.eqb ex (-prec)%Z then Npos mx else 0%N
-  | _ => 0%N
-  end.
+  Bnormfr_mantissa (B2BSN x).
 
-Definition Bldexp mode f e :=
-  match f with
-  | B754_finite sx mx ex _ =>
-    FF2B _ (proj1 (binary_round_correct mode sx mx (ex+e)))
-  | _ => f
-  end.
+Definition lift x y (Ny : @BSN.is_nan prec emax y = is_nan x) : binary_float.
+Proof.
+destruct (is_nan x).
+exact x.
+now apply (BSN2B' y).
+Defined.
+
+Lemma B2BSN_lift :
+  forall x y Ny,
+  B2BSN (lift x y Ny) = y.
+Proof.
+intros x y Ny.
+unfold lift.
+destruct x as [sx|sx|sx px Px|sx mx ex Bx] ; simpl ; try apply B2BSN_BSN2B'.
+now destruct y.
+Qed.
+
+Definition Bldexp (mode : mode) (x : binary_float) (e : Z) : binary_float.
+Proof.
+apply (lift x (Bldexp mode (B2BSN x) e)).
+rewrite <- is_nan_B2BSN.
+apply is_nan_Bldexp.
+Defined.
 
 Theorem Bldexp_correct :
   forall m (f : binary_float) e,
@@ -2450,144 +1291,38 @@ Theorem Bldexp_correct :
   else
     B2FF (Bldexp m f e) = binary_overflow m (Bsign f).
 Proof.
-intros m f e.
-case f.
-- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode].
-  now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0].
-- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode].
-  now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0].
-- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode].
-  now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0].
-- intros s mf ef Hmef.
-  case (Rlt_bool_spec _ _); intro Hover.
-  + unfold Bldexp; rewrite B2R_FF2B, is_finite_FF2B, Bsign_FF2B.
-    simpl; unfold F2R; simpl; rewrite Rmult_assoc, <-bpow_plus.
-    destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr).
-    fold emin in Hr; simpl in Hr; rewrite Rlt_bool_true in Hr.
-    * now destruct Hr as (Hr, (Hfr, Hsr)); rewrite Hr, Hfr, Hsr.
-    * now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus.
-  + unfold Bldexp; rewrite B2FF_FF2B; simpl.
-    destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr).
-    fold emin in Hr; simpl in Hr; rewrite Rlt_bool_false in Hr; [exact Hr|].
-    now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus.
-Qed.
+intros mode x e.
+generalize (Bldexp_correct prec emax _ _ mode (B2BSN x) e).
+replace (BSN.Bldexp _ _ _) with (B2BSN (Bldexp mode x e)) by apply B2BSN_lift.
+rewrite B2R_B2BSN.
+destruct Rlt_bool.
+- destruct x as [sx|sx|sx px Px|sx mx ex Bx] ; try easy.
+  now destruct Bldexp.
+- intros H.
+  apply eq_binary_overflow_FF2SF.
+  rewrite B2SF_B2BSN in H.
+  rewrite FF2SF_B2FF, H.
+  destruct x as [sx|sx|sx px Px|sx mx ex Bx] ; simpl in H ; try easy.
+  contradict H.
+  unfold BSN.binary_overflow.
+  now destruct overflow_to_inf.
+Qed.
+
+Section Bfrexp.
 
 (** This hypothesis is needed to implement [Bfrexp]
     (otherwise, we have emin > - prec
      and [Bfrexp] cannot fit the mantissa in interval #[0.5, 1)#) *)
-Hypothesis Hemax : (3 <= emax)%Z.
+Hypothesis Hemax : (2 < emax)%Z.
 
-Definition Ffrexp_core_binary s m e :=
-  if (Z.to_pos prec <=? digits2_pos m)%positive then
-    (F754_finite s m (-prec), (e + prec)%Z)
-  else
-    let d := (prec - Z.pos (digits2_pos m))%Z in
-    (F754_finite s (shift_pos (Z.to_pos d) m) (-prec), (e + prec - d)%Z).
-
-Lemma Bfrexp_correct_aux :
-  forall sx mx ex (Hx : bounded mx ex = true),
-  let x := F2R (Float radix2 (cond_Zopp sx (Z.pos mx)) ex) in
-  let z := fst (Ffrexp_core_binary sx mx ex) in
-  let e := snd (Ffrexp_core_binary sx mx ex) in
-  valid_binary z = true /\
-  (/2 <= Rabs (FF2R radix2 z) < 1)%R /\
-  (x = FF2R radix2 z * bpow radix2 e)%R.
-Proof.
-intros sx mx ex Bx.
-set (x := F2R _).
-set (z := fst _).
-set (e := snd _); simpl.
-assert (Dmx_le_prec : (Z.pos (digits2_pos mx) <= prec)%Z).
-{ revert Bx; unfold bounded; rewrite Bool.andb_true_iff.
-  unfold canonical_mantissa; rewrite <-Zeq_is_eq_bool; unfold fexp, FLT_exp.
-  case (Z.max_spec (Z.pos (digits2_pos mx) + ex - prec) emin); lia. }
-assert (Dmx_le_prec' : (digits2_pos mx <= Z.to_pos prec)%positive).
-{ change (_ <= _)%positive
-    with (Z.pos (digits2_pos mx) <= Z.pos (Z.to_pos prec))%Z.
-  now rewrite Z2Pos.id; [|now apply prec_gt_0_]. }
-unfold z, e, Ffrexp_core_binary.
-case (Pos.leb_spec _ _); simpl; intro Dmx.
-- unfold bounded, F2R; simpl.
-  assert (Dmx' : digits2_pos mx = Z.to_pos prec).
-  { now apply Pos.le_antisym. }
-  assert (Dmx'' : Z.pos (digits2_pos mx) = prec).
-  { now rewrite Dmx', Z2Pos.id; [|apply prec_gt_0_]. }
-  split; [|split].
-  + apply andb_true_intro.
-    split; [|apply Zle_bool_true; lia].
-    apply Zeq_bool_true; unfold fexp, FLT_exp.
-    rewrite Dmx', Z2Pos.id; [|now apply prec_gt_0_].
-    rewrite Z.max_l; [ring|unfold emin; lia].
-  + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0].
-    rewrite <-abs_IZR, abs_cond_Zopp; simpl; split.
-    * apply (Rmult_le_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|].
-      rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl.
-      rewrite Rmult_1_r.
-      change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus.
-      rewrite <-Dmx'', Z.add_comm, Zpos_digits2_pos, Zdigits_mag; [|lia].
-      set (b := bpow _ _).
-      rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
-      apply bpow_mag_le; apply IZR_neq; lia.
-    * apply (Rmult_lt_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|].
-      rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl.
-      rewrite Rmult_1_l, Rmult_1_r.
-      rewrite <-Dmx'', Zpos_digits2_pos, Zdigits_mag; [|lia].
-      set (b := bpow _ _).
-      rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
-      apply bpow_mag_gt; apply IZR_neq; lia.
-  + unfold x, F2R; simpl; rewrite Rmult_assoc, <-bpow_plus.
-    now replace (_ + _)%Z with ex by ring.
-- unfold bounded, F2R; simpl.
-  assert (Dmx' : (Z.pos (digits2_pos mx) < prec)%Z).
-  { now rewrite <-(Z2Pos.id prec); [|now apply prec_gt_0_]. }
-  split; [|split].
-  + unfold bounded; apply andb_true_intro.
-    split; [|apply Zle_bool_true; lia].
-    apply Zeq_bool_true; unfold fexp, FLT_exp.
-    rewrite Zpos_digits2_pos, shift_pos_correct, Z.pow_pos_fold.
-    rewrite Z2Pos.id; [|lia].
-    rewrite Z.mul_comm; change 2%Z with (radix2 : Z).
-    rewrite Zdigits_mult_Zpower; [|lia|lia].
-    rewrite Zpos_digits2_pos; replace (_ - _)%Z with (- prec)%Z by ring.
-    now rewrite Z.max_l; [|unfold emin; lia].
-  + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0].
-    rewrite <-abs_IZR, abs_cond_Zopp; simpl.
-    rewrite shift_pos_correct, mult_IZR.
-    change (IZR (Z.pow_pos _ _))
-      with (bpow radix2 (Z.pos (Z.to_pos ((prec - Z.pos (digits2_pos mx)))))).
-    rewrite Z2Pos.id; [|lia].
-    rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus.
-    set (d := Z.pos (digits2_pos mx)).
-    replace (_ + _)%Z with (- d)%Z by ring; split.
-    * apply (Rmult_le_reg_l (bpow radix2 d)); [now apply bpow_gt_0|].
-      rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r.
-      rewrite Rmult_1_l.
-      change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus.
-      rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
-      unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia].
-      apply bpow_mag_le; apply IZR_neq; lia.
-    * apply (Rmult_lt_reg_l (bpow radix2 d)); [now apply bpow_gt_0|].
-      rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r.
-      rewrite Rmult_1_l, Rmult_1_r.
-      rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
-      unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia].
-      apply bpow_mag_gt; apply IZR_neq; lia.
-  + rewrite Rmult_assoc, <-bpow_plus, shift_pos_correct.
-    rewrite IZR_cond_Zopp, mult_IZR, cond_Ropp_mult_r, <-IZR_cond_Zopp.
-    change (IZR (Z.pow_pos _ _))
-      with (bpow radix2 (Z.pos (Z.to_pos (prec - Z.pos (digits2_pos mx))))).
-    rewrite Z2Pos.id; [|lia].
-    rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus.
-    now replace (_ + _)%Z with ex by ring; rewrite Rmult_comm.
-Qed.
-
-Definition Bfrexp f :=
-  match f with
-  | B754_finite s m e H =>
-    let e' := snd (Ffrexp_core_binary s m e) in
-    (FF2B _ (proj1 (Bfrexp_correct_aux s m e H)), e')
-  | _ => (f, (-2*emax-prec)%Z)
-  end.
+Definition Bfrexp (x : binary_float) : binary_float * Z.
+Proof.
+set (y := Bfrexp (B2BSN x)).
+refine (pair _ (snd y)).
+apply (lift x (fst y)).
+rewrite <- is_nan_B2BSN.
+apply is_nan_Bfrexp.
+Defined.
 
 Theorem Bfrexp_correct :
   forall f,
@@ -2599,19 +1334,27 @@ Theorem Bfrexp_correct :
   (x = B2R z * bpow radix2 e)%R /\
   e = mag radix2 x.
 Proof.
-intro f; case f; intro s; try discriminate; intros m e Hf _.
-generalize (Bfrexp_correct_aux s m e Hf).
-intros (_, (Hb, Heq)); simpl; rewrite B2R_FF2B.
-split; [now simpl|]; split; [now simpl|].
-rewrite Heq, mag_mult_bpow.
-- apply (Z.add_reg_l (- (snd (Ffrexp_core_binary s m e)))).
-  now ring_simplify; symmetry; apply mag_unique.
-- intro H; destruct Hb as (Hb, _); revert Hb; rewrite H, Rabs_R0; lra.
+intros x Fx.
+rewrite <- is_finite_strict_B2BSN in Fx.
+generalize (Bfrexp_correct prec emax _ (B2BSN x) Fx).
+simpl.
+rewrite <- B2R_B2BSN.
+rewrite B2BSN_lift.
+destruct BSN.Bfrexp as [z e].
+rewrite B2R_B2BSN.
+now intros [H1 [H2 H3]].
 Qed.
 
+End Bfrexp.
+
 (** Ulp *)
 
-Definition Bulp x := Bldexp mode_NE Bone (fexp (snd (Bfrexp x))).
+Definition Bulp (x : binary_float) : binary_float.
+Proof.
+apply (lift x (Bulp (B2BSN x))).
+rewrite <- is_nan_B2BSN.
+apply is_nan_Bulp.
+Defined.
 
 Theorem Bulp_correct :
   forall x,
@@ -2620,373 +1363,72 @@ Theorem Bulp_correct :
   is_finite (Bulp x) = true /\
   Bsign (Bulp x) = false.
 Proof.
-intro x; case x.
-- intros s _; unfold Bulp.
-  replace (fexp _) with emin.
-  + generalize (Bldexp_correct mode_NE Bone emin).
-    rewrite Bone_correct, Rmult_1_l, round_generic;
-      [|now apply valid_rnd_N|apply generic_format_bpow; unfold fexp, FLT_exp;
-        rewrite Z.max_r; unfold Prec_gt_0 in prec_gt_0_; lia].
-    rewrite Rlt_bool_true.
-    * intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs.
-      split; [|now split; [apply is_finite_Bone|apply Bsign_Bone]].
-      simpl; unfold ulp; rewrite Req_bool_true; [|reflexivity].
-      destruct (negligible_exp_FLT emin prec) as (n, (Hn, Hn')).
-      change fexp with (FLT_exp emin prec); rewrite Hn.
-      now unfold FLT_exp; rewrite Z.max_r;
-        [|unfold Prec_gt_0 in prec_gt_0_; lia].
-    * rewrite Rabs_pos_eq; [|now apply bpow_ge_0]; apply bpow_lt.
-      unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
-  + simpl; change (fexp _) with (fexp (-2 * emax - prec)).
-    unfold fexp, FLT_exp; rewrite Z.max_r; [reflexivity|].
-    unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
-- intro; discriminate.
-- intros s pl Hpl; discriminate.
-- intros s m e Hme _; unfold Bulp, ulp, cexp.
-  set (f := B754_finite _ _ _ _).
-  rewrite Req_bool_false.
-  + destruct (Bfrexp_correct f (eq_refl _)) as (Hfr1, (Hfr2, Hfr3)).
-    rewrite Hfr3.
-    set (e' := fexp _).
-    generalize (Bldexp_correct mode_NE Bone e').
-    rewrite Bone_correct, Rmult_1_l, round_generic; [|now apply valid_rnd_N|].
-    { rewrite Rlt_bool_true.
-      - intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs.
-        now split; [|split; [apply is_finite_Bone|apply Bsign_Bone]].
-      - rewrite Rabs_pos_eq; [|now apply bpow_ge_0].
-        unfold e', fexp, FLT_exp.
-        case (Z.max_spec (mag radix2 (B2R f) - prec) emin)
-          as [(_, Hm)|(_, Hm)]; rewrite Hm; apply bpow_lt;
-          [now unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia|].
-        apply (Zplus_lt_reg_r _ _ prec); ring_simplify.
-        assert (mag radix2 (B2R f) <= emax)%Z;
-          [|now unfold Prec_gt_0 in prec_gt_0_; lia].
-        apply mag_le_bpow; [|now apply abs_B2R_lt_emax].
-        now unfold f, B2R; apply F2R_neq_0; case s. }
-    apply generic_format_bpow, Z.max_lub.
-    * unfold Prec_gt_0 in prec_gt_0_; lia.
-    * apply Z.le_max_r.
-  + now unfold f, B2R; apply F2R_neq_0; case s.
+intros x Fx.
+rewrite <- is_finite_B2BSN in Fx.
+generalize (Bulp_correct prec emax _ _ _ Fx).
+replace (BSN.Bulp (B2BSN x)) with (B2BSN (Bulp x)) by apply B2BSN_lift.
+rewrite 2!B2R_B2BSN.
+now destruct Bulp.
 Qed.
 
 (** Successor (and predecessor) *)
 
-Definition Bpred_pos pred_pos_nan x :=
-  match x with
-  | B754_finite _ mx _ _ =>
-    let d :=
-      if (mx~0 =? shift_pos (Z.to_pos prec) 1)%positive then
-        Bldexp mode_NE Bone (fexp (snd (Bfrexp x) - 1))
-      else
-        Bulp x in
-    Bminus (fun _ => pred_pos_nan) mode_NE x d
-  | _ => x
-  end.
-
-Theorem Bpred_pos_correct :
-  forall pred_pos_nan x,
-  (0 < B2R x)%R ->
-  B2R (Bpred_pos pred_pos_nan x) = pred_pos radix2 fexp (B2R x) /\
-  is_finite (Bpred_pos pred_pos_nan x) = true /\
-  Bsign (Bpred_pos pred_pos_nan x) = false.
-Proof.
-intros pred_pos_nan x.
-generalize (Bfrexp_correct x).
-case x.
-- simpl; intros s _ Bx; exfalso; apply (Rlt_irrefl _ Bx).
-- simpl; intros s _ Bx; exfalso; apply (Rlt_irrefl _ Bx).
-- simpl; intros s pl Hpl _ Bx; exfalso; apply (Rlt_irrefl _ Bx).
-- intros sx mx ex Hmex Hfrexpx Px.
-  assert (Hsx : sx = false).
-  { revert Px; case sx; unfold B2R, F2R; simpl; [|now intro].
-    intro Px; exfalso; revert Px; apply Rle_not_lt.
-    rewrite <-(Rmult_0_l (bpow radix2 ex)).
-    apply Rmult_le_compat_r; [apply bpow_ge_0|apply IZR_le; lia]. }
-  clear Px; rewrite Hsx in Hfrexpx |- *; clear Hsx sx.
-  specialize (Hfrexpx (eq_refl _)).
-  simpl in Hfrexpx; rewrite B2R_FF2B in Hfrexpx.
-  destruct Hfrexpx as (Hfrexpx_bounds, (Hfrexpx_eq, Hfrexpx_exp)).
-  unfold Bpred_pos, Bfrexp.
-  simpl (snd (_, snd _)).
-  rewrite Hfrexpx_exp.
-  set (x' := B754_finite _ _ _ _).
-  set (xr := F2R _).
-  assert (Nzxr : xr <> 0%R).
-  { unfold xr, F2R; simpl.
-    rewrite <-(Rmult_0_l (bpow radix2 ex)); intro H.
-    apply Rmult_eq_reg_r in H; [|apply Rgt_not_eq, bpow_gt_0].
-    apply eq_IZR in H; lia. }
-  assert (Hulp := Bulp_correct x').
-  specialize (Hulp (eq_refl _)).
-  assert (Hldexp := Bldexp_correct mode_NE Bone (fexp (mag radix2 xr - 1))).
-  rewrite Bone_correct, Rmult_1_l in Hldexp.
-  assert (Fbpowxr : generic_format radix2 fexp
-                      (bpow radix2 (fexp (mag radix2 xr - 1)))).
-  { apply generic_format_bpow, Z.max_lub.
-    - unfold Prec_gt_0 in prec_gt_0_; lia.
-    - apply Z.le_max_r. }
-  assert (H : Rlt_bool (Rabs
-               (round radix2 fexp (round_mode mode_NE)
-                  (bpow radix2 (fexp (mag radix2 xr - 1)))))
-              (bpow radix2 emax) = true); [|rewrite H in Hldexp; clear H].
-  { apply Rlt_bool_true; rewrite round_generic;
-      [|apply valid_rnd_round_mode|apply Fbpowxr].
-    rewrite Rabs_pos_eq; [|apply bpow_ge_0]; apply bpow_lt.
-    apply Z.max_lub_lt; [|unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia].
-    apply (Zplus_lt_reg_r _ _ (prec + 1)); ring_simplify.
-    rewrite Z.add_1_r; apply Zle_lt_succ, mag_le_bpow.
-    - exact Nzxr.
-    - apply (Rlt_le_trans _ (bpow radix2 emax)).
-      + change xr with (B2R x'); apply abs_B2R_lt_emax.
-      + apply bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. }
-  set (d := if (mx~0 =? _)%positive then _ else _).
-  set (minus_nan := fun _ => _).
-  assert (Hminus := Bminus_correct minus_nan mode_NE x' d (eq_refl _)).
-  assert (Fd : is_finite d = true).
-  { unfold d; case (_ =? _)%positive.
-    - now rewrite (proj1 (proj2 Hldexp)), is_finite_Bone.
-    - now rewrite (proj1 (proj2 Hulp)). }
-  specialize (Hminus Fd).
-  assert (Px : (0 <= B2R x')%R).
-  { unfold B2R, x', F2R; simpl.
-    now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. }
-  assert (Pd : (0 <= B2R d)%R).
-  { unfold d; case (_ =? _)%positive.
-    - rewrite (proj1 Hldexp).
-      now rewrite round_generic; [apply bpow_ge_0|apply valid_rnd_N|].
-    - rewrite (proj1 Hulp); apply ulp_ge_0. }
-  assert (Hdlex : (B2R d <= B2R x')%R).
-  { unfold d; case (_ =? _)%positive.
-    - rewrite (proj1 Hldexp).
-      rewrite round_generic; [|now apply valid_rnd_N|now simpl].
-      apply (Rle_trans _ (bpow radix2 (mag radix2 xr - 1))).
-      + apply bpow_le, Z.max_lub.
-        * unfold Prec_gt_0 in prec_gt_0_; lia.
-        * apply (Zplus_le_reg_r _ _ 1); ring_simplify.
-          apply mag_ge_bpow.
-          replace (_ - 1)%Z with emin by ring.
-          now change xr with (B2R x'); apply abs_B2R_ge_emin.
-      + rewrite <-(Rabs_pos_eq _ Px).
-        now change xr with (B2R x'); apply bpow_mag_le.
-    - rewrite (proj1 Hulp); apply ulp_le_id.
-      + assert (B2R x' <> 0%R); [exact Nzxr|lra].
-      + apply generic_format_B2R. }
-  assert (H : Rlt_bool
-            (Rabs
-               (round radix2 fexp
-                  (round_mode mode_NE) (B2R x' - B2R d)))
-            (bpow radix2 emax) = true); [|rewrite H in Hminus; clear H].
-  { apply Rlt_bool_true.
-    rewrite <-round_NE_abs; [|now apply FLT_exp_valid].
-    rewrite Rabs_pos_eq; [|lra].
-    apply (Rle_lt_trans _ (B2R x')).
-    - apply round_le_generic;
-        [now apply FLT_exp_valid|now apply valid_rnd_N| |lra].
-      apply generic_format_B2R.
-    - apply (Rle_lt_trans _ _ _ (Rle_abs _)), abs_B2R_lt_emax. }
-  rewrite (proj1 Hminus).
-  rewrite (proj1 (proj2 Hminus)).
-  rewrite (proj2 (proj2 Hminus)).
-  split; [|split; [reflexivity|now case (Rcompare_spec _ _); [lra| |]]].
-  unfold pred_pos, d.
-  case (Pos.eqb_spec _ _); intro Hd; case (Req_bool_spec _ _); intro Hpred.
-  + rewrite (proj1 Hldexp).
-    rewrite (round_generic _ _ _ _ Fbpowxr).
-    change xr with (B2R x').
-    replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')).
-    * rewrite round_generic; [reflexivity|now apply valid_rnd_N|].
-      apply generic_format_pred_pos;
-        [now apply FLT_exp_valid|apply generic_format_B2R|].
-      change xr with (B2R x') in Nzxr; lra.
-    * now unfold pred_pos; rewrite Req_bool_true.
-  + exfalso; apply Hpred.
-    assert (Hmx : IZR (Z.pos mx) = bpow radix2 (prec - 1)).
-    { apply (Rmult_eq_reg_l 2); [|lra]; rewrite <-mult_IZR.
-      change (2 * Z.pos mx)%Z with (Z.pos mx~0); rewrite Hd.
-      rewrite shift_pos_correct, Z.mul_1_r.
-      change (IZR (Z.pow_pos _ _)) with (bpow radix2 (Z.pos (Z.to_pos prec))).
-      rewrite Z2Pos.id; [|exact prec_gt_0_].
-      change 2%R with (bpow radix2 1); rewrite <-bpow_plus.
-      f_equal; ring. }
-    unfold x' at 1; unfold B2R at 1; unfold F2R; simpl.
-    rewrite Hmx, <-bpow_plus; f_equal.
-    apply (Z.add_reg_l 1); ring_simplify; symmetry; apply mag_unique_pos.
-    unfold F2R; simpl; rewrite Hmx, <-bpow_plus; split.
-    * right; f_equal; ring.
-    * apply bpow_lt; lia.
-  + rewrite (proj1 Hulp).
-    assert (H : ulp radix2 fexp (B2R x')
-                = bpow radix2 (fexp (mag radix2 (B2R x') - 1)));
-      [|rewrite H; clear H].
-    { unfold ulp; rewrite Req_bool_false; [|now simpl].
-      unfold cexp; f_equal.
-      assert (H : (mag radix2 (B2R x') <= emin + prec)%Z).
-      { assert (Hcm : canonical_mantissa mx ex = true).
-        { now generalize Hmex; unfold bounded; rewrite Bool.andb_true_iff. }
-        apply (canonical_canonical_mantissa false) in Hcm.
-        revert Hcm; fold emin; unfold canonical, cexp; simpl.
-        change (F2R _) with (B2R x'); intro Hex.
-        apply Z.nlt_ge; intro H'; apply Hd.
-        apply Pos2Z.inj_pos; rewrite shift_pos_correct, Z.mul_1_r.
-        apply eq_IZR; change (IZR (Z.pow_pos _ _))
-          with (bpow radix2 (Z.pos (Z.to_pos prec))).
-        rewrite Z2Pos.id; [|exact prec_gt_0_].
-        change (Z.pos mx~0) with (2 * Z.pos mx)%Z.
-        rewrite Z.mul_comm, mult_IZR.
-        apply (Rmult_eq_reg_r (bpow radix2 (ex - 1)));
-          [|apply Rgt_not_eq, bpow_gt_0].
-        change 2%R with (bpow radix2 1); rewrite Rmult_assoc, <-!bpow_plus.
-        replace (1 + _)%Z with ex by ring.
-        unfold B2R at 1, F2R in Hpred; simpl in Hpred; rewrite Hpred.
-        change (F2R _) with (B2R x'); rewrite Hex.
-        unfold fexp, FLT_exp; rewrite Z.max_l; [f_equal; ring|lia]. }
-      now unfold fexp, FLT_exp; do 2 (rewrite Z.max_r; [|lia]). }
-    replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')).
-    * rewrite round_generic; [reflexivity|apply valid_rnd_N|].
-      apply generic_format_pred_pos;
-        [now apply FLT_exp_valid| |change xr with (B2R x') in Nzxr; lra].
-      apply generic_format_B2R.
-    * now unfold pred_pos; rewrite Req_bool_true.
-  + rewrite (proj1 Hulp).
-    replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')).
-    * rewrite round_generic; [reflexivity|now apply valid_rnd_N|].
-      apply generic_format_pred_pos;
-        [now apply FLT_exp_valid|apply generic_format_B2R|].
-      change xr with (B2R x') in Nzxr; lra.
-    * now unfold pred_pos; rewrite Req_bool_false.
-Qed.
-
-Definition Bsucc succ_nan x :=
-  match x with
-  | B754_zero _ => Bldexp mode_NE Bone emin
-  | B754_infinity false => x
-  | B754_infinity true => Bopp succ_nan Bmax_float
-  | B754_nan _ _ _ => build_nan (succ_nan x)
-  | B754_finite false _ _ _ =>
-    Bplus (fun _ => succ_nan) mode_NE x (Bulp x)
-  | B754_finite true _ _ _ =>
-    Bopp succ_nan (Bpred_pos succ_nan (Bopp succ_nan x))
-  end.
+Definition Bsucc (x : binary_float) : binary_float.
+Proof.
+apply (lift x (Bsucc (B2BSN x))).
+rewrite <- is_nan_B2BSN.
+apply is_nan_Bsucc.
+Defined.
 
 Lemma Bsucc_correct :
-  forall succ_nan x,
+  forall x,
   is_finite x = true ->
   if Rlt_bool (succ radix2 fexp (B2R x)) (bpow radix2 emax) then
-    B2R (Bsucc succ_nan x) = succ radix2 fexp (B2R x) /\
-    is_finite (Bsucc succ_nan x) = true /\
-    (Bsign (Bsucc succ_nan x) = Bsign x && is_finite_strict x)%bool
+    B2R (Bsucc x) = succ radix2 fexp (B2R x) /\
+    is_finite (Bsucc x) = true /\
+    (Bsign (Bsucc x) = Bsign x && is_finite_strict x)%bool
   else
-    B2FF (Bsucc succ_nan x) = F754_infinity false.
-Proof.
-assert (Hsucc : succ radix2 fexp 0 = bpow radix2 emin).
-{ unfold succ; rewrite Rle_bool_true; [|now right]; rewrite Rplus_0_l.
-  unfold ulp; rewrite Req_bool_true; [|now simpl].
-  destruct (negligible_exp_FLT emin prec) as (n, (Hne, Hn)).
-  now unfold fexp; rewrite Hne; unfold FLT_exp; rewrite Z.max_r;
-    [|unfold Prec_gt_0 in prec_gt_0_; lia]. }
-intros succ_nan [s|s|s pl Hpl|sx mx ex Hmex]; try discriminate; intros _.
-- generalize (Bldexp_correct mode_NE Bone emin); unfold Bsucc; simpl.
-  assert (Hbemin : round radix2 fexp ZnearestE (bpow radix2 emin)
-                   = bpow radix2 emin).
-  { rewrite round_generic; [reflexivity|apply valid_rnd_N|].
-    apply generic_format_bpow.
-    unfold fexp, FLT_exp; rewrite Z.max_r; [now simpl|].
-    unfold Prec_gt_0 in prec_gt_0_; lia. }
-  rewrite Hsucc, Rlt_bool_true.
-  + intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs.
-    rewrite Bone_correct, Rmult_1_l, is_finite_Bone, Bsign_Bone.
-    case Rlt_bool_spec; intro Hover.
-    * now rewrite Bool.andb_false_r.
-    * exfalso; revert Hover; apply Rlt_not_le, bpow_lt.
-      unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
-  + rewrite Bone_correct, Rmult_1_l, Hbemin, Rabs_pos_eq; [|apply bpow_ge_0].
-    apply bpow_lt; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
-- unfold Bsucc; case sx.
-  + case Rlt_bool_spec; intro Hover.
-    * rewrite B2R_Bopp; simpl (Bopp _ (B754_finite _ _ _ _)).
-      rewrite is_finite_Bopp.
-      set (ox := B754_finite false mx ex Hmex).
-      assert (Hpred := Bpred_pos_correct succ_nan ox).
-      assert (Hox : (0 < B2R ox)%R); [|specialize (Hpred Hox); clear Hox].
-      { now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. }
-      rewrite (proj1 Hpred), (proj1 (proj2 Hpred)).
-      unfold succ; rewrite Rle_bool_false; [split; [|split]|].
-      { now unfold B2R, F2R, ox; simpl; rewrite Ropp_mult_distr_l, <-opp_IZR. }
-      { now simpl. }
-      { simpl (Bsign (B754_finite _ _ _ _)); simpl (true && _)%bool.
-        rewrite Bsign_Bopp, (proj2 (proj2 Hpred)); [now simpl|].
-        now destruct Hpred as (_, (H, _)); revert H; case (Bpred_pos _ _). }
-      unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z.
-      rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_lt_contravar.
-      now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0].
-    * exfalso; revert Hover; apply Rlt_not_le.
-      apply (Rle_lt_trans _ (succ radix2 fexp 0)).
-      { apply succ_le; [now apply FLT_exp_valid|apply generic_format_B2R|
-                        apply generic_format_0|].
-        unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z.
-        rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_le_contravar.
-        now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. }
-      rewrite Hsucc; apply bpow_lt.
-      unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
-  + set (x := B754_finite _ _ _ _).
-    set (plus_nan := fun _ => succ_nan).
-    assert (Hulp := Bulp_correct x (eq_refl _)).
-    assert (Hplus := Bplus_correct plus_nan mode_NE x (Bulp x) (eq_refl _)).
-    rewrite (proj1 (proj2 Hulp)) in Hplus; specialize (Hplus (eq_refl _)).
-    assert (Px : (0 <= B2R x)%R).
-    { now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. }
-    assert (Hsucc' : (succ radix2 fexp (B2R x)
-                      = B2R x + ulp radix2 fexp (B2R x))%R).
-    { now unfold succ; rewrite (Rle_bool_true _ _ Px). }
-    rewrite (proj1 Hulp), <- Hsucc' in Hplus.
-    rewrite round_generic in Hplus;
-      [|apply valid_rnd_N| now apply generic_format_succ;
-                           [apply FLT_exp_valid|apply generic_format_B2R]].
-    rewrite Rabs_pos_eq in Hplus; [|apply (Rle_trans _ _ _ Px), succ_ge_id].
-    revert Hplus; case Rlt_bool_spec; intros Hover Hplus.
-    * split; [now simpl|split; [now simpl|]].
-      rewrite (proj2 (proj2 Hplus)); case Rcompare_spec.
-      { intro H; exfalso; revert H.
-        apply Rle_not_lt, (Rle_trans _ _ _ Px), succ_ge_id. }
-      { intro H; exfalso; revert H; apply Rgt_not_eq, Rlt_gt.
-        apply (Rlt_le_trans _ (B2R x)); [|apply succ_ge_id].
-        now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. }
-      now simpl.
-    * now rewrite (proj1 Hplus).
-Qed.
-
-Definition Bpred pred_nan x :=
-  Bopp pred_nan (Bsucc pred_nan (Bopp pred_nan x)).
+    B2FF (Bsucc x) = F754_infinity false.
+Proof.
+intros x Fx.
+rewrite <- is_finite_B2BSN in Fx.
+generalize (Bsucc_correct prec emax _ _ _ Fx).
+replace (BSN.Bsucc (B2BSN x)) with (B2BSN (Bsucc x)) by apply B2BSN_lift.
+rewrite 2!B2R_B2BSN.
+destruct Rlt_bool.
+- rewrite (Bsign_B2BSN x) by now destruct x.
+  rewrite is_finite_strict_B2BSN.
+  now destruct Bsucc.
+- now destruct Bsucc as [|[|]| |].
+Qed.
+
+Definition Bpred (x : binary_float) : binary_float.
+Proof.
+apply (lift x (Bpred (B2BSN x))).
+rewrite <- is_nan_B2BSN.
+apply is_nan_Bpred.
+Defined.
 
 Lemma Bpred_correct :
-  forall pred_nan x,
+  forall x,
   is_finite x = true ->
   if Rlt_bool (- bpow radix2 emax) (pred radix2 fexp (B2R x)) then
-    B2R (Bpred pred_nan x) = pred radix2 fexp (B2R x) /\
-    is_finite (Bpred pred_nan x) = true /\
-    (Bsign (Bpred pred_nan x) = Bsign x || negb (is_finite_strict x))%bool
+    B2R (Bpred x) = pred radix2 fexp (B2R x) /\
+    is_finite (Bpred x) = true /\
+    (Bsign (Bpred x) = Bsign x || negb (is_finite_strict x))%bool
   else
-    B2FF (Bpred pred_nan x) = F754_infinity true.
-Proof.
-intros pred_nan x Fx.
-assert (Fox : is_finite (Bopp pred_nan x) = true).
-{ now rewrite is_finite_Bopp. }
-rewrite <-(Ropp_involutive (B2R x)), <-(B2R_Bopp pred_nan).
-rewrite pred_opp, Rlt_bool_opp.
-generalize (Bsucc_correct pred_nan _ Fox).
-case (Rlt_bool _ _).
-- intros (HR, (HF, HS)); unfold Bpred.
-  rewrite B2R_Bopp, HR, is_finite_Bopp.
-  rewrite <-(Bool.negb_involutive (Bsign x)), <-Bool.negb_andb.
-  split; [reflexivity|split; [exact HF|]].
-  replace (is_finite_strict x) with (is_finite_strict (Bopp pred_nan x));
-    [|now case x; try easy; intros s pl Hpl; simpl;
-        rewrite is_finite_strict_build_nan].
-  rewrite Bsign_Bopp, <-(Bsign_Bopp pred_nan x), HS.
-  + now simpl.
-  + now revert Fx; case x.
-  + now revert HF; case (Bsucc _ _).
-- now unfold Bpred; case (Bsucc _ _); intro s; case s.
+    B2FF (Bpred x) = F754_infinity true.
+Proof.
+intros x Fx.
+rewrite <- is_finite_B2BSN in Fx.
+generalize (Bpred_correct prec emax _ _ _ Fx).
+replace (BSN.Bpred (B2BSN x)) with (B2BSN (Bpred x)) by apply B2BSN_lift.
+rewrite 2!B2R_B2BSN.
+destruct Rlt_bool.
+- rewrite (Bsign_B2BSN x) by now destruct x.
+  rewrite is_finite_strict_B2BSN.
+  now destruct Bpred.
+- now destruct Bpred as [|[|]| |].
 Qed.
 
 End Binary.
diff --git a/flocq/IEEE754/BinarySingleNaN.v b/flocq/IEEE754/BinarySingleNaN.v
new file mode 100644
index 00000000..2dd5c3c6
--- /dev/null
+++ b/flocq/IEEE754/BinarySingleNaN.v
@@ -0,0 +1,3421 @@
+(**
+This file is part of the Flocq formalization of floating-point
+arithmetic in Coq: http://flocq.gforge.inria.fr/
+
+Copyright (C) 2010-2018 Sylvie Boldo
+#<br />#
+Copyright (C) 2010-2018 Guillaume Melquiond
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+COPYING file for more details.
+*)
+
+(** * IEEE-754 arithmetic *)
+
+From Coq Require Import ZArith Reals Psatz SpecFloat.
+
+Require Import Core Round Bracket Operations Div Sqrt Relative.
+
+Definition SF2R beta x :=
+  match x with
+  | S754_finite s m e => F2R (Float beta (cond_Zopp s (Zpos m)) e)
+  | _ => 0%R
+  end.
+
+Class Prec_lt_emax prec emax := prec_lt_emax : (prec < emax)%Z.
+Arguments prec_lt_emax prec emax {Prec_lt_emax}.
+
+Section Binary.
+
+(** [prec] is the number of bits of the mantissa including the implicit one;
+    [emax] is the exponent of the infinities.
+    For instance, binary32 is defined by [prec = 24] and [emax = 128]. *)
+Variable prec emax : Z.
+Context (prec_gt_0_ : Prec_gt_0 prec).
+Context (prec_lt_emax_ : Prec_lt_emax prec emax).
+
+Notation emin := (emin prec emax).
+Notation fexp := (fexp prec emax).
+Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec.
+Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec.
+
+Notation canonical_mantissa := (canonical_mantissa prec emax).
+
+Notation bounded := (SpecFloat.bounded prec emax).
+
+Notation valid_binary := (valid_binary prec emax).
+
+(** Basic type used for representing binary FP numbers.
+    Note that there is exactly one such object per FP datum. *)
+
+Inductive binary_float :=
+  | B754_zero (s : bool)
+  | B754_infinity (s : bool)
+  | B754_nan : binary_float
+  | B754_finite (s : bool) (m : positive) (e : Z) :
+    bounded m e = true -> binary_float.
+
+Definition SF2B x :=
+  match x as x return valid_binary x = true -> binary_float with
+  | S754_finite s m e => B754_finite s m e
+  | S754_infinity s => fun _ => B754_infinity s
+  | S754_zero s => fun _ => B754_zero s
+  | S754_nan => fun _ => B754_nan
+  end.
+
+Definition B2SF x :=
+  match x with
+  | B754_finite s m e _ => S754_finite s m e
+  | B754_infinity s => S754_infinity s
+  | B754_zero s => S754_zero s
+  | B754_nan => S754_nan
+  end.
+
+Definition B2R f :=
+  match f with
+  | B754_finite s m e _ => F2R (Float radix2 (cond_Zopp s (Zpos m)) e)
+  | _ => 0%R
+  end.
+
+Theorem SF2R_B2SF :
+  forall x,
+  SF2R radix2 (B2SF x) = B2R x.
+Proof.
+now intros [sx|sx| |sx mx ex Hx].
+Qed.
+
+Theorem B2SF_SF2B :
+  forall x Hx,
+  B2SF (SF2B x Hx) = x.
+Proof.
+now intros [sx|sx| |sx mx ex] Hx.
+Qed.
+
+Theorem valid_binary_B2SF :
+  forall x,
+  valid_binary (B2SF x) = true.
+Proof.
+now intros [sx|sx| |sx mx ex Hx].
+Qed.
+
+Theorem SF2B_B2SF :
+  forall x H,
+  SF2B (B2SF x) H = x.
+Proof.
+intros [sx|sx| |sx mx ex Hx] H ; try easy.
+apply f_equal, eqbool_irrelevance.
+Qed.
+
+Theorem SF2B_B2SF_valid :
+  forall x,
+  SF2B (B2SF x) (valid_binary_B2SF x) = x.
+Proof.
+intros x.
+apply SF2B_B2SF.
+Qed.
+
+Theorem B2R_SF2B :
+  forall x Hx,
+  B2R (SF2B x Hx) = SF2R radix2 x.
+Proof.
+now intros [sx|sx| |sx mx ex] Hx.
+Qed.
+
+Theorem match_SF2B :
+  forall {T} fz fi fn ff x Hx,
+  match SF2B x Hx return T with
+  | B754_zero sx => fz sx
+  | B754_infinity sx => fi sx
+  | B754_nan => fn
+  | B754_finite sx mx ex _ => ff sx mx ex
+  end =
+  match x with
+  | S754_zero sx => fz sx
+  | S754_infinity sx => fi sx
+  | S754_nan => fn
+  | S754_finite sx mx ex => ff sx mx ex
+  end.
+Proof.
+now intros T fz fi fn ff [sx|sx| |sx mx ex] Hx.
+Qed.
+
+Theorem canonical_canonical_mantissa :
+  forall (sx : bool) mx ex,
+  canonical_mantissa mx ex = true ->
+  canonical radix2 fexp (Float radix2 (cond_Zopp sx (Zpos mx)) ex).
+Proof.
+intros sx mx ex H.
+assert (Hx := Zeq_bool_eq _ _ H). clear H.
+apply sym_eq.
+simpl.
+pattern ex at 2 ; rewrite <- Hx.
+apply (f_equal fexp).
+rewrite mag_F2R_Zdigits.
+rewrite <- Zdigits_abs.
+rewrite Zpos_digits2_pos.
+now case sx.
+now case sx.
+Qed.
+
+Theorem generic_format_B2R :
+  forall x,
+  generic_format radix2 fexp (B2R x).
+Proof.
+intros [sx|sx| |sx mx ex Hx] ; try apply generic_format_0.
+simpl.
+apply generic_format_canonical.
+apply canonical_canonical_mantissa.
+now destruct (andb_prop _ _ Hx) as (H, _).
+Qed.
+
+Theorem FLT_format_B2R :
+  forall x,
+  FLT_format radix2 emin prec (B2R x).
+Proof with auto with typeclass_instances.
+intros x.
+apply FLT_format_generic...
+apply generic_format_B2R.
+Qed.
+
+Theorem B2SF_inj :
+  forall x y : binary_float,
+  B2SF x = B2SF y ->
+  x = y.
+Proof.
+intros [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; try easy.
+(* *)
+intros H.
+now inversion H.
+(* *)
+intros H.
+now inversion H.
+(* *)
+intros H.
+inversion H.
+clear H.
+revert Hx.
+rewrite H2, H3.
+intros Hx.
+apply f_equal, eqbool_irrelevance.
+Qed.
+
+Definition is_finite_strict f :=
+  match f with
+  | B754_finite _ _ _ _ => true
+  | _ => false
+  end.
+
+Definition is_finite_strict_SF f :=
+  match f with
+  | S754_finite _ _ _ => true
+  | _ => false
+  end.
+
+Theorem is_finite_strict_B2R :
+  forall x,
+  B2R x <> 0%R ->
+  is_finite_strict x = true.
+Proof.
+now intros [sx|sx| |sx mx ex Bx] Hx.
+Qed.
+
+Theorem is_finite_strict_SF2B :
+  forall x Hx,
+  is_finite_strict (SF2B x Hx) = is_finite_strict_SF x.
+Proof.
+now intros [sx|sx| |sx mx ex] Hx.
+Qed.
+
+Theorem B2R_inj:
+  forall x y : binary_float,
+  is_finite_strict x = true ->
+  is_finite_strict y = true ->
+  B2R x = B2R y ->
+  x = y.
+Proof.
+intros [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; try easy.
+simpl.
+intros _ _ Heq.
+assert (Hs: sx = sy).
+(* *)
+revert Heq. clear.
+case sx ; case sy ; try easy ;
+  intros Heq ; apply False_ind ; revert Heq.
+apply Rlt_not_eq.
+apply Rlt_trans with R0.
+now apply F2R_lt_0.
+now apply F2R_gt_0.
+apply Rgt_not_eq.
+apply Rgt_trans with R0.
+now apply F2R_gt_0.
+now apply F2R_lt_0.
+assert (mx = my /\ ex = ey).
+(* *)
+refine (_ (canonical_unique _ fexp _ _ _ _ Heq)).
+rewrite Hs.
+now case sy ; intro H ; injection H ; split.
+apply canonical_canonical_mantissa.
+exact (proj1 (andb_prop _ _ Hx)).
+apply canonical_canonical_mantissa.
+exact (proj1 (andb_prop _ _ Hy)).
+(* *)
+revert Hx.
+rewrite Hs, (proj1 H), (proj2 H).
+intros Hx.
+apply f_equal.
+apply eqbool_irrelevance.
+Qed.
+
+Definition Bsign x :=
+  match x with
+  | B754_nan => false
+  | B754_zero s => s
+  | B754_infinity s => s
+  | B754_finite s _ _ _ => s
+  end.
+
+Definition sign_SF x :=
+  match x with
+  | S754_nan => false
+  | S754_zero s => s
+  | S754_infinity s => s
+  | S754_finite s _ _ => s
+  end.
+
+Theorem Bsign_SF2B :
+  forall x H,
+  Bsign (SF2B x H) = sign_SF x.
+Proof.
+now intros [sx|sx| |sx mx ex] H.
+Qed.
+
+Definition is_finite f :=
+  match f with
+  | B754_finite _ _ _ _ => true
+  | B754_zero _ => true
+  | _ => false
+  end.
+
+Definition is_finite_SF f :=
+  match f with
+  | S754_finite _ _ _ => true
+  | S754_zero _ => true
+  | _ => false
+  end.
+
+Theorem is_finite_SF2B :
+  forall x Hx,
+  is_finite (SF2B x Hx) = is_finite_SF x.
+Proof.
+now intros [| | |].
+Qed.
+
+Theorem is_finite_SF_B2SF :
+  forall x,
+  is_finite_SF (B2SF x) = is_finite x.
+Proof.
+now intros [| | |].
+Qed.
+
+Theorem B2R_Bsign_inj:
+  forall x y : binary_float,
+    is_finite x = true ->
+    is_finite y = true ->
+    B2R x = B2R y ->
+    Bsign x = Bsign y ->
+    x = y.
+Proof.
+intros. destruct x, y; try (apply B2R_inj; now eauto).
+- simpl in H2. congruence.
+- symmetry in H1. apply Rmult_integral in H1.
+  destruct H1. apply (eq_IZR _ 0) in H1. destruct s0; discriminate H1.
+  simpl in H1. pose proof (bpow_gt_0 radix2 e).
+  rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3.
+- apply Rmult_integral in H1.
+  destruct H1. apply (eq_IZR _ 0) in H1. destruct s; discriminate H1.
+  simpl in H1. pose proof (bpow_gt_0 radix2 e).
+  rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3.
+Qed.
+
+Definition is_nan f :=
+  match f with
+  | B754_nan => true
+  | _ => false
+  end.
+
+Definition is_nan_SF f :=
+  match f with
+  | S754_nan => true
+  | _ => false
+  end.
+
+Theorem is_nan_SF2B :
+  forall x Hx,
+  is_nan (SF2B x Hx) = is_nan_SF x.
+Proof.
+now intros [| | |].
+Qed.
+
+Theorem is_nan_SF_B2SF :
+  forall x,
+  is_nan_SF (B2SF x) = is_nan x.
+Proof.
+now intros [| | |].
+Qed.
+
+Definition erase (x : binary_float) : binary_float.
+Proof.
+destruct x as [s|s| |s m e H].
+- exact (B754_zero s).
+- exact (B754_infinity s).
+- exact B754_nan.
+- apply (B754_finite s m e).
+  destruct bounded.
+  apply eq_refl.
+  exact H.
+Defined.
+
+Theorem erase_correct :
+  forall x, erase x = x.
+Proof.
+destruct x as [s|s| |s m e H] ; try easy ; simpl.
+- apply f_equal, eqbool_irrelevance.
+Qed.
+
+(** Opposite *)
+
+Definition Bopp x :=
+  match x with
+  | B754_nan => x
+  | B754_infinity sx => B754_infinity (negb sx)
+  | B754_finite sx mx ex Hx => B754_finite (negb sx) mx ex Hx
+  | B754_zero sx => B754_zero (negb sx)
+  end.
+
+Theorem Bopp_involutive :
+  forall x,
+  Bopp (Bopp x) = x.
+Proof.
+now intros [sx|sx| |sx mx ex Hx] ; simpl ; try rewrite Bool.negb_involutive.
+Qed.
+
+Theorem B2R_Bopp :
+  forall x,
+  B2R (Bopp x) = (- B2R x)%R.
+Proof.
+intros [sx|sx| |sx mx ex Hx]; apply sym_eq ; try apply Ropp_0.
+simpl.
+rewrite <- F2R_opp.
+now case sx.
+Qed.
+
+Theorem is_nan_Bopp :
+  forall x,
+  is_nan (Bopp x) = is_nan x.
+Proof.
+now intros [| | |].
+Qed.
+
+Theorem is_finite_Bopp :
+  forall x,
+  is_finite (Bopp x) = is_finite x.
+Proof.
+now intros [| | |].
+Qed.
+
+Theorem is_finite_strict_Bopp :
+  forall x,
+  is_finite_strict (Bopp x) = is_finite_strict x.
+Proof.
+now intros [| | |].
+Qed.
+
+Lemma Bsign_Bopp :
+  forall x, is_nan x = false -> Bsign (Bopp x) = negb (Bsign x).
+Proof. now intros [s|s| |s m e H]. Qed.
+
+(** Absolute value *)
+
+Definition Babs (x : binary_float) : binary_float :=
+  match x with
+  | B754_nan => x
+  | B754_infinity sx => B754_infinity false
+  | B754_finite sx mx ex Hx => B754_finite false mx ex Hx
+  | B754_zero sx => B754_zero false
+  end.
+
+Theorem B2R_Babs :
+  forall x,
+  B2R (Babs x) = Rabs (B2R x).
+Proof.
+intros [sx|sx| |sx mx ex Hx]; apply sym_eq ; try apply Rabs_R0.
+simpl. rewrite <- F2R_abs. now destruct sx.
+Qed.
+
+Theorem is_nan_Babs :
+  forall x,
+  is_nan (Babs x) = is_nan x.
+Proof.
+now intros [| | |].
+Qed.
+
+Theorem is_finite_Babs :
+  forall x,
+  is_finite (Babs x) = is_finite x.
+Proof.
+now intros [| | |].
+Qed.
+
+Theorem is_finite_strict_Babs :
+  forall x,
+  is_finite_strict (Babs x) = is_finite_strict x.
+Proof.
+now intros [| | |].
+Qed.
+
+Theorem Bsign_Babs :
+  forall x,
+  Bsign (Babs x) = false.
+Proof.
+now intros [| | |].
+Qed.
+
+Theorem Babs_idempotent :
+  forall (x: binary_float),
+  Babs (Babs x) = Babs x.
+Proof.
+now intros [sx|sx| |sx mx ex Hx].
+Qed.
+
+Theorem Babs_Bopp :
+  forall x,
+  Babs (Bopp x) = Babs x.
+Proof.
+now intros [| | |].
+Qed.
+
+(** Comparison
+
+[Some c] means ordered as per [c]; [None] means unordered. *)
+
+Definition Bcompare (f1 f2 : binary_float) : option comparison :=
+  SFcompare (B2SF f1) (B2SF f2).
+
+Theorem Bcompare_correct :
+  forall f1 f2,
+  is_finite f1 = true -> is_finite f2 = true ->
+  Bcompare f1 f2 = Some (Rcompare (B2R f1) (B2R f2)).
+Proof.
+  Ltac apply_Rcompare :=
+    match goal with
+      | [ |- Lt = Rcompare _ _ ] => symmetry; apply Rcompare_Lt
+      | [ |- Eq = Rcompare _ _ ] => symmetry; apply Rcompare_Eq
+      | [ |- Gt = Rcompare _ _ ] => symmetry; apply Rcompare_Gt
+    end.
+  unfold Bcompare, SFcompare; intros f1 f2 H1 H2.
+  destruct f1, f2; try easy; apply f_equal; clear H1 H2.
+  now rewrite Rcompare_Eq.
+  destruct s0 ; apply_Rcompare.
+  now apply F2R_lt_0.
+  now apply F2R_gt_0.
+  destruct s ; apply_Rcompare.
+  now apply F2R_lt_0.
+  now apply F2R_gt_0.
+  simpl.
+  apply andb_prop in e0; destruct e0; apply (canonical_canonical_mantissa false) in H.
+  apply andb_prop in e2; destruct e2; apply (canonical_canonical_mantissa false) in H1.
+  pose proof (Zcompare_spec e e1); unfold canonical, Fexp in H1, H.
+  assert (forall m1 m2 e1 e2,
+    let x := (IZR (Zpos m1) * bpow radix2 e1)%R in
+    let y := (IZR (Zpos m2) * bpow radix2 e2)%R in
+    (cexp radix2 fexp x < cexp radix2 fexp y)%Z -> (x < y)%R).
+  {
+  intros; apply Rnot_le_lt; intro; apply (mag_le radix2) in H5.
+  apply Zlt_not_le with (1 := H4).
+  now apply fexp_monotone.
+  now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)).
+  }
+  assert (forall m1 m2 e1 e2, (IZR (- Zpos m1) * bpow radix2 e1 < IZR (Zpos m2) * bpow radix2 e2)%R).
+  {
+  intros; apply (Rlt_trans _ 0%R).
+  now apply (F2R_lt_0 _ (Float radix2 (Zneg m1) e0)).
+  now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)).
+  }
+  unfold F2R, Fnum, Fexp.
+  destruct s, s0; try (now apply_Rcompare; apply H5); inversion H3;
+    try (apply_Rcompare; apply H4; rewrite H, H1 in H7; assumption);
+    try (apply_Rcompare; do 2 rewrite opp_IZR, Ropp_mult_distr_l_reverse;
+      apply Ropp_lt_contravar; apply H4; rewrite H, H1 in H7; assumption);
+    rewrite H7, Rcompare_mult_r, Rcompare_IZR by (apply bpow_gt_0); reflexivity.
+Qed.
+
+Theorem Bcompare_swap :
+  forall x y,
+  Bcompare y x = match Bcompare x y with Some c => Some (CompOpp c) | None => None end.
+Proof.
+  intros.
+  unfold Bcompare.
+  destruct x as [ ? | [] | | [] mx ex Bx ];
+  destruct y as [ ? | [] | | [] my ey By ]; simpl; try easy.
+- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy.
+  now rewrite (Pcompare_antisym mx my).
+- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy.
+  now rewrite Pcompare_antisym.
+Qed.
+
+Definition Beqb (f1 f2 : binary_float) : bool := SFeqb (B2SF f1) (B2SF f2).
+
+Theorem Beqb_correct :
+  forall f1 f2,
+  is_finite f1 = true -> is_finite f2 = true ->
+  Beqb f1 f2 = Req_bool (B2R f1) (B2R f2).
+Proof.
+intros f1 f2 F1 F2.
+generalize (Bcompare_correct _ _ F1 F2).
+unfold Beqb, SFeqb, Bcompare.
+intros ->.
+case Rcompare_spec; intro H; case Req_bool_spec; intro H'; try reflexivity; lra.
+Qed.
+
+Definition Bltb (f1 f2 : binary_float) : bool := SFltb (B2SF f1) (B2SF f2).
+
+Theorem Bltb_correct :
+  forall f1 f2,
+  is_finite f1 = true -> is_finite f2 = true ->
+  Bltb f1 f2 = Rlt_bool (B2R f1) (B2R f2).
+Proof.
+intros f1 f2 F1 F2.
+generalize (Bcompare_correct _ _ F1 F2).
+unfold Bltb, SFltb, Bcompare.
+intros ->.
+case Rcompare_spec; intro H; case Rlt_bool_spec; intro H'; try reflexivity; lra.
+Qed.
+
+Definition Bleb (f1 f2 : binary_float) : bool := SFleb (B2SF f1) (B2SF f2).
+
+Theorem Bleb_correct :
+  forall f1 f2,
+  is_finite f1 = true -> is_finite f2 = true ->
+  Bleb f1 f2 = Rle_bool (B2R f1) (B2R f2).
+Proof.
+intros f1 f2 F1 F2.
+generalize (Bcompare_correct _ _ F1 F2).
+unfold Bleb, SFleb, Bcompare.
+intros ->.
+case Rcompare_spec; intro H; case Rle_bool_spec; intro H'; try reflexivity; lra.
+Qed.
+
+Theorem bounded_le_emax_minus_prec :
+  forall mx ex,
+  bounded mx ex = true ->
+  (F2R (Float radix2 (Zpos mx) ex)
+   <= bpow radix2 emax - bpow radix2 (emax - prec))%R.
+Proof.
+intros mx ex Hx.
+destruct (andb_prop _ _ Hx) as (H1,H2).
+generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1.
+generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2.
+generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex).
+destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex).
+unfold mag_val.
+intros H.
+elim Ex; [|now apply Rgt_not_eq, F2R_gt_0]; intros _.
+rewrite <-F2R_Zabs; simpl; clear Ex; intros Ex.
+generalize (Rmult_lt_compat_r (bpow radix2 (-ex)) _ _ (bpow_gt_0 _ _) Ex).
+unfold F2R; simpl; rewrite Rmult_assoc, <-!bpow_plus.
+rewrite H; [|intro H'; discriminate H'].
+rewrite <-Z.add_assoc, Z.add_opp_diag_r, Z.add_0_r, Rmult_1_r.
+rewrite <-(IZR_Zpower _ _ (Zdigits_ge_0 _ _)); clear Ex; intro Ex.
+generalize (Zlt_le_succ _ _ (lt_IZR _ _ Ex)); clear Ex; intro Ex.
+generalize (IZR_le _ _ Ex).
+rewrite succ_IZR; clear Ex; intro Ex.
+generalize (Rplus_le_compat_r (-1) _ _ Ex); clear Ex; intro Ex.
+ring_simplify in Ex; revert Ex.
+rewrite (IZR_Zpower _ _ (Zdigits_ge_0 _ _)); intro Ex.
+generalize (Rmult_le_compat_r (bpow radix2 ex) _ _ (bpow_ge_0 _ _) Ex).
+intro H'; apply (Rle_trans _ _ _ H').
+rewrite Rmult_minus_distr_r, Rmult_1_l, <-bpow_plus.
+revert H1; unfold fexp, FLT_exp; intro H1.
+generalize (Z.le_max_l (Z.pos (digits2_pos mx) + ex - prec) emin).
+
+rewrite H1; intro H1'.
+generalize (proj1 (Z.le_sub_le_add_r _ _ _) H1').
+rewrite Zpos_digits2_pos; clear H1'; intro H1'.
+apply (Rle_trans _ _ _ (Rplus_le_compat_r _ _ _ (bpow_le _ _ _ H1'))).
+replace emax with (emax - prec - ex + (ex + prec))%Z at 1 by ring.
+replace (emax - prec)%Z with (emax - prec - ex + ex)%Z at 2 by ring.
+do 2 rewrite (bpow_plus _ (emax - prec - ex)).
+rewrite <-Rmult_minus_distr_l.
+rewrite <-(Rmult_1_l (_ + _)).
+apply Rmult_le_compat_r.
+{ apply Rle_0_minus, bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. }
+change 1%R with (bpow radix2 0); apply bpow_le; lia.
+Qed.
+
+Theorem bounded_lt_emax :
+  forall mx ex,
+  bounded mx ex = true ->
+  (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R.
+Proof.
+intros mx ex Hx.
+destruct (andb_prop _ _ Hx) as (H1,H2).
+generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1.
+generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2.
+generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex).
+destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex).
+unfold mag_val.
+intros H.
+apply Rlt_le_trans with (bpow radix2 e').
+change (Zpos mx) with (Z.abs (Zpos mx)).
+rewrite F2R_Zabs.
+apply Ex.
+apply Rgt_not_eq.
+now apply F2R_gt_0.
+apply bpow_le.
+rewrite H. 2: discriminate.
+revert H1. clear -H2.
+rewrite Zpos_digits2_pos.
+unfold fexp, FLT_exp.
+intros ; lia.
+Qed.
+
+Theorem bounded_ge_emin :
+  forall mx ex,
+  bounded mx ex = true ->
+  (bpow radix2 emin <= F2R (Float radix2 (Zpos mx) ex))%R.
+Proof.
+intros mx ex Hx.
+destruct (andb_prop _ _ Hx) as [H1 _].
+apply Zeq_bool_eq in H1.
+generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex).
+destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as [e' Ex].
+unfold mag_val.
+intros H.
+assert (H0 : Zpos mx <> 0%Z) by easy.
+rewrite Rabs_pos_eq in Ex by now apply F2R_ge_0.
+refine (Rle_trans _ _ _ _ (proj1 (Ex _))).
+2: now apply F2R_neq_0.
+apply bpow_le.
+rewrite H by easy.
+revert H1.
+rewrite Zpos_digits2_pos.
+generalize (Zdigits radix2 (Zpos mx)) (Zdigits_gt_0 radix2 (Zpos mx) H0).
+unfold fexp, FLT_exp.
+clear -prec_gt_0_.
+unfold Prec_gt_0 in prec_gt_0_.
+intros ; lia.
+Qed.
+
+Theorem abs_B2R_le_emax_minus_prec :
+  forall x,
+  (Rabs (B2R x) <= bpow radix2 emax - bpow radix2 (emax - prec))%R.
+Proof.
+intros [sx|sx| |sx mx ex Hx] ; simpl ;
+  [rewrite Rabs_R0 ; apply Rle_0_minus, bpow_le ;
+   revert prec_gt_0_; unfold Prec_gt_0; lia..|].
+rewrite <- F2R_Zabs, abs_cond_Zopp.
+now apply bounded_le_emax_minus_prec.
+Qed.
+
+Theorem abs_B2R_lt_emax :
+  forall x,
+  (Rabs (B2R x) < bpow radix2 emax)%R.
+Proof.
+intros [sx|sx| |sx mx ex Hx] ; simpl ; try ( rewrite Rabs_R0 ; apply bpow_gt_0 ).
+rewrite <- F2R_Zabs, abs_cond_Zopp.
+now apply bounded_lt_emax.
+Qed.
+
+Theorem abs_B2R_ge_emin :
+  forall x,
+  is_finite_strict x = true ->
+  (bpow radix2 emin <= Rabs (B2R x))%R.
+Proof.
+intros [sx|sx| |sx mx ex Hx] ; simpl ; try discriminate.
+intros; case sx; simpl.
+- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl.
+  rewrite Rabs_pos_eq; [|apply bpow_ge_0].
+  now apply bounded_ge_emin.
+- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl.
+  rewrite Rabs_pos_eq; [|apply bpow_ge_0].
+  now apply bounded_ge_emin.
+Qed.
+
+Theorem bounded_canonical_lt_emax :
+  forall mx ex,
+  canonical radix2 fexp (Float radix2 (Zpos mx) ex) ->
+  (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R ->
+  bounded mx ex = true.
+Proof.
+intros mx ex Cx Bx.
+apply andb_true_intro.
+split.
+unfold canonical_mantissa.
+unfold canonical, Fexp in Cx.
+rewrite Cx at 2.
+rewrite Zpos_digits2_pos.
+unfold cexp.
+rewrite mag_F2R_Zdigits. 2: discriminate.
+now apply -> Zeq_is_eq_bool.
+apply Zle_bool_true.
+unfold canonical, Fexp in Cx.
+rewrite Cx.
+unfold cexp, fexp, FLT_exp.
+destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). simpl.
+apply Z.max_lub.
+cut (e' - 1 < emax)%Z. clear ; lia.
+apply lt_bpow with radix2.
+apply Rle_lt_trans with (2 := Bx).
+change (Zpos mx) with (Z.abs (Zpos mx)).
+rewrite F2R_Zabs.
+apply Ex.
+apply Rgt_not_eq.
+now apply F2R_gt_0.
+unfold emin.
+generalize (prec_gt_0 prec) (prec_lt_emax prec emax).
+clear ; lia.
+Qed.
+
+(** Truncation *)
+
+Theorem shr_m_shr_record_of_loc :
+  forall m l,
+  shr_m (shr_record_of_loc m l) = m.
+Proof.
+now intros m [|[| |]].
+Qed.
+
+Theorem loc_of_shr_record_of_loc :
+  forall m l,
+  loc_of_shr_record (shr_record_of_loc m l) = l.
+Proof.
+now intros m [|[| |]].
+Qed.
+
+Lemma inbetween_shr_1 :
+  forall x mrs e,
+  (0 <= shr_m mrs)%Z ->
+  inbetween_float radix2 (shr_m mrs) e x (loc_of_shr_record mrs) ->
+  inbetween_float radix2 (shr_m (shr_1 mrs)) (e + 1) x (loc_of_shr_record (shr_1 mrs)).
+Proof.
+intros x mrs e Hm Hl.
+refine (_ (new_location_even_correct (F2R (Float radix2 (shr_m (shr_1 mrs)) (e + 1))) (bpow radix2 e) 2 _ _ _ x (if shr_r (shr_1 mrs) then 1 else 0) (loc_of_shr_record mrs) _ _)) ; try easy.
+2: apply bpow_gt_0.
+2: now case (shr_r (shr_1 mrs)) ; split.
+change 2%R with (bpow radix2 1).
+rewrite <- bpow_plus.
+rewrite (Zplus_comm 1), <- (F2R_bpow radix2 (e + 1)).
+unfold inbetween_float, F2R. simpl.
+rewrite plus_IZR, Rmult_plus_distr_r.
+replace (Bracket.new_location_even 2 (if shr_r (shr_1 mrs) then 1%Z else 0%Z) (loc_of_shr_record mrs)) with (loc_of_shr_record (shr_1 mrs)).
+easy.
+clear -Hm.
+destruct mrs as (m, r, s).
+now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
+rewrite (F2R_change_exp radix2 e).
+2: apply Zle_succ.
+unfold F2R. simpl.
+rewrite <- 2!Rmult_plus_distr_r, <- 2!plus_IZR.
+rewrite Zplus_assoc.
+replace (shr_m (shr_1 mrs) * 2 ^ (e + 1 - e) + (if shr_r (shr_1 mrs) then 1%Z else 0%Z))%Z with (shr_m mrs).
+exact Hl.
+ring_simplify (e + 1 - e)%Z.
+change (2^1)%Z with 2%Z.
+rewrite Zmult_comm.
+clear -Hm.
+destruct mrs as (m, r, s).
+now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
+Qed.
+
+Theorem inbetween_shr :
+  forall x m e l n,
+  (0 <= m)%Z ->
+  inbetween_float radix2 m e x l ->
+  let '(mrs, e') := shr (shr_record_of_loc m l) e n in
+  inbetween_float radix2 (shr_m mrs) e' x (loc_of_shr_record mrs).
+Proof.
+intros x m e l n Hm Hl.
+destruct n as [|n|n].
+now destruct l as [|[| |]].
+2: now destruct l as [|[| |]].
+unfold shr.
+rewrite iter_pos_nat.
+rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
+induction (nat_of_P n).
+simpl.
+rewrite Zplus_0_r.
+now destruct l as [|[| |]].
+rewrite iter_nat_S.
+rewrite inj_S.
+unfold Z.succ.
+rewrite Zplus_assoc.
+revert IHn0.
+apply inbetween_shr_1.
+clear -Hm.
+induction n0.
+now destruct l as [|[| |]].
+rewrite iter_nat_S.
+revert IHn0.
+generalize (iter_nat shr_1 n0 (shr_record_of_loc m l)).
+clear.
+intros (m, r, s) Hm.
+now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
+Qed.
+
+Notation shr_fexp := (shr_fexp prec emax).
+
+Theorem shr_truncate :
+  forall m e l,
+  (0 <= m)%Z ->
+  shr_fexp m e l =
+  let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e').
+Proof.
+intros m e l Hm.
+case_eq (truncate radix2 fexp (m, e, l)).
+intros (m', e') l'.
+unfold shr_fexp.
+rewrite Zdigits2_Zdigits.
+case_eq (fexp (Zdigits radix2 m + e) - e)%Z.
+(* *)
+intros He.
+unfold truncate.
+rewrite He.
+simpl.
+intros H.
+now inversion H.
+(* *)
+intros p Hp.
+assert (He: (e <= fexp (Zdigits radix2 m + e))%Z).
+clear -Hp ; lia.
+destruct (inbetween_float_ex radix2 m e l) as (x, Hx).
+generalize (inbetween_shr x m e l (fexp (Zdigits radix2 m + e) - e) Hm Hx).
+assert (Hx0 : (0 <= x)%R).
+apply Rle_trans with (F2R (Float radix2 m e)).
+now apply F2R_ge_0.
+exact (proj1 (inbetween_float_bounds _ _ _ _ _ Hx)).
+case_eq (shr (shr_record_of_loc m l) e (fexp (Zdigits radix2 m + e) - e)).
+intros mrs e'' H3 H4 H1.
+generalize (truncate_correct radix2 _ x m e l Hx0 Hx (or_introl _ He)).
+rewrite H1.
+intros (H2,_).
+rewrite <- Hp, H3.
+assert (e'' = e').
+change (snd (mrs, e'') = snd (fst (m',e',l'))).
+rewrite <- H1, <- H3.
+unfold truncate.
+now rewrite Hp.
+rewrite H in H4 |- *.
+apply (f_equal (fun v => (v, _))).
+destruct (inbetween_float_unique _ _ _ _ _ _ _ H2 H4) as (H5, H6).
+rewrite H5, H6.
+case mrs.
+now intros m0 [|] [|].
+(* *)
+intros p Hp.
+unfold truncate.
+rewrite Hp.
+simpl.
+intros H.
+now inversion H.
+Qed.
+
+(** Rounding modes *)
+
+Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA.
+
+Definition round_mode m :=
+  match m with
+  | mode_NE => ZnearestE
+  | mode_ZR => Ztrunc
+  | mode_DN => Zfloor
+  | mode_UP => Zceil
+  | mode_NA => ZnearestA
+  end.
+
+Definition choice_mode m sx mx lx :=
+  match m with
+  | mode_NE => cond_incr (round_N (negb (Z.even mx)) lx) mx
+  | mode_ZR => mx
+  | mode_DN => cond_incr (round_sign_DN sx lx) mx
+  | mode_UP => cond_incr (round_sign_UP sx lx) mx
+  | mode_NA => cond_incr (round_N true lx) mx
+  end.
+
+Global Instance valid_rnd_round_mode : forall m, Valid_rnd (round_mode m).
+Proof.
+destruct m ; unfold round_mode ; auto with typeclass_instances.
+Qed.
+
+Definition overflow_to_inf m s :=
+  match m with
+  | mode_NE => true
+  | mode_NA => true
+  | mode_ZR => false
+  | mode_UP => negb s
+  | mode_DN => s
+  end.
+
+Definition binary_overflow m s :=
+  if overflow_to_inf m s then S754_infinity s
+  else S754_finite s (Z.to_pos (Zpower 2 prec - 1)%Z) (emax - prec).
+
+Theorem is_nan_binary_overflow :
+  forall mode s,
+  is_nan_SF (binary_overflow mode s) = false.
+Proof.
+intros mode s.
+unfold binary_overflow.
+now destruct overflow_to_inf.
+Qed.
+
+Theorem binary_overflow_correct :
+  forall m s,
+  valid_binary (binary_overflow m s) = true.
+Proof.
+intros m s.
+unfold binary_overflow.
+case overflow_to_inf.
+easy.
+unfold valid_binary, bounded.
+rewrite Zle_bool_refl.
+rewrite Bool.andb_true_r.
+apply Zeq_bool_true.
+rewrite Zpos_digits2_pos.
+replace (Zdigits radix2 _) with prec.
+unfold fexp, FLT_exp, emin.
+generalize (prec_gt_0 prec) (prec_lt_emax prec emax).
+clear ; zify ; lia.
+change 2%Z with (radix_val radix2).
+assert (H: (0 < radix2 ^ prec - 1)%Z).
+  apply Zlt_succ_pred.
+  now apply Zpower_gt_1.
+rewrite Z2Pos.id by exact H.
+apply Zle_antisym.
+- apply Z.lt_pred_le.
+  apply Zdigits_gt_Zpower.
+  rewrite Z.abs_eq by now apply Zlt_le_weak.
+  apply Z.lt_le_pred.
+  apply Zpower_lt.
+  now apply Zlt_le_weak.
+  apply Z.lt_pred_l.
+- apply Zdigits_le_Zpower.
+  rewrite Z.abs_eq by now apply Zlt_le_weak.
+  apply Z.lt_pred_l.
+Qed.
+
+Definition binary_fit_aux mode sx mx ex :=
+  if Zle_bool ex (emax - prec) then S754_finite sx mx ex
+  else binary_overflow mode sx.
+
+Theorem binary_fit_aux_correct :
+  forall mode sx mx ex,
+  canonical_mantissa mx ex = true ->
+  let x := SF2R radix2 (S754_finite sx mx ex) in
+  let z := binary_fit_aux mode sx mx ex in
+  valid_binary z = true /\
+  if Rlt_bool (Rabs x) (bpow radix2 emax) then
+    SF2R radix2 z = x /\ is_finite_SF z = true /\ sign_SF z = sx
+  else
+    z = binary_overflow mode sx.
+Proof.
+intros m sx mx ex Cx.
+unfold binary_fit_aux.
+simpl.
+rewrite F2R_cond_Zopp.
+rewrite abs_cond_Ropp.
+rewrite Rabs_pos_eq by now apply F2R_ge_0.
+destruct Zle_bool eqn:He.
+- assert (Hb: bounded mx ex = true).
+  { unfold bounded. now rewrite Cx. }
+  apply (conj Hb).
+  rewrite Rlt_bool_true.
+  repeat split.
+  apply F2R_cond_Zopp.
+  now apply bounded_lt_emax.
+- rewrite Rlt_bool_false.
+  { repeat split.
+    apply binary_overflow_correct. }
+  apply Rnot_lt_le.
+  intros Hx.
+  apply bounded_canonical_lt_emax in Hx.
+  revert Hx.
+  unfold bounded.
+  now rewrite Cx, He.
+  now apply (canonical_canonical_mantissa false).
+Qed.
+
+Definition binary_round_aux mode sx mx ex lx :=
+  let '(mrs', e') := shr_fexp mx ex lx in
+  let '(mrs'', e'') := shr_fexp (choice_mode mode sx (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in
+  match shr_m mrs'' with
+  | Z0 => S754_zero sx
+  | Zpos m => binary_fit_aux mode sx m e''
+  | _ => S754_nan
+  end.
+
+Theorem binary_round_aux_correct' :
+  forall mode x mx ex lx,
+  (x <> 0)%R ->
+  inbetween_float radix2 mx ex (Rabs x) lx ->
+  (ex <= cexp radix2 fexp x)%Z ->
+  let z := binary_round_aux mode (Rlt_bool x 0) mx ex lx in
+  valid_binary z = true /\
+  if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then
+    SF2R radix2 z = round radix2 fexp (round_mode mode) x /\
+    is_finite_SF z = true /\ sign_SF z = Rlt_bool x 0
+  else
+    z = binary_overflow mode (Rlt_bool x 0).
+Proof with auto with typeclass_instances.
+intros m x mx ex lx Px Bx Ex z.
+unfold binary_round_aux in z.
+revert z.
+rewrite shr_truncate.
+refine (_ (round_trunc_sign_any_correct' _ _ (round_mode m) (choice_mode m) _ x mx ex lx Bx (or_introl _ Ex))).
+rewrite <- cexp_abs in Ex.
+refine (_ (truncate_correct_partial' _ fexp _ _ _ _ _ Bx Ex)).
+destruct (truncate radix2 fexp (mx, ex, lx)) as ((m1, e1), l1).
+rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc.
+set (m1' := choice_mode m (Rlt_bool x 0) m1 l1).
+intros (H1a,H1b) H1c.
+rewrite H1c.
+assert (Hm: (m1 <= m1')%Z).
+(* . *)
+unfold m1', choice_mode, cond_incr.
+case m ;
+  try apply Z.le_refl ;
+  match goal with |- (m1 <= if ?b then _ else _)%Z =>
+    case b ; [ apply Zle_succ | apply Z.le_refl ] end.
+assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)).
+(* . *)
+rewrite <- (Z.abs_eq m1').
+rewrite <- (abs_cond_Zopp (Rlt_bool x 0) m1').
+rewrite F2R_Zabs.
+now apply f_equal.
+apply Z.le_trans with (2 := Hm).
+apply Zlt_succ_le.
+apply gt_0_F2R with radix2 e1.
+apply Rle_lt_trans with (1 := Rabs_pos x).
+exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)).
+(* . *)
+assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact).
+now apply inbetween_Exact.
+destruct m1' as [|m1'|m1'].
+(* . m1' = 0 *)
+rewrite shr_truncate. 2: apply Z.le_refl.
+generalize (truncate_0 radix2 fexp e1 loc_Exact).
+destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2).
+rewrite shr_m_shr_record_of_loc.
+intros Hm2.
+rewrite Hm2.
+repeat split.
+rewrite Rlt_bool_true.
+repeat split.
+apply sym_eq.
+case Rlt_bool ; apply F2R_0.
+rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0.
+apply bpow_gt_0.
+(* . 0 < m1' *)
+assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z).
+rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs.
+2: discriminate.
+rewrite H1b.
+rewrite cexp_abs.
+fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)).
+apply cexp_round_ge...
+rewrite H1c.
+case (Rlt_bool x 0).
+apply Rlt_not_eq.
+now apply F2R_lt_0.
+apply Rgt_not_eq.
+now apply F2R_gt_0.
+refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)).
+2: now rewrite Hr ; apply F2R_gt_0.
+refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)).
+2: discriminate.
+rewrite shr_truncate. 2: easy.
+destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2).
+rewrite shr_m_shr_record_of_loc.
+intros (H3,H4) (H2,_).
+destruct m2 as [|m2|m2].
+elim Rgt_not_eq with (2 := H3).
+rewrite F2R_0.
+now apply F2R_gt_0.
+destruct (binary_fit_aux_correct m (Rlt_bool x 0) m2 e2) as [H5 H6].
+  apply Zeq_bool_true.
+  rewrite Zpos_digits2_pos.
+  rewrite <- mag_F2R_Zdigits by easy.
+  now rewrite <- H3.
+apply (conj H5).
+revert H6.
+simpl.
+rewrite 2!F2R_cond_Zopp.
+now rewrite <- H3.
+elim Rgt_not_eq with (2 := H3).
+apply Rlt_trans with R0.
+now apply F2R_lt_0.
+now apply F2R_gt_0.
+rewrite <- Hr.
+apply generic_format_abs...
+apply generic_format_round...
+(* . not m1' < 0 *)
+elim Rgt_not_eq with (2 := Hr).
+apply Rlt_le_trans with R0.
+now apply F2R_lt_0.
+apply Rabs_pos.
+(* *)
+now apply Rabs_pos_lt.
+(* all the modes are valid *)
+clear. case m.
+exact inbetween_int_NE_sign.
+exact inbetween_int_ZR_sign.
+exact inbetween_int_DN_sign.
+exact inbetween_int_UP_sign.
+exact inbetween_int_NA_sign.
+(* *)
+apply inbetween_float_bounds in Bx.
+apply Zlt_succ_le.
+eapply gt_0_F2R.
+apply Rle_lt_trans with (2 := proj2 Bx).
+apply Rabs_pos.
+Qed.
+
+Theorem binary_round_aux_correct :
+  forall mode x mx ex lx,
+  inbetween_float radix2 (Zpos mx) ex (Rabs x) lx ->
+  (ex <= fexp (Zdigits radix2 (Zpos mx) + ex))%Z ->
+  let z := binary_round_aux mode (Rlt_bool x 0) (Zpos mx) ex lx in
+  valid_binary z = true /\
+  if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then
+    SF2R radix2 z = round radix2 fexp (round_mode mode) x /\
+    is_finite_SF z = true /\ sign_SF z = Rlt_bool x 0
+  else
+    z = binary_overflow mode (Rlt_bool x 0).
+Proof with auto with typeclass_instances.
+intros m x mx ex lx Bx Ex z.
+unfold binary_round_aux in z.
+revert z.
+rewrite shr_truncate. 2: easy.
+refine (_ (round_trunc_sign_any_correct _ _ (round_mode m) (choice_mode m) _ x (Zpos mx) ex lx Bx (or_introl _ Ex))).
+refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Bx Ex)).
+destruct (truncate radix2 fexp (Zpos mx, ex, lx)) as ((m1, e1), l1).
+rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc.
+set (m1' := choice_mode m (Rlt_bool x 0) m1 l1).
+intros (H1a,H1b) H1c.
+rewrite H1c.
+assert (Hm: (m1 <= m1')%Z).
+(* . *)
+unfold m1', choice_mode, cond_incr.
+case m ;
+  try apply Z.le_refl ;
+  match goal with |- (m1 <= if ?b then _ else _)%Z =>
+    case b ; [ apply Zle_succ | apply Z.le_refl ] end.
+assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)).
+(* . *)
+rewrite <- (Z.abs_eq m1').
+rewrite <- (abs_cond_Zopp (Rlt_bool x 0) m1').
+rewrite F2R_Zabs.
+now apply f_equal.
+apply Z.le_trans with (2 := Hm).
+apply Zlt_succ_le.
+apply gt_0_F2R with radix2 e1.
+apply Rle_lt_trans with (1 := Rabs_pos x).
+exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)).
+(* . *)
+assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact).
+now apply inbetween_Exact.
+destruct m1' as [|m1'|m1'].
+(* . m1' = 0 *)
+rewrite shr_truncate. 2: apply Z.le_refl.
+generalize (truncate_0 radix2 fexp e1 loc_Exact).
+destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2).
+rewrite shr_m_shr_record_of_loc.
+intros Hm2.
+rewrite Hm2.
+repeat split.
+rewrite Rlt_bool_true.
+repeat split.
+apply sym_eq.
+case Rlt_bool ; apply F2R_0.
+rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0.
+apply bpow_gt_0.
+(* . 0 < m1' *)
+assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z).
+rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs.
+2: discriminate.
+rewrite H1b.
+rewrite cexp_abs.
+fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)).
+apply cexp_round_ge...
+rewrite H1c.
+case (Rlt_bool x 0).
+apply Rlt_not_eq.
+now apply F2R_lt_0.
+apply Rgt_not_eq.
+now apply F2R_gt_0.
+refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)).
+2: now rewrite Hr ; apply F2R_gt_0.
+refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)).
+2: discriminate.
+rewrite shr_truncate. 2: easy.
+destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2).
+rewrite shr_m_shr_record_of_loc.
+intros (H3,H4) (H2,_).
+destruct m2 as [|m2|m2].
+elim Rgt_not_eq with (2 := H3).
+rewrite F2R_0.
+now apply F2R_gt_0.
+destruct (binary_fit_aux_correct m (Rlt_bool x 0) m2 e2) as [H5 H6].
+  apply Zeq_bool_true.
+  rewrite Zpos_digits2_pos.
+  rewrite <- mag_F2R_Zdigits by easy.
+  now rewrite <- H3.
+apply (conj H5).
+revert H6.
+simpl.
+rewrite 2!F2R_cond_Zopp.
+now rewrite <- H3.
+elim Rgt_not_eq with (2 := H3).
+apply Rlt_trans with R0.
+now apply F2R_lt_0.
+now apply F2R_gt_0.
+rewrite <- Hr.
+apply generic_format_abs...
+apply generic_format_round...
+(* . not m1' < 0 *)
+elim Rgt_not_eq with (2 := Hr).
+apply Rlt_le_trans with R0.
+now apply F2R_lt_0.
+apply Rabs_pos.
+(* *)
+apply Rlt_le_trans with (2 := proj1 (inbetween_float_bounds _ _ _ _ _ Bx)).
+now apply F2R_gt_0.
+(* all the modes are valid *)
+clear. case m.
+exact inbetween_int_NE_sign.
+exact inbetween_int_ZR_sign.
+exact inbetween_int_DN_sign.
+exact inbetween_int_UP_sign.
+exact inbetween_int_NA_sign.
+Qed.
+
+(** Multiplication *)
+
+Lemma Bmult_correct_aux :
+  forall m sx mx ex (Hx : bounded mx ex = true) sy my ey (Hy : bounded my ey = true),
+  let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
+  let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in
+  let z := binary_round_aux m (xorb sx sy) (Zpos (mx * my)) (ex + ey) loc_Exact in
+  valid_binary z = true /\
+  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then
+    SF2R radix2 z = round radix2 fexp (round_mode m) (x * y) /\
+    is_finite_SF z = true /\ sign_SF z = xorb sx sy
+  else
+    z = binary_overflow m (xorb sx sy).
+Proof.
+intros m sx mx ex Hx sy my ey Hy x y.
+unfold x, y.
+rewrite <- F2R_mult.
+simpl.
+replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx) * cond_Zopp sy (Zpos my)) (ex + ey))) 0).
+apply binary_round_aux_correct.
+constructor.
+rewrite <- F2R_abs.
+apply F2R_eq.
+rewrite Zabs_Zmult.
+now rewrite 2!abs_cond_Zopp.
+(* *)
+change (Zpos (mx * my)) with (Zpos mx * Zpos my)%Z.
+assert (forall m e, bounded m e = true -> fexp (Zdigits radix2 (Zpos m) + e) = e)%Z.
+clear. intros m e Hb.
+destruct (andb_prop _ _ Hb) as (H,_).
+apply Zeq_bool_eq.
+now rewrite <- Zpos_digits2_pos.
+generalize (H _ _ Hx) (H _ _ Hy).
+clear x y sx sy Hx Hy H.
+unfold fexp, FLT_exp.
+refine (_ (Zdigits_mult_ge radix2 (Zpos mx) (Zpos my) _ _)) ; try discriminate.
+refine (_ (Zdigits_gt_0 radix2 (Zpos mx) _) (Zdigits_gt_0 radix2 (Zpos my) _)) ; try discriminate.
+generalize (Zdigits radix2 (Zpos mx)) (Zdigits radix2 (Zpos my)) (Zdigits radix2 (Zpos mx * Zpos my)).
+intros dx dy dxy Hx Hy Hxy.
+unfold emin.
+generalize (prec_lt_emax prec emax).
+lia.
+(* *)
+case sx ; case sy.
+apply Rlt_bool_false.
+now apply F2R_ge_0.
+apply Rlt_bool_true.
+now apply F2R_lt_0.
+apply Rlt_bool_true.
+now apply F2R_lt_0.
+apply Rlt_bool_false.
+now apply F2R_ge_0.
+Qed.
+
+Definition Bmult m x y :=
+  match x, y with
+  | B754_nan, _ | _, B754_nan => B754_nan
+  | B754_infinity sx, B754_infinity sy => B754_infinity (xorb sx sy)
+  | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy)
+  | B754_finite sx _ _ _, B754_infinity sy => B754_infinity (xorb sx sy)
+  | B754_infinity _, B754_zero _ => B754_nan
+  | B754_zero _, B754_infinity _ => B754_nan
+  | B754_finite sx _ _ _, B754_zero sy => B754_zero (xorb sx sy)
+  | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy)
+  | B754_zero sx, B754_zero sy => B754_zero (xorb sx sy)
+  | B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
+    SF2B _ (proj1 (Bmult_correct_aux m sx mx ex Hx sy my ey Hy))
+  end.
+
+(* TODO: lemme d'equivalence *)
+
+Theorem Bmult_correct :
+  forall m x y,
+  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x * B2R y))) (bpow radix2 emax) then
+    B2R (Bmult m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y) /\
+    is_finite (Bmult m x y) = andb (is_finite x) (is_finite y) /\
+    (is_nan (Bmult m x y) = false ->
+      Bsign (Bmult m x y) = xorb (Bsign x) (Bsign y))
+  else
+    B2SF (Bmult m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
+Proof.
+intros m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ;
+  try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | now auto with typeclass_instances ] ).
+simpl.
+case Bmult_correct_aux.
+intros H1.
+case Rlt_bool.
+intros (H2, (H3, H4)).
+split.
+now rewrite B2R_SF2B.
+split.
+now rewrite is_finite_SF2B.
+rewrite Bsign_SF2B. auto.
+intros H2.
+now rewrite B2SF_SF2B.
+Qed.
+
+(** Normalization and rounding *)
+
+Theorem shl_align_correct':
+  forall mx ex e,
+  (e <= ex)%Z ->
+  let (mx', ex') := shl_align mx ex e in
+  F2R (Float radix2 (Zpos mx') e) = F2R (Float radix2 (Zpos mx) ex) /\
+  ex' = e.
+Proof.
+intros mx ex ex' He.
+unfold shl_align.
+destruct (ex' - ex)%Z as [|d|d] eqn:Hd ; simpl.
+- now replace ex with ex' by lia.
+- exfalso ; lia.
+- refine (conj _ eq_refl).
+  rewrite shift_pos_correct, Zmult_comm.
+  change (Zpower_pos 2 d) with (Zpower radix2 (Z.opp (Z.neg d))).
+  rewrite <- Hd.
+  replace (- (ex' - ex))%Z with (ex - ex')%Z by ring.
+  now apply eq_sym, F2R_change_exp.
+Qed.
+
+Theorem shl_align_correct :
+  forall mx ex ex',
+  let (mx', ex'') := shl_align mx ex ex' in
+  F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex'') /\
+  (ex'' <= ex')%Z.
+Proof.
+intros mx ex ex'.
+generalize (shl_align_correct' mx ex ex').
+unfold shl_align.
+destruct (ex' - ex)%Z as [|d|d] eqn:Hd ; simpl.
+- refine (fun H => _ (H _)).
+  2: clear -Hd; lia.
+  clear.
+  intros [H1 ->].
+  now split.
+- intros _.
+  refine (conj eq_refl _).
+  lia.
+- refine (fun H => _ (H _)).
+  2: clear -Hd; lia.
+  clear.
+  now split.
+Qed.
+
+Theorem snd_shl_align :
+  forall mx ex ex',
+  (ex' <= ex)%Z ->
+  snd (shl_align mx ex ex') = ex'.
+Proof.
+intros mx ex ex' He.
+generalize (shl_align_correct' mx ex ex' He).
+now destruct shl_align as [m e].
+Qed.
+
+Definition shl_align_fexp mx ex :=
+  shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)).
+
+Theorem shl_align_fexp_correct :
+  forall mx ex,
+  let (mx', ex') := shl_align_fexp mx ex in
+  F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex') /\
+  (ex' <= fexp (Zdigits radix2 (Zpos mx') + ex'))%Z.
+Proof.
+intros mx ex.
+unfold shl_align_fexp.
+generalize (shl_align_correct mx ex (fexp (Zpos (digits2_pos mx) + ex))).
+rewrite Zpos_digits2_pos.
+case shl_align.
+intros mx' ex' (H1, H2).
+split.
+exact H1.
+rewrite <- mag_F2R_Zdigits. 2: easy.
+rewrite <- H1.
+now rewrite mag_F2R_Zdigits.
+Qed.
+
+(* TODO: lemme equivalence pour le cas mode_NE *)
+Definition binary_round m sx mx ex :=
+  let '(mz, ez) := shl_align_fexp mx ex in binary_round_aux m sx (Zpos mz) ez loc_Exact.
+
+Theorem binary_round_correct :
+  forall m sx mx ex,
+  let z := binary_round m sx mx ex in
+  valid_binary z = true /\
+  let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
+  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then
+    SF2R radix2 z = round radix2 fexp (round_mode m) x /\
+    is_finite_SF z = true /\
+    sign_SF z = sx
+  else
+    z = binary_overflow m sx.
+Proof.
+intros m sx mx ex.
+unfold binary_round.
+generalize (shl_align_fexp_correct mx ex).
+destruct (shl_align_fexp mx ex) as (mz, ez).
+intros (H1, H2).
+set (x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex)).
+replace sx with (Rlt_bool x 0).
+apply binary_round_aux_correct.
+constructor.
+unfold x.
+now rewrite <- F2R_Zabs, abs_cond_Zopp.
+exact H2.
+unfold x.
+case sx.
+apply Rlt_bool_true.
+now apply F2R_lt_0.
+apply Rlt_bool_false.
+now apply F2R_ge_0.
+Qed.
+
+Theorem is_nan_binary_round :
+  forall mode sx mx ex,
+  is_nan_SF (binary_round mode sx mx ex) = false.
+Proof.
+intros mode sx mx ex.
+generalize (binary_round_correct mode sx mx ex).
+simpl.
+destruct binary_round ; try easy.
+intros [_ H].
+destruct Rlt_bool ; try easy.
+unfold binary_overflow in H.
+now destruct overflow_to_inf.
+Qed.
+
+(* TODO: lemme equivalence pour le cas mode_NE *)
+Definition binary_normalize mode m e szero :=
+  match m with
+  | Z0 => B754_zero szero
+  | Zpos m => SF2B _ (proj1 (binary_round_correct mode false m e))
+  | Zneg m => SF2B _ (proj1 (binary_round_correct mode true m e))
+  end.
+
+Theorem binary_normalize_correct :
+  forall m mx ex szero,
+  let x := F2R (Float radix2 mx ex) in
+  let z := binary_normalize m mx ex szero in
+  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then
+    B2R z = round radix2 fexp (round_mode m) x /\
+    is_finite z = true /\
+    Bsign z =
+      match Rcompare x 0 with
+        | Eq => szero
+        | Lt => true
+        | Gt => false
+      end
+  else
+    B2SF z = binary_overflow m (Rlt_bool x 0).
+Proof with auto with typeclass_instances.
+intros m mx ez szero.
+destruct mx as [|mz|mz] ; simpl.
+rewrite F2R_0, round_0, Rabs_R0, Rlt_bool_true...
+split... split...
+rewrite Rcompare_Eq...
+apply bpow_gt_0.
+(* . mz > 0 *)
+generalize (binary_round_correct m false mz ez).
+simpl.
+case Rlt_bool_spec.
+intros _ (Vz, (Rz, (Rz', Rz''))).
+split.
+now rewrite B2R_SF2B.
+split.
+now rewrite is_finite_SF2B.
+rewrite Bsign_SF2B, Rz''.
+rewrite Rcompare_Gt...
+apply F2R_gt_0.
+simpl. lia.
+intros Hz' (Vz, Rz).
+rewrite B2SF_SF2B, Rz.
+apply f_equal.
+apply sym_eq.
+apply Rlt_bool_false.
+now apply F2R_ge_0.
+(* . mz < 0 *)
+generalize (binary_round_correct m true mz ez).
+simpl.
+case Rlt_bool_spec.
+intros _ (Vz, (Rz, (Rz', Rz''))).
+split.
+now rewrite B2R_SF2B.
+split.
+now rewrite is_finite_SF2B.
+rewrite Bsign_SF2B, Rz''.
+rewrite Rcompare_Lt...
+apply F2R_lt_0.
+simpl. lia.
+intros Hz' (Vz, Rz).
+rewrite B2SF_SF2B, Rz.
+apply f_equal.
+apply sym_eq.
+apply Rlt_bool_true.
+now apply F2R_lt_0.
+Qed.
+
+Theorem is_nan_binary_normalize :
+  forall mode m e szero,
+  is_nan (binary_normalize mode m e szero) = false.
+Proof.
+intros mode m e szero.
+generalize (binary_normalize_correct mode m e szero).
+simpl.
+destruct Rlt_bool.
+- intros [_ [H _]].
+  now destruct binary_normalize.
+- intros H.
+  rewrite <- is_nan_SF_B2SF.
+  rewrite H.
+  unfold binary_overflow.
+  now destruct overflow_to_inf.
+Qed.
+
+(** Addition *)
+
+Definition Fplus_naive sx mx ex sy my ey ez :=
+  (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))).
+
+Lemma Fplus_naive_correct :
+  forall sx mx ex sy my ey ez,
+  (ez <= ex)%Z -> (ez <= ey)%Z ->
+  let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
+  let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in
+  F2R (Float radix2 (Fplus_naive sx mx ex sy my ey ez) ez) = (x + y)%R.
+Proof.
+intros sx mx ex sy my ey ez Ex Ey.
+unfold Fplus_naive, F2R. simpl.
+generalize (shl_align_correct' mx ex ez Ex).
+generalize (shl_align_correct' my ey ez Ey).
+destruct shl_align as [my' ey'].
+destruct shl_align as [mx' ex'].
+intros [Hy _].
+intros [Hx _].
+simpl.
+rewrite plus_IZR, Rmult_plus_distr_r.
+generalize (f_equal (cond_Ropp sx) Hx).
+generalize (f_equal (cond_Ropp sy) Hy).
+rewrite <- 4!F2R_cond_Zopp.
+unfold F2R. simpl.
+now intros -> ->.
+Qed.
+
+Lemma sign_plus_overflow :
+  forall m sx mx ex sy my ey,
+  bounded mx ex = true ->
+  bounded my ey = true ->
+  let z := (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) + F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey))%R in
+  (bpow radix2 emax <= Rabs (round radix2 fexp (round_mode m) z))%R ->
+  sx = Rlt_bool z 0 /\ sx = sy.
+Proof with auto with typeclass_instances.
+intros m sx mx ex sy my ey Hx Hy z Bz.
+destruct (Bool.bool_dec sx sy) as [Hs|Hs].
+(* .. *)
+refine (conj _ Hs).
+unfold z.
+rewrite Hs.
+apply sym_eq.
+case sy.
+apply Rlt_bool_true.
+rewrite <- (Rplus_0_r 0).
+apply Rplus_lt_compat.
+now apply F2R_lt_0.
+now apply F2R_lt_0.
+apply Rlt_bool_false.
+rewrite <- (Rplus_0_r 0).
+apply Rplus_le_compat.
+now apply F2R_ge_0.
+now apply F2R_ge_0.
+(* .. *)
+elim Rle_not_lt with (1 := Bz).
+generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy).
+intros Bx By (Hx',_) (Hy',_).
+generalize (canonical_canonical_mantissa sx _ _ Hx') (canonical_canonical_mantissa sy _ _ Hy').
+clear -Bx By Hs prec_gt_0_.
+intros Cx Cy.
+destruct sx.
+(* ... *)
+destruct sy.
+now elim Hs.
+clear Hs.
+apply Rabs_lt.
+split.
+apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)).
+rewrite F2R_Zopp.
+now apply Ropp_lt_contravar.
+apply round_ge_generic...
+now apply generic_format_canonical.
+pattern (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)) at 1 ; rewrite <- Rplus_0_r.
+apply Rplus_le_compat_l.
+now apply F2R_ge_0.
+apply Rle_lt_trans with (2 := By).
+apply round_le_generic...
+now apply generic_format_canonical.
+rewrite <- (Rplus_0_l (F2R (Float radix2 (Zpos my) ey))).
+apply Rplus_le_compat_r.
+now apply F2R_le_0.
+(* ... *)
+destruct sy.
+2: now elim Hs.
+clear Hs.
+apply Rabs_lt.
+split.
+apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)).
+rewrite F2R_Zopp.
+now apply Ropp_lt_contravar.
+apply round_ge_generic...
+now apply generic_format_canonical.
+pattern (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)) at 1 ; rewrite <- Rplus_0_l.
+apply Rplus_le_compat_r.
+now apply F2R_ge_0.
+apply Rle_lt_trans with (2 := Bx).
+apply round_le_generic...
+now apply generic_format_canonical.
+rewrite <- (Rplus_0_r (F2R (Float radix2 (Zpos mx) ex))).
+apply Rplus_le_compat_l.
+now apply F2R_le_0.
+Qed.
+
+Definition Bplus m x y :=
+  match x, y with
+  | B754_nan, _ | _, B754_nan => B754_nan
+  | B754_infinity sx, B754_infinity sy => if Bool.eqb sx sy then x else B754_nan
+  | B754_infinity _, _ => x
+  | _, B754_infinity _ => y
+  | B754_zero sx, B754_zero sy =>
+    if Bool.eqb sx sy then x else
+    match m with mode_DN => B754_zero true | _ => B754_zero false end
+  | B754_zero _, _ => y
+  | _, B754_zero _ => x
+  | B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
+    let ez := Z.min ex ey in
+    binary_normalize m (Fplus_naive sx mx ex sy my ey ez)
+      ez (match m with mode_DN => true | _ => false end)
+  end.
+
+Theorem Bplus_correct :
+  forall m x y,
+  is_finite x = true ->
+  is_finite y = true ->
+  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x + B2R y))) (bpow radix2 emax) then
+    B2R (Bplus m x y) = round radix2 fexp (round_mode m) (B2R x + B2R y) /\
+    is_finite (Bplus m x y) = true /\
+    Bsign (Bplus m x y) =
+      match Rcompare (B2R x + B2R y) 0 with
+        | Eq => match m with mode_DN => orb (Bsign x) (Bsign y)
+                                 | _ => andb (Bsign x) (Bsign y) end
+        | Lt => true
+        | Gt => false
+      end
+  else
+    (B2SF (Bplus m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y).
+Proof with auto with typeclass_instances.
+intros m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy.
+(* *)
+rewrite Rplus_0_r, round_0, Rabs_R0, Rlt_bool_true...
+simpl.
+rewrite Rcompare_Eq by auto.
+destruct sx, sy; try easy; now case m.
+apply bpow_gt_0.
+(* *)
+rewrite Rplus_0_l, round_generic, Rlt_bool_true...
+split... split...
+simpl. unfold F2R.
+erewrite <- Rmult_0_l, Rcompare_mult_r.
+rewrite Rcompare_IZR with (y:=0%Z).
+destruct sy...
+apply bpow_gt_0.
+apply abs_B2R_lt_emax.
+apply generic_format_B2R.
+(* *)
+rewrite Rplus_0_r, round_generic, Rlt_bool_true...
+split... split...
+simpl. unfold F2R.
+erewrite <- Rmult_0_l, Rcompare_mult_r.
+rewrite Rcompare_IZR with (y:=0%Z).
+destruct sx...
+apply bpow_gt_0.
+apply abs_B2R_lt_emax.
+apply generic_format_B2R.
+(* *)
+clear Fx Fy.
+simpl.
+set (szero := match m with mode_DN => true | _ => false end).
+set (ez := Z.min ex ey).
+assert (Hp := Fplus_naive_correct sx mx ex sy my ey ez (Z.le_min_l _ _) (Z.le_min_r _ _)).
+set (mz := Fplus_naive sx mx ex sy my ey ez).
+simpl in Hp.
+fold mz in Hp.
+rewrite <- Hp.
+generalize (binary_normalize_correct m mz ez szero).
+simpl.
+case Rlt_bool_spec ; intros Hz.
+intros [H1 [H2 H3]].
+apply (conj H1).
+apply (conj H2).
+rewrite H3.
+case Rcompare_spec ; try easy.
+intros Hz'.
+rewrite Hz' in Hp.
+apply eq_sym, Rplus_opp_r_uniq in Hp.
+rewrite <- F2R_Zopp in Hp.
+eapply canonical_unique in Hp.
+inversion Hp.
+clear -H0.
+destruct sy, sx, m ; easy.
+apply canonical_canonical_mantissa.
+apply Bool.andb_true_iff in Hy. easy.
+rewrite <- cond_Zopp_negb.
+apply canonical_canonical_mantissa.
+apply Bool.andb_true_iff in Hx. easy.
+intros Vz.
+rewrite Hp in Hz.
+assert (Sz := sign_plus_overflow m sx mx ex sy my ey Hx Hy Hz).
+split.
+rewrite Vz.
+apply f_equal.
+now rewrite Hp.
+apply Sz.
+Qed.
+
+(** Subtraction *)
+
+Definition Bminus m x y :=
+  match x, y with
+  | B754_nan, _ | _, B754_nan => B754_nan
+  | B754_infinity sx, B754_infinity sy =>
+    if Bool.eqb sx (negb sy) then x else B754_nan
+  | B754_infinity _, _ => x
+  | _, B754_infinity sy => B754_infinity (negb sy)
+  | B754_zero sx, B754_zero sy =>
+    if Bool.eqb sx (negb sy) then x else
+    match m with mode_DN => B754_zero true | _ => B754_zero false end
+  | B754_zero _, B754_finite sy my ey Hy => B754_finite (negb sy) my ey Hy
+  | _, B754_zero _ => x
+  | B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
+    let ez := Z.min ex ey in
+    binary_normalize m (Fplus_naive sx mx ex (negb sy) my ey ez)
+      ez (match m with mode_DN => true | _ => false end)
+  end.
+
+Theorem Bminus_correct :
+  forall m x y,
+  is_finite x = true ->
+  is_finite y = true ->
+  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x - B2R y))) (bpow radix2 emax) then
+    B2R (Bminus m x y) = round radix2 fexp (round_mode m) (B2R x - B2R y) /\
+    is_finite (Bminus m x y) = true /\
+    Bsign (Bminus m x y) =
+      match Rcompare (B2R x - B2R y) 0 with
+        | Eq => match m with mode_DN => orb (Bsign x) (negb (Bsign y))
+                                 | _ => andb (Bsign x) (negb (Bsign y)) end
+        | Lt => true
+        | Gt => false
+      end
+  else
+    (B2SF (Bminus m x y) = binary_overflow m (Bsign x) /\ Bsign x = negb (Bsign y)).
+Proof with auto with typeclass_instances.
+intros m x y Fx Fy.
+generalize (Bplus_correct m x (Bopp y) Fx).
+rewrite is_finite_Bopp, B2R_Bopp.
+intros H.
+specialize (H Fy).
+rewrite <- Bsign_Bopp.
+destruct x as [| | |sx mx ex Hx], y as [| | |sy my ey Hy] ; try easy.
+now clear -Fy; destruct y as [ | | | ].
+Qed.
+
+(** Fused Multiply-Add *)
+
+Definition Bfma_szero m (x y z: binary_float) : bool :=
+  let s_xy := xorb (Bsign x) (Bsign y) in  (* sign of product x*y *)
+  if Bool.eqb s_xy (Bsign z) then s_xy
+  else match m with mode_DN => true | _ => false end.
+
+Definition Bfma m (x y z: binary_float) :=
+  match x, y with
+  | B754_nan, _ | _, B754_nan
+  | B754_infinity _, B754_zero _
+  | B754_zero _, B754_infinity _ =>
+      (* Multiplication produces NaN *)
+      B754_nan
+  | B754_infinity sx, B754_infinity sy
+  | B754_infinity sx, B754_finite sy _ _ _
+  | B754_finite sx _ _ _, B754_infinity sy =>
+      let s := xorb sx sy in
+      (* Multiplication produces infinity with sign [s] *)
+      match z with
+      | B754_nan => B754_nan
+      | B754_infinity sz => if Bool.eqb s sz then z else B754_nan
+      | _ => B754_infinity s
+      end
+  | B754_finite sx _ _ _, B754_zero sy
+  | B754_zero sx, B754_finite sy _ _ _
+  | B754_zero sx, B754_zero sy =>
+      (* Multiplication produces zero *)
+      match z with
+      | B754_nan => B754_nan
+      | B754_zero _ => B754_zero (Bfma_szero m x y z)
+      | _ => z
+      end
+  | B754_finite sx mx ex _, B754_finite sy my ey _ =>
+      (* Multiplication produces a finite, non-zero result *)
+      match z with
+      | B754_nan => B754_nan
+      | B754_infinity sz => z
+      | B754_zero _ =>
+         let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in
+         let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in
+         let '(Float _ mr er) := Fmult X Y in
+         binary_normalize m mr er (Bfma_szero m x y z)
+      | B754_finite sz mz ez _ =>
+         let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in
+         let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in
+         let Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez in
+         let '(Float _ mr er) := Fplus (Fmult X Y) Z in
+         binary_normalize m mr er (Bfma_szero m x y z)
+      end
+  end.
+
+Theorem Bfma_correct:
+  forall m x y z,
+  is_finite x = true ->
+  is_finite y = true ->
+  is_finite z = true ->
+  let res := (B2R x * B2R y + B2R z)%R in
+  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) res)) (bpow radix2 emax) then
+    B2R (Bfma m x y z) = round radix2 fexp (round_mode m) res /\
+    is_finite (Bfma m x y z) = true /\
+    Bsign (Bfma m x y z) =
+      match Rcompare res 0 with
+        | Eq => Bfma_szero m x y z
+        | Lt => true
+        | Gt => false
+      end
+  else
+    B2SF (Bfma m x y z) = binary_overflow m (Rlt_bool res 0).
+Proof.
+  intros. pattern (Bfma m x y z).
+  match goal with |- ?p ?x => set (PROP := p) end.
+  set (szero := Bfma_szero m x y z).
+  assert (BINORM: forall mr er, F2R (Float radix2 mr er) = res ->
+       PROP (binary_normalize m mr er szero)).
+  { intros mr er E.
+    specialize (binary_normalize_correct m mr er szero).
+    change (FLT_exp (3 - emax - prec) prec) with fexp. rewrite E. tauto.
+  }
+  set (add_zero :=
+    match z with
+    | B754_nan => B754_nan
+    | B754_zero sz => B754_zero szero
+    | _ => z
+    end).
+  assert (ADDZERO: B2R x = 0%R \/ B2R y = 0%R -> PROP add_zero).
+  {
+    intros Z.
+    assert (RES: res = B2R z).
+    { unfold res. destruct Z as [E|E]; rewrite E, ?Rmult_0_l, ?Rmult_0_r, Rplus_0_l; auto. }
+    unfold PROP, add_zero; destruct z as [ sz | sz | | sz mz ez Bz]; try discriminate.
+  - simpl in RES; rewrite RES; rewrite round_0 by apply valid_rnd_round_mode.
+    rewrite Rlt_bool_true. split. reflexivity. split. reflexivity.
+    rewrite Rcompare_Eq by auto. reflexivity.
+    rewrite Rabs_R0; apply bpow_gt_0.
+  - rewrite RES, round_generic, Rlt_bool_true.
+    split. reflexivity. split. reflexivity.
+    unfold B2R. destruct sz.
+    rewrite Rcompare_Lt. auto. apply F2R_lt_0. reflexivity.
+    rewrite Rcompare_Gt. auto. apply F2R_gt_0. reflexivity.
+    apply abs_B2R_lt_emax. apply valid_rnd_round_mode. apply generic_format_B2R.
+  }
+  destruct x as [ sx | sx | | sx mx ex Bx];
+  destruct y as [ sy | sy | | sy my ey By];
+  try discriminate.
+- apply ADDZERO; auto.
+- apply ADDZERO; auto.
+- apply ADDZERO; auto.
+- destruct z as [ sz | sz | | sz mz ez Bz]; try discriminate; unfold Bfma.
++ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex).
+  set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey).
+  destruct (Fmult X Y) as [mr er] eqn:FRES.
+  apply BINORM. unfold res. rewrite <- FRES, F2R_mult, Rplus_0_r. auto.
++ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex).
+  set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey).
+  set (Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez).
+  destruct (Fplus (Fmult X Y) Z) as [mr er] eqn:FRES.
+  apply BINORM. unfold res. rewrite <- FRES, F2R_plus, F2R_mult. auto.
+Qed.
+
+(** Division *)
+
+Lemma Bdiv_correct_aux :
+  forall m sx mx ex sy my ey,
+  let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
+  let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in
+  let z :=
+    let '(mz, ez, lz) := SFdiv_core_binary prec emax (Zpos mx) ex (Zpos my) ey in
+    binary_round_aux m (xorb sx sy) mz ez lz in
+  valid_binary z = true /\
+  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then
+    SF2R radix2 z = round radix2 fexp (round_mode m) (x / y) /\
+    is_finite_SF z = true /\ sign_SF z = xorb sx sy
+  else
+    z = binary_overflow m (xorb sx sy).
+Proof.
+intros m sx mx ex sy my ey.
+unfold SFdiv_core_binary.
+rewrite 2!Zdigits2_Zdigits.
+set (e' := Z.min _ _).
+match goal with |- context [Z.div_eucl ?m _] => set (mx' := m) end.
+generalize (Fdiv_core_correct radix2 (Zpos mx) ex (Zpos my) ey e' eq_refl eq_refl).
+unfold Fdiv_core.
+rewrite Zle_bool_true by apply Z.le_min_r.
+assert (mx' = Zpos mx * Zpower radix2 (ex - ey - e'))%Z as <-.
+{ unfold mx'.
+  destruct (ex - ey - e')%Z as [|p|p].
+  now rewrite Zmult_1_r.
+  now rewrite Z.shiftl_mul_pow2.
+  easy. }
+clearbody mx'.
+destruct Z.div_eucl as [q r].
+intros Bz.
+assert (xorb sx sy = Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) *
+  / F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey)) 0) as ->.
+{ apply eq_sym.
+case sy ; simpl.
+change (Zneg my) with (Z.opp (Zpos my)).
+rewrite F2R_Zopp.
+rewrite <- Ropp_inv_permute.
+rewrite Ropp_mult_distr_r_reverse.
+case sx ; simpl.
+apply Rlt_bool_false.
+rewrite <- Ropp_mult_distr_l_reverse.
+apply Rmult_le_pos.
+rewrite <- F2R_opp.
+now apply F2R_ge_0.
+apply Rlt_le.
+apply Rinv_0_lt_compat.
+now apply F2R_gt_0.
+apply Rlt_bool_true.
+rewrite <- Ropp_0.
+apply Ropp_lt_contravar.
+apply Rmult_lt_0_compat.
+now apply F2R_gt_0.
+apply Rinv_0_lt_compat.
+now apply F2R_gt_0.
+apply Rgt_not_eq.
+now apply F2R_gt_0.
+case sx.
+apply Rlt_bool_true.
+rewrite F2R_Zopp.
+rewrite Ropp_mult_distr_l_reverse.
+rewrite <- Ropp_0.
+apply Ropp_lt_contravar.
+apply Rmult_lt_0_compat.
+now apply F2R_gt_0.
+apply Rinv_0_lt_compat.
+now apply F2R_gt_0.
+apply Rlt_bool_false.
+apply Rmult_le_pos.
+now apply F2R_ge_0.
+apply Rlt_le.
+apply Rinv_0_lt_compat.
+now apply F2R_gt_0. }
+unfold Rdiv.
+apply binary_round_aux_correct'.
+- apply Rmult_integral_contrapositive_currified.
+  now apply F2R_neq_0 ; case sx.
+  apply Rinv_neq_0_compat.
+  now apply F2R_neq_0 ; case sy.
+- rewrite Rabs_mult, Rabs_Rinv.
+  + rewrite <- 2!F2R_Zabs, 2!abs_cond_Zopp; simpl.
+    replace (SpecFloat.new_location _ _) with (Bracket.new_location (Z.pos my) r loc_Exact);
+      [exact Bz|].
+    case my as [p|p|]; [reflexivity| |reflexivity].
+    unfold Bracket.new_location, SpecFloat.new_location; simpl.
+    unfold Bracket.new_location_even, SpecFloat.new_location_even; simpl.
+    now case Zeq_bool; [|case r as [|rp|rp]; case Z.compare].
+  + now apply F2R_neq_0 ; case sy.
+- rewrite <- cexp_abs, Rabs_mult, Rabs_Rinv.
+  rewrite 2!F2R_cond_Zopp, 2!abs_cond_Ropp, <- Rabs_Rinv.
+  rewrite <- Rabs_mult, cexp_abs.
+  apply Z.le_trans with (1 := Z.le_min_l _ _).
+  apply FLT_exp_monotone.
+  now apply mag_div_F2R.
+  now apply F2R_neq_0.
+  now apply F2R_neq_0 ; case sy.
+Qed.
+
+Definition Bdiv m x y :=
+  match x, y with
+  | B754_nan, _ | _, B754_nan => B754_nan
+  | B754_infinity sx, B754_infinity sy => B754_nan
+  | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy)
+  | B754_finite sx _ _ _, B754_infinity sy => B754_zero (xorb sx sy)
+  | B754_infinity sx, B754_zero sy => B754_infinity (xorb sx sy)
+  | B754_zero sx, B754_infinity sy => B754_zero (xorb sx sy)
+  | B754_finite sx _ _ _, B754_zero sy => B754_infinity (xorb sx sy)
+  | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy)
+  | B754_zero sx, B754_zero sy => B754_nan
+  | B754_finite sx mx ex _, B754_finite sy my ey _ =>
+    SF2B _ (proj1 (Bdiv_correct_aux m sx mx ex sy my ey))
+  end.
+
+Theorem Bdiv_correct :
+  forall m x y,
+  B2R y <> 0%R ->
+  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x / B2R y))) (bpow radix2 emax) then
+    B2R (Bdiv m x y) = round radix2 fexp (round_mode m) (B2R x / B2R y) /\
+    is_finite (Bdiv m x y) = is_finite x /\
+    (is_nan (Bdiv m x y) = false ->
+      Bsign (Bdiv m x y) = xorb (Bsign x) (Bsign y))
+  else
+    B2SF (Bdiv m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
+Proof.
+intros m x [sy|sy| |sy my ey Hy] Zy ; try now elim Zy.
+revert x.
+unfold Rdiv.
+intros [sx|sx| |sx mx ex Hx] ;
+  try ( rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | auto with typeclass_instances ] ).
+simpl.
+case Bdiv_correct_aux.
+intros H1.
+unfold Rdiv.
+case Rlt_bool.
+intros (H2, (H3, H4)).
+split.
+now rewrite B2R_SF2B.
+split.
+now rewrite is_finite_SF2B.
+rewrite Bsign_SF2B. congruence.
+intros H2.
+now rewrite B2SF_SF2B.
+Qed.
+
+(** Square root *)
+
+Lemma Bsqrt_correct_aux :
+  forall m mx ex (Hx : bounded mx ex = true),
+  let x := F2R (Float radix2 (Zpos mx) ex) in
+  let z :=
+    let '(mz, ez, lz) := SFsqrt_core_binary prec emax (Zpos mx) ex in
+    binary_round_aux m false mz ez lz in
+  valid_binary z = true /\
+  SF2R radix2 z = round radix2 fexp (round_mode m) (sqrt x) /\
+  is_finite_SF z = true /\ sign_SF z = false.
+Proof with auto with typeclass_instances.
+intros m mx ex Hx.
+unfold SFsqrt_core_binary.
+rewrite Zdigits2_Zdigits.
+set (e' := Z.min _ _).
+assert (2 * e' <= ex)%Z as He.
+{ assert (e' <= Z.div2 ex)%Z by apply Z.le_min_r.
+  rewrite (Zdiv2_odd_eqn ex).
+  destruct Z.odd ; lia. }
+generalize (Fsqrt_core_correct radix2 (Zpos mx) ex e' eq_refl He).
+unfold Fsqrt_core.
+set (mx' := match (ex - 2 * e')%Z with Z0 => _ | _ => _ end).
+assert (mx' = Zpos mx * Zpower radix2 (ex - 2 * e'))%Z as <-.
+{ unfold mx'.
+  destruct (ex - 2 * e')%Z as [|p|p].
+  now rewrite Zmult_1_r.
+  now rewrite Z.shiftl_mul_pow2.
+  easy. }
+clearbody mx'.
+destruct Z.sqrtrem as [mz r].
+set (lz := if Zeq_bool r 0 then _ else _).
+clearbody lz.
+intros Bz.
+refine (_ (binary_round_aux_correct' m (sqrt (F2R (Float radix2 (Zpos mx) ex))) mz e' lz _ _ _)) ; cycle 1.
+  now apply Rgt_not_eq, sqrt_lt_R0, F2R_gt_0.
+  rewrite Rabs_pos_eq.
+  exact Bz.
+  apply sqrt_ge_0.
+  apply Z.le_trans with (1 := Z.le_min_l _ _).
+  apply FLT_exp_monotone.
+  rewrite mag_sqrt_F2R by easy.
+  apply Z.le_refl.
+rewrite Rlt_bool_false by apply sqrt_ge_0.
+rewrite Rlt_bool_true.
+easy.
+rewrite Rabs_pos_eq.
+refine (_ (relative_error_FLT_ex radix2 emin prec (prec_gt_0 prec) (round_mode m) (sqrt (F2R (Float radix2 (Zpos mx) ex))) _)).
+fold fexp.
+intros (eps, (Heps, Hr)).
+change fexp with (FLT_exp emin prec).
+rewrite Hr.
+assert (Heps': (Rabs eps < 1)%R).
+apply Rlt_le_trans with (1 := Heps).
+fold (bpow radix2 0).
+apply bpow_le.
+generalize (prec_gt_0 prec).
+clear ; lia.
+apply Rsqr_incrst_0.
+3: apply bpow_ge_0.
+rewrite Rsqr_mult.
+rewrite Rsqr_sqrt.
+2: now apply F2R_ge_0.
+unfold Rsqr.
+apply Rmult_ge_0_gt_0_lt_compat.
+apply Rle_ge.
+apply Rle_0_sqr.
+apply bpow_gt_0.
+now apply bounded_lt_emax.
+apply Rlt_le_trans with 4%R.
+apply (Rsqr_incrst_1 _ 2).
+apply Rplus_lt_compat_l.
+apply (Rabs_lt_inv _ _ Heps').
+rewrite <- (Rplus_opp_r 1).
+apply Rplus_le_compat_l.
+apply Rlt_le.
+apply (Rabs_lt_inv _ _ Heps').
+now apply IZR_le.
+change 4%R with (bpow radix2 2).
+apply bpow_le.
+generalize (prec_gt_0 prec) (prec_lt_emax prec emax).
+clear ; lia.
+apply Rmult_le_pos.
+apply sqrt_ge_0.
+rewrite <- (Rplus_opp_r 1).
+apply Rplus_le_compat_l.
+apply Rlt_le.
+apply (Rabs_lt_inv _ _ Heps').
+rewrite Rabs_pos_eq.
+2: apply sqrt_ge_0.
+apply Rsqr_incr_0.
+2: apply bpow_ge_0.
+2: apply sqrt_ge_0.
+rewrite Rsqr_sqrt.
+2: now apply F2R_ge_0.
+apply Rle_trans with (bpow radix2 emin).
+unfold Rsqr.
+rewrite <- bpow_plus.
+apply bpow_le.
+unfold emin.
+generalize (prec_lt_emax prec emax).
+clear ; lia.
+apply generic_format_ge_bpow with fexp.
+intros.
+apply Z.le_max_r.
+now apply F2R_gt_0.
+apply generic_format_canonical.
+apply (canonical_canonical_mantissa false).
+apply (andb_prop _ _ Hx).
+apply round_ge_generic...
+apply generic_format_0.
+apply sqrt_ge_0.
+Qed.
+
+Definition Bsqrt m x :=
+  match x with
+  | B754_nan => B754_nan
+  | B754_infinity false => x
+  | B754_infinity true => B754_nan
+  | B754_finite true _ _ _ => B754_nan
+  | B754_zero _ => x
+  | B754_finite sx mx ex Hx =>
+    SF2B _ (proj1 (Bsqrt_correct_aux m mx ex Hx))
+  end.
+
+Theorem Bsqrt_correct :
+  forall m x,
+  B2R (Bsqrt m x) = round radix2 fexp (round_mode m) (sqrt (B2R x)) /\
+  is_finite (Bsqrt m x) = match x with B754_zero _ => true | B754_finite false _ _ _ => true | _ => false end /\
+  (is_nan (Bsqrt m x) = false -> Bsign (Bsqrt m x) = Bsign x).
+Proof.
+intros m [sx|[|]| |sx mx ex Hx] ;
+  try ( simpl ; rewrite sqrt_0, round_0, ?B2R_build_nan, ?is_finite_build_nan, ?is_nan_build_nan ; intuition auto with typeclass_instances ; easy).
+simpl.
+case Bsqrt_correct_aux.
+intros H1 (H2, (H3, H4)).
+case sx.
+refine (conj _ (conj (refl_equal false) _)).
+apply sym_eq.
+unfold sqrt.
+case Rcase_abs.
+intros _.
+apply round_0.
+auto with typeclass_instances.
+intros H.
+elim Rge_not_lt with (1 := H).
+now apply F2R_lt_0.
+easy.
+split.
+now rewrite B2R_SF2B.
+split.
+now rewrite is_finite_SF2B.
+intros _.
+now rewrite Bsign_SF2B.
+Qed.
+
+(** A few values *)
+
+Definition Bone := SF2B _ (proj1 (binary_round_correct mode_NE false 1 0)).
+
+Theorem Bone_correct : B2R Bone = 1%R.
+Proof.
+unfold Bone; simpl.
+set (Hr := binary_round_correct _ _ _ _).
+unfold Hr; rewrite B2R_SF2B.
+destruct Hr as (Vz, Hr).
+revert Hr.
+fold emin; simpl.
+rewrite round_generic; [|now apply valid_rnd_N|].
+- unfold F2R; simpl; rewrite Rmult_1_r.
+  rewrite Rlt_bool_true.
+  + now intros (Hr, Hr'); rewrite Hr.
+  + rewrite Rabs_pos_eq; [|lra].
+    change 1%R with (bpow radix2 0); apply bpow_lt.
+    generalize (prec_gt_0 prec) (prec_lt_emax prec emax).
+    lia.
+- apply generic_format_F2R; intros _.
+  unfold cexp, fexp, FLT_exp, F2R; simpl; rewrite Rmult_1_r, mag_1.
+  unfold emin.
+  generalize (prec_gt_0 prec) (prec_lt_emax prec emax).
+  lia.
+Qed.
+
+Theorem is_finite_strict_Bone :
+  is_finite_strict Bone = true.
+Proof.
+apply is_finite_strict_B2R.
+rewrite Bone_correct.
+apply R1_neq_R0.
+Qed.
+
+Theorem is_nan_Bone :
+  is_nan Bone = false.
+Proof.
+unfold Bone.
+rewrite is_nan_SF2B.
+apply is_nan_binary_round.
+Qed.
+
+Theorem is_finite_Bone :
+  is_finite Bone = true.
+Proof.
+generalize is_finite_strict_Bone.
+now destruct Bone.
+Qed.
+
+Theorem Bsign_Bone :
+  Bsign Bone = false.
+Proof.
+generalize Bone_correct is_finite_strict_Bone.
+destruct Bone as [sx|sx| |[|] mx ex Bx] ; try easy.
+intros H _.
+contradict H.
+apply Rlt_not_eq, Rlt_trans with (2 := Rlt_0_1).
+now apply F2R_lt_0.
+Qed.
+
+Lemma Bmax_float_proof :
+  valid_binary
+    (S754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec))
+  = true.
+Proof.
+unfold valid_binary, bounded; apply andb_true_intro; split.
+- unfold canonical_mantissa; apply Zeq_bool_true.
+  set (p := Z.pos (digits2_pos _)).
+  assert (H : p = prec).
+  { unfold p; rewrite Zpos_digits2_pos, Pos2Z.inj_sub.
+    - rewrite shift_pos_correct, Z.mul_1_r.
+      assert (P2pm1 : (0 <= 2 ^ prec - 1)%Z).
+      { apply (Zplus_le_reg_r _ _ 1); ring_simplify.
+        change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
+        apply Zpower_le; unfold Prec_gt_0 in prec_gt_0_; lia. }
+      apply Zdigits_unique;
+        rewrite Z.pow_pos_fold, Z2Pos.id; [|exact prec_gt_0_]; simpl; split.
+      + rewrite (Z.abs_eq _ P2pm1).
+        replace prec with (prec - 1 + 1)%Z at 2 by ring.
+        rewrite Zpower_plus; [| unfold Prec_gt_0 in prec_gt_0_; lia|lia].
+        simpl; unfold Z.pow_pos; simpl.
+        assert (1 <= 2 ^ (prec - 1))%Z; [|lia].
+        change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
+        apply Zpower_le; simpl; unfold Prec_gt_0 in prec_gt_0_; lia.
+      + now rewrite Z.abs_eq; [lia|].
+    - change (_ < _)%positive
+        with (Z.pos 1 < Z.pos (shift_pos (Z.to_pos prec) 1))%Z.
+      rewrite shift_pos_correct, Z.mul_1_r, Z.pow_pos_fold.
+      rewrite Z2Pos.id; [|exact prec_gt_0_].
+      change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
+      apply Zpower_lt; unfold Prec_gt_0 in prec_gt_0_; lia. }
+  unfold fexp, FLT_exp; rewrite H, Z.max_l; [ring|].
+  unfold emin.
+  generalize (prec_gt_0 prec) (prec_lt_emax prec emax).
+  lia.
+- apply Zle_bool_true; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
+Qed.
+
+Definition Bmax_float := SF2B _ Bmax_float_proof.
+
+(** Extraction/modification of mantissa/exponent *)
+
+Definition Bnormfr_mantissa x := SFnormfr_mantissa prec (B2SF x).
+
+Lemma Bnormfr_mantissa_correct :
+  forall x,
+  (/ 2 <= Rabs (B2R x) < 1)%R ->
+  match x with
+  | B754_finite _ m e _ =>
+    Bnormfr_mantissa x = N.pos m
+    /\ Z.pos (digits2_pos m) = prec /\ (e = - prec)%Z
+  | _ => False
+  end.
+Proof.
+intro x.
+destruct x as [s|s| |s m e B]; [now simpl; rewrite Rabs_R0; lra..| ].
+unfold Bnormfr_mantissa, SFnormfr_mantissa; simpl.
+intro Hx.
+cut (e = -prec /\ Z.pos (digits2_pos m) = prec)%Z.
+{ now intros [-> ->]; rewrite Z.eqb_refl. }
+revert Hx.
+change (/ 2)%R with (bpow radix2 (0 - 1)); change 1%R with (bpow radix2 0).
+intro H; generalize (mag_unique _ _ _ H); clear H.
+rewrite Float_prop.mag_F2R_Zdigits; [ |now case s].
+replace (Digits.Zdigits _ _)
+  with (Digits.Zdigits radix2 (Z.pos m)); [ |now case s].
+clear s.
+rewrite <-Digits.Zpos_digits2_pos.
+intro He; replace e with (e - 0)%Z by ring; rewrite <-He.
+cut (Z.pos (digits2_pos m) = prec)%Z.
+{ now intro H; split; [ |exact H]; ring_simplify; rewrite H. }
+revert B; unfold bounded, canonical_mantissa.
+intro H; generalize (andb_prop _ _ H); clear H; intros [H _]; revert H.
+intro H; generalize (Zeq_bool_eq _ _ H); clear H.
+unfold fexp, emin.
+unfold Prec_gt_0 in prec_gt_0_; unfold Prec_lt_emax in prec_lt_emax_.
+lia.
+Qed.
+
+Definition Bldexp mode f e :=
+  match f with
+  | B754_finite sx mx ex _ =>
+    SF2B _ (proj1 (binary_round_correct mode sx mx (ex+e)))
+  | _ => f
+  end.
+
+Theorem is_nan_Bldexp :
+  forall mode x e,
+  is_nan (Bldexp mode x e) = is_nan x.
+Proof.
+intros mode [sx|sx| |sx mx ex Bx] e ; try easy.
+unfold Bldexp.
+rewrite is_nan_SF2B.
+apply is_nan_binary_round.
+Qed.
+
+Theorem Bldexp_correct :
+  forall m (f : binary_float) e,
+  if Rlt_bool
+       (Rabs (round radix2 fexp (round_mode m) (B2R f * bpow radix2 e)))
+       (bpow radix2 emax) then
+    (B2R (Bldexp m f e)
+     = round radix2 fexp (round_mode m) (B2R f * bpow radix2 e))%R /\
+    is_finite (Bldexp m f e) = is_finite f /\
+    Bsign (Bldexp m f e) = Bsign f
+  else
+    B2SF (Bldexp m f e) = binary_overflow m (Bsign f).
+Proof.
+intros m f e.
+case f.
+- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode].
+  now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0].
+- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode].
+  now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0].
+- simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode].
+  now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0].
+- intros s mf ef Hmef.
+  case (Rlt_bool_spec _ _); intro Hover.
+  + unfold Bldexp; rewrite B2R_SF2B, is_finite_SF2B, Bsign_SF2B.
+    simpl; unfold F2R; simpl; rewrite Rmult_assoc, <-bpow_plus.
+    destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr).
+    fold emin in Hr; simpl in Hr; rewrite Rlt_bool_true in Hr.
+    * now destruct Hr as (Hr, (Hfr, Hsr)); rewrite Hr, Hfr, Hsr.
+    * now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus.
+  + unfold Bldexp; rewrite B2SF_SF2B; simpl.
+    destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr).
+    fold emin in Hr; simpl in Hr; rewrite Rlt_bool_false in Hr; [exact Hr|].
+    now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus.
+Qed.
+
+Lemma Bldexp_Bopp_NE x e : Bldexp mode_NE (Bopp x) e = Bopp (Bldexp mode_NE x e).
+Proof.
+case x as [s|s| |s m e' B]; [now simpl..| ].
+apply B2SF_inj.
+replace (B2SF (Bopp _)) with (SFopp (B2SF (Bldexp mode_NE (B754_finite s m e' B) e))).
+{ unfold Bldexp, Bopp; rewrite !B2SF_SF2B.
+  unfold binary_round.
+  set (shl := shl_align_fexp _ _); case shl; intros mz ez.
+  unfold binary_round_aux.
+  set (shr := shr_fexp _ _ _); case shr; intros mrs e''.
+  unfold choice_mode.
+  set (shr' := shr_fexp _ _ _); case shr'; intros mrs' e'''.
+  unfold binary_fit_aux.
+  now case (shr_m mrs') as [|p|p]; [|case Z.leb|]. }
+now case Bldexp as [s'|s'| |s' m' e'' B'].
+Qed.
+
+Definition Ffrexp_core_binary s m e :=
+  if Zlt_bool (-prec) emin then
+    (S754_finite s m e, 0%Z)
+  else if (Z.to_pos prec <=? digits2_pos m)%positive then
+    (S754_finite s m (-prec), (e + prec)%Z)
+  else
+    let d := (prec - Z.pos (digits2_pos m))%Z in
+    (S754_finite s (shift_pos (Z.to_pos d) m) (-prec), (e + prec - d)%Z).
+
+Lemma Bfrexp_correct_aux :
+  forall sx mx ex (Hx : bounded mx ex = true),
+  let x := F2R (Float radix2 (cond_Zopp sx (Z.pos mx)) ex) in
+  let z := fst (Ffrexp_core_binary sx mx ex) in
+  let e := snd (Ffrexp_core_binary sx mx ex) in
+  valid_binary z = true /\
+  ((2 < emax)%Z -> (/2 <= Rabs (SF2R radix2 z) < 1)%R) /\
+  (x = SF2R radix2 z * bpow radix2 e)%R.
+Proof.
+intros sx mx ex Bx.
+set (x := F2R _).
+set (z := fst _).
+set (e := snd _); simpl.
+assert (Dmx_le_prec : (Z.pos (digits2_pos mx) <= prec)%Z).
+{ revert Bx; unfold bounded; rewrite Bool.andb_true_iff.
+  unfold canonical_mantissa; rewrite <-Zeq_is_eq_bool; unfold fexp, FLT_exp.
+  case (Z.max_spec (Z.pos (digits2_pos mx) + ex - prec) emin); lia. }
+assert (Dmx_le_prec' : (digits2_pos mx <= Z.to_pos prec)%positive).
+{ change (_ <= _)%positive
+    with (Z.pos (digits2_pos mx) <= Z.pos (Z.to_pos prec))%Z.
+  now rewrite Z2Pos.id; [|now apply prec_gt_0_]. }
+unfold z, e, Ffrexp_core_binary.
+case Z.ltb_spec ; intros Hp ; unfold emin in Hp.
+{ apply (conj Bx).
+  split.
+  clear -Hp ; lia.
+  now rewrite Rmult_1_r. }
+case (Pos.leb_spec _ _); simpl; intro Dmx.
+- unfold bounded, F2R; simpl.
+  assert (Dmx' : digits2_pos mx = Z.to_pos prec).
+  { now apply Pos.le_antisym. }
+  assert (Dmx'' : Z.pos (digits2_pos mx) = prec).
+  { now rewrite Dmx', Z2Pos.id; [|apply prec_gt_0_]. }
+  split; [|split].
+  + apply andb_true_intro.
+    split ; cycle 1.
+    { apply Zle_bool_true. clear -Hp ; lia. }
+    apply Zeq_bool_true; unfold fexp, FLT_exp.
+    rewrite Dmx', Z2Pos.id by apply prec_gt_0_.
+    rewrite Z.max_l.
+    ring.
+    clear -Hp.
+    unfold emin ; lia.
+  + intros _.
+    rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)) by now apply bpow_ge_0.
+    rewrite <-abs_IZR, abs_cond_Zopp; simpl; split.
+    * apply (Rmult_le_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|].
+      rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl.
+      rewrite Rmult_1_r.
+      change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus.
+      rewrite <-Dmx'', Z.add_comm, Zpos_digits2_pos, Zdigits_mag; [|lia].
+      set (b := bpow _ _).
+      rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
+      apply bpow_mag_le; apply IZR_neq; lia.
+    * apply (Rmult_lt_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|].
+      rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl.
+      rewrite Rmult_1_l, Rmult_1_r.
+      rewrite <-Dmx'', Zpos_digits2_pos, Zdigits_mag; [|lia].
+      set (b := bpow _ _).
+      rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
+      apply bpow_mag_gt; apply IZR_neq; lia.
+  + rewrite Rmult_assoc, <- bpow_plus.
+    now replace (_ + _)%Z with ex by ring.
+- unfold bounded, F2R; simpl.
+  assert (Dmx' : (Z.pos (digits2_pos mx) < prec)%Z).
+  { now rewrite <-(Z2Pos.id prec); [|now apply prec_gt_0_]. }
+  split; [|split].
+  + unfold bounded; apply andb_true_intro.
+    split ; cycle 1.
+    { apply Zle_bool_true. clear -Hp ; lia. }
+    apply Zeq_bool_true; unfold fexp, FLT_exp.
+    rewrite Zpos_digits2_pos, shift_pos_correct, Z.pow_pos_fold.
+    rewrite Z2Pos.id; [|lia].
+    rewrite Z.mul_comm; change 2%Z with (radix2 : Z).
+    rewrite Zdigits_mult_Zpower; [|lia|lia].
+    rewrite Zpos_digits2_pos; replace (_ - _)%Z with (- prec)%Z by ring.
+    now apply Z.max_l.
+  + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0].
+    rewrite <-abs_IZR, abs_cond_Zopp; simpl.
+    rewrite shift_pos_correct, mult_IZR.
+    change (IZR (Z.pow_pos _ _))
+      with (bpow radix2 (Z.pos (Z.to_pos ((prec - Z.pos (digits2_pos mx)))))).
+    rewrite Z2Pos.id; [|lia].
+    rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus.
+    set (d := Z.pos (digits2_pos mx)).
+    replace (_ + _)%Z with (- d)%Z by ring; split.
+    * apply (Rmult_le_reg_l (bpow radix2 d)); [now apply bpow_gt_0|].
+      rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r.
+      rewrite Rmult_1_l.
+      change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus.
+      rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
+      unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia].
+      apply bpow_mag_le; apply IZR_neq; lia.
+    * apply (Rmult_lt_reg_l (bpow radix2 d)); [now apply bpow_gt_0|].
+      rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r.
+      rewrite Rmult_1_l, Rmult_1_r.
+      rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
+      unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia].
+      apply bpow_mag_gt; apply IZR_neq; lia.
+  + rewrite Rmult_assoc, <-bpow_plus, shift_pos_correct.
+    rewrite IZR_cond_Zopp, mult_IZR, cond_Ropp_mult_r, <-IZR_cond_Zopp.
+    change (IZR (Z.pow_pos _ _))
+      with (bpow radix2 (Z.pos (Z.to_pos (prec - Z.pos (digits2_pos mx))))).
+    rewrite Z2Pos.id; [|lia].
+    rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus.
+    now replace (_ + _)%Z with ex by ring; rewrite Rmult_comm.
+Qed.
+
+Definition Bfrexp f :=
+  match f with
+  | B754_finite s m e H =>
+    let e' := snd (Ffrexp_core_binary s m e) in
+    (SF2B _ (proj1 (Bfrexp_correct_aux s m e H)), e')
+  | _ => (f, (-2*emax-prec)%Z)
+  end.
+
+Theorem is_nan_Bfrexp :
+  forall x,
+  is_nan (fst (Bfrexp x)) = is_nan x.
+Proof.
+intros [sx|sx| |sx mx ex Bx] ; try easy.
+simpl.
+rewrite is_nan_SF2B.
+unfold Ffrexp_core_binary.
+destruct Zlt_bool ; try easy.
+now destruct Pos.leb.
+Qed.
+
+Theorem Bfrexp_correct :
+  forall f,
+  is_finite_strict f = true ->
+  let (z, e) := Bfrexp f in
+  (B2R f = B2R z * bpow radix2 e)%R /\
+  ( (2 < emax)%Z -> (/2 <= Rabs (B2R z) < 1)%R /\ e = mag radix2 (B2R f) ).
+Proof.
+intro f; case f; intro s; try discriminate; intros m e Hf _.
+generalize (Bfrexp_correct_aux s m e Hf).
+intros (_, (Hb, Heq)); simpl; rewrite B2R_SF2B.
+split.
+easy.
+intros Hp.
+specialize (Hb Hp).
+split.
+easy.
+rewrite Heq, mag_mult_bpow.
+- apply (Z.add_reg_l (- (snd (Ffrexp_core_binary s m e)))).
+  now ring_simplify; symmetry; apply mag_unique.
+- intro H; destruct Hb as (Hb, _); revert Hb; rewrite H, Rabs_R0; lra.
+Qed.
+
+(** Ulp *)
+
+Lemma Bulp_correct_aux :
+  bounded 1 emin = true.
+Proof.
+unfold bounded, canonical_mantissa.
+rewrite Zeq_bool_true.
+apply Zle_bool_true.
+unfold emin.
+generalize (prec_gt_0 prec) (prec_lt_emax prec emax).
+lia.
+apply Z.max_r.
+simpl digits2_pos.
+generalize (prec_gt_0 prec).
+lia.
+Qed.
+
+Definition Bulp x :=
+  match x with
+  | B754_zero _ => B754_finite false 1 emin Bulp_correct_aux
+  | B754_infinity _ => B754_infinity false
+  | B754_nan => B754_nan
+  | B754_finite _ _ e _ => binary_normalize mode_ZR 1 e false
+  end.
+
+Theorem is_nan_Bulp :
+  forall x,
+  is_nan (Bulp x) = is_nan x.
+Proof.
+intros [sx|sx| |sx mx ex Bx] ; try easy.
+unfold Bulp.
+apply is_nan_binary_normalize.
+Qed.
+
+Theorem Bulp_correct :
+  forall x,
+  is_finite x = true ->
+  B2R (Bulp x) = ulp radix2 fexp (B2R x) /\
+  is_finite (Bulp x) = true /\
+  Bsign (Bulp x) = false.
+Proof.
+intros [sx|sx| |sx mx ex Hx] Fx ; try easy ; simpl.
+- repeat split.
+  change fexp with (FLT_exp emin prec).
+  rewrite ulp_FLT_0 by easy.
+  apply F2R_bpow.
+- destruct (binary_round_correct mode_ZR false 1 ex) as [H1 H2].
+  revert H2.
+  simpl.
+  destruct (andb_prop _ _ Hx) as [H5 H6].
+  replace (round _ _ _ _) with (bpow radix2 ex).
+  rewrite Rlt_bool_true.
+  intros [H2 [H3 H4]].
+  split ; [|split].
+  + rewrite B2R_SF2B.
+    rewrite ulp_canonical.
+    exact H2.
+    now case sx.
+    now apply canonical_canonical_mantissa.
+  + now rewrite is_finite_SF2B.
+  + now rewrite Bsign_SF2B.
+  + rewrite Rabs_pos_eq by apply bpow_ge_0.
+    apply bpow_lt.
+    generalize (prec_gt_0 prec) (Zle_bool_imp_le _ _ H6).
+    clear ; lia.
+  + rewrite F2R_bpow.
+    apply sym_eq, round_generic.
+    typeclasses eauto.
+    apply generic_format_FLT_bpow.
+    easy.
+    rewrite (canonical_canonical_mantissa false _ _ H5).
+    apply Z.max_le_iff.
+    now right.
+Qed.
+
+Theorem is_finite_strict_Bulp :
+  forall x,
+  is_finite_strict (Bulp x) = is_finite x.
+Proof.
+intros [sx|sx| |sx mx ex Bx] ; try easy.
+generalize (Bulp_correct (B754_finite sx mx ex Bx) eq_refl).
+destruct Bulp as [sy| | |] ; try easy.
+intros [H _].
+contradict H.
+rewrite ulp_neq_0.
+apply Rlt_not_eq.
+apply bpow_gt_0.
+apply F2R_neq_0.
+now destruct sx.
+Qed.
+
+Definition Bulp' x := Bldexp mode_NE Bone (fexp (snd (Bfrexp x))).
+
+Theorem Bulp'_correct :
+  (2 < emax)%Z ->
+  forall x,
+  is_finite x = true ->
+  Bulp' x = Bulp x.
+Proof.
+intros Hp x Fx.
+assert (B2R (Bulp' x) = ulp radix2 fexp (B2R x) /\
+        is_finite (Bulp' x) = true /\
+        Bsign (Bulp' x) = false) as [H1 [H2 H3]].
+{ destruct x as [sx|sx| |sx mx ex Hx] ; unfold Bulp'.
+- replace (fexp _) with emin.
+  + generalize (Bldexp_correct mode_NE Bone emin).
+    rewrite Bone_correct, Rmult_1_l, round_generic;
+      [|now apply valid_rnd_N|apply generic_format_bpow; unfold fexp, FLT_exp;
+        rewrite Z.max_r; unfold Prec_gt_0 in prec_gt_0_; lia].
+    rewrite Rlt_bool_true.
+    * intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs.
+      split; [|now split; [apply is_finite_Bone|apply Bsign_Bone]].
+      simpl; unfold ulp; rewrite Req_bool_true; [|reflexivity].
+      destruct (negligible_exp_FLT emin prec) as (n, (Hn, Hn')).
+      change fexp with (FLT_exp emin prec); rewrite Hn.
+      now unfold FLT_exp; rewrite Z.max_r;
+        [|unfold Prec_gt_0 in prec_gt_0_; lia].
+    * rewrite Rabs_pos_eq; [|now apply bpow_ge_0]; apply bpow_lt.
+      unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
+  + simpl; change (fexp _) with (fexp (-2 * emax - prec)).
+    unfold fexp, FLT_exp; rewrite Z.max_r; [reflexivity|].
+    unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
+- discriminate.
+- discriminate.
+- unfold ulp, cexp.
+  set (f := B754_finite _ _ _ _).
+  rewrite Req_bool_false.
+  + destruct (Bfrexp_correct f (eq_refl _)) as (Hfr1, (Hfr2, Hfr3)).
+    apply Hp.
+    simpl.
+    rewrite Hfr3.
+    set (e' := fexp _).
+    generalize (Bldexp_correct mode_NE Bone e').
+    rewrite Bone_correct, Rmult_1_l, round_generic; [|now apply valid_rnd_N|].
+    { rewrite Rlt_bool_true.
+      - intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs.
+        now split; [|split; [apply is_finite_Bone|apply Bsign_Bone]].
+      - rewrite Rabs_pos_eq; [|now apply bpow_ge_0].
+        unfold e', fexp, FLT_exp.
+        apply bpow_lt.
+        case (Z.max_spec (mag radix2 (B2R f) - prec) emin)
+          as [(_, Hm)|(_, Hm)]; rewrite Hm;
+          [now unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia|].
+        apply (Zplus_lt_reg_r _ _ prec); ring_simplify.
+        assert (mag radix2 (B2R f) <= emax)%Z;
+          [|now unfold Prec_gt_0 in prec_gt_0_; lia].
+        apply mag_le_bpow; [|now apply abs_B2R_lt_emax].
+        now unfold f, B2R; apply F2R_neq_0; case sx. }
+    apply generic_format_bpow, Z.max_lub.
+    * unfold Prec_gt_0 in prec_gt_0_; lia.
+    * apply Z.le_max_r.
+  + now unfold f, B2R; apply F2R_neq_0; case sx. }
+destruct (Bulp_correct x Fx) as [H4 [H5 H6]].
+apply B2R_Bsign_inj ; try easy.
+now rewrite H4.
+now rewrite H3.
+Qed.
+
+(** Successor (and predecessor) *)
+
+Definition Bsucc x :=
+  match x with
+  | B754_zero _ => B754_finite false 1 emin Bulp_correct_aux
+  | B754_infinity false => x
+  | B754_infinity true => Bopp Bmax_float
+  | B754_nan => B754_nan
+  | B754_finite false mx ex _ =>
+    SF2B _ (proj1 (binary_round_correct mode_UP false (mx + 1) ex))
+  | B754_finite true mx ex _ =>
+    SF2B _ (proj1 (binary_round_correct mode_ZR true (xO mx - 1) (ex - 1)))
+  end.
+
+Theorem is_nan_Bsucc :
+  forall x,
+  is_nan (Bsucc x) = is_nan x.
+Proof.
+unfold Bsucc.
+intros [sx|[|]| |[|] mx ex Bx] ; try easy.
+rewrite is_nan_SF2B.
+apply is_nan_binary_round.
+rewrite is_nan_SF2B.
+apply is_nan_binary_round.
+Qed.
+
+Theorem Bsucc_correct :
+  forall x,
+  is_finite x = true ->
+  if Rlt_bool (succ radix2 fexp (B2R x)) (bpow radix2 emax) then
+    B2R (Bsucc x) = succ radix2 fexp (B2R x) /\
+    is_finite (Bsucc x) = true /\
+    (Bsign (Bsucc x) = Bsign x && is_finite_strict x)%bool
+  else
+    B2SF (Bsucc x) = S754_infinity false.
+Proof.
+intros [sx|sx| | [|] mx ex Bx] Hx ; try easy ; clear Hx.
+- simpl.
+  change fexp with (FLT_exp emin prec).
+  rewrite succ_0, ulp_FLT_0 by easy.
+  rewrite Rlt_bool_true.
+  repeat split ; cycle 1.
+  now case sx.
+  apply F2R_bpow.
+  apply bpow_lt.
+  unfold emin.
+  generalize (prec_gt_0 prec) (prec_lt_emax prec emax).
+  lia.
+- assert (Cx := proj1 (andb_prop _ _ Bx)).
+  change (B2R (B754_finite _ _ _ _)) with (F2R (Fopp (Float radix2 (Zpos mx) ex))).
+  rewrite F2R_opp, succ_opp.
+  rewrite Rlt_bool_true ; cycle 1.
+  { apply Rle_lt_trans with 0%R.
+    2: apply bpow_gt_0.
+    rewrite <- Ropp_0.
+    apply Ropp_le_contravar.
+    apply pred_ge_0.
+    now apply FLT_exp_valid.
+    now apply F2R_gt_0.
+    apply generic_format_canonical.
+    now apply (canonical_canonical_mantissa false). }
+  simpl.
+  rewrite B2R_SF2B, is_finite_SF2B, Bsign_SF2B.
+  generalize (binary_round_correct mode_ZR true (xO mx - 1) (ex - 1)).
+  set (z := binary_round _ _ _ _).
+  rewrite F2R_cond_Zopp.
+  simpl.
+  rewrite round_ZR_opp.
+  rewrite round_ZR_DN by now apply F2R_ge_0.
+  assert (H: F2R (Float radix2 (Zpos (xO mx - 1)) (ex - 1)) = (F2R (Float radix2 (Zpos mx) ex) - F2R (Float radix2 1 (ex - 1)))%R).
+  { rewrite (F2R_change_exp _ (ex - 1) _ ex) by apply Z.le_pred_l.
+    rewrite <- F2R_minus, Fminus_same_exp.
+    apply F2R_eq.
+    replace (ex - (ex - 1))%Z with 1%Z by ring.
+    now rewrite Zmult_comm. }
+  rewrite Rlt_bool_true.
+  + intros [_ [H1 [H2 H3]]].
+    split.
+    2: now split.
+    rewrite H1, H.
+    apply f_equal.
+    apply round_DN_minus_eps_pos.
+      now apply FLT_exp_valid.
+      now apply F2R_gt_0.
+      apply (generic_format_B2R (B754_finite false mx ex Bx)).
+    split.
+      now apply F2R_gt_0.
+    rewrite F2R_bpow.
+    change fexp with (FLT_exp emin prec).
+    destruct (ulp_FLT_pred_pos radix2 emin prec (F2R (Float radix2 (Zpos mx) ex))) as [Hu|[Hu1 Hu2]].
+    * apply (generic_format_B2R (B754_finite false mx ex Bx)).
+    * now apply F2R_ge_0.
+    * rewrite Hu.
+      rewrite ulp_canonical.
+      apply bpow_le.
+      apply Z.le_pred_l.
+      easy.
+      now apply (canonical_canonical_mantissa false).
+    * rewrite Hu2.
+      rewrite ulp_canonical.
+      rewrite <- (Zmult_1_r radix2).
+      change (_ / _)%R with (bpow radix2 ex * bpow radix2 (-1))%R.
+      rewrite <- bpow_plus.
+      apply Rle_refl.
+      easy.
+      now apply (canonical_canonical_mantissa false).
+  + rewrite Rabs_Ropp, Rabs_pos_eq.
+    eapply Rle_lt_trans.
+    2: apply bounded_lt_emax with (1 := Bx).
+    apply Rle_trans with (F2R (Float radix2 (Zpos (xO mx - 1)) (ex - 1))).
+    apply round_DN_pt.
+    now apply FLT_exp_valid.
+    rewrite H.
+    rewrite <- (Rminus_0_r (F2R _)) at 2.
+    apply Rplus_le_compat_l.
+    apply Ropp_le_contravar.
+    now apply F2R_ge_0.
+    apply round_DN_pt.
+    now apply FLT_exp_valid.
+    apply generic_format_0.
+    now apply F2R_ge_0.
+- assert (Cx := proj1 (andb_prop _ _ Bx)).
+  apply (canonical_canonical_mantissa false) in Cx.
+  replace (succ _ _ _) with (F2R (Float radix2 (Zpos mx + 1) ex)) ; cycle 1.
+  { unfold succ, B2R.
+    rewrite Rle_bool_true by now apply F2R_ge_0.
+    rewrite ulp_canonical by easy.
+    rewrite <- F2R_bpow.
+    rewrite <- F2R_plus.
+    now rewrite Fplus_same_exp. }
+  simpl.
+  rewrite B2R_SF2B, is_finite_SF2B, Bsign_SF2B.
+  generalize (binary_round_correct mode_UP false (mx + 1) ex).
+  simpl.
+  rewrite round_generic.
+  + rewrite Rabs_pos_eq by now apply F2R_ge_0.
+    case Rlt_bool_spec ; intros Hs.
+    now intros [_ H].
+    intros H.
+    rewrite B2SF_SF2B.
+    now rewrite (proj2 H).
+  + apply valid_rnd_UP.
+  + destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as [e He].
+    rewrite Rabs_pos_eq in He by now apply F2R_ge_0.
+    refine (_ (He _)).
+    2: now apply F2R_neq_0.
+    clear He. intros He.
+    destruct (F2R_p1_le_bpow _ (Zpos mx) _ _ eq_refl (proj2 He)) as [H|H].
+    * apply generic_format_F2R.
+      intros _.
+      rewrite Cx at 2.
+      apply cexp_ge_bpow.
+      apply FLT_exp_monotone.
+      rewrite Rabs_pos_eq by now apply F2R_ge_0.
+      rewrite (mag_unique_pos _ _ e).
+      apply He.
+      split.
+      apply Rle_trans with (1 := proj1 He).
+      apply F2R_le.
+      apply Z.le_succ_diag_r.
+      exact H.
+    * simpl in H.
+      rewrite H.
+      apply generic_format_FLT_bpow.
+      easy.
+      apply le_bpow with radix2.
+      apply Rlt_le.
+      apply Rle_lt_trans with (2 := proj2 He).
+      apply generic_format_ge_bpow with fexp.
+      intros e'.
+      apply Z.le_max_r.
+      now apply F2R_gt_0.
+      now apply generic_format_canonical.
+Qed.
+
+Definition Bpred x := Bopp (Bsucc (Bopp x)).
+
+Theorem is_nan_Bpred :
+  forall x,
+  is_nan (Bpred x) = is_nan x.
+Proof.
+intros x.
+unfold Bpred.
+rewrite is_nan_Bopp, is_nan_Bsucc.
+apply is_nan_Bopp.
+Qed.
+
+Theorem Bpred_correct :
+  forall x,
+  is_finite x = true ->
+  if Rlt_bool (- bpow radix2 emax) (pred radix2 fexp (B2R x)) then
+    B2R (Bpred x) = pred radix2 fexp (B2R x) /\
+    is_finite (Bpred x) = true /\
+    (Bsign (Bpred x) = Bsign x || negb (is_finite_strict x))%bool
+  else
+    B2SF (Bpred x) = S754_infinity true.
+Proof.
+intros x Fx.
+assert (Fox : is_finite (Bopp x) = true).
+{ now rewrite is_finite_Bopp. }
+rewrite <-(Ropp_involutive (B2R x)), <-B2R_Bopp.
+rewrite pred_opp, Rlt_bool_opp.
+generalize (Bsucc_correct _ Fox).
+case (Rlt_bool _ _).
+- intros (HR, (HF, HS)); unfold Bpred.
+  rewrite B2R_Bopp, HR, is_finite_Bopp.
+  rewrite <-(Bool.negb_involutive (Bsign x)), <-Bool.negb_andb.
+  apply (conj eq_refl).
+  apply (conj HF).
+  rewrite Bsign_Bopp, <-(Bsign_Bopp x), HS.
+  + now rewrite is_finite_strict_Bopp.
+  + now revert Fx; case x.
+  + now revert HF; case (Bsucc _).
+- now unfold Bpred; case (Bsucc _); intro s; case s.
+Qed.
+
+Definition Bpred_pos' x :=
+  match x with
+  | B754_finite _ mx _ _ =>
+    let d :=
+      if (mx~0 =? shift_pos (Z.to_pos prec) 1)%positive then
+        Bldexp mode_NE Bone (fexp (snd (Bfrexp x) - 1))
+      else
+        Bulp' x in
+    Bminus mode_NE x d
+  | _ => x
+  end.
+
+Theorem Bpred_pos'_correct :
+  (2 < emax)%Z ->
+  forall x,
+  (0 < B2R x)%R ->
+  Bpred_pos' x = Bpred x.
+Proof.
+intros Hp x Fx.
+assert (B2R (Bpred_pos' x) = pred_pos radix2 fexp (B2R x) /\
+        is_finite (Bpred_pos' x) = true /\
+        Bsign (Bpred_pos' x) = false) as [H1 [H2 H3]].
+{ generalize (Bfrexp_correct x).
+  destruct x as [sx|sx| |sx mx ex Bx] ; try elim (Rlt_irrefl _ Fx).
+  intros Hfrexpx.
+  assert (Hsx : sx = false).
+  { apply gt_0_F2R in Fx.
+    revert Fx.
+    now case sx. }
+  clear Fx.
+  rewrite Hsx in Hfrexpx |- *; clear Hsx sx.
+  specialize (Hfrexpx (eq_refl _)).
+  simpl in Hfrexpx; rewrite B2R_SF2B in Hfrexpx.
+  destruct Hfrexpx as (Hfrexpx_bounds, (Hfrexpx_eq, Hfrexpx_exp)).
+  apply Hp.
+  unfold Bpred_pos', Bfrexp.
+  simpl (snd (_, snd _)).
+  rewrite Hfrexpx_exp.
+  set (x' := B754_finite _ _ _ _).
+  set (xr := F2R _).
+  assert (Nzxr : xr <> 0%R).
+  { unfold xr, F2R; simpl.
+    rewrite <-(Rmult_0_l (bpow radix2 ex)); intro H.
+    apply Rmult_eq_reg_r in H; [|apply Rgt_not_eq, bpow_gt_0].
+    apply eq_IZR in H; lia. }
+  assert (Hulp := Bulp_correct x' (eq_refl _)).
+  rewrite <- (Bulp'_correct Hp x') in Hulp by easy.
+  assert (Hldexp := Bldexp_correct mode_NE Bone (fexp (mag radix2 xr - 1))).
+  rewrite Bone_correct, Rmult_1_l in Hldexp.
+  assert (Fbpowxr : generic_format radix2 fexp
+                      (bpow radix2 (fexp (mag radix2 xr - 1)))).
+  { apply generic_format_bpow, Z.max_lub.
+    - unfold Prec_gt_0 in prec_gt_0_; lia.
+    - apply Z.le_max_r. }
+  assert (H : Rlt_bool (Rabs
+               (round radix2 fexp (round_mode mode_NE)
+                  (bpow radix2 (fexp (mag radix2 xr - 1)))))
+              (bpow radix2 emax) = true); [|rewrite H in Hldexp; clear H].
+  { apply Rlt_bool_true; rewrite round_generic;
+      [|apply valid_rnd_round_mode|apply Fbpowxr].
+    rewrite Rabs_pos_eq; [|apply bpow_ge_0]; apply bpow_lt.
+    apply Z.max_lub_lt; [|unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia].
+    apply (Zplus_lt_reg_r _ _ (prec + 1)); ring_simplify.
+    rewrite Z.add_1_r; apply Zle_lt_succ, mag_le_bpow.
+    - exact Nzxr.
+    - apply (Rlt_le_trans _ (bpow radix2 emax)).
+      + change xr with (B2R x'); apply abs_B2R_lt_emax.
+      + apply bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. }
+  set (d := if (mx~0 =? _)%positive then _ else _).
+  assert (Hminus := Bminus_correct mode_NE x' d (eq_refl _)).
+  assert (Fd : is_finite d = true).
+  { unfold d; case (_ =? _)%positive.
+    - now rewrite (proj1 (proj2 Hldexp)), is_finite_Bone.
+    - now rewrite (proj1 (proj2 Hulp)). }
+  specialize (Hminus Fd).
+  assert (Px : (0 <= B2R x')%R).
+  { unfold B2R, x', F2R; simpl.
+    now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. }
+  assert (Pd : (0 <= B2R d)%R).
+  { unfold d; case (_ =? _)%positive.
+    - rewrite (proj1 Hldexp).
+      now rewrite round_generic; [apply bpow_ge_0|apply valid_rnd_N|].
+    - rewrite (proj1 Hulp); apply ulp_ge_0. }
+  assert (Hdlex : (B2R d <= B2R x')%R).
+  { unfold d; case (_ =? _)%positive.
+    - rewrite (proj1 Hldexp).
+      rewrite round_generic; [|now apply valid_rnd_N|now simpl].
+      apply (Rle_trans _ (bpow radix2 (mag radix2 xr - 1))).
+      + apply bpow_le, Z.max_lub.
+        * unfold Prec_gt_0 in prec_gt_0_; lia.
+        * apply (Zplus_le_reg_r _ _ 1); ring_simplify.
+          apply mag_ge_bpow.
+          replace (_ - 1)%Z with emin by ring.
+          now change xr with (B2R x'); apply abs_B2R_ge_emin.
+      + rewrite <-(Rabs_pos_eq _ Px).
+        now change xr with (B2R x'); apply bpow_mag_le.
+    - rewrite (proj1 Hulp); apply ulp_le_id.
+      + assert (B2R x' <> 0%R); [exact Nzxr|lra].
+      + apply generic_format_B2R. }
+  assert (H : Rlt_bool
+            (Rabs
+               (round radix2 fexp
+                  (round_mode mode_NE) (B2R x' - B2R d)))
+            (bpow radix2 emax) = true); [|rewrite H in Hminus; clear H].
+  { apply Rlt_bool_true.
+    rewrite <-round_NE_abs; [|now apply FLT_exp_valid].
+    rewrite Rabs_pos_eq; [|lra].
+    apply (Rle_lt_trans _ (B2R x')).
+    - apply round_le_generic;
+        [now apply FLT_exp_valid|now apply valid_rnd_N| |lra].
+      apply generic_format_B2R.
+    - apply (Rle_lt_trans _ _ _ (Rle_abs _)), abs_B2R_lt_emax. }
+  rewrite (proj1 Hminus).
+  rewrite (proj1 (proj2 Hminus)).
+  rewrite (proj2 (proj2 Hminus)).
+  split; [|split; [reflexivity|now case (Rcompare_spec _ _); [lra| |]]].
+  unfold pred_pos, d.
+  case (Pos.eqb_spec _ _); intro Hd; case (Req_bool_spec _ _); intro Hpred.
+  + rewrite (proj1 Hldexp).
+    rewrite (round_generic _ _ _ _ Fbpowxr).
+    change xr with (B2R x').
+    replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')).
+    * rewrite round_generic; [reflexivity|now apply valid_rnd_N|].
+      apply generic_format_pred_pos;
+        [now apply FLT_exp_valid|apply generic_format_B2R|].
+      change xr with (B2R x') in Nzxr; lra.
+    * now unfold pred_pos; rewrite Req_bool_true.
+  + exfalso; apply Hpred.
+    assert (Hmx : IZR (Z.pos mx) = bpow radix2 (prec - 1)).
+    { apply (Rmult_eq_reg_l 2); [|lra]; rewrite <-mult_IZR.
+      change (2 * Z.pos mx)%Z with (Z.pos mx~0); rewrite Hd.
+      rewrite shift_pos_correct, Z.mul_1_r.
+      change (IZR (Z.pow_pos _ _)) with (bpow radix2 (Z.pos (Z.to_pos prec))).
+      rewrite Z2Pos.id; [|exact prec_gt_0_].
+      change 2%R with (bpow radix2 1); rewrite <-bpow_plus.
+      f_equal; ring. }
+    unfold x' at 1; unfold B2R at 1; unfold F2R; simpl.
+    rewrite Hmx, <-bpow_plus; f_equal.
+    apply (Z.add_reg_l 1); ring_simplify; symmetry; apply mag_unique_pos.
+    unfold F2R; simpl; rewrite Hmx, <-bpow_plus; split.
+    * right; f_equal; ring.
+    * apply bpow_lt; lia.
+  + rewrite (proj1 Hulp).
+    assert (H : ulp radix2 fexp (B2R x')
+                = bpow radix2 (fexp (mag radix2 (B2R x') - 1)));
+      [|rewrite H; clear H].
+    { unfold ulp; rewrite Req_bool_false; [|now simpl].
+      unfold cexp; f_equal.
+      assert (H : (mag radix2 (B2R x') <= emin + prec)%Z).
+      { assert (Hcm : canonical_mantissa mx ex = true).
+        { now generalize Bx; unfold bounded; rewrite Bool.andb_true_iff. }
+        apply (canonical_canonical_mantissa false) in Hcm.
+        revert Hcm; fold emin; unfold canonical, cexp; simpl.
+        change (F2R _) with (B2R x'); intro Hex.
+        apply Z.nlt_ge; intro H'; apply Hd.
+        apply Pos2Z.inj_pos; rewrite shift_pos_correct, Z.mul_1_r.
+        apply eq_IZR; change (IZR (Z.pow_pos _ _))
+          with (bpow radix2 (Z.pos (Z.to_pos prec))).
+        rewrite Z2Pos.id; [|exact prec_gt_0_].
+        change (Z.pos mx~0) with (2 * Z.pos mx)%Z.
+        rewrite Z.mul_comm, mult_IZR.
+        apply (Rmult_eq_reg_r (bpow radix2 (ex - 1)));
+          [|apply Rgt_not_eq, bpow_gt_0].
+        change 2%R with (bpow radix2 1); rewrite Rmult_assoc, <-!bpow_plus.
+        replace (1 + _)%Z with ex by ring.
+        unfold B2R at 1, F2R in Hpred; simpl in Hpred; rewrite Hpred.
+        change (F2R _) with (B2R x'); rewrite Hex.
+        unfold fexp, FLT_exp; rewrite Z.max_l; [f_equal; ring|lia]. }
+      now unfold fexp, FLT_exp; do 2 (rewrite Z.max_r; [|lia]). }
+    replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')).
+    * rewrite round_generic; [reflexivity|apply valid_rnd_N|].
+      apply generic_format_pred_pos;
+        [now apply FLT_exp_valid| |change xr with (B2R x') in Nzxr; lra].
+      apply generic_format_B2R.
+    * now unfold pred_pos; rewrite Req_bool_true.
+  + rewrite (proj1 Hulp).
+    replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')).
+    * rewrite round_generic; [reflexivity|now apply valid_rnd_N|].
+      apply generic_format_pred_pos;
+        [now apply FLT_exp_valid|apply generic_format_B2R|].
+      change xr with (B2R x') in Nzxr; lra.
+    * now unfold pred_pos; rewrite Req_bool_false. }
+assert (is_finite x = true /\ Bsign x = false) as [H4 H5].
+{ clear -Fx.
+  destruct x as [| | |sx mx ex Hx] ; try elim Rlt_irrefl with (1 := Fx).
+  repeat split.
+  destruct sx.
+  elim Rlt_not_le with (1 := Fx).
+  now apply F2R_le_0.
+  easy. }
+generalize (Bpred_correct x H4).
+rewrite Rlt_bool_true ; cycle 1.
+{ apply Rlt_le_trans with 0%R.
+  rewrite <- Ropp_0.
+  apply Ropp_lt_contravar.
+  apply bpow_gt_0.
+  apply pred_ge_0.
+  now apply FLT_exp_valid.
+  exact Fx.
+  apply generic_format_B2R. }
+intros [H7 [H8 H9]].
+apply eq_sym.
+apply B2R_Bsign_inj ; try easy.
+rewrite H7, H1.
+apply pred_eq_pos.
+now apply Rlt_le.
+rewrite H9, H3.
+rewrite is_finite_strict_B2R by now apply Rgt_not_eq.
+now rewrite H5.
+Qed.
+
+Definition Bsucc' x :=
+  match x with
+  | B754_zero _ => Bldexp mode_NE Bone emin
+  | B754_infinity false => x
+  | B754_infinity true => Bopp Bmax_float
+  | B754_nan => B754_nan
+  | B754_finite false _ _ _ => Bplus mode_NE x (Bulp x)
+  | B754_finite true _ _ _ => Bopp (Bpred_pos' (Bopp x))
+  end.
+
+Theorem Bsucc'_correct :
+  (2 < emax)%Z ->
+  forall x,
+  is_finite x = true ->
+  Bsucc' x = Bsucc x.
+Proof.
+intros Hp x Fx.
+destruct x as [sx|sx| |sx mx ex Bx] ; try easy.
+{ generalize (Bldexp_correct mode_NE Bone emin).
+  rewrite Bone_correct, Rmult_1_l.
+  rewrite round_generic.
+  rewrite Rlt_bool_true.
+  simpl.
+  intros [H1 [H2 H3]].
+  apply B2R_inj.
+  apply is_finite_strict_B2R.
+  rewrite H1.
+  apply Rgt_not_eq.
+  apply bpow_gt_0.
+  easy.
+  rewrite H1.
+  apply eq_sym, F2R_bpow.
+  rewrite Rabs_pos_eq.
+  apply bpow_lt.
+  unfold emin.
+  generalize (prec_gt_0 prec) (prec_lt_emax prec emax).
+  lia.
+  apply bpow_ge_0.
+  apply valid_rnd_N.
+  apply generic_format_bpow.
+  unfold fexp.
+  rewrite Z.max_r.
+  apply Z.le_refl.
+  generalize (prec_gt_0 prec).
+  lia. }
+set (x := B754_finite sx mx ex Bx).
+assert (H:
+  if Rlt_bool (succ radix2 fexp (B2R x)) (bpow radix2 emax) then
+    B2R (Bsucc' x) = succ radix2 fexp (B2R x) /\
+    is_finite (Bsucc' x) = true /\
+    Bsign (Bsucc' x) = sx
+  else
+    B2SF (Bsucc' x) = S754_infinity false).
+{
+  assert (Hsucc : succ radix2 fexp 0 = bpow radix2 emin).
+  { rewrite succ_0.
+    now apply ulp_FLT_0. }
+  unfold Bsucc', x; destruct sx.
+  + case Rlt_bool_spec; intro Hover.
+    * rewrite B2R_Bopp; simpl (Bopp (B754_finite _ _ _ _)).
+      rewrite is_finite_Bopp.
+      set (ox := B754_finite false mx ex Bx).
+      assert (Hpred := Bpred_correct ox eq_refl).
+      rewrite Bpred_pos'_correct ; cycle 1.
+        exact Hp.
+        now apply F2R_gt_0.
+      rewrite Rlt_bool_true in Hpred.
+      rewrite (proj1 Hpred), (proj1 (proj2 Hpred)).
+      split.
+      rewrite <- succ_opp.
+      simpl.
+      now rewrite <- F2R_opp.
+      apply (conj eq_refl).
+      rewrite Bsign_Bopp, (proj2 (proj2 Hpred)).
+      easy.
+      generalize (proj1 (proj2 Hpred)).
+      now case Bpred.
+      apply Rlt_le_trans with 0%R.
+      rewrite <- Ropp_0.
+      apply Ropp_lt_contravar, bpow_gt_0.
+      apply pred_ge_0.
+      now apply FLT_exp_valid.
+      now apply F2R_gt_0.
+      apply generic_format_B2R.
+    * exfalso; revert Hover; apply Rlt_not_le.
+      apply (Rle_lt_trans _ (succ radix2 fexp 0)).
+      { apply succ_le; [now apply FLT_exp_valid|apply generic_format_B2R|
+                        apply generic_format_0|].
+        unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z.
+        rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_le_contravar.
+        now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. }
+      rewrite Hsucc; apply bpow_lt.
+      unfold emin.
+      generalize (prec_gt_0 prec) (prec_lt_emax prec emax).
+      lia.
+  + fold x.
+    assert (Hulp := Bulp_correct x (eq_refl _)).
+    assert (Hplus := Bplus_correct mode_NE x (Bulp x) (eq_refl _)).
+    rewrite (proj1 (proj2 Hulp)) in Hplus; specialize (Hplus (eq_refl _)).
+    assert (Px : (0 <= B2R x)%R).
+    { now apply F2R_ge_0. }
+    assert (Hsucc' : (succ radix2 fexp (B2R x)
+                      = B2R x + ulp radix2 fexp (B2R x))%R).
+    { now unfold succ; rewrite (Rle_bool_true _ _ Px). }
+    rewrite (proj1 Hulp), <- Hsucc' in Hplus.
+    rewrite round_generic in Hplus;
+      [|apply valid_rnd_N| now apply generic_format_succ;
+                           [apply FLT_exp_valid|apply generic_format_B2R]].
+    rewrite Rabs_pos_eq in Hplus; [|apply (Rle_trans _ _ _ Px), succ_ge_id].
+    revert Hplus; case Rlt_bool_spec; intros Hover Hplus.
+    * split; [now simpl|split; [now simpl|]].
+      rewrite (proj2 (proj2 Hplus)); case Rcompare_spec.
+      { intro H; exfalso; revert H.
+        apply Rle_not_lt, (Rle_trans _ _ _ Px), succ_ge_id. }
+      { intro H; exfalso; revert H; apply Rgt_not_eq, Rlt_gt.
+        apply (Rlt_le_trans _ (B2R x)); [|apply succ_ge_id].
+        now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. }
+      now simpl.
+    * now rewrite (proj1 Hplus). }
+generalize (Bsucc_correct x Fx).
+revert H.
+case Rlt_bool_spec ; intros H.
+intros [H1 [H2 H3]] [H4 [H5 H6]].
+apply B2R_Bsign_inj ; try easy.
+now rewrite H4.
+rewrite H3, H6.
+simpl.
+now case sx.
+intros H1 H2.
+apply B2SF_inj.
+now rewrite H1, H2.
+Qed.
+
+End Binary.
+
+Arguments B754_zero {prec} {emax}.
+Arguments B754_infinity {prec} {emax}.
+Arguments B754_nan {prec} {emax}.
+Arguments B754_finite {prec} {emax}.
+
+Arguments SF2B {prec} {emax}.
+Arguments B2SF {prec} {emax}.
+Arguments B2R {prec} {emax}.
+
+Arguments is_finite_strict {prec} {emax}.
+Arguments is_finite {prec} {emax}.
+Arguments is_nan {prec} {emax}.
+
+Arguments erase {prec} {emax}.
+Arguments Bsign {prec} {emax}.
+Arguments Bcompare {prec} {emax}.
+Arguments Beqb {prec} {emax}.
+Arguments Bltb {prec} {emax}.
+Arguments Bleb {prec} {emax}.
+Arguments Bopp {prec} {emax}.
+Arguments Babs {prec} {emax}.
+Arguments Bone {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+Arguments Bmax_float {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+
+Arguments Bplus {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+Arguments Bminus {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+Arguments Bmult {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+Arguments Bfma {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+Arguments Bdiv {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+Arguments Bsqrt {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+
+Arguments Bldexp {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+Arguments Bnormfr_mantissa {prec} {emax}.
+Arguments Bfrexp {prec} {emax} {prec_gt_0_}.
+Arguments Bulp {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+Arguments Bulp' {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+Arguments Bsucc {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+Arguments Bpred {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
+Arguments Bpred_pos' {prec} {emax} {prec_gt_0_} {prec_lt_emax_}.
diff --git a/flocq/IEEE754/Bits.v b/flocq/IEEE754/Bits.v
index b38d4900..0a8e6127 100644
--- a/flocq/IEEE754/Bits.v
+++ b/flocq/IEEE754/Bits.v
@@ -19,8 +19,9 @@ COPYING file for more details.
 
 (** * IEEE-754 encoding of binary floating-point data *)
 
-From Coq Require Import Lia.
-Require Import Core Digits Binary.
+From Coq Require Import ZArith Reals Lia SpecFloat.
+
+Require Import Core BinarySingleNaN Binary.
 
 Section Binary_Bits.
 
@@ -128,10 +129,11 @@ Qed.
 Hypothesis Hmw : (0 < mw)%Z.
 Hypothesis Hew : (0 < ew)%Z.
 
-Let emax := Zpower 2 (ew - 1).
 Let prec := (mw + 1)%Z.
-Let emin := (3 - emax - prec)%Z.
-Let binary_float := binary_float prec emax.
+Let emax := Zpower 2 (ew - 1).
+Notation emin := (emin prec emax) (only parsing).
+Notation fexp := (fexp prec emax) (only parsing).
+Notation binary_float := (binary_float prec emax) (only parsing).
 
 Let Hprec : (0 < prec)%Z.
 Proof.
@@ -247,7 +249,7 @@ Theorem split_bits_of_binary_float_correct :
 Proof.
 intros [sx|sx|sx plx Hplx|sx mx ex Hx] ;
   try ( simpl ; apply split_join_bits ; split ; try apply Z.le_refl ; try apply Zlt_pred ; trivial ; lia ).
-simpl. apply split_join_bits; split; try (zify; lia).
+simpl. apply split_join_bits; split; try lia.
 destruct (digits2_Pnat_correct plx).
 unfold nan_pl in Hplx.
 rewrite Zpos_digits2_pos, <- Z_of_nat_S_digits2_Pnat in Hplx.
@@ -255,7 +257,7 @@ rewrite Zpower_nat_Z in H0.
 eapply Z.lt_le_trans. apply H0.
 change 2%Z with (radix_val radix2). apply Zpower_le.
 rewrite Z.ltb_lt in Hplx.
-unfold prec in *. zify; lia.
+unfold prec in *. lia.
 (* *)
 unfold bits_of_binary_float, split_bits_of_binary_float.
 assert (Hf: (emin <= ex /\ Zdigits radix2 (Zpos mx) <= prec)%Z).
@@ -263,9 +265,8 @@ destruct (andb_prop _ _ Hx) as (Hx', _).
 unfold canonical_mantissa in Hx'.
 rewrite Zpos_digits2_pos in Hx'.
 generalize (Zeq_bool_eq _ _ Hx').
-unfold FLT_exp.
-unfold emin.
-clear ; zify ; lia.
+unfold fexp, FLT_exp, emin.
+clear ; lia.
 case Zle_bool_spec ; intros H ;
   [ apply -> Z.le_0_sub in H | apply -> Z.lt_sub_0 in H ] ;
   apply split_join_bits ; try now split.
@@ -319,7 +320,7 @@ intros [sx|sx|sx pl pl_range|sx mx ex H].
 - unfold bounded in H.
   apply Bool.andb_true_iff in H ; destruct H as [A B].
   apply Z.leb_le in B.
-  unfold canonical_mantissa, FLT_exp in A. apply Zeq_bool_eq in A.
+  unfold canonical_mantissa, fexp, FLT_exp in A. apply Zeq_bool_eq in A.
   case Zle_bool_spec ; intros H.
   + apply join_bits_range.
     * split.
@@ -331,9 +332,10 @@ intros [sx|sx|sx pl pl_range|sx mx ex H].
       change (2^1)%Z with 2%Z.
       clear ; lia.
       apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)).
-      clear -A ; zify ; lia.
+      unfold emin in A.
+      clear -A ; lia.
     * split.
-      unfold emin ; clear -A ; zify ; lia.
+      unfold emin in A |- * ; clear -A ; lia.
       replace ew with ((ew - 1) + 1)%Z by ring.
       rewrite Zpower_plus by (clear - Hew ; lia).
       unfold emin, emax in *.
@@ -444,7 +446,7 @@ now apply Z.lt_gt.
 apply bounded_canonical_lt_emax ; try assumption.
 unfold canonical, cexp.
 rewrite mag_F2R_Zdigits. 2: discriminate.
-unfold Fexp, FLT_exp.
+unfold Fexp, fexp, FLT_exp.
 rewrite <- H.
 set (ex := ((x / 2^mw) mod 2^ew)%Z).
 replace (prec + (ex + emin - 1) - prec)%Z with (ex + emin - 1)%Z by ring.
@@ -536,7 +538,8 @@ rewrite Zpos_digits2_pos.
 unfold FLT_exp, emin.
 generalize (Zdigits radix2 (Zpos mx)).
 clear.
-intros ; zify ; lia.
+unfold fexp, emin.
+intros ; lia.
 (* . *)
 rewrite Zeq_bool_true. 2: apply refl_equal.
 simpl.
@@ -549,7 +552,8 @@ apply -> Z.lt_sub_0 in Hm.
 generalize (Zdigits_le_Zpower radix2 _ (Zpos mx) Hm).
 generalize (Zdigits radix2 (Zpos mx)).
 clear.
-intros ; zify ; lia.
+unfold fexp, emin.
+intros ; lia.
 Qed.
 
 Theorem bits_of_binary_float_of_bits :
@@ -590,7 +594,7 @@ case Zeq_bool_spec ; intros He2.
 case_eq mx; intros Hm.
 now rewrite He2.
 now rewrite He2.
-intros. zify; lia.
+intros ; lia.
 (* normal *)
 case_eq (mx + 2 ^ mw)%Z.
 intros Hm.
@@ -603,7 +607,7 @@ now ring_simplify (mx + 2^mw - 2^mw)%Z (ex + emin - 1 - emin + 1)%Z.
 now ring_simplify.
 intros p Hm.
 apply False_ind.
-clear -Bm Hm ; zify ; lia.
+clear -Bm Hm ; lia.
 Qed.
 
 End Binary_Bits.
@@ -658,8 +662,8 @@ Definition ternop_nan_pl32 (f1 f2 f3 : binary32) : { nan : binary32 | is_nan 24
 Definition b32_erase : binary32 -> binary32 := erase 24 128.
 Definition b32_opp : binary32 -> binary32 := Bopp 24 128 unop_nan_pl32.
 Definition b32_abs : binary32 -> binary32 := Babs 24 128 unop_nan_pl32.
-Definition b32_pred : binary32 -> binary32 := Bpred _ _ Hprec Hprec_emax Hemax unop_nan_pl32.
-Definition b32_succ : binary32 -> binary32 := Bsucc _ _ Hprec Hprec_emax Hemax unop_nan_pl32.
+Definition b32_pred : binary32 -> binary32 := Bpred _ _ Hprec Hprec_emax.
+Definition b32_succ : binary32 -> binary32 := Bsucc _ _ Hprec Hprec_emax.
 Definition b32_sqrt : mode -> binary32 -> binary32 := Bsqrt  _ _ Hprec Hprec_emax unop_nan_pl32.
 
 Definition b32_plus :  mode -> binary32 -> binary32 -> binary32 := Bplus  _ _ Hprec Hprec_emax binop_nan_pl32.
@@ -725,8 +729,8 @@ Definition ternop_nan_pl64 (f1 f2 f3 : binary64) : { nan : binary64 | is_nan 53
 Definition b64_erase : binary64 -> binary64 := erase 53 1024.
 Definition b64_opp : binary64 -> binary64 := Bopp 53 1024 unop_nan_pl64.
 Definition b64_abs : binary64 -> binary64 := Babs 53 1024 unop_nan_pl64.
-Definition b64_pred : binary64 -> binary64 := Bpred _ _ Hprec Hprec_emax Hemax unop_nan_pl64.
-Definition b64_succ : binary64 -> binary64 := Bsucc _ _ Hprec Hprec_emax Hemax unop_nan_pl64.
+Definition b64_pred : binary64 -> binary64 := Bpred _ _ Hprec Hprec_emax.
+Definition b64_succ : binary64 -> binary64 := Bsucc _ _ Hprec Hprec_emax.
 Definition b64_sqrt : mode -> binary64 -> binary64 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64.
 
 Definition b64_plus  : mode -> binary64 -> binary64 -> binary64 := Bplus  _ _ Hprec Hprec_emax binop_nan_pl64.
diff --git a/flocq/IEEE754/SpecFloatCompat.v b/flocq/IEEE754/SpecFloatCompat.v
deleted file mode 100644
index e2ace4d5..00000000
--- a/flocq/IEEE754/SpecFloatCompat.v
+++ /dev/null
@@ -1,435 +0,0 @@
-(**
-This file is part of the Flocq formalization of floating-point
-arithmetic in Coq: http://flocq.gforge.inria.fr/
-
-Copyright (C) 2018-2019 Guillaume Bertholon
-#<br />#
-Copyright (C) 2018-2019 Érik Martin-Dorel
-#<br />#
-Copyright (C) 2018-2019 Pierre Roux
-
-This library is free software; you can redistribute it and/or
-modify it under the terms of the GNU Lesser General Public
-License as published by the Free Software Foundation; either
-version 3 of the License, or (at your option) any later version.
-
-This library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-COPYING file for more details.
-*)
-
-Require Import ZArith.
-
-(** ** Inductive specification of floating-point numbers
-
-Similar to [IEEE754.Binary.full_float], but with no NaN payload. *)
-Variant spec_float :=
-  | S754_zero (s : bool)
-  | S754_infinity (s : bool)
-  | S754_nan
-  | S754_finite (s : bool) (m : positive) (e : Z).
-
-(** ** Parameterized definitions
-
-[prec] is the number of bits of the mantissa including the implicit one;
-[emax] is the exponent of the infinities.
-
-For instance, Binary64 is defined by [prec = 53] and [emax = 1024]. *)
-Section FloatOps.
-  Variable prec emax : Z.
-
-  Definition emin := (3-emax-prec)%Z.
-  Definition fexp e := Z.max (e - prec) emin.
-
-  Section Zdigits2.
-    Fixpoint digits2_pos (n : positive) : positive :=
-      match n with
-      | xH => xH
-      | xO p => Pos.succ (digits2_pos p)
-      | xI p => Pos.succ (digits2_pos p)
-      end.
-
-    Definition Zdigits2 n :=
-      match n with
-      | Z0 => n
-      | Zpos p => Zpos (digits2_pos p)
-      | Zneg p => Zpos (digits2_pos p)
-      end.
-  End Zdigits2.
-
-  Section ValidBinary.
-    Definition canonical_mantissa m e :=
-      Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e.
-
-    Definition bounded m e :=
-      andb (canonical_mantissa m e) (Zle_bool e (emax - prec)).
-
-    Definition valid_binary x :=
-      match x with
-      | S754_finite _ m e => bounded m e
-      | _ => true
-      end.
-  End ValidBinary.
-
-  Section Iter.
-    Context {A : Type}.
-    Variable (f : A -> A).
-
-    Fixpoint iter_pos (n : positive) (x : A) {struct n} : A :=
-      match n with
-      | xI n' => iter_pos n' (iter_pos n' (f x))
-      | xO n' => iter_pos n' (iter_pos n' x)
-      | xH => f x
-      end.
-  End Iter.
-
-  Section Rounding.
-    Inductive location := loc_Exact | loc_Inexact : comparison -> location.
-
-    Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }.
-
-    Definition shr_1 mrs :=
-      let '(Build_shr_record m r s) := mrs in
-      let s := orb r s in
-      match m with
-      | Z0 => Build_shr_record Z0 false s
-      | Zpos xH => Build_shr_record Z0 true s
-      | Zpos (xO p) => Build_shr_record (Zpos p) false s
-      | Zpos (xI p) => Build_shr_record (Zpos p) true s
-      | Zneg xH => Build_shr_record Z0 true s
-      | Zneg (xO p) => Build_shr_record (Zneg p) false s
-      | Zneg (xI p) => Build_shr_record (Zneg p) true s
-      end.
-
-    Definition loc_of_shr_record mrs :=
-      match mrs with
-      | Build_shr_record _ false false => loc_Exact
-      | Build_shr_record _ false true => loc_Inexact Lt
-      | Build_shr_record _ true false => loc_Inexact Eq
-      | Build_shr_record _ true true => loc_Inexact Gt
-      end.
-
-    Definition shr_record_of_loc m l :=
-      match l with
-      | loc_Exact => Build_shr_record m false false
-      | loc_Inexact Lt => Build_shr_record m false true
-      | loc_Inexact Eq => Build_shr_record m true false
-      | loc_Inexact Gt => Build_shr_record m true true
-      end.
-
-    Definition shr mrs e n :=
-      match n with
-      | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z)
-      | _ => (mrs, e)
-      end.
-
-    Definition shr_fexp m e l :=
-      shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e).
-
-    Definition round_nearest_even mx lx :=
-      match lx with
-      | loc_Exact => mx
-      | loc_Inexact Lt => mx
-      | loc_Inexact Eq => if Z.even mx then mx else (mx + 1)%Z
-      | loc_Inexact Gt => (mx + 1)%Z
-      end.
-
-    Definition binary_round_aux sx mx ex lx :=
-      let '(mrs', e') := shr_fexp mx ex lx in
-      let '(mrs'', e'') := shr_fexp (round_nearest_even (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in
-      match shr_m mrs'' with
-      | Z0 => S754_zero sx
-      | Zpos m => if Zle_bool e'' (emax - prec) then S754_finite sx m e'' else S754_infinity sx
-      | _ => S754_nan
-      end.
-
-    Definition shl_align mx ex ex' :=
-      match (ex' - ex)%Z with
-      | Zneg d => (shift_pos d mx, ex')
-      | _ => (mx, ex)
-      end.
-
-    Definition binary_round sx mx ex :=
-      let '(mz, ez) := shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex))in
-      binary_round_aux sx (Zpos mz) ez loc_Exact.
-
-    Definition binary_normalize m e szero :=
-      match m with
-      | Z0 => S754_zero szero
-      | Zpos m => binary_round false m e
-      | Zneg m => binary_round true m e
-      end.
-  End Rounding.
-
-  (** ** Define operations *)
-
-  Definition SFopp x :=
-    match x with
-    | S754_nan => S754_nan
-    | S754_infinity sx => S754_infinity (negb sx)
-    | S754_finite sx mx ex => S754_finite (negb sx) mx ex
-    | S754_zero sx => S754_zero (negb sx)
-    end.
-
-  Definition SFabs x :=
-    match x with
-    | S754_nan => S754_nan
-    | S754_infinity sx => S754_infinity false
-    | S754_finite sx mx ex => S754_finite false mx ex
-    | S754_zero sx => S754_zero false
-    end.
-
-  Definition SFcompare f1 f2 :=
-    match f1, f2 with
-    | S754_nan , _ | _, S754_nan => None
-    | S754_infinity s1, S754_infinity s2 =>
-      Some match s1, s2 with
-      | true, true => Eq
-      | false, false => Eq
-      | true, false => Lt
-      | false, true => Gt
-      end
-    | S754_infinity s, _ => Some (if s then Lt else Gt)
-    | _, S754_infinity s => Some (if s then Gt else Lt)
-    | S754_finite s _ _, S754_zero _ => Some (if s then Lt else Gt)
-    | S754_zero _, S754_finite s _ _ => Some (if s then Gt else Lt)
-    | S754_zero _, S754_zero _ => Some Eq
-    | S754_finite s1 m1 e1, S754_finite s2 m2 e2 =>
-      Some match s1, s2 with
-      | true, false => Lt
-      | false, true => Gt
-      | false, false =>
-        match Z.compare e1 e2 with
-        | Lt => Lt
-        | Gt => Gt
-        | Eq => Pcompare m1 m2 Eq
-        end
-      | true, true =>
-        match Z.compare e1 e2 with
-        | Lt => Gt
-        | Gt => Lt
-        | Eq => CompOpp (Pcompare m1 m2 Eq)
-        end
-      end
-    end.
-
-  Definition SFeqb f1 f2 :=
-    match SFcompare f1 f2 with
-    | Some Eq => true
-    | _ => false
-    end.
-
-  Definition SFltb f1 f2 :=
-    match SFcompare f1 f2 with
-    | Some Lt => true
-    | _ => false
-    end.
-
-  Definition SFleb f1 f2 :=
-    match SFcompare f1 f2 with
-    | Some (Lt | Eq) => true
-    | _ => false
-    end.
-
-  Variant float_class : Set :=
-    | PNormal | NNormal | PSubn | NSubn | PZero | NZero | PInf | NInf | NaN.
-
-  Definition SFclassify f :=
-    match f with
-    | S754_nan => NaN
-    | S754_infinity false => PInf
-    | S754_infinity true => NInf
-    | S754_zero false => NZero
-    | S754_zero true => PZero
-    | S754_finite false m _ =>
-      if (digits2_pos m =? Z.to_pos prec)%positive then PNormal
-      else PSubn
-    | S754_finite true m _ =>
-      if (digits2_pos m =? Z.to_pos prec)%positive then NNormal
-      else NSubn
-    end.
-
-  Definition SFmul x y :=
-    match x, y with
-    | S754_nan, _ | _, S754_nan => S754_nan
-    | S754_infinity sx, S754_infinity sy => S754_infinity (xorb sx sy)
-    | S754_infinity sx, S754_finite sy _ _ => S754_infinity (xorb sx sy)
-    | S754_finite sx _ _, S754_infinity sy => S754_infinity (xorb sx sy)
-    | S754_infinity _, S754_zero _ => S754_nan
-    | S754_zero _, S754_infinity _ => S754_nan
-    | S754_finite sx _ _, S754_zero sy => S754_zero (xorb sx sy)
-    | S754_zero sx, S754_finite sy _ _ => S754_zero (xorb sx sy)
-    | S754_zero sx, S754_zero sy => S754_zero (xorb sx sy)
-    | S754_finite sx mx ex, S754_finite sy my ey =>
-      binary_round_aux (xorb sx sy) (Zpos (mx * my)) (ex + ey) loc_Exact
-    end.
-
-  Definition cond_Zopp (b : bool) m := if b then Z.opp m else m.
-
-  Definition SFadd x y :=
-    match x, y with
-    | S754_nan, _ | _, S754_nan => S754_nan
-    | S754_infinity sx, S754_infinity sy =>
-      if Bool.eqb sx sy then x else S754_nan
-    | S754_infinity _, _ => x
-    | _, S754_infinity _ => y
-    | S754_zero sx, S754_zero sy =>
-      if Bool.eqb sx sy then x else
-      S754_zero false
-    | S754_zero _, _ => y
-    | _, S754_zero _ => x
-    | S754_finite sx mx ex, S754_finite sy my ey =>
-      let ez := Z.min ex ey in
-      binary_normalize (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez)))))
-        ez false
-    end.
-
-  Definition SFsub x y :=
-    match x, y with
-    | S754_nan, _ | _, S754_nan => S754_nan
-    | S754_infinity sx, S754_infinity sy =>
-      if Bool.eqb sx (negb sy) then x else S754_nan
-    | S754_infinity _, _ => x
-    | _, S754_infinity sy => S754_infinity (negb sy)
-    | S754_zero sx, S754_zero sy =>
-      if Bool.eqb sx (negb sy) then x else
-      S754_zero false
-    | S754_zero _, S754_finite sy my ey => S754_finite (negb sy) my ey
-    | _, S754_zero _ => x
-    | S754_finite sx mx ex, S754_finite sy my ey =>
-      let ez := Z.min ex ey in
-      binary_normalize (Zminus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez)))))
-        ez false
-    end.
-
-  Definition new_location_even nb_steps k :=
-    if Zeq_bool k 0 then loc_Exact
-    else loc_Inexact (Z.compare (2 * k) nb_steps).
-
-  Definition new_location_odd nb_steps k :=
-    if Zeq_bool k 0 then loc_Exact
-    else
-      loc_Inexact
-      match Z.compare (2 * k + 1) nb_steps with
-      | Lt => Lt
-      | Eq => Lt
-      | Gt => Gt
-      end.
-
-  Definition new_location nb_steps :=
-    if Z.even nb_steps then new_location_even nb_steps else new_location_odd nb_steps.
-
-  Definition SFdiv_core_binary m1 e1 m2 e2 :=
-    let d1 := Zdigits2 m1 in
-    let d2 := Zdigits2 m2 in
-    let e' := Z.min (fexp (d1 + e1 - (d2 + e2))) (e1 - e2) in
-    let s := (e1 - e2 - e')%Z in
-    let m' :=
-      match s with
-      | Zpos _ => Z.shiftl m1 s
-      | Z0 => m1
-      | Zneg _ => Z0
-      end in
-    let '(q, r) := Z.div_eucl m' m2 in
-    (q, e', new_location m2 r).
-
-  Definition SFdiv x y :=
-    match x, y with
-    | S754_nan, _ | _, S754_nan => S754_nan
-    | S754_infinity sx, S754_infinity sy => S754_nan
-    | S754_infinity sx, S754_finite sy _ _ => S754_infinity (xorb sx sy)
-    | S754_finite sx _ _, S754_infinity sy => S754_zero (xorb sx sy)
-    | S754_infinity sx, S754_zero sy => S754_infinity (xorb sx sy)
-    | S754_zero sx, S754_infinity sy => S754_zero (xorb sx sy)
-    | S754_finite sx _ _, S754_zero sy => S754_infinity (xorb sx sy)
-    | S754_zero sx, S754_finite sy _ _ => S754_zero (xorb sx sy)
-    | S754_zero sx, S754_zero sy => S754_nan
-    | S754_finite sx mx ex, S754_finite sy my ey =>
-      let '(mz, ez, lz) := SFdiv_core_binary (Zpos mx) ex (Zpos my) ey in
-      binary_round_aux (xorb sx sy) mz ez lz
-    end.
-
-  Definition SFsqrt_core_binary m e :=
-    let d := Zdigits2 m in
-    let e' := Z.min (fexp (Z.div2 (d + e + 1))) (Z.div2 e) in
-    let s := (e - 2 * e')%Z in
-    let m' :=
-      match s with
-      | Zpos p => Z.shiftl m s
-      | Z0 => m
-      | Zneg _ => Z0
-      end in
-    let (q, r) := Z.sqrtrem m' in
-    let l :=
-      if Zeq_bool r 0 then loc_Exact
-      else loc_Inexact (if Zle_bool r q then Lt else Gt) in
-    (q, e', l).
-
-  Definition SFsqrt x :=
-    match x with
-    | S754_nan => S754_nan
-    | S754_infinity false => x
-    | S754_infinity true => S754_nan
-    | S754_finite true _ _ => S754_nan
-    | S754_zero _ => x
-    | S754_finite sx mx ex =>
-      let '(mz, ez, lz) := SFsqrt_core_binary (Zpos mx) ex in
-      binary_round_aux false mz ez lz
-    end.
-
-  Definition SFnormfr_mantissa f :=
-    match f with
-    | S754_finite _ mx ex =>
-      if Z.eqb ex (-prec) then Npos mx else 0%N
-    | _ => 0%N
-    end.
-
-  Definition SFldexp f e :=
-    match f with
-    | S754_finite sx mx ex => binary_round sx mx (ex+e)
-    | _ => f
-    end.
-
-  Definition SFfrexp f :=
-    match f with
-    | S754_finite sx mx ex =>
-      if (Z.to_pos prec <=? digits2_pos mx)%positive then
-        (S754_finite sx mx (-prec), (ex+prec)%Z)
-      else
-        let d := (prec - Z.pos (digits2_pos mx))%Z in
-        (S754_finite sx (shift_pos (Z.to_pos d) mx) (-prec), (ex+prec-d)%Z)
-    | _ => (f, (-2*emax-prec)%Z)
-    end.
-
-  Definition SFone := binary_round false 1 0.
-
-  Definition SFulp x := SFldexp SFone (fexp (snd (SFfrexp x))).
-
-  Definition SFpred_pos x :=
-    match x with
-    | S754_finite _ mx _ =>
-      let d :=
-        if (mx~0 =? shift_pos (Z.to_pos prec) 1)%positive then
-          SFldexp SFone (fexp (snd (SFfrexp x) - 1))
-        else
-          SFulp x in
-      SFsub x d
-    | _ => x
-    end.
-
-  Definition SFmax_float :=
-    S754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec).
-
-  Definition SFsucc x :=
-    match x with
-    | S754_zero _ => SFldexp SFone emin
-    | S754_infinity false => x
-    | S754_infinity true => SFopp SFmax_float
-    | S754_nan => x
-    | S754_finite false _ _ => SFadd x (SFulp x)
-    | S754_finite true _ _ => SFopp (SFpred_pos (SFopp x))
-    end.
-
-  Definition SFpred f := SFopp (SFsucc (SFopp f)).
-End FloatOps.
diff --git a/flocq/Prop/Div_sqrt_error.v b/flocq/Prop/Div_sqrt_error.v
index 9aa9c508..49c46b7e 100644
--- a/flocq/Prop/Div_sqrt_error.v
+++ b/flocq/Prop/Div_sqrt_error.v
@@ -19,7 +19,8 @@ COPYING file for more details.
 
 (** * Remainder of the division and square root are in the FLX format *)
 
-Require Import Psatz.
+From Coq Require Import ZArith Reals Psatz.
+
 Require Import Core Operations Relative Sterbenz Mult_error.
 
 Section Fprop_divsqrt_error.
diff --git a/flocq/Prop/Double_rounding.v b/flocq/Prop/Double_rounding.v
index 3e942fe0..0580ab5e 100644
--- a/flocq/Prop/Double_rounding.v
+++ b/flocq/Prop/Double_rounding.v
@@ -21,8 +21,9 @@ COPYING file for more details.
 
 (** * Conditions for innocuous double rounding. *)
 
-Require Import Psatz.
-Require Import Raux Defs Generic_fmt Operations Ulp FLX FLT FTZ.
+From Coq Require Import ZArith Reals Psatz.
+
+Require Import Core FTZ.
 
 Open Scope R_scope.
 
@@ -460,11 +461,11 @@ assert (Hx''pow : x'' = bpow (mag x)).
   unfold x'', round, F2R, scaled_mantissa, cexp; simpl.
   apply (Rmult_le_reg_r (bpow (- fexp2 (mag x)))); [now apply bpow_gt_0|].
   bpow_simplify.
-  rewrite <- (IZR_Zpower _ (_ - _)); [|lia].
+  rewrite <- (IZR_Zpower _ (_ - _)) by lia.
   apply IZR_le.
   apply Zlt_succ_le; unfold Z.succ.
   apply lt_IZR.
-  rewrite plus_IZR; rewrite IZR_Zpower; [|lia].
+  rewrite plus_IZR; rewrite IZR_Zpower by lia.
   apply (Rmult_lt_reg_r (bpow (fexp2 (mag x)))); [now apply bpow_gt_0|].
   rewrite Rmult_plus_distr_r; rewrite Rmult_1_l.
   bpow_simplify.
@@ -487,7 +488,7 @@ unfold round, F2R, scaled_mantissa, cexp; simpl.
 assert (Hf : (0 <= mag x - fexp1 (mag x''))%Z).
 { rewrite Hx''pow.
   rewrite mag_bpow.
-  assert (fexp1 (mag x + 1) <= mag x)%Z; [|lia].
+  cut (fexp1 (mag x + 1) <= mag x)%Z. lia.
   destruct (Zle_or_lt (mag x) (fexp1 (mag x))) as [Hle|Hlt];
     [|now apply Vfexp1].
   assert (H : (mag x = fexp1 (mag x) :> Z)%Z);
@@ -496,10 +497,10 @@ assert (Hf : (0 <= mag x - fexp1 (mag x''))%Z).
   now apply Vfexp1. }
 rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x'')))%Z).
 - rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x)))%Z).
-  + rewrite IZR_Zpower; [|exact Hf].
-    rewrite IZR_Zpower; [|lia].
+  + rewrite IZR_Zpower by exact Hf.
+    rewrite IZR_Zpower by lia.
     now bpow_simplify.
-  + rewrite IZR_Zpower; [|lia].
+  + rewrite IZR_Zpower by lia.
     apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
     rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
       [|now apply Rle_ge; apply bpow_ge_0].
@@ -831,7 +832,7 @@ split.
     apply succ_le_lt; [apply Vfexp|idtac|exact Fx|assumption].
     apply (generic_format_bpow beta fexp (mag x - 1)).
     replace (_ + _)%Z with (mag x : Z) by ring.
-    assert (fexp (mag x) < mag x)%Z; [|lia].
+    cut (fexp (mag x) < mag x)%Z. lia.
     now apply mag_generic_gt; [|now apply Rgt_not_eq|].
 - rewrite Rabs_right.
   + apply Rlt_trans with x.
@@ -884,7 +885,7 @@ destruct (Req_dec x 0) as [Zx|Nzx].
       rewrite Rmult_plus_distr_r.
       rewrite <- Fx.
       rewrite mult_IZR.
-      rewrite IZR_Zpower; [|lia].
+      rewrite IZR_Zpower by lia.
       bpow_simplify.
       now rewrite <- Fy. }
     apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|].
@@ -1053,7 +1054,7 @@ apply round_round_lt_mid.
 - lra.
 - now rewrite Lxy.
 - rewrite Lxy.
-  assert (fexp1 (mag x) < mag x)%Z; [|lia].
+  cut (fexp1 (mag x) < mag x)%Z. lia.
   now apply mag_generic_gt; [|apply Rgt_not_eq|].
 - unfold midp.
   apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))).
@@ -1198,8 +1199,7 @@ assert (Lyx : (mag y <= mag x)%Z);
   [now apply mag_le; [|apply Rlt_le]|].
 destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge].
 - (* mag x - 2 < mag y *)
-  assert (Hor : (mag y = mag x :> Z)
-                \/ (mag y = mag x - 1 :> Z)%Z) by lia.
+  assert (Hor : (mag y = mag x :> Z) \/ (mag y = mag x - 1 :> Z)%Z) by lia.
   destruct Hor as [Heq|Heqm1].
   + (* mag y = mag x *)
     apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
@@ -1344,10 +1344,10 @@ destruct (Rlt_or_le (bpow (mag x - 1)) x) as [Hx|Hx].
     apply (Rmult_le_reg_r (bpow (- fexp (mag x - 1)%Z)));
       [now apply bpow_gt_0|].
     bpow_simplify.
-    rewrite <- (IZR_Zpower beta (_ - _ - _)); [|lia].
+    rewrite <- (IZR_Zpower beta (_ - _ - _)) by lia.
     apply IZR_le.
     apply Zceil_glb.
-    rewrite IZR_Zpower; [|lia].
+    rewrite IZR_Zpower by lia.
     rewrite Xpow at 1.
     rewrite Rmult_minus_distr_r.
     bpow_simplify.
@@ -1402,7 +1402,7 @@ apply round_round_gt_mid.
 - exact Vfexp2.
 - lra.
 - apply Hexp4; lia.
-- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|lia].
+- cut (fexp1 (mag (x - y)) < mag (x - y))%Z. lia.
   apply (valid_exp_large fexp1 (mag x - 1)).
   + apply (valid_exp_large fexp1 (mag y)); [|lia].
     now apply mag_generic_gt; [|apply Rgt_not_eq|].
@@ -1880,7 +1880,7 @@ apply round_round_lt_mid.
 - lra.
 - now rewrite Lxy.
 - rewrite Lxy.
-  assert (fexp1 (mag x) < mag x)%Z; [|lia].
+  cut (fexp1 (mag x) < mag x)%Z. lia.
   now apply mag_generic_gt; [|apply Rgt_not_eq|].
 - unfold midp.
   apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))).
@@ -2008,8 +2008,7 @@ assert (Lyx : (mag y <= mag x)%Z);
   [now apply mag_le; [|apply Rlt_le]|].
 destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge].
 - (* mag x - 2 < mag y *)
-  assert (Hor : (mag y = mag x :> Z)
-                \/ (mag y = mag x - 1 :> Z)%Z) by lia.
+  assert (Hor : (mag y = mag x :> Z) \/ (mag y = mag x - 1 :> Z)%Z) by lia.
   destruct Hor as [Heq|Heqm1].
   + (* mag y = mag x *)
     apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
@@ -2114,7 +2113,7 @@ apply round_round_gt_mid.
 - exact Vfexp2.
 - lra.
 - apply Hexp4; lia.
-- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|lia].
+- cut (fexp1 (mag (x - y)) < mag (x - y))%Z. lia.
   apply (valid_exp_large fexp1 (mag x - 1)).
   + apply (valid_exp_large fexp1 (mag y)); [|lia].
     now apply mag_generic_gt; [|apply Rgt_not_eq|].
@@ -2744,11 +2743,11 @@ destruct (Req_dec a 0) as [Za|Nza].
     apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x)))));
       [now apply bpow_gt_0|bpow_simplify].
     rewrite Fx at 1; bpow_simplify.
-    rewrite <- IZR_Zpower; [|lia].
+    rewrite <- IZR_Zpower by lia.
     rewrite <- plus_IZR, <- 2!mult_IZR.
     apply IZR_le, Zlt_succ_le, lt_IZR.
     unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR.
-    rewrite IZR_Zpower; [|lia].
+    rewrite IZR_Zpower by lia.
     apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x)))));
       [now apply bpow_gt_0|bpow_simplify].
     rewrite <- Fx.
@@ -3163,11 +3162,11 @@ destruct (Req_dec a 0) as [Za|Nza].
     apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x)))));
       [now apply bpow_gt_0|bpow_simplify].
     rewrite Fx at 1; bpow_simplify.
-    rewrite <- IZR_Zpower; [|lia].
+    rewrite <- IZR_Zpower by lia.
     rewrite <- plus_IZR, <- 2!mult_IZR.
     apply IZR_le, Zlt_succ_le, lt_IZR.
     unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR.
-    rewrite IZR_Zpower; [|lia].
+    rewrite IZR_Zpower by lia.
     apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x)))));
       [now apply bpow_gt_0|bpow_simplify].
     rewrite <- Fx.
@@ -3481,7 +3480,7 @@ assert (Hf : F2R f = x).
   rewrite plus_IZR.
   rewrite Rmult_plus_distr_r.
   rewrite mult_IZR.
-  rewrite IZR_Zpower; [|lia].
+  rewrite IZR_Zpower by lia.
   unfold cexp at 2; bpow_simplify.
   unfold Zminus; rewrite bpow_plus.
   rewrite (Rmult_comm _ (bpow (- 1))).
@@ -3527,12 +3526,12 @@ assert (Hf : F2R f = x).
     unfold round, F2R, scaled_mantissa, cexp; simpl.
     bpow_simplify.
     rewrite Lrd.
-    rewrite <- (IZR_Zpower _ (_ - _)); [|lia].
+    rewrite <- (IZR_Zpower _ (_ - _)) by lia.
     rewrite <- mult_IZR.
     rewrite (Zfloor_imp (Zfloor (x * bpow (- fexp1 (mag x))) *
                          beta ^ (fexp1 (mag x) - fexp2 (mag x)))).
     + rewrite mult_IZR.
-      rewrite IZR_Zpower; [|lia].
+      rewrite IZR_Zpower by lia.
       bpow_simplify.
       now unfold rd.
     + split; [now apply Rle_refl|].
@@ -3843,7 +3842,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - mag (x / y)
     bpow_simplify.
     rewrite (Rmult_comm p).
     unfold p; bpow_simplify.
-    rewrite <- IZR_Zpower; [|lia].
+    rewrite <- IZR_Zpower by lia.
     rewrite <- mult_IZR.
     rewrite <- minus_IZR.
     apply IZR_le.
@@ -3851,7 +3850,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - mag (x / y)
     apply Zlt_le_succ.
     apply lt_IZR.
     rewrite mult_IZR.
-    rewrite IZR_Zpower; [|lia].
+    rewrite IZR_Zpower by lia.
     apply (Rmult_lt_reg_r (bpow (fexp1 (mag x))));
       [now apply bpow_gt_0|bpow_simplify].
     rewrite <- Fx.
@@ -4017,7 +4016,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y))
     rewrite (Rmult_comm u1).
     unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl.
     bpow_simplify.
-    rewrite <- (IZR_Zpower _ (_ - _)%Z); [|lia].
+    rewrite <- (IZR_Zpower _ (_ - _)%Z) by lia.
     do 5 rewrite <- mult_IZR.
     rewrite <- plus_IZR.
     rewrite <- minus_IZR.
@@ -4027,7 +4026,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y))
     apply lt_IZR.
     rewrite plus_IZR.
     do 5 rewrite mult_IZR; simpl.
-    rewrite IZR_Zpower; [|lia].
+    rewrite IZR_Zpower by lia.
     apply (Rmult_lt_reg_r (bpow (fexp1 (mag x))));
       [now apply bpow_gt_0|].
     rewrite Rmult_assoc.
@@ -4226,7 +4225,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y))
     rewrite (Rmult_comm u1).
     unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl.
     bpow_simplify.
-    rewrite <- (IZR_Zpower _ (_ - _)%Z); [|lia].
+    rewrite <- (IZR_Zpower _ (_ - _)%Z) by lia.
     do 5 rewrite <- mult_IZR.
     do 2 rewrite <- plus_IZR.
     apply IZR_le.
@@ -4234,7 +4233,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y))
     apply lt_IZR.
     rewrite plus_IZR.
     do 5 rewrite mult_IZR; simpl.
-    rewrite IZR_Zpower; [|lia].
+    rewrite IZR_Zpower by lia.
     apply (Rmult_lt_reg_r (bpow (fexp1 (mag x))));
       [now apply bpow_gt_0|].
     rewrite (Rmult_assoc _ (IZR mx)).
diff --git a/flocq/Prop/Mult_error.v b/flocq/Prop/Mult_error.v
index f4467025..ce909350 100644
--- a/flocq/Prop/Mult_error.v
+++ b/flocq/Prop/Mult_error.v
@@ -19,7 +19,8 @@ COPYING file for more details.
 
 (** * Error of the multiplication is in the FLX/FLT format *)
 
-From Coq Require Import Lia.
+From Coq Require Import ZArith Reals Lia.
+
 Require Import Core Operations Plus_error.
 
 Section Fprop_mult_error.
@@ -243,8 +244,7 @@ destruct (mag beta x) as (ex,Ex) ; simpl.
 specialize (Ex Hx0).
 destruct (mag beta y) as (ey,Ey) ; simpl.
 specialize (Ey Hy0).
-assert (emin + 2 * prec -1 < ex + ey)%Z.
-2: lia.
+cut (emin + 2 * prec -1 < ex + ey)%Z. lia.
 apply (lt_bpow beta).
 apply Rle_lt_trans with (1:=Hxy).
 rewrite Rabs_mult, bpow_plus.
@@ -298,7 +298,7 @@ destruct (mag beta x) as (ex,Hx).
 destruct (mag beta y) as (ey,Hy).
 simpl; apply Z.le_trans with ((ex-prec)+(ey-prec))%Z.
 2: apply Zplus_le_compat; apply Z.le_max_l.
-assert (e + 2*prec -1< ex+ey)%Z;[idtac|lia].
+cut (e + 2*prec -1< ex+ey)%Z. lia.
 apply lt_bpow with beta.
 apply Rle_lt_trans with (1:=H1).
 rewrite Rabs_mult, bpow_plus.
@@ -329,7 +329,7 @@ apply (generic_format_F2R' _ _ _ f).
 { now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. }
 intro Nzmx; unfold mx, ex; rewrite <- Fx.
 unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx).
-unfold FLT_exp; rewrite Z.max_l; [|lia]; rewrite <- Z.add_max_distr_r.
+unfold FLT_exp; rewrite Z.max_l by lia; rewrite <- Z.add_max_distr_r.
 set (n := (_ - _ + _)%Z); apply (Z.le_trans _ n); [unfold n; lia|].
 apply Z.le_max_l.
 Qed.
diff --git a/flocq/Prop/Plus_error.v b/flocq/Prop/Plus_error.v
index 514d3aab..bf0b28cd 100644
--- a/flocq/Prop/Plus_error.v
+++ b/flocq/Prop/Plus_error.v
@@ -19,11 +19,9 @@ COPYING file for more details.
 
 (** * Error of the rounded-to-nearest addition is representable. *)
 
-Require Import Psatz.
-Require Import Raux Defs Float_prop Generic_fmt.
-Require Import FIX FLX FLT Ulp Operations.
-Require Import Relative.
+From Coq Require Import ZArith Reals Psatz.
 
+Require Import Core Operations Relative.
 
 Section Fprop_plus_error.
 
@@ -519,7 +517,7 @@ rewrite <- mag_minus1; try assumption.
 unfold FLT_exp; apply bpow_le.
 apply Z.le_trans with (2:=Z.le_max_l _ _).
 destruct (mag beta x) as (n,Hn); simpl.
-assert (e + prec < n)%Z; try lia.
+cut (e + prec < n)%Z. lia.
 apply lt_bpow with beta.
 apply Rle_lt_trans with (1:=He).
 now apply Hn.
@@ -567,7 +565,7 @@ unfold cexp.
 rewrite <- mag_minus1 by easy.
 unfold FLX_exp; apply bpow_le.
 destruct (mag beta x) as (n,Hn); simpl.
-assert (e + prec < n)%Z; try lia.
+cut (e + prec < n)%Z. lia.
 apply lt_bpow with beta.
 apply Rle_lt_trans with (1:=He).
 now apply Hn.
diff --git a/flocq/Prop/Relative.v b/flocq/Prop/Relative.v
index 6b8e8f77..a87e5666 100644
--- a/flocq/Prop/Relative.v
+++ b/flocq/Prop/Relative.v
@@ -18,8 +18,10 @@ COPYING file for more details.
 *)
 
 (** * Relative error of the roundings *)
+
+From Coq Require Import ZArith Reals Psatz.
+
 Require Import Core.
-Require Import Psatz.  (* for lra *)
 
 Section Fprop_relative.
 
diff --git a/flocq/Prop/Round_odd.v b/flocq/Prop/Round_odd.v
index a433c381..a7d98eb4 100644
--- a/flocq/Prop/Round_odd.v
+++ b/flocq/Prop/Round_odd.v
@@ -20,7 +20,8 @@ COPYING file for more details.
 (** * Rounding to odd and its properties, including the equivalence
       between rnd_NE and double rounding with rnd_odd and then rnd_NE *)
 
-Require Import Reals Psatz.
+From Coq Require Import ZArith Reals Psatz.
+
 Require Import Core Operations.
 
 Definition Zrnd_odd x :=  match Req_EM_T x (IZR (Zfloor x))  with
diff --git a/flocq/Prop/Sterbenz.v b/flocq/Prop/Sterbenz.v
index 9594ac5d..8f516d0e 100644
--- a/flocq/Prop/Sterbenz.v
+++ b/flocq/Prop/Sterbenz.v
@@ -19,7 +19,9 @@ COPYING file for more details.
 
 (** * Sterbenz conditions for exact subtraction *)
 
-Require Import Raux Defs Generic_fmt Operations.
+From Coq Require Import ZArith Reals.
+
+Require Import Zaux Raux Defs Generic_fmt Operations.
 
 Section Fprop_Sterbenz.
 
diff --git a/flocq/Version.v b/flocq/Version.v
index aebb0d76..55afdadb 100644
--- a/flocq/Version.v
+++ b/flocq/Version.v
@@ -29,4 +29,4 @@ Definition Flocq_version := Eval vm_compute in
       parse t major (minor * 10 + N_of_ascii h - N_of_ascii "0"%char)%N
     | Empty_string => (major * 100 + minor)%N
     end in
-  parse "3.4.0"%string N0 N0.
+  parse "4.0.0"%string N0 N0.
diff --git a/lib/Floats.v b/lib/Floats.v
index fd0a3d32..33e48524 100644
--- a/lib/Floats.v
+++ b/lib/Floats.v
@@ -17,8 +17,9 @@
 
 (** Formalization of floating-point numbers, using the Flocq library. *)
 
+Require Import Reals.
 Require Import Coqlib Zbits Integers.
-From Flocq Require Import Binary Bits Core.
+From Flocq Require Import BinarySingleNaN Binary Bits Core.
 Require Import IEEE754_extra.
 Require Import Program.
 Require Archi.
@@ -31,6 +32,12 @@ Set Asymmetric Patterns.
 Definition float := binary64. (**r the type of IEE754 double-precision FP numbers *)
 Definition float32 := binary32. (**r the type of IEE754 single-precision FP numbers *)
 
+Lemma integer_representable_n :
+  forall n : Z, - 2 ^ 53 <= n <= 2 ^ 53 -> integer_representable 53 1024 n.
+Proof.
+now apply integer_representable_n.
+Qed.
+
 (** Boolean-valued comparisons *)
 
 Definition cmp_of_comparison (c: comparison) (x: option Datatypes.comparison) : bool :=
@@ -477,9 +484,9 @@ Proof.
   set (y := Int.sub x ox8000_0000).
   pose proof (Int.unsigned_range x); pose proof (Int.signed_range y).
   assert (Ry: integer_representable 53 1024 (Int.signed y)).
-  { apply integer_representable_n; auto; smart_omega. }
+  { apply integer_representable_n. smart_omega. }
   assert (R8: integer_representable 53 1024 (Int.unsigned ox8000_0000)).
-  { apply integer_representable_2p with (p := 31);auto; smart_omega. }
+  { apply integer_representable_2p with (p := 31); easy. }
   rewrite BofZ_plus by auto.
   f_equal.
   unfold Int.ltu in H. destruct zlt in H; try discriminate.
@@ -496,7 +503,7 @@ Proof.
   set (lo := Int.and x ox7FFF_FFFF).
   assert (R: forall n, integer_representable 53 1024 (Int.signed n)).
   { intros. pose proof (Int.signed_range n).
-    apply integer_representable_n; auto; smart_omega. }
+    apply integer_representable_n. smart_omega. }
   unfold sub, of_int. rewrite BofZ_minus by auto. unfold of_intu. f_equal.
   assert (E: Int.add hi lo = x).
   { unfold hi, lo. rewrite Int.add_is_or. 
@@ -645,8 +652,8 @@ Proof.
   intros. pose proof (Int.unsigned_range x).
   rewrite ! from_words_eq. unfold sub. rewrite BofZ_minus.
   unfold of_intu. apply (f_equal (BofZ 53 1024 __ __)). rewrite Int.unsigned_zero. lia.
-  apply integer_representable_n; auto; smart_omega.
-  apply integer_representable_n; auto; rewrite Int.unsigned_zero; smart_omega.
+  apply integer_representable_n. smart_omega.
+  apply integer_representable_n. easy.
 Qed.
 
 Lemma ox8000_0000_signed_unsigned:
@@ -672,8 +679,8 @@ Proof.
   change (Int.unsigned ox8000_0000) with Int.half_modulus.
   unfold sub. rewrite BofZ_minus.
   unfold of_int. apply f_equal. lia.
-  apply integer_representable_n; auto; smart_omega.
-  apply integer_representable_n; auto; smart_omega.
+  apply integer_representable_n. smart_omega.
+  apply integer_representable_n. easy.
 Qed.
 
 Definition ox4530_0000 := Int.repr 1160773632.        (**r [0x4530_0000] *)
@@ -718,7 +725,7 @@ Proof.
   destruct (BofZ_representable 53 1024 __ __ (2^84 + Int.unsigned x * 2^32)) as (D & E & F).
   replace (2^84 + Int.unsigned x * 2^32)
     with  ((2^52 + Int.unsigned x) * 2^32) by ring.
-  apply integer_representable_n2p; auto. smart_omega. lia. lia.
+  apply integer_representable_n2p; try easy. smart_omega.
   apply B2R_Bsign_inj; auto.
   rewrite A, D. rewrite <- IZR_Zpower by lia. rewrite <- plus_IZR. auto.
   rewrite C, F. symmetry. apply Zlt_bool_false.
@@ -748,13 +755,13 @@ Proof.
   unfold of_longu. f_equal.
   rewrite <- (Int64.ofwords_recompose l) at 1. rewrite Int64.ofwords_add'.
   fold xh; fold xl. compute_this (two_p 32); compute_this p20; ring.
-  apply integer_representable_n2p; auto.
-  compute_this p20; smart_omega. lia. lia.
-  apply integer_representable_n; auto; smart_omega.
+  apply integer_representable_n2p; try easy.
+  compute_this p20; smart_omega.
+  apply integer_representable_n. smart_omega.
   replace (2^84 + xh * 2^32) with ((2^52 + xh) * 2^32) by ring.
-  apply integer_representable_n2p; auto. smart_omega. lia. lia.
+  apply integer_representable_n2p; try easy. smart_omega.
   change (2^84 + p20 * 2^32) with ((2^52 + 1048576) * 2^32).
-  apply integer_representable_n2p; auto. lia. lia.
+  apply integer_representable_n2p; easy.
 Qed.
 
 Theorem of_long_from_words:
@@ -782,16 +789,15 @@ Proof.
   unfold of_long. apply f_equal.
   rewrite <- (Int64.ofwords_recompose l) at 1. rewrite Int64.ofwords_add''.
   fold xh; fold xl. compute_this (two_p 32); ring.
-  apply integer_representable_n2p; auto.
-  compute_this (2^20); smart_omega. lia. lia.
-  apply integer_representable_n; auto; smart_omega.
+  apply integer_representable_n2p; try easy.
+  compute_this (2^20); smart_omega.
+  apply integer_representable_n. smart_omega.
   replace (2^84 + (xh + Int.half_modulus) * 2^32)
      with ((2^52 + xh + Int.half_modulus) * 2^32)
        by (compute_this Int.half_modulus; ring).
-  apply integer_representable_n2p; auto. smart_omega. lia. lia.
+  apply integer_representable_n2p; try easy. smart_omega.
   change (2^84 + p * 2^32) with ((2^52 + p) * 2^32).
-  apply integer_representable_n2p; auto.
-  compute_this p; smart_omega. lia.
+  apply integer_representable_n2p; easy.
 Qed.
 
 (** Conversions from 64-bit integers can be expressed in terms of
@@ -813,11 +819,11 @@ Proof.
   assert (DECOMP: x = yh * 2^32 + yl).
   { unfold x. rewrite <- (Int64.ofwords_recompose l). apply Int64.ofwords_add'. }
   rewrite BofZ_mult. rewrite BofZ_plus. rewrite DECOMP; auto.
-  apply integer_representable_n2p; auto. smart_omega. lia. lia.
-  apply integer_representable_n; auto; smart_omega.
-  apply integer_representable_n; auto; smart_omega.
-  apply integer_representable_n; auto; smart_omega.
-  compute; auto.
+  apply integer_representable_n2p; try easy. smart_omega.
+  apply integer_representable_n. smart_omega.
+  apply integer_representable_n. smart_omega.
+  apply integer_representable_n. easy.
+  easy.
 Qed.
 
 Theorem of_long_decomp:
@@ -836,11 +842,11 @@ Proof.
   assert (DECOMP: x = yh * 2^32 + yl).
   { unfold x. rewrite <- (Int64.ofwords_recompose l), Int64.ofwords_add''. auto. }
   rewrite BofZ_mult. rewrite BofZ_plus. rewrite DECOMP; auto.
-  apply integer_representable_n2p; auto. smart_omega. lia. lia.
-  apply integer_representable_n; auto; smart_omega.
-  apply integer_representable_n; auto; smart_omega.
-  apply integer_representable_n; auto. compute; intuition congruence.
-  compute; auto.
+  apply integer_representable_n2p; try easy. smart_omega.
+  apply integer_representable_n. smart_omega.
+  apply integer_representable_n. smart_omega.
+  apply integer_representable_n. easy.
+  easy.
 Qed.
 
 (** Conversions from unsigned longs can be expressed in terms of conversions from signed longs.
@@ -901,7 +907,7 @@ Proof.
   }
   assert (EQ: Int64.signed n * 2 = int_round_odd (Int64.unsigned x) 1).
   {
-  symmetry. apply int_round_odd_bits. lia.
+  symmetry. apply int_round_odd_bits. easy.
   intros. rewrite NB2 by lia. replace i with 0 by lia. auto.
   rewrite NB2 by lia. rewrite dec_eq_false by lia. rewrite dec_eq_true.
   rewrite orb_comm. unfold Int64.testbit. change (2^1) with 2.
@@ -1221,7 +1227,7 @@ Theorem of_int_double:
   forall n, of_int n = of_double (Float.of_int n).
 Proof.
   intros. symmetry. apply Bconv_BofZ.
-  apply integer_representable_n; auto. generalize (Int.signed_range n); Float.smart_omega.
+  apply integer_representable_n. generalize (Int.signed_range n); Float.smart_omega.
 Qed.
 
 Theorem of_intu_double:
@@ -1337,11 +1343,9 @@ Proof.
   apply Z.le_trans with (2^64). lia. compute; intuition congruence.
   lia.
   exact (proj1 H).
-  unfold int_round_odd. apply integer_representable_n2p_wide. auto. lia.
+  unfold int_round_odd. apply integer_representable_n2p_wide; try easy.
   unfold int_round_odd in H0, H1.
   split; (apply Zmult_le_reg_r with (2^11); [compute; auto | assumption]).
-  lia.
-  lia.
 Qed.
 
 Theorem of_longu_double_1:
diff --git a/lib/IEEE754_extra.v b/lib/IEEE754_extra.v
index b0d1944e..f7505c49 100644
--- a/lib/IEEE754_extra.v
+++ b/lib/IEEE754_extra.v
@@ -18,8 +18,11 @@
 (** Additional operations and proofs about IEEE-754 binary
     floating-point numbers, on top of the Flocq library. *)
 
+Require Import Reals.
+Require Import SpecFloat.
 From Flocq Require Import Core Digits Operations Round Bracket Sterbenz
-                          Binary Round_odd.
+                          BinarySingleNaN Binary Round_odd.
+Require Import ZArith.
 Require Import Psatz.
 Require Import Bool.
 Require Import Eqdep_dec.
@@ -34,10 +37,10 @@ Section Extra_ops.
 
 Variable prec emax : Z.
 Context (prec_gt_0_ : Prec_gt_0 prec).
-Let emin := (3 - emax - prec)%Z.
-Let fexp := FLT_exp emin prec.
-Hypothesis Hmax : (prec < emax)%Z.
-Let binary_float := binary_float prec emax.
+Context (prec_lt_emax_ : Prec_lt_emax prec emax).
+Notation emin := (emin prec emax).
+Notation fexp := (fexp prec emax).
+Notation binary_float := (binary_float prec emax).
 
 (** Remarks on [is_finite] *)
 
@@ -117,10 +120,12 @@ Defined.
 Definition integer_representable (n: Z): Prop :=
   Z.abs n <= 2^emax - 2^(emax - prec) /\ generic_format radix2 fexp (IZR n).
 
-Let int_upper_bound_eq: 2^emax - 2^(emax - prec) = (2^prec - 1) * 2^(emax - prec).
+Lemma int_upper_bound_eq: 2^emax - 2^(emax - prec) = (2^prec - 1) * 2^(emax - prec).
 Proof.
-  red in prec_gt_0_.
-  ring_simplify. rewrite <- (Zpower_plus radix2) by lia. f_equal. f_equal. lia.
+  red in prec_gt_0_, prec_lt_emax_.
+  ring_simplify.
+  rewrite <- (Zpower_plus radix2) by lia.
+  now replace (emax - prec + prec)%Z with emax by ring.
 Qed.
 
 Lemma integer_representable_n2p:
@@ -129,16 +134,16 @@ Lemma integer_representable_n2p:
   integer_representable (n * 2^p).
 Proof.
   intros; split.
-- red in prec_gt_0_. replace (Z.abs (n * 2^p)) with (Z.abs n * 2^p).
+- red in prec_gt_0_, prec_lt_emax_. replace (Z.abs (n * 2^p)) with (Z.abs n * 2^p).
   rewrite int_upper_bound_eq.
-  apply Zmult_le_compat. zify; lia. apply (Zpower_le radix2); lia.
-  zify; lia. apply (Zpower_ge_0 radix2).
+  apply Zmult_le_compat. lia. apply (Zpower_le radix2); lia.
+  lia. apply (Zpower_ge_0 radix2).
   rewrite Z.abs_mul. f_equal. rewrite Z.abs_eq. auto. apply (Zpower_ge_0 radix2).
 - apply generic_format_FLT. exists (Float radix2 n p).
   unfold F2R; simpl.
   rewrite <- IZR_Zpower by auto. apply mult_IZR.
-  simpl; zify; lia.
-  unfold emin, Fexp; red in prec_gt_0_; lia.
+  simpl; lia.
+  unfold emin, Fexp; red in prec_gt_0_, prec_lt_emax_; lia.
 Qed.
 
 Lemma integer_representable_2p:
@@ -157,7 +162,7 @@ Proof.
   assert (2^(emax - prec) <= 2^(emax - 1)).
   { apply (Zpower_le radix2). lia. }
   lia.
-- red in prec_gt_0_.
+- red in prec_gt_0_, prec_lt_emax_.
   apply generic_format_FLT. exists (Float radix2 1 p).
   unfold F2R; simpl.
   rewrite Rmult_1_l. rewrite <- IZR_Zpower. auto. lia.
@@ -190,7 +195,7 @@ Qed.
 Lemma integer_representable_n:
   forall n, -2^prec <= n <= 2^prec -> integer_representable n.
 Proof.
-  red in prec_gt_0_. intros.
+  red in prec_gt_0_, prec_lt_emax_. intros.
   replace n with (n * 2^0) by (change (2^0) with 1; ring).
   apply integer_representable_n2p_wide. auto. lia. lia.
 Qed.
@@ -200,7 +205,7 @@ Lemma round_int_no_overflow:
   Z.abs n <= 2^emax - 2^(emax-prec) ->
   (Rabs (round radix2 fexp (round_mode mode_NE) (IZR n)) < bpow radix2 emax)%R.
 Proof.
-  intros. red in prec_gt_0_.
+  intros. red in prec_gt_0_, prec_lt_emax_.
   rewrite <- round_NE_abs.
   apply Rle_lt_trans with (IZR (2^emax - 2^(emax-prec))).
   apply round_le_generic. apply fexp_correct; auto. apply valid_rnd_N.
@@ -220,7 +225,7 @@ Qed.
 (** Conversion from an integer.  Round to nearest. *)
 
 Definition BofZ (n: Z) : binary_float :=
-  binary_normalize prec emax prec_gt_0_ Hmax mode_NE n 0 false.
+  binary_normalize prec emax _ _ mode_NE n 0 false.
 
 Theorem BofZ_correct:
   forall n,
@@ -233,7 +238,7 @@ Theorem BofZ_correct:
     B2FF prec emax (BofZ n) = binary_overflow prec emax mode_NE (Z.ltb n 0).
 Proof.
   intros.
-  generalize (binary_normalize_correct prec emax prec_gt_0_ Hmax mode_NE n 0 false).
+  generalize (binary_normalize_correct prec emax _ _ mode_NE n 0 false).
   fold emin; fold fexp; fold (BofZ n).
   replace (F2R {| Fnum := n; Fexp := 0 |}) with (IZR n).
   destruct Rlt_bool.
@@ -287,7 +292,7 @@ Lemma BofZ_finite_pos0:
   Z.abs n <= 2^emax - 2^(emax-prec) -> is_finite_pos0 (BofZ n) = true.
 Proof.
   intros.
-  generalize (binary_normalize_correct prec emax prec_gt_0_ Hmax mode_NE n 0 false).
+  generalize (binary_normalize_correct prec emax _ _ mode_NE n 0 false).
   fold emin; fold fexp; fold (BofZ n).
   replace (F2R {| Fnum := n; Fexp := 0 |}) with (IZR n) by
     (unfold F2R; simpl; ring).
@@ -295,12 +300,13 @@ Proof.
   intros (A & B & C).
   destruct (BofZ n); auto; try discriminate.
   simpl in *. rewrite C. rewrite Rcompare_IZR.
-  generalize (Zcompare_spec n 0); intros SPEC; inversion SPEC; auto.
+  generalize (Zcompare_spec n 0); intros SPEC; destruct SPEC; auto.
   assert ((round radix2 fexp ZnearestE (IZR n) <= -1)%R).
   { apply round_le_generic. apply fexp_correct. auto. apply valid_rnd_N.
     apply (integer_representable_opp 1).
     apply (integer_representable_2p 0).
-    red in prec_gt_0_; lia.
+
+    red in prec_gt_0_, prec_lt_emax_; lia.
     apply IZR_le; lia.
   }
   lra.
@@ -321,12 +327,12 @@ Qed.
 Theorem BofZ_plus:
   forall nan p q,
   integer_representable p -> integer_representable q ->
-  Bplus _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) = BofZ (p + q).
+  Bplus _ _ _ _ nan mode_NE (BofZ p) (BofZ q) = BofZ (p + q).
 Proof.
   intros.
   destruct (BofZ_representable p) as (A & B & C); auto.
   destruct (BofZ_representable q) as (D & E & F); auto.
-  generalize (Bplus_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) B E).
+  generalize (Bplus_correct _ _ _ _ nan mode_NE (BofZ p) (BofZ q) B E).
   fold emin; fold fexp.
   rewrite A, D. rewrite <- plus_IZR.
   generalize (BofZ_correct (p + q)). destruct Rlt_bool.
@@ -351,12 +357,12 @@ Qed.
 Theorem BofZ_minus:
   forall nan p q,
   integer_representable p -> integer_representable q ->
-  Bminus _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) = BofZ (p - q).
+  Bminus _ _ _ _ nan mode_NE (BofZ p) (BofZ q) = BofZ (p - q).
 Proof.
   intros.
   destruct (BofZ_representable p) as (A & B & C); auto.
   destruct (BofZ_representable q) as (D & E & F); auto.
-  generalize (Bminus_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) B E).
+  generalize (Bminus_correct _ _ _ _ nan mode_NE (BofZ p) (BofZ q) B E).
   fold emin; fold fexp.
   rewrite A, D. rewrite <- minus_IZR.
   generalize (BofZ_correct (p - q)). destruct Rlt_bool.
@@ -385,7 +391,7 @@ Theorem BofZ_mult:
   forall nan p q,
   integer_representable p -> integer_representable q ->
   0 < q ->
-  Bmult _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) = BofZ (p * q).
+  Bmult _ _ _ _ nan mode_NE (BofZ p) (BofZ q) = BofZ (p * q).
 Proof.
   intros.
   assert (SIGN: xorb (p <? 0) (q <? 0) = (p * q <? 0)).
@@ -397,7 +403,7 @@ Proof.
   }
   destruct (BofZ_representable p) as (A & B & C); auto.
   destruct (BofZ_representable q) as (D & E & F); auto.
-  generalize (Bmult_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q)).
+  generalize (Bmult_correct _ _ _ _ nan mode_NE (BofZ p) (BofZ q)).
   fold emin; fold fexp.
   rewrite A, B, C, D, E, F. rewrite <- mult_IZR.
   generalize (BofZ_correct (p * q)). destruct Rlt_bool.
@@ -415,7 +421,7 @@ Theorem BofZ_mult_2p:
   Z.abs x <= 2^emax - 2^(emax-prec) ->
   2^prec <= Z.abs x ->
   0 <= p <= emax - 1 ->
-  Bmult _ _ _ Hmax nan mode_NE (BofZ x) (BofZ (2^p)) = BofZ (x * 2^p).
+  Bmult _ _ _ _ nan mode_NE (BofZ x) (BofZ (2^p)) = BofZ (x * 2^p).
 Proof.
   intros.
   destruct (Z.eq_dec x 0).
@@ -475,7 +481,7 @@ Proof.
     apply Zlt_bool_true. apply Z.mul_neg_pos; auto.
     apply Zlt_bool_false. apply Z.mul_nonneg_nonneg; lia.
   }
-  generalize (Bmult_correct _ _ _ Hmax nan mode_NE (BofZ x) (BofZ (2^p)))
+  generalize (Bmult_correct _ _ _ _ nan mode_NE (BofZ x) (BofZ (2^p)))
              (BofZ_correct (x * 2^p)).
   fold emin; fold fexp. rewrite A, B, C, D, E, F, H4, H5.
   destruct Rlt_bool.
@@ -524,7 +530,7 @@ Proof.
   {
     unfold cexp, FLT_exp, FIX_exp.
     replace (mag radix2 x - prec') with p by (unfold prec'; lia).
-    apply Z.max_l. unfold emin', emin. red in prec_gt_0_; lia.
+    apply Z.max_l. unfold emin', emin. red in prec_gt_0_, prec_lt_emax_; lia.
   }
   assert (RND: round radix2 (FIX_exp p) Zrnd_odd x =
                round radix2 (FLT_exp emin' prec') Zrnd_odd x).
@@ -806,7 +812,7 @@ Qed.
 Theorem ZofB_minus:
   forall minus_nan m f p q,
   ZofB f = Some p -> 0 <= p < 2*q -> q <= 2^prec -> (IZR q <= B2R _ _ f)%R ->
-  ZofB (Bminus _ _ _ Hmax minus_nan m f (BofZ q)) = Some (p - q).
+  ZofB (Bminus _ _ _ _ minus_nan m f (BofZ q)) = Some (p - q).
 Proof.
   intros.
   assert (Q: -2^prec <= q <= 2^prec).
@@ -820,7 +826,7 @@ Proof.
     apply sterbenz_aux. now apply FLT_exp_valid. apply FLT_exp_monotone. apply generic_format_B2R.
     apply integer_representable_n. auto. lra. }
   destruct (BofZ_exact q Q) as (A & B & C).
-  generalize (Bminus_correct _ _ _ Hmax minus_nan m f (BofZ q) FIN B).
+  generalize (Bminus_correct _ _ _ _ minus_nan m f (BofZ q) FIN B).
   rewrite Rlt_bool_true.
 - fold emin; fold fexp. intros (D & E & F).
   rewrite ZofB_correct. rewrite E. rewrite D. rewrite A. rewrite EXACT.
@@ -870,10 +876,10 @@ Qed.
 Theorem ZofB_range_minus:
   forall minus_nan m f p q,
   ZofB_range f 0 (2 * q - 1) = Some p -> q <= 2^prec -> (IZR q <= B2R _ _ f)%R ->
-  ZofB_range (Bminus _ _ _ Hmax minus_nan m f (BofZ q)) (-q) (q - 1) = Some (p - q).
+  ZofB_range (Bminus _ _ _ _ minus_nan m f (BofZ q)) (-q) (q - 1) = Some (p - q).
 Proof.
   intros. destruct (ZofB_range_inversion _ _ _ _ H) as (A & B & C).
-  set (f' := Bminus prec emax prec_gt_0_ Hmax minus_nan m f (BofZ q)).
+  set (f' := Bminus prec emax _ _ minus_nan m f (BofZ q)).
   assert (D: ZofB f' = Some (p - q)).
   { apply ZofB_minus. auto. lia. auto. auto. }
   unfold ZofB_range. rewrite D. rewrite Zle_bool_true by lia. rewrite Zle_bool_true by lia. auto.
@@ -886,70 +892,30 @@ Qed.
 Theorem Bplus_commut:
   forall plus_nan mode (x y: binary_float),
   plus_nan x y = plus_nan y x ->
-  Bplus _ _ _ Hmax plus_nan mode x y = Bplus _ _ _ Hmax plus_nan mode y x.
+  Bplus _ _ _ _ plus_nan mode x y = Bplus _ _ _ _ plus_nan mode y x.
 Proof.
   intros until y; intros NAN.
-  pose proof (Bplus_correct _ _ _ Hmax plus_nan mode x y).
-  pose proof (Bplus_correct _ _ _ Hmax plus_nan mode y x).
-  unfold Bplus in *; destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto.
+  unfold Bplus. rewrite NAN. f_equal.
+  destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto; simpl.
 - rewrite (eqb_sym sy sx). destruct (eqb sx sy) eqn:EQB; auto.
   f_equal; apply eqb_prop; auto.
-- rewrite NAN; auto.
-- rewrite (eqb_sym sy sx). destruct (eqb sx sy) eqn:EQB.
+- rewrite (eqb_sym sy sx). destruct (eqb sx sy) eqn:EQB; auto.
   f_equal; apply eqb_prop; auto.
-  rewrite NAN; auto.
-- rewrite NAN; auto.
-- rewrite NAN; auto.
-- rewrite NAN; auto.
-- rewrite NAN; auto.
-- rewrite NAN; auto.
-- rewrite NAN; auto.
-- generalize (H (eq_refl _) (eq_refl _)); clear H.
-  generalize (H0 (eq_refl _) (eq_refl _)); clear H0.
-  fold emin. fold fexp.
-  set (x := B754_finite prec emax sx mx ex Hx). set (rx := B2R _ _ x).
-  set (y := B754_finite prec emax sy my ey Hy). set (ry := B2R _ _ y).
-  rewrite (Rplus_comm ry rx). destruct Rlt_bool.
-  + intros (A1 & A2 & A3) (B1 & B2 & B3).
-    apply B2R_Bsign_inj; auto. rewrite <- B1 in A1. auto.
-    rewrite Z.add_comm. rewrite Z.min_comm. auto.
-  + intros (A1 & A2) (B1 & B2). apply B2FF_inj. rewrite B2 in B1. rewrite <- B1 in A1. auto.
+- rewrite Z.min_comm. f_equal.
+  apply Zplus_comm.
 Qed.
 
 Theorem Bmult_commut:
   forall mult_nan mode (x y: binary_float),
   mult_nan x y = mult_nan y x ->
-  Bmult _ _ _ Hmax mult_nan mode x y = Bmult _ _ _ Hmax mult_nan mode y x.
+  Bmult _ _ _ _ mult_nan mode x y = Bmult _ _ _ _ mult_nan mode y x.
 Proof.
   intros until y; intros NAN.
-  pose proof (Bmult_correct _ _ _ Hmax mult_nan mode x y).
-  pose proof (Bmult_correct _ _ _ Hmax mult_nan mode y x).
-  unfold Bmult in *; destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto.
-- rewrite (xorb_comm sx sy); auto.
-- rewrite NAN; auto.
-- rewrite NAN; auto.
-- rewrite (xorb_comm sx sy); auto.
-- rewrite NAN; auto.
-- rewrite (xorb_comm sx sy); auto.
-- rewrite NAN; auto.
-- rewrite (xorb_comm sx sy); auto.
-- rewrite NAN; auto.
-- rewrite NAN; auto.
-- rewrite NAN; auto.
-- rewrite NAN; auto.
-- rewrite (xorb_comm sx sy); auto.
-- rewrite (xorb_comm sx sy); auto.
-- rewrite NAN; auto.
-- revert H H0. fold emin. fold fexp.
-  set (x := B754_finite prec emax sx mx ex Hx). set (rx := B2R _ _ x).
-  set (y := B754_finite prec emax sy my ey Hy). set (ry := B2R _ _ y).
-  rewrite (Rmult_comm ry rx).
-  destruct (Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (rx * ry)))
-                     (bpow radix2 emax)).
-  + intros (A1 & A2 & A3) (B1 & B2 & B3).
-    apply B2R_Bsign_inj; auto. rewrite <- B1 in A1. auto.
-    rewrite ! Bsign_FF2B. f_equal. f_equal. apply xorb_comm. now rewrite Pos.mul_comm. apply Z.add_comm.
-  + intros A B. apply B2FF_inj. etransitivity. eapply A. rewrite xorb_comm. auto.
+  unfold Bmult. rewrite NAN. f_equal.
+  destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto;
+    simpl; try rewrite xorb_comm; auto.
+  apply B2SF_inj. rewrite 2!B2SF_SF2B.
+  now rewrite xorb_comm, Pos.mul_comm, Zplus_comm.
 Qed.
 
 (** Multiplication by 2 is diagonal addition. *)
@@ -958,15 +924,15 @@ Theorem Bmult2_Bplus:
   forall plus_nan mult_nan mode (f: binary_float),
   (forall (x y: binary_float),
    is_nan _ _ x = true -> is_finite _ _ y = true -> plus_nan x x = mult_nan x y) ->
-  Bplus _ _ _ Hmax plus_nan mode f f = Bmult _ _ _ Hmax mult_nan mode f (BofZ 2%Z).
+  Bplus _ _ _ _ plus_nan mode f f = Bmult _ _ _ _ mult_nan mode f (BofZ 2%Z).
 Proof.
   intros until f; intros NAN.
   destruct (BofZ_representable 2) as (A & B & C).
-  apply (integer_representable_2p 1). red in prec_gt_0_; lia.
-  pose proof (Bmult_correct _ _ _ Hmax mult_nan mode f (BofZ 2%Z)). fold emin in H.
+  apply (integer_representable_2p 1). red in prec_gt_0_, prec_lt_emax_; lia.
+  pose proof (Bmult_correct _ _ _ _ mult_nan mode f (BofZ 2%Z)). fold emin in H.
   rewrite A, B, C in H. rewrite xorb_false_r in H.
   destruct (is_finite _ _ f) eqn:FIN.
-- pose proof (Bplus_correct _ _ _ Hmax plus_nan mode f f FIN FIN). fold emin in H0.
+- pose proof (Bplus_correct _ _ _ _ plus_nan mode f f FIN FIN). fold emin in H0.
   assert (EQ: (B2R prec emax f * IZR 2%Z = B2R prec emax f + B2R prec emax f)%R).
   { ring. }
   rewrite <- EQ in H0. destruct Rlt_bool.
@@ -981,12 +947,12 @@ Proof.
     rewrite Rcompare_F2R. destruct s; auto.
     unfold F2R. simpl. ring.
     apply IZR_lt. lia.
-    destruct (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ 2)); reflexivity || discriminate.
+    destruct (Bmult prec emax _ _ mult_nan mode f (BofZ 2)); reflexivity || discriminate.
   + destruct H0 as (P & Q). apply B2FF_inj. rewrite P, H. auto.
 - destruct f as [sf|sf|sf pf Hf|sf mf ef Hf]; try discriminate.
-  + simpl Bplus. rewrite eqb_true. destruct (BofZ 2) as [| | |s2 m2 e2 H2] eqn:B2; try discriminate; simpl in *.
+  + unfold Bplus. simpl BSN.Bplus. rewrite eqb_true. destruct (BofZ 2) as [| | |s2 m2 e2 H2] eqn:B2; try discriminate; simpl in *.
     assert ((0 = 2)%Z) by (apply eq_IZR; auto). discriminate.
-    subst s2. rewrite xorb_false_r. auto.
+    subst s2. unfold Bmult. simpl. rewrite xorb_false_r. auto.
     auto.
   + unfold Bplus, Bmult. rewrite <- NAN by auto. auto.
 Qed.
@@ -1028,9 +994,7 @@ Proof.
   intros. unfold bounded, canonical_mantissa. rewrite andb_true_iff.
   rewrite <- Zeq_is_eq_bool. rewrite <- Zle_is_le_bool.
   rewrite Bexact_inverse_mantissa_digits2_pos.
-  split.
-- intros; split. unfold FLT_exp. unfold emin in H. zify; lia. lia.
-- intros [A B]. unfold FLT_exp in A. unfold emin. zify; lia.
+  unfold fexp, FLT_exp, emin. lia.
 Qed.
 
 Program Definition Bexact_inverse (f: binary_float) : option binary_float :=
@@ -1083,12 +1047,12 @@ Theorem Bdiv_mult_inverse:
    is_nan _ _ x = true -> is_finite _ _ y = true -> is_finite _ _ z = true ->
    div_nan x y = mult_nan x z) ->
   Bexact_inverse y = Some z ->
-  Bdiv _ _ _ Hmax div_nan mode x y = Bmult _ _ _ Hmax mult_nan mode x z.
+  Bdiv _ _ _ _ div_nan mode x y = Bmult _ _ _ _ mult_nan mode x z.
 Proof.
   intros until z; intros NAN; intros. destruct (Bexact_inverse_correct _ _ H) as (A & B & C & D & E).
-  pose proof (Bmult_correct _ _ _ Hmax mult_nan mode x z).
+  pose proof (Bmult_correct _ _ _ _ mult_nan mode x z).
   fold emin in H0. fold fexp in H0.
-  pose proof (Bdiv_correct _ _ _ Hmax div_nan mode x y D).
+  pose proof (Bdiv_correct _ _ _ _ div_nan mode x y D).
   fold emin in H1. fold fexp in H1.
   unfold Rdiv in H1. rewrite <- C in H1.
   destruct (is_finite _ _ x) eqn:FINX.
@@ -1102,8 +1066,8 @@ Proof.
     apply is_finite_not_is_nan. rewrite Q. simpl. apply is_finite_strict_finite; auto.  + apply B2FF_inj. rewrite H0, H1. rewrite E. auto.
 - destruct y; try discriminate. destruct z; try discriminate.
   destruct x; try discriminate; simpl.
-  + simpl in E; congruence.
-  + erewrite NAN; eauto.
+  + simpl in E. now rewrite E.
+  + unfold Bdiv. now rewrite (NAN _ _ (B754_finite prec emax s0 m0 e1 e2)).
 Qed.
 
 (** ** Conversion from scientific notation *)
@@ -1136,7 +1100,7 @@ Qed.
   division with [m].  However, we treat specially very large or very small values of [e],
   when the result is known to be [+infinity] or [0.0] respectively. *)
 
-Definition Bparse (base: positive) (m: positive) (e: Z): binary_float :=
+Program Definition Bparse (base: positive) (m: positive) (e: Z): binary_float :=
   match e with
   | Z0 =>
      BofZ (Zpos m)
@@ -1147,9 +1111,21 @@ Definition Bparse (base: positive) (m: positive) (e: Z): binary_float :=
   | Zneg p =>
      if e * Z.log2 (Zpos base) + Z.log2_up (Zpos m) <? emin
      then B754_zero _ _ false
-     else FF2B prec emax _ (proj1 (Bdiv_correct_aux prec emax prec_gt_0_ Hmax mode_NE
-                                     false m Z0 false (pos_pow base p) Z0))
+     else BSN2B' prec emax (SF2B _ (proj1 (Bdiv_correct_aux prec emax _ _ mode_NE
+                                     false m Z0 false (pos_pow base p) Z0))) _
   end.
+Next Obligation.
+destruct Bdiv_correct_aux as [H1 H2].
+rewrite is_nan_SF2B.
+clear H1.
+destruct SFdiv_core_binary as [[mz ez] lz].
+destruct Rlt_bool.
+destruct H2 as [_ [H _]].
+now destruct BSN.binary_round_aux.
+simpl in H2.
+rewrite H2.
+apply is_nan_binary_overflow.
+Qed.
 
 (** Properties of [Z.log2] and [Z.log2_up]. *)
 
@@ -1209,7 +1185,7 @@ Proof.
   apply generic_format_FLT. exists (Float radix2 1 emax).
   unfold F2R; simpl. ring.
   simpl. apply (Zpower_gt_1 radix2); auto.
-  simpl. unfold emin; red in prec_gt_0_; lia.
+  simpl. unfold emin; red in prec_gt_0_, prec_lt_emax_; lia.
 Qed.
 
 Lemma round_NE_underflows:
@@ -1297,8 +1273,12 @@ Proof.
   replace (Rabs 0)%R with 0%R. apply bpow_gt_0. apply (abs_IZR 0).
   zify; lia.
 + (* no underflow *)
-  generalize (Bdiv_correct_aux prec emax prec_gt_0_ Hmax mode_NE false m 0 false (pos_pow b e) 0).
-  set (f := let '(mz, ez, lz) := Fdiv_core_binary prec emax (Z.pos m) 0 (Z.pos (pos_pow b e)) 0
+  rewrite B2R_BSN2B', B2R_SF2B.
+  rewrite B2FF_BSN2B', B2SF_SF2B.
+  rewrite Bsign_BSN2B', Bsign_SF2B.
+  rewrite is_finite_BSN2B', is_finite_SF2B.
+  generalize (Bdiv_correct_aux prec emax _ _ mode_NE false m 0 false (pos_pow b e) 0).
+  set (f := let '(mz, ez, lz) := SFdiv_core_binary prec emax (Z.pos m) 0 (Z.pos (pos_pow b e)) 0
          in binary_round_aux prec emax mode_NE (xorb false false) mz ez lz).
   fold emin; fold fexp. rewrite ! A. unfold cond_Zopp. rewrite pos_pow_spec.
   assert (B: (IZR (Z.pos m) / IZR (Z.pos b ^ Z.pos e) =
@@ -1311,10 +1291,9 @@ Proof.
            (IZR (Z.pos m) * bpow base (Z.neg e))))
     (bpow radix2 emax)).
 * destruct Q as (Q1 & Q2 & Q3).
-  split. rewrite B2R_FF2B, Q1. auto.
-  split. rewrite is_finite_FF2B. auto.
-  rewrite Bsign_FF2B. auto.
-* rewrite B2FF_FF2B. auto.
+  split. rewrite Q1. auto.
+  split; auto.
+* rewrite Q. auto.
 Qed.
 
 End Extra_ops.
@@ -1391,7 +1370,7 @@ Proof.
   {
     apply round_generic. apply valid_rnd_round_mode. eapply generic_inclusion_le.
     5: apply generic_format_B2R. apply fexp_correct; auto. apply fexp_correct; auto.
-    instantiate (1 := emax2). intros. unfold fexp2, FLT_exp. unfold emin2. zify; lia.
+    instantiate (1 := emax2). intros. unfold fexp, fexp2, FLT_exp. unfold emin, emin2. lia.
     apply Rlt_le; auto.
   }
   rewrite EQ. rewrite Rlt_bool_true by auto. auto.
@@ -1414,7 +1393,8 @@ Proof.
   replace (F2R {| Fnum := n; Fexp := 0 |}) with (IZR n).
   destruct Rlt_bool.
 - intros (P & Q & R) (D & E & F). apply B2R_Bsign_inj; auto.
-  congruence. rewrite F, C, R. rewrite Rcompare_IZR.
+  now rewrite P, D.
+  rewrite F, C, R. rewrite Rcompare_IZR.
   unfold Z.ltb. auto.
 - intros P Q. apply B2FF_inj. rewrite P, Q. rewrite C. f_equal.
   generalize (Zlt_bool_spec n 0); intros LT; inversion LT.