Merge branch 'master' into ppc64

Resolved conflicts in:configure	powerpc/Asmexpand.ml

84 files changed, 5968 insertions, 2375 deletions

diff --git a/.depend b/.depend
index 889d6a1a..3cfb86ae 100644
--- a/.depend
+++ b/.depend
@@ -129,10 +129,10 @@ flocq/Core/Fcore_Zaux.vo flocq/Core/Fcore_Zaux.glob flocq/Core/Fcore_Zaux.v.beau
 flocq/Core/Fcore_defs.vo flocq/Core/Fcore_defs.glob flocq/Core/Fcore_defs.v.beautified: flocq/Core/Fcore_defs.v flocq/Core/Fcore_Raux.vo
 flocq/Core/Fcore_digits.vo flocq/Core/Fcore_digits.glob flocq/Core/Fcore_digits.v.beautified: flocq/Core/Fcore_digits.v flocq/Core/Fcore_Zaux.vo
 flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_float_prop.glob flocq/Core/Fcore_float_prop.v.beautified: flocq/Core/Fcore_float_prop.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo
-flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_FIX.glob flocq/Core/Fcore_FIX.v.beautified: flocq/Core/Fcore_FIX.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_rnd_ne.vo
-flocq/Core/Fcore_FLT.vo flocq/Core/Fcore_FLT.glob flocq/Core/Fcore_FLT.v.beautified: flocq/Core/Fcore_FLT.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_rnd_ne.vo
-flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FLX.glob flocq/Core/Fcore_FLX.v.beautified: flocq/Core/Fcore_FLX.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_rnd_ne.vo
-flocq/Core/Fcore_FTZ.vo flocq/Core/Fcore_FTZ.glob flocq/Core/Fcore_FTZ.v.beautified: flocq/Core/Fcore_FTZ.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FLX.vo
+flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_FIX.glob flocq/Core/Fcore_FIX.v.beautified: flocq/Core/Fcore_FIX.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_rnd_ne.vo
+flocq/Core/Fcore_FLT.vo flocq/Core/Fcore_FLT.glob flocq/Core/Fcore_FLT.v.beautified: flocq/Core/Fcore_FLT.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_rnd_ne.vo
+flocq/Core/Fcore_FLX.vo flocq/Core/Fcore_FLX.glob flocq/Core/Fcore_FLX.v.beautified: flocq/Core/Fcore_FLX.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_FIX.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_rnd_ne.vo
+flocq/Core/Fcore_FTZ.vo flocq/Core/Fcore_FTZ.glob flocq/Core/Fcore_FTZ.v.beautified: flocq/Core/Fcore_FTZ.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_ulp.vo flocq/Core/Fcore_FLX.vo
 flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_generic_fmt.glob flocq/Core/Fcore_generic_fmt.v.beautified: flocq/Core/Fcore_generic_fmt.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_float_prop.vo
 flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_rnd.glob flocq/Core/Fcore_rnd.v.beautified: flocq/Core/Fcore_rnd.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo
 flocq/Core/Fcore_rnd_ne.vo flocq/Core/Fcore_rnd_ne.glob flocq/Core/Fcore_rnd_ne.v.beautified: flocq/Core/Fcore_rnd_ne.v flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_defs.vo flocq/Core/Fcore_rnd.vo flocq/Core/Fcore_generic_fmt.vo flocq/Core/Fcore_float_prop.vo flocq/Core/Fcore_ulp.vo
diff --git a/arm/AsmToJSON.ml b/arm/AsmToJSON.ml
index 75724d43..bb0c0c04 100644
--- a/arm/AsmToJSON.ml
+++ b/arm/AsmToJSON.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (* *********************************************************************)
 
-(* Simple functions to serialize powerpc Asm to JSON *)
+(* Simple functions to serialize arm Asm to JSON *)
 
 (* Dummy function *)
 
diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml
index d13015ff..990f207d 100644
--- a/arm/Asmexpand.ml
+++ b/arm/Asmexpand.ml
@@ -395,17 +395,38 @@ let expand_instruction instr =
   | _ ->
      emit instr
 
-let expand_function fn =
+let int_reg_to_dwarf = function
+   | IR0 -> 0  | IR1 -> 1  | IR2 -> 2  | IR3 -> 3
+   | IR4 -> 4  | IR5 -> 5  | IR6 -> 6  | IR7 -> 7
+   | IR8 -> 8  | IR9 -> 9  | IR10 -> 10 | IR11 -> 11
+   | IR12 -> 12 | IR13 -> 13 | IR14 -> 14
+
+let float_reg_to_dwarf = function
+   | FR0 -> 64  | FR1 -> 65  | FR2 -> 66  | FR3 -> 67
+   | FR4 -> 68  | FR5 -> 69  | FR6 -> 70  | FR7 -> 71
+   | FR8 -> 72  | FR9 -> 73  | FR10 -> 74 | FR11 -> 75
+   | FR12 -> 76 | FR13 -> 77 | FR14 -> 78 | FR15 -> 79
+
+let preg_to_dwarf = function
+   | IR r -> int_reg_to_dwarf r
+   | FR r -> float_reg_to_dwarf r
+   | _ -> assert false
+
+
+let expand_function id fn =
   try
     set_current_function fn;
-    List.iter expand_instruction fn.fn_code;
+    if !Clflags.option_g then
+      expand_debug id 13 preg_to_dwarf expand_instruction fn.fn_code
+    else
+      List.iter expand_instruction fn.fn_code;
     Errors.OK (get_current_function ())
   with Error s ->
     Errors.Error (Errors.msg (coqstring_of_camlstring s))
 
-let expand_fundef = function
+let expand_fundef id = function
   | Internal f ->
-      begin match expand_function f with
+      begin match expand_function id f with
       | Errors.OK tf -> Errors.OK (Internal tf)
       | Errors.Error msg -> Errors.Error msg
       end
@@ -413,4 +434,4 @@ let expand_fundef = function
       Errors.OK (External ef)
 
 let expand_program (p: Asm.program) : Asm.program Errors.res =
-  AST.transform_partial_program expand_fundef p
+  AST.transform_partial_ident_program expand_fundef p
diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml
index f7f0d313..2e676090 100644
--- a/arm/TargetPrinter.ml
+++ b/arm/TargetPrinter.ml
@@ -20,6 +20,7 @@ open AST
 open Memdata
 open Asm
 open PrintAsmaux
+open Fileinfo
 
 (* Type for the ABI versions *)
 type float_abi_type =
@@ -152,8 +153,11 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET =
       | Section_user(s, wr, ex) ->
           sprintf ".section	\"%s\",\"a%s%s\",%%progbits"
             s (if wr then "w" else "") (if ex then "x" else "")
-      | Section_debug_info
-      | Section_debug_abbrev -> "" (* Dummy value *)
+      | Section_debug_info _ -> ".section	.debug_info,\"\",%progbits"
+      | Section_debug_loc -> ".section	.debug_loc,\"\",%progbits"
+      | Section_debug_abbrev -> ".section	.debug_abbrev,\"\",%progbits"
+      | Section_debug_line _ -> ".section	.debug_line,\"\",%progbits"
+
             
     let section oc sec =
       fprintf oc "	%s\n" (name_of_section sec)
@@ -894,25 +898,31 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET =
         | _ -> "armv7");
       fprintf oc "	.fpu	%s\n"
         (if Opt.vfpv3 then "vfpv3-d16" else "vfpv2");
-      fprintf oc "	.%s\n" (if !Clflags.option_mthumb then "thumb" else "arm")
-
-    let print_epilogue oc = ()
-
-    let default_falignment = 4
+      fprintf oc "	.%s\n" (if !Clflags.option_mthumb then "thumb" else "arm");
+      if !Clflags.option_g then begin
+        section oc Section_text;
+        let low_pc = new_label () in
+        Debug.add_compilation_section_start ".text" low_pc;
+        fprintf oc "%a:\n" elf_label low_pc;
+        fprintf oc "	.cfi_sections	.debug_frame\n"
+      end
 
-    let get_start_addr () = -1 (* Dummy constant *)
 
-    let get_end_addr () = -1 (* Dummy constant *)
+    let print_epilogue oc = 
+      if !Clflags.option_g then begin
+        let high_pc = new_label () in
+        Debug.add_compilation_section_end ".text" high_pc;
+        Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f));
+        section oc Section_text;
+        fprintf oc "%a:\n" elf_label high_pc
+        end
 
-    let get_stmt_list_addr () = -1 (* Dummy constant *)
 
-    module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs (* Dummy Abbrev types *)
-        
+    let default_falignment = 4
+    
     let label = elf_label
        
     let new_label = new_label
-        
-    let print_file_loc _ _ = () (* Dummy function *)
   end
 
 let sel_target () = 
diff --git a/backend/Asmexpandaux.ml b/backend/Asmexpandaux.ml
index 6ce6c005..25be9be3 100644
--- a/backend/Asmexpandaux.ml
+++ b/backend/Asmexpandaux.ml
@@ -55,3 +55,93 @@ let get_current_function () =
   let fn = !current_function in
   set_current_function dummy_function;
   {fn with fn_code = c}
+
+(* Expand function for debug information *)
+
+let expand_scope id lbl oldscopes newscopes =
+  let opening = List.filter (fun a -> not (List.mem a oldscopes)) newscopes
+  and closing = List.filter (fun a -> not (List.mem a newscopes)) oldscopes in
+  List.iter (fun i -> Debug.open_scope id i lbl) opening;
+  List.iter (fun i -> Debug.close_scope id i lbl) closing
+
+let translate_annot sp preg_to_dwarf annot = 
+  let rec aux = function
+    | BA x -> Some (sp,BA (preg_to_dwarf x))
+    | BA_int _
+    | BA_long _
+    | BA_float _
+    | BA_single _
+    | BA_loadglobal _
+    | BA_addrglobal _
+    | BA_loadstack _ -> None
+    | BA_addrstack ofs -> Some (sp,BA_addrstack ofs)
+    | BA_splitlong (hi,lo) -> 
+        begin
+          match (aux hi,aux lo) with
+          | Some (_,hi) ,Some (_,lo) -> Some (sp,BA_splitlong (hi,lo))
+          | _,_ -> None
+        end in
+  (match annot with
+  | [] -> None
+  | a::_ -> aux a)
+    
+
+let expand_debug id sp preg simple l =
+  let get_lbl = function
+    | None -> 
+        let lbl = new_label () in
+        emit (Plabel lbl);
+        lbl
+    | Some lbl -> lbl in
+  let rec  aux lbl scopes = function
+    | [] -> let lbl = get_lbl lbl in
+      Debug.function_end id lbl
+    | (Pbuiltin(EF_debug (kind,txt,_x),args,_) as i)::rest ->
+        let kind = (P.to_int kind) in
+        begin
+          match kind with
+          | 1-> 
+              emit i;aux lbl scopes rest
+          | 2 ->
+              aux  lbl scopes rest
+          | 3 ->
+             begin 
+               match translate_annot sp preg args with
+               | Some a ->
+                   let lbl = get_lbl lbl in
+                   Debug.start_live_range (id,txt) lbl a;
+                   aux (Some lbl) scopes rest
+               | None ->  aux lbl scopes rest
+             end
+          | 4 ->
+              let lbl = get_lbl lbl in
+              Debug.end_live_range (id,txt) lbl;
+              aux (Some lbl) scopes rest
+          | 5 ->
+              begin
+                match translate_annot sp preg args with
+                | Some a->
+                    Debug.stack_variable (id,txt) a;
+                    aux lbl scopes rest
+                | _ ->  aux lbl scopes rest
+              end
+          | 6  ->
+              let lbl = get_lbl lbl in
+              let scopes' = List.map (function BA_int x -> Int32.to_int (camlint_of_coqint x) | _ -> assert false) args in
+              expand_scope id lbl scopes scopes';
+              aux (Some lbl) scopes' rest
+          | _ ->
+              aux None scopes rest
+        end
+    | i::rest -> simple i; aux None scopes rest in
+  (* We need to move all closing debug annotations before the last real statement *)
+  let rec move_debug acc bcc = function
+    | (Pbuiltin(EF_debug (kind,_,_),_,_) as i)::rest ->
+        let kind = (P.to_int kind) in
+        if kind = 1 then
+          move_debug acc (i::bcc) rest (* Do not move debug line *)
+        else
+          move_debug (i::acc) bcc rest (* Move the debug annotations forward *)
+    | b::rest -> List.rev ((List.rev (b::bcc)@List.rev acc)@rest) (* We found the first non debug location *)
+    | [] -> List.rev acc (* This actually can never happen *) in
+  aux None [] (move_debug [] [] (List.rev l))
diff --git a/backend/Constprop.v b/backend/Constprop.v
index cd844d30..8f4cb76d 100644
--- a/backend/Constprop.v
+++ b/backend/Constprop.v
@@ -144,9 +144,9 @@ Fixpoint debug_strength_reduction (ae: AE.t) (al: list (builtin_arg reg)) :=
   | a :: al =>
       let a' := builtin_arg_reduction ae a in
       let al' := a :: debug_strength_reduction ae al in
-      match a' with
-      | BA_int _ | BA_long _ | BA_float _ | BA_single _ => a' :: al'
-      | _ => al'
+      match a, a' with
+      | BA _, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => a' :: al'
+      | _, _ => al'
       end
   end.
 
diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v
index d9005f5e..eafefed5 100644
--- a/backend/Constpropproof.v
+++ b/backend/Constpropproof.v
@@ -243,7 +243,11 @@ Proof.
   induction 2; simpl.
 - exists (@nil val); constructor.
 - destruct IHlist_forall2 as (vl' & A).
-  destruct (builtin_arg_reduction ae a1); repeat (eauto; econstructor). 
+  assert (eval_builtin_args ge (fun r => rs#r) sp m
+             (a1 :: debug_strength_reduction ae al) (b1 :: vl'))
+  by (constructor; eauto).
+  destruct a1; try (econstructor; eassumption).
+  destruct (builtin_arg_reduction ae (BA x)); repeat (eauto; econstructor). 
 Qed.
 
 Lemma builtin_strength_reduction_correct:
diff --git a/backend/Fileinfo.ml b/backend/Fileinfo.ml
new file mode 100644
index 00000000..0490def0
--- /dev/null
+++ b/backend/Fileinfo.ml
@@ -0,0 +1,80 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
+(*          Bernhard Schommer, AbsInt Angewandte Informatik GmbH       *)
+(*                                                                     *)
+(*  Copyright Institut National de Recherche en Informatique et en     *)
+(*  Automatique.  All rights reserved.  This file is distributed       *)
+(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+open Printf
+
+(* Printing annotations in asm syntax *)
+
+let filename_info : (string, int * Printlines.filebuf option) Hashtbl.t
+                  = Hashtbl.create 7
+
+let last_file = ref ""
+
+let reset_filenames () =
+  Hashtbl.clear filename_info; last_file := ""
+
+let close_filenames () =
+  Hashtbl.iter
+    (fun file (num, fb) ->
+       match fb with Some b -> Printlines.close b | None -> ())
+    filename_info;
+  reset_filenames()
+
+let enter_filename f =
+  let num = Hashtbl.length filename_info + 1 in
+  let filebuf =
+    if !Clflags.option_S || !Clflags.option_dasm then begin
+      try Some (Printlines.openfile f)
+      with Sys_error _ -> None
+    end else None in
+  Hashtbl.add filename_info f (num, filebuf);
+  (num, filebuf)
+
+(* Add file and line debug location, using GNU assembler-style DWARF2
+   directives *)
+let print_file oc file =
+  try
+    Hashtbl.find filename_info file
+  with Not_found ->
+    let (filenum, filebuf as res) = enter_filename file in
+    fprintf oc "	.file	%d %S\n" filenum file;
+    res
+
+let print_file_line oc pref file line =
+  if !Clflags.option_g && file <> "" then begin
+    let (filenum, filebuf) = print_file oc file in
+    fprintf oc "	.loc	%d %d\n" filenum line;
+    match filebuf with
+    | None -> ()
+    | Some fb -> Printlines.copy oc pref fb line line
+  end
+
+(* Add file and line debug location, using DWARF2 directives in the style
+   of Diab C 5 *)
+
+let print_file_line_d2 oc pref file line =
+  if !Clflags.option_g && file <> "" then begin
+    let (_, filebuf) =
+      try
+        Hashtbl.find filename_info file
+      with Not_found ->
+        enter_filename file in
+    if file <> !last_file then begin
+      fprintf oc "	.d2file	%S\n" file;
+      last_file := file
+    end;
+    fprintf oc "	.d2line	%d\n" line;
+    match filebuf with
+    | None -> ()
+    | Some fb -> Printlines.copy oc pref fb line line
+  end
diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml
index f3c80f3e..594b43b7 100644
--- a/backend/PrintAsm.ml
+++ b/backend/PrintAsm.ml
@@ -24,14 +24,11 @@ open TargetPrinter
 module Printer(Target:TARGET) =
   struct
 
-    let addr_mapping: (string, (int * int)) Hashtbl.t = Hashtbl.create 7
-
     let get_fun_addr name =
-      let name = extern_atom name in
-      let start_addr = new_label ()
-      and end_addr = new_label () in
-      Hashtbl.add addr_mapping name (start_addr,end_addr);
-      start_addr,end_addr
+      let s = Target.new_label ()
+      and e = Target.new_label () in
+      Debug.add_fun_addr name (e,s);
+      s,e
 
     let print_debug_label oc l =
       if !Clflags.option_g && Configuration.advanced_debug then
@@ -39,7 +36,6 @@ module Printer(Target:TARGET) =
       else
         ()
 
-
     let print_location oc loc =
       if loc <> Cutil.no_loc then Target.print_file_line oc (fst loc) (snd loc)
           
@@ -67,7 +63,9 @@ module Printer(Target:TARGET) =
       print_debug_label oc e;
       Target.print_fun_info oc name;
       Target.emit_constants oc lit;
-      Target.print_jumptable oc jmptbl
+      Target.print_jumptable oc jmptbl;
+      if !Clflags.option_g then
+        Hashtbl.iter (fun p i -> Debug.add_label name p i) current_function_labels
     
     let print_init_data oc name id =
       if Str.string_match PrintCsyntax.re_string_literal (extern_atom name) 0
@@ -81,10 +79,11 @@ module Printer(Target:TARGET) =
       match v.gvar_init with
       | [] -> ()
       | _  ->
+          Debug.variable_printed (extern_atom name);
           let sec =
             match C2C.atom_sections name with
             | [s] -> s
-        |  _  -> Section_data true
+            |  _  -> Section_data true
           and align =
             match C2C.atom_alignof name with
             | Some a -> a
@@ -102,8 +101,7 @@ module Printer(Target:TARGET) =
             let sz =
               match v.gvar_init with [Init_space sz] -> sz | _ -> assert false in
             Target.print_comm_symb oc sz name align
-              
-              
+                            
     let print_globdef oc (name,gdef) =
       match gdef with
       | Gfun (Internal code) -> print_function oc name code
@@ -113,33 +111,34 @@ module Printer(Target:TARGET) =
     module DwarfTarget: DwarfTypes.DWARF_TARGET =
       struct
         let label = Target.label
+        let section = Target.section
         let name_of_section = Target.name_of_section
-        let print_file_loc = Target.print_file_loc
-        let get_start_addr = Target.get_start_addr   
-        let get_end_addr = Target.get_end_addr
-        let get_stmt_list_addr = Target.get_stmt_list_addr
-        let name_of_section = Target.name_of_section
-        let get_fun_addr s = try Some (Hashtbl.find addr_mapping s) with Not_found -> None
+        let symbol = Target.symbol
       end
 
-    module DebugPrinter = DwarfPrinter (DwarfTarget) (Target.DwarfAbbrevs)
-      
-     
+    module DebugPrinter = DwarfPrinter (DwarfTarget)     
   end
 
 let print_program oc p db =
   let module Target = (val (sel_target ()):TARGET) in
   let module Printer = Printer(Target) in
-  reset_filenames ();
+  Fileinfo.reset_filenames ();
   print_version_and_options oc Target.comment;
   Target.print_prologue oc;
   List.iter (Printer.print_globdef oc) p.prog_defs;
   Target.print_epilogue oc;
-  close_filenames ();
   if !Clflags.option_g && Configuration.advanced_debug then
     begin
-      match db with
+      let atom_to_s s =
+        let s = C2C.atom_sections s in
+        match s with
+        | [] -> Target.name_of_section Section_text
+        | (Section_user (n,_,_))::_ -> n
+        | a::_ ->
+            Target.name_of_section a in
+      match Debug.generate_debug_info atom_to_s (Target.name_of_section Section_text) with
       | None -> ()
       | Some db ->
           Printer.DebugPrinter.print_debug oc db
-    end
+    end;
+  Fileinfo.close_filenames ()
diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml
index 67e53aea..78399c04 100644
--- a/backend/PrintAsmaux.ml
+++ b/backend/PrintAsmaux.ml
@@ -14,7 +14,6 @@
 open AST
 open Asm
 open Camlcoq
-open DwarfTypes
 open Datatypes
 open Memdata
 open Printf
@@ -45,13 +44,8 @@ module type TARGET =
       val comment: string
       val symbol: out_channel -> P.t -> unit
       val default_falignment: int
-      val get_start_addr: unit -> int
-      val get_end_addr: unit -> int
-      val get_stmt_list_addr: unit -> int
       val new_label: unit -> int
       val label: out_channel -> int -> unit
-      val print_file_loc: out_channel -> file_loc -> unit
-      module DwarfAbbrevs:  DWARF_ABBREVS
     end
 
 (* On-the-fly label renaming *)
@@ -139,77 +133,6 @@ let cfi_rel_offset =
 let coqint oc n =
   fprintf oc "%ld" (camlint_of_coqint n)
 
-(* Printing annotations in asm syntax *)
-(** All files used in the debug entries *)
-module StringSet = Set.Make(String)
-let all_files : StringSet.t ref = ref StringSet.empty
-let add_file file =
-  all_files := StringSet.add file !all_files
-
-
-let filename_info : (string, int * Printlines.filebuf option) Hashtbl.t
-                  = Hashtbl.create 7
-
-let last_file = ref ""
-
-let reset_filenames () =
-  Hashtbl.clear filename_info; last_file := ""
-
-let close_filenames () =
-  Hashtbl.iter
-    (fun file (num, fb) ->
-       match fb with Some b -> Printlines.close b | None -> ())
-    filename_info;
-  reset_filenames()
-
-let enter_filename f =
-  let num = Hashtbl.length filename_info + 1 in
-  let filebuf =
-    if !Clflags.option_S || !Clflags.option_dasm then begin
-      try Some (Printlines.openfile f)
-      with Sys_error _ -> None
-    end else None in
-  Hashtbl.add filename_info f (num, filebuf);
-  (num, filebuf)
-
-(* Add file and line debug location, using GNU assembler-style DWARF2
-   directives *)
-
-let print_file_line oc pref file line =
-  if !Clflags.option_g && file <> "" then begin
-    let (filenum, filebuf) =
-      try
-        Hashtbl.find filename_info file
-      with Not_found ->
-        let (filenum, filebuf as res) = enter_filename file in
-        fprintf oc "	.file	%d %S\n" filenum file;
-        res in
-    fprintf oc "	.loc	%d %d\n" filenum line;
-    match filebuf with
-    | None -> ()
-    | Some fb -> Printlines.copy oc pref fb line line
-  end
-
-(* Add file and line debug location, using DWARF2 directives in the style
-   of Diab C 5 *)
-
-let print_file_line_d2 oc pref file line =
-  if !Clflags.option_g && file <> "" then begin
-    let (_, filebuf) =
-      try
-        Hashtbl.find filename_info file
-      with Not_found ->
-        enter_filename file in
-    if file <> !last_file then begin
-      fprintf oc "	.d2file	%S\n" file;
-      last_file := file
-    end;
-    fprintf oc "	.d2line	%d\n" line;
-    match filebuf with
-    | None -> ()
-    | Some fb -> Printlines.copy oc pref fb line line
-  end
-
 (** Programmer-supplied annotations (__builtin_annot). *)
 
 let re_annot_param = Str.regexp "%%\\|%[1-9][0-9]*"
@@ -283,6 +206,9 @@ let print_debug_info comment print_line print_preg sp_name oc kind txt args =
   | 5 ->  (* local variable preallocated in stack *)
       fprintf oc "%s debug: %s resides at%a\n"
                  comment txt print_debug_args args
+  | 6 ->  (* scope annotations *)
+      fprintf oc "%s debug: current scopes%a\n"
+                 comment print_debug_args args;
   | _ ->
       ()
 					    
@@ -330,7 +256,12 @@ let print_inline_asm print_preg oc txt sg args res =
 (** Print CompCert version and command-line as asm comment *)
 
 let print_version_and_options oc comment =
-  fprintf oc "%s File generated by CompCert %s\n" comment Version.version;
+  let version_string =  
+    if Version.buildnr <> "" && Version.tag <> "" then
+      sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag
+    else
+      Version.version in
+  fprintf oc "%s File generated by CompCert %s\n" comment version_string;
   fprintf oc "%s Command line:" comment;
   for i = 1 to Array.length Sys.argv - 1 do
     fprintf oc " %s" Sys.argv.(i)
diff --git a/backend/RTL.v b/backend/RTL.v
index 56a5efeb..3cd4335d 100644
--- a/backend/RTL.v
+++ b/backend/RTL.v
@@ -104,8 +104,7 @@ Record function: Type := mkfunction {
     for its stack-allocated activation record.  [fn_params] is the list
     of registers that are bound to the values of arguments at call time.
     [fn_entrypoint] is the node of the first instruction of the function
-    in the CFG.  [fn_code_wf] asserts that all instructions of the function
-    have nodes no greater than [fn_nextpc]. *)
+    in the CFG. *)
 
 Definition fundef := AST.fundef function.
 
diff --git a/backend/RTLgen.v b/backend/RTLgen.v
index d818de58..3da961c6 100644
--- a/backend/RTLgen.v
+++ b/backend/RTLgen.v
@@ -415,11 +415,12 @@ Fixpoint convert_builtin_args {A: Type} (al: list (builtin_arg expr)) (rl: list
       a1' :: convert_builtin_args al rl1
   end.
 
-Definition convert_builtin_res (map: mapping) (r: builtin_res ident) : mon (builtin_res reg) :=
-  match r with
-  | BR id => do r <- find_var map id; ret (BR r)
-  | BR_none => ret BR_none
-  | _ => error (Errors.msg "RTLgen: bad builtin_res")
+Definition convert_builtin_res (map: mapping) (oty: option typ) (r: builtin_res ident) : mon (builtin_res reg) :=
+  match r, oty with
+  | BR id, _ => do r <- find_var map id; ret (BR r)
+  | BR_none, None => ret BR_none
+  | BR_none, Some _ => do r <- new_reg; ret (BR r)
+  | _, _ => error (Errors.msg "RTLgen: bad builtin_res")
   end.
 
 (** Translation of an expression.  [transl_expr map a rd nd]
@@ -598,7 +599,7 @@ Fixpoint transl_stmt (map: mapping) (s: stmt) (nd: node)
       let al := exprlist_of_expr_list (params_of_builtin_args args) in
       do rargs <- alloc_regs map al;
       let args' := convert_builtin_args args rargs in
-      do res' <- convert_builtin_res map res;
+      do res' <- convert_builtin_res map (sig_res (ef_sig ef)) res;
       do n1 <- add_instr (Ibuiltin ef args' res' nd);
          transl_exprlist map al rargs n1
   | Sseq s1 s2 =>
diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v
index 559ab3a2..19f6f1f4 100644
--- a/backend/RTLgenproof.v
+++ b/backend/RTLgenproof.v
@@ -234,6 +234,7 @@ Proof.
   intros. inv H1; simpl.
 - eapply match_env_update_var; eauto.
 - auto.
+- eapply match_env_update_temp; eauto.
 Qed.
 
 (** Matching and [let]-bound variables. *)
diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v
index 41b5016f..1e665002 100644
--- a/backend/RTLgenspec.v
+++ b/backend/RTLgenspec.v
@@ -814,7 +814,10 @@ Inductive tr_builtin_res: mapping -> builtin_res ident -> builtin_res reg -> Pro
       map.(map_vars)!id = Some r ->
       tr_builtin_res map (BR id) (BR r)
   | tr_builtin_res_none: forall map,
-      tr_builtin_res map BR_none BR_none.
+      tr_builtin_res map BR_none BR_none
+  | tr_builtin_res_fresh: forall map r,
+      ~reg_in_map map r ->
+      tr_builtin_res map BR_none (BR r).
 
 (** [tr_stmt c map stmt ns ncont nexits nret rret] holds if the graph [c],
   starting at node [ns], contains instructions that perform the Cminor
@@ -1214,14 +1217,17 @@ Proof.
 Qed.
 
 Lemma convert_builtin_res_charact:
-  forall map res s res' s' INCR
-    (TR: convert_builtin_res map res s = OK res' s' INCR)
+  forall map oty res s res' s' INCR
+    (TR: convert_builtin_res map oty res s = OK res' s' INCR)
     (WF: map_valid map s),
   tr_builtin_res map res res'.
 Proof.
-  destruct res; simpl; intros; monadInv TR. 
-- constructor.  unfold find_var in EQ. destruct (map_vars map)!x; inv EQ; auto.
-- constructor.
+  destruct res; simpl; intros.
+- monadInv TR. constructor.  unfold find_var in EQ. destruct (map_vars map)!x; inv EQ; auto.
+- destruct oty; monadInv TR.
++ constructor. eauto with rtlg. 
++ constructor.
+- monadInv TR.
 Qed.
 
 Lemma transl_stmt_charact:
diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml
index 5cd5997d..bd281374 100644
--- a/cfrontend/C2C.ml
+++ b/cfrontend/C2C.ml
@@ -524,6 +524,13 @@ let convertField env f =
   (intern_string f.fld_name, convertTyp env f.fld_typ)
 
 let convertCompositedef env su id attr members =
+  let t = match su with 
+  | C.Struct -> 
+      let layout = Cutil.struct_layout env members in
+      List.iter (fun (a,b) -> Debug.set_member_offset id a b) layout;
+      TStruct (id,attr) 
+  | C.Union -> TUnion (id,attr) in
+  Debug.set_composite_size id su (Cutil.sizeof env t);
   Composite(intern_string id.name,
             begin match su with C.Struct -> Struct | C.Union -> Union end,
             List.map (convertField env) members,
@@ -741,6 +748,22 @@ let rec convertExpr env e =
   | C.ECompound(ty1, ie) ->
       unsupported "compound literals"; ezero
 
+  | C.ECall({edesc = C.EVar {name = "__builtin_debug"}}, args) ->
+      let (kind, args1) =
+        match args with
+        | {edesc = C.EConst(CInt(n,_,_))} :: args1 -> (n, args1)
+        | _ -> error "ill_formed __builtin_debug"; (0L, args) in
+      let (text, args2) =
+        match args1 with
+        | {edesc = C.EConst(CStr(txt))} :: args2 -> (txt, args2)
+        | {edesc = C.EVar id} :: args2 -> (id.name, args2)
+        | _ -> error "ill_formed __builtin_debug"; ("", args1) in
+      let targs2 = convertTypArgs env [] args2 in
+      Ebuiltin(
+        EF_debug(P.of_int64 kind, intern_string text,
+                 typlist_of_typelist targs2),
+        targs2, convertExprList env args2, convertTyp env e.etyp)
+ 
   | C.ECall({edesc = C.EVar {name = "__builtin_annot"}}, args) ->
       begin match args with
       | {edesc = C.EConst(CStr txt)} :: args1 ->
@@ -922,16 +945,6 @@ let rec contains_case s =
 
 (** Annotations for line numbers *)
 
-let add_lineno prev_loc this_loc s =
-  if !Clflags.option_g && prev_loc <> this_loc && this_loc <> Cutil.no_loc
-  then begin
-    let txt = sprintf "#line:%s:%d" (fst this_loc) (snd this_loc) in
-     Ssequence(Sdo(Ebuiltin(EF_debug(P.one, intern_string txt, []),
-                            Tnil, Enil, Tvoid)),
-               s)
-  end else
-    s
-
 (** Statements *)
 
 let swrap = function
@@ -939,36 +952,31 @@ let swrap = function
   | Errors.Error msg ->
       error ("retyping error: " ^  string_of_errmsg msg); Sskip
 
-let rec convertStmt ploc env s =
+let rec convertStmt env s =
   updateLoc s.sloc;
   match s.sdesc with
   | C.Sskip ->
       Sskip
   | C.Sdo e ->
-      add_lineno ploc s.sloc (swrap (Ctyping.sdo (convertExpr env e)))
+      swrap (Ctyping.sdo (convertExpr env e))
   | C.Sseq(s1, s2) ->
-      let s1' = convertStmt ploc env s1 in
-      let s2' = convertStmt s1.sloc env s2 in
+      let s1' = convertStmt env s1 in
+      let s2' = convertStmt env s2 in
       Ssequence(s1', s2')
   | C.Sif(e, s1, s2) ->
       let te = convertExpr env e in
-      add_lineno ploc s.sloc 
-        (swrap (Ctyping.sifthenelse te 
-                      (convertStmt s.sloc env s1) (convertStmt s.sloc env s2)))
+      swrap (Ctyping.sifthenelse te (convertStmt env s1) (convertStmt env s2))
   | C.Swhile(e, s1) ->
       let te = convertExpr env e in
-      add_lineno ploc s.sloc
-        (swrap (Ctyping.swhile te (convertStmt s.sloc env s1)))
+      swrap (Ctyping.swhile te (convertStmt env s1))
   | C.Sdowhile(s1, e) ->
       let te = convertExpr env e in
-      add_lineno ploc s.sloc
-        (swrap (Ctyping.sdowhile te (convertStmt s.sloc env s1)))
+      swrap (Ctyping.sdowhile te (convertStmt env s1))
   | C.Sfor(s1, e, s2, s3) ->
       let te = convertExpr env e in
-      add_lineno ploc s.sloc
-        (swrap (Ctyping.sfor
-                      (convertStmt s.sloc env s1) te
-                      (convertStmt s.sloc env s2) (convertStmt s.sloc env s3)))
+      swrap (Ctyping.sfor
+                  (convertStmt env s1) te
+                  (convertStmt env s2) (convertStmt env s3))
   | C.Sbreak ->
       Sbreak
   | C.Scontinue ->
@@ -981,22 +989,20 @@ let rec convertStmt ploc env s =
           contains_case init
         end;
       let te = convertExpr env e in
-      add_lineno ploc s.sloc
-        (swrap (Ctyping.sswitch te
-                    (convertSwitch s.sloc env (is_longlong env e.etyp) cases)))
+      swrap (Ctyping.sswitch te
+               (convertSwitch env (is_longlong env e.etyp) cases))
   | C.Slabeled(C.Slabel lbl, s1) ->
-      add_lineno ploc s.sloc
-        (Slabel(intern_string lbl, convertStmt s.sloc env s1))
+      Slabel(intern_string lbl, convertStmt env s1)
   | C.Slabeled(C.Scase _, _) ->
       unsupported "'case' outside of 'switch'"; Sskip
   | C.Slabeled(C.Sdefault, _) ->
       unsupported "'default' outside of 'switch'"; Sskip
   | C.Sgoto lbl ->
-      add_lineno ploc s.sloc (Sgoto(intern_string lbl))
+      Sgoto(intern_string lbl)
   | C.Sreturn None ->
-      add_lineno ploc s.sloc (Sreturn None)
+      Sreturn None
   | C.Sreturn(Some e) ->
-      add_lineno ploc s.sloc (Sreturn(Some(convertExpr env e)))
+      Sreturn(Some(convertExpr env e))
   | C.Sblock _ ->
       unsupported "nested blocks"; Sskip
   | C.Sdecl _ ->
@@ -1004,10 +1010,9 @@ let rec convertStmt ploc env s =
   | C.Sasm(attrs, txt, outputs, inputs, clobber) ->
       if not !Clflags.option_finline_asm then
         unsupported "inline 'asm' statement (consider adding option -finline-asm)";
-      add_lineno ploc s.sloc
-        (Sdo (convertAsm s.sloc env txt outputs inputs clobber))
+      Sdo (convertAsm s.sloc env txt outputs inputs clobber)
 
-and convertSwitch ploc env is_64 = function
+and convertSwitch env is_64 = function
   | [] ->
       LSnil
   | (lbl, s) :: rem ->
@@ -1024,7 +1029,7 @@ and convertSwitch ploc env is_64 = function
                               then Z.of_uint64 v
                               else Z.of_uint32 (Int64.to_int32 v))
       in
-      LScons(lbl', convertStmt ploc env s, convertSwitch s.sloc env is_64 rem)
+      LScons(lbl', convertStmt env s, convertSwitch env is_64 rem)
 
 (** Function definitions *)
 
@@ -1038,7 +1043,9 @@ let convertFundef loc env fd =
   let params =
     List.map
       (fun (id, ty) ->
-        (intern_string id.name, convertTyp env ty))
+        let id' = intern_string id.name in
+        Debug.atom_parameter fd.fd_name id id';
+        (id', convertTyp env ty))
       fd.fd_params in
   let vars =
     List.map
@@ -1047,10 +1054,13 @@ let convertFundef loc env fd =
           unsupported "'static' or 'extern' local variable";
         if init <> None then
           unsupported "initialized local variable";
-        (intern_string id.name, convertTyp env ty))
+        let id' = intern_string id.name in
+        Debug.atom_local_variable id id';
+        (id', convertTyp env ty))
       fd.fd_locals in
-  let body' = convertStmt loc env fd.fd_body in
+  let body' = convertStmt env fd.fd_body in
   let id' = intern_string fd.fd_name.name in
+  Debug.atom_function fd.fd_name id';
   Hashtbl.add decl_atom id'
     { a_storage = fd.fd_storage;
       a_alignment = None;
@@ -1116,6 +1126,7 @@ let convertInitializer env ty i =
 
 let convertGlobvar loc env (sto, id, ty, optinit) =
   let id' = intern_string id.name in
+  Debug.atom_global_variable id id';
   let ty' = convertTyp env ty in 
   let sz = Ctypes.sizeof !comp_env ty' in
   let al = Ctypes.alignof !comp_env ty' in
diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v
index a555f792..1f55da7f 100644
--- a/cfrontend/Ctypes.v
+++ b/cfrontend/Ctypes.v
@@ -802,13 +802,13 @@ Program Definition composite_of_def
 Next Obligation.
   apply Zle_ge. eapply Zle_trans. eapply sizeof_composite_pos. 
   apply align_le; apply alignof_composite_pos.
-Qed.
+Defined.
 Next Obligation.
   apply align_attr_two_p. apply alignof_composite_two_p.
-Qed.
+Defined.
 Next Obligation.
   apply align_divides. apply alignof_composite_pos.
-Qed.
+Defined.
 
 (** The composite environment for a program is obtained by entering
   its composite definitions in sequence.  The definitions are assumed
diff --git a/common/AST.v b/common/AST.v
index 4d929f13..4e02b3d4 100644
--- a/common/AST.v
+++ b/common/AST.v
@@ -264,10 +264,46 @@ Qed.
 
 End TRANSF_PROGRAM.
 
+(** General iterator over program that applies a given code transfomration 
+    function to all function descriptions with their identifers and leaves
+    teh other parts of the program unchanged. *)
+
+Section TRANSF_PROGRAM_IDENT.
+
+Variable A B V: Type.
+Variable transf: ident -> A -> B.
+
+Definition transform_program_globdef_ident (idg: ident * globdef A V) : ident * globdef B V :=
+  match idg with
+  | (id, Gfun f) => (id, Gfun (transf id f))
+  | (id, Gvar v) => (id, Gvar v)
+  end.
+
+Definition transform_program_ident (p: program A V): program B V :=
+  mkprogram
+    (List.map transform_program_globdef_ident p.(prog_defs))
+    p.(prog_public)
+    p.(prog_main).
+
+Lemma tranforma_program_function_ident:
+  forall p i tf,
+  In (i, Gfun tf) (transform_program_ident p).(prog_defs) ->
+  exists f, In (i, Gfun f) p.(prog_defs) /\ transf i f = tf.
+Proof.
+  simpl. unfold transform_program_ident. intros.
+  exploit list_in_map_inv; eauto. 
+  intros [[i' gd] [EQ IN]]. simpl in EQ. destruct gd; inv EQ. 
+  exists f; auto.
+Qed.
+
+End TRANSF_PROGRAM_IDENT.
+
 (** The following is a more general presentation of [transform_program] where 
   global variable information can be transformed, in addition to function
   definitions.  Moreover, the transformation functions can fail and
-  return an error message. *)
+  return an error message. Also the transformation functions are defined
+  for the case the identifier of the function is passed as additional 
+  argument *)
 
 Open Local Scope error_monad_scope.
 Open Local Scope string_scope.
@@ -276,12 +312,18 @@ Section TRANSF_PROGRAM_GEN.
 
 Variables A B V W: Type.
 Variable transf_fun: A -> res B.
+Variable transf_fun_ident: ident -> A -> res B.
 Variable transf_var: V -> res W.
+Variable transf_var_ident: ident -> V -> res W.
 
 Definition transf_globvar (g: globvar V) : res (globvar W) :=
   do info' <- transf_var g.(gvar_info);
   OK (mkglobvar info' g.(gvar_init) g.(gvar_readonly) g.(gvar_volatile)).
 
+Definition transf_globvar_ident (i: ident) (g: globvar V) : res (globvar W) :=
+  do info' <- transf_var_ident i g.(gvar_info);
+  OK (mkglobvar info' g.(gvar_init) g.(gvar_readonly) g.(gvar_volatile)).
+
 Fixpoint transf_globdefs (l: list (ident * globdef A V)) : res (list (ident * globdef B W)) :=
   match l with
   | nil => OK nil
@@ -299,10 +341,31 @@ Fixpoint transf_globdefs (l: list (ident * globdef A V)) : res (list (ident * gl
       end
   end.
 
+Fixpoint transf_globdefs_ident (l: list (ident * globdef A V)) : res (list (ident * globdef B W)) := 
+  match l with
+  | nil => OK nil
+  | (id, Gfun f) :: l' =>
+    match transf_fun_ident id f with
+      | Error msg => Error (MSG "In function " :: CTX id :: MSG ": " :: msg)
+      | OK tf =>
+        do tl' <- transf_globdefs_ident l'; OK ((id, Gfun tf) :: tl')
+    end
+  | (id, Gvar v) :: l' =>
+    match transf_globvar_ident id v with
+      | Error msg => Error (MSG "In variable " :: CTX id :: MSG ": " :: msg)
+      | OK tv =>
+        do tl' <- transf_globdefs_ident l'; OK ((id, Gvar tv) :: tl')
+    end
+  end.
+
 Definition transform_partial_program2 (p: program A V) : res (program B W) :=
   do gl' <- transf_globdefs p.(prog_defs);
   OK (mkprogram gl' p.(prog_public) p.(prog_main)).
 
+Definition transform_partial_ident_program2 (p: program A V) : res (program B W) :=
+  do gl' <- transf_globdefs_ident p.(prog_defs);
+  OK (mkprogram gl' p.(prog_public) p.(prog_main)).
+
 Lemma transform_partial_program2_function:
   forall p tp i tf,
   transform_partial_program2 p = OK tp ->
@@ -321,6 +384,24 @@ Proof.
   exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto.
 Qed.
 
+Lemma transform_partial_ident_program2_function:
+  forall p tp i tf,
+  transform_partial_ident_program2 p = OK tp ->
+  In (i, Gfun tf) tp.(prog_defs) ->
+  exists f, In (i, Gfun f) p.(prog_defs) /\ transf_fun_ident i f = OK tf.
+Proof.
+  intros. monadInv H. simpl in H0. 
+  revert x EQ H0. induction (prog_defs p); simpl; intros.
+  inv EQ. contradiction.
+  destruct a as [id [f|v]].
+  destruct (transf_fun_ident id f) as [tf1|msg] eqn:?; monadInv EQ.
+  simpl in H0; destruct H0. inv H. exists f; auto. 
+  exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto.
+  destruct (transf_globvar_ident id v) as [tv1|msg] eqn:?; monadInv EQ.
+  simpl in H0; destruct H0. inv H.
+  exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto.
+Qed.
+
 Lemma transform_partial_program2_variable:
   forall p tp i tv,
   transform_partial_program2 p = OK tp ->
@@ -342,6 +423,28 @@ Proof.
   exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto.
 Qed.
 
+
+Lemma transform_partial_ident_program2_variable:
+  forall p tp i tv,
+  transform_partial_ident_program2 p = OK tp ->
+  In (i, Gvar tv) tp.(prog_defs) ->
+  exists v,
+     In (i, Gvar(mkglobvar v tv.(gvar_init) tv.(gvar_readonly) tv.(gvar_volatile))) p.(prog_defs)
+  /\ transf_var_ident i v = OK tv.(gvar_info).
+Proof.
+  intros. monadInv H. simpl in H0. 
+  revert x EQ H0. induction (prog_defs p); simpl; intros.
+  inv EQ. contradiction.
+  destruct a as [id [f|v]].
+  destruct (transf_fun_ident id f) as [tf1|msg] eqn:?; monadInv EQ.
+  simpl in H0; destruct H0. inv H.
+  exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto.
+  destruct (transf_globvar_ident id v) as [tv1|msg] eqn:?; monadInv EQ.
+  simpl in H0; destruct H0. inv H.
+  monadInv Heqr. simpl. exists (gvar_info v). split. left. destruct v; auto. auto.
+  exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto.
+Qed.
+
 Lemma transform_partial_program2_succeeds:
   forall p tp i g,
   transform_partial_program2 p = OK tp ->
@@ -361,6 +464,25 @@ Proof.
   destruct H0. inv H. monadInv TV. econstructor; eauto. eapply IHl; eauto.
 Qed.
 
+Lemma transform_partial_ident_program2_succeeds:
+  forall p tp i g,
+  transform_partial_ident_program2 p = OK tp ->
+  In (i, g) p.(prog_defs) ->
+  match g with
+  | Gfun fd => exists tfd, transf_fun_ident i fd = OK tfd
+  | Gvar gv => exists tv, transf_var_ident i gv.(gvar_info) = OK tv
+  end.
+Proof.
+  intros. monadInv H. 
+  revert x EQ H0. induction (prog_defs p); simpl; intros.
+  contradiction.
+  destruct a as [id1 g1]. destruct g1.
+  destruct (transf_fun_ident id1 f) eqn:TF; try discriminate. monadInv EQ. 
+  destruct H0. inv H. econstructor; eauto. eapply IHl; eauto.
+  destruct (transf_globvar_ident id1 v) eqn:TV; try discriminate. monadInv EQ.
+  destruct H0. inv H. monadInv TV. econstructor; eauto. eapply IHl; eauto.
+Qed.
+
 Lemma transform_partial_program2_main:
   forall p tp,
   transform_partial_program2 p = OK tp ->
@@ -369,6 +491,14 @@ Proof.
   intros. monadInv H. reflexivity.
 Qed.
 
+Lemma transform_partial_ident_program2_main:
+  forall p tp,
+  transform_partial_ident_program2 p = OK tp ->
+  tp.(prog_main) = p.(prog_main).
+Proof.
+  intros. monadInv H. reflexivity.
+Qed.
+
 Lemma transform_partial_program2_public:
   forall p tp,
   transform_partial_program2 p = OK tp ->
@@ -377,6 +507,14 @@ Proof.
   intros. monadInv H. reflexivity.
 Qed.
 
+Lemma transform_partial_ident_program2_public:
+  forall p tp,
+  transform_partial_ident_program2 p = OK tp ->
+  tp.(prog_public) = p.(prog_public).
+Proof.
+  intros. monadInv H. reflexivity.
+Qed.
+
 (** Additionally, we can also "augment" the program with new global definitions
   and a different "main" function. *)
 
@@ -397,6 +535,18 @@ Proof.
   intros. monadInv H. reflexivity.
 Qed.
 
+Definition transform_partial_augment_ident_program (p: program A V) : res (program B W) :=
+  do gl' <- transf_globdefs_ident p.(prog_defs);
+  OK(mkprogram (gl' ++ new_globs) p.(prog_public) new_main).
+
+Lemma transform_partial_augment_ident_program_main:
+  forall p tp,
+  transform_partial_augment_ident_program p = OK tp ->
+  tp.(prog_main) = new_main.
+Proof.
+  intros. monadInv H. reflexivity.
+Qed.
+
 End AUGMENT.
 
 Remark transform_partial_program2_augment:
@@ -409,6 +559,16 @@ Proof.
   simpl. f_equal. f_equal. rewrite <- app_nil_end. auto.
 Qed.
 
+Remark transform_partial_ident_program2_augment:
+  forall p,
+  transform_partial_ident_program2 p =
+  transform_partial_augment_ident_program nil p.(prog_main) p.
+Proof.
+  unfold transform_partial_ident_program2, transform_partial_augment_ident_program; intros.
+  destruct (transf_globdefs_ident (prog_defs p)); auto.
+  simpl. f_equal. f_equal. rewrite <- app_nil_end. auto.
+Qed.
+
 End TRANSF_PROGRAM_GEN.
 
 (** The following is a special case of [transform_partial_program2],
@@ -418,10 +578,14 @@ Section TRANSF_PARTIAL_PROGRAM.
 
 Variable A B V: Type.
 Variable transf_partial: A -> res B.
+Variable transf_partial_ident: ident -> A -> res B.
 
 Definition transform_partial_program (p: program A V) : res (program B V) :=
   transform_partial_program2 transf_partial (fun v => OK v) p.
 
+Definition transform_partial_ident_program (p: program A V) : res (program B V) :=
+  transform_partial_ident_program2 transf_partial_ident (fun _ v => OK v) p.
+
 Lemma transform_partial_program_main:
   forall p tp,
   transform_partial_program p = OK tp ->
@@ -430,6 +594,14 @@ Proof.
   apply transform_partial_program2_main.
 Qed.
 
+Lemma transform_partial_ident_program_main:
+  forall p tp,
+  transform_partial_ident_program p = OK tp ->
+  tp.(prog_main) = p.(prog_main).
+Proof.
+  apply transform_partial_ident_program2_main.
+Qed.
+
 Lemma transform_partial_program_public:
   forall p tp,
   transform_partial_program p = OK tp ->
@@ -438,6 +610,14 @@ Proof.
   apply transform_partial_program2_public.
 Qed.
 
+Lemma transform_partial_ident_program_public:
+  forall p tp,
+  transform_partial_ident_program p = OK tp ->
+  tp.(prog_public) = p.(prog_public).
+Proof.
+  apply transform_partial_ident_program2_public.
+Qed.
+
 Lemma transform_partial_program_function:
   forall p tp i tf,
   transform_partial_program p = OK tp ->
@@ -447,6 +627,15 @@ Proof.
   apply transform_partial_program2_function. 
 Qed.
 
+Lemma transform_partial_ident_program_function:
+  forall p tp i tf,
+  transform_partial_ident_program p = OK tp ->
+  In (i, Gfun tf) tp.(prog_defs) ->
+  exists f, In (i, Gfun f) p.(prog_defs) /\ transf_partial_ident i f = OK tf.
+Proof.
+  apply transform_partial_ident_program2_function. 
+Qed.
+
 Lemma transform_partial_program_succeeds:
   forall p tp i fd,
   transform_partial_program p = OK tp ->
@@ -457,6 +646,16 @@ Proof.
   exploit transform_partial_program2_succeeds; eauto. 
 Qed.
 
+Lemma transform_partial_ident_program_succeeds:
+  forall p tp i fd,
+  transform_partial_ident_program p = OK tp ->
+  In (i, Gfun fd) p.(prog_defs) ->
+  exists tfd, transf_partial_ident i fd = OK tfd.
+Proof.
+  unfold transform_partial_ident_program; intros. 
+  exploit transform_partial_ident_program2_succeeds; eauto. 
+Qed.
+
 End TRANSF_PARTIAL_PROGRAM.
 
 Lemma transform_program_partial_program:
@@ -475,6 +674,22 @@ Proof.
     destruct v; auto.
 Qed.
 
+Lemma transform_program_partial_ident_program:
+  forall (A B V: Type) (transf: ident -> A -> B) (p: program A V),
+  transform_partial_ident_program (fun id f => OK(transf id f)) p = OK(transform_program_ident transf p).
+Proof.
+  intros.
+  unfold transform_partial_ident_program, transform_partial_ident_program2, transform_program; intros.
+  replace (transf_globdefs_ident (fun id f => OK (transf id f)) (fun _  v => OK v) p.(prog_defs))
+     with (OK (map (transform_program_globdef_ident transf) p.(prog_defs))).
+  auto. 
+  induction (prog_defs p); simpl.
+  auto.
+  destruct a as [id [f|v]]; rewrite <- IHl.
+    auto.
+    destruct v; auto.
+Qed.
+
 (** The following is a relational presentation of 
   [transform_partial_augment_preogram].  Given relations between function
   definitions and between variable information, it defines a relation
diff --git a/common/Sections.ml b/common/Sections.ml
index c0c95848..cc8b0758 100644
--- a/common/Sections.ml
+++ b/common/Sections.ml
@@ -27,8 +27,10 @@ type section_name =
   | Section_literal
   | Section_jumptable
   | Section_user of string * bool (*writable*) * bool (*executable*)
-  | Section_debug_info
+  | Section_debug_info of string
   | Section_debug_abbrev
+  | Section_debug_loc
+  | Section_debug_line of string
 
 type access_mode =
   | Access_default
diff --git a/common/Sections.mli b/common/Sections.mli
index e878b9e5..7a8c8225 100644
--- a/common/Sections.mli
+++ b/common/Sections.mli
@@ -26,8 +26,10 @@ type section_name =
   | Section_literal
   | Section_jumptable
   | Section_user of string * bool (*writable*) * bool (*executable*)
-  | Section_debug_info
+  | Section_debug_info of string
   | Section_debug_abbrev
+  | Section_debug_loc
+  | Section_debug_line of string
 
 type access_mode =
   | Access_default
diff --git a/configure b/configure
index 9646449e..9bbc5019 100755
--- a/configure
+++ b/configure
@@ -124,7 +124,8 @@ case "$target" in
         casmruntime="${toolprefix}gcc -c -Wa,-mregnames"
         clinker="${toolprefix}gcc"
         libmath="-lm"
-        cchecklink=${build_checklink};;
+        cchecklink=${build_checklink}
+        advanced_debug=true;;
     esac;;
   arm*-*)
     arch="arm"
diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml
index 6569bb4c..d064f4b1 100644
--- a/cparser/Bitfields.ml
+++ b/cparser/Bitfields.ml
@@ -111,16 +111,16 @@ let pack_bitfields env sid ml =
           end
   in pack [] 0 ml
 
-let rec transf_members env id count = function
+let rec transf_struct_members env id count = function
   | [] -> []
   | m :: ms as ml ->
       if m.fld_bitfield = None then
-        m :: transf_members env id count ms
+        m :: transf_struct_members env id count ms
       else begin
         let (nbits, bitfields, ml') = pack_bitfields env id ml in
         if nbits = 0 then
           (* Lone zero-size bitfield: just ignore *)
-          transf_members env id count ml'
+          transf_struct_members env id count ml'
         else begin
           (* Create integer field of sufficient size for this bitfield group *)
           let carrier = sprintf "__bf%d" count in
@@ -134,6 +134,7 @@ let rec transf_members env id count = function
                   if !config.bitfields_msb_first
                   then sizeof_ikind carrier_ikind * 8 - pos - sz
                   else pos in
+                Debug.set_bitfield_offset id name pos carrier (sizeof_ikind carrier_ikind);
                 Hashtbl.add bitfield_table
                   (id, name)
                   {bf_carrier = carrier; bf_carrier_typ = carrier_typ;
@@ -143,14 +144,49 @@ let rec transf_members env id count = function
               end)
             bitfields;
           { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None}
-          :: transf_members env id (count + 1) ml'
+          :: transf_struct_members env id (count + 1) ml'
         end
       end
 
+let rec transf_union_members env id count = function
+    [] -> []
+  | m :: ms ->
+      (match m.fld_bitfield with
+      | None ->  m::transf_union_members env id count ms
+      | Some nbits ->
+          let carrier = sprintf "__bf%d" count in
+          let carrier_ikind = unsigned_ikind_for_carrier nbits in
+          let carrier_typ = TInt(carrier_ikind, []) in
+          let signed =
+            match unroll env m.fld_typ with
+            | TInt(ik, _) -> is_signed_ikind ik
+            | TEnum(eid, _) -> is_signed_enum_bitfield env id m.fld_name eid nbits
+            | _ -> assert false (* should never happen, checked in Elab *) in
+          let signed2 =
+            match unroll env (type_of_member env m) with
+            | TInt(ik, _) -> is_signed_ikind ik
+            | _ -> assert false (* should never happen, checked in Elab *) in
+          let pos' =
+            if !config.bitfields_msb_first
+            then sizeof_ikind carrier_ikind * 8 - nbits
+            else 0 in
+          let is_bool =
+            match unroll env m.fld_typ with
+            | TInt(IBool, _) -> true
+            | _ -> false in
+          Hashtbl.add bitfield_table
+            (id, m.fld_name)
+            {bf_carrier = carrier; bf_carrier_typ = carrier_typ;
+             bf_pos = pos'; bf_size = nbits;
+             bf_signed = signed; bf_signed_res = signed2;
+             bf_bool = is_bool};
+          { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None}
+          :: transf_struct_members env id (count + 1) ms)
+
 let transf_composite env su id attr ml =
   match su with
-  | Struct -> (attr, transf_members env id 1 ml)
-  | Union  -> (attr, ml)
+  | Struct -> (attr, transf_struct_members env id 1 ml)
+  | Union  -> (attr, transf_union_members env id 1 ml)
 
 (* Bitfield manipulation expressions *)
 
@@ -317,6 +353,7 @@ let rec is_bitfield_access env e =
   match e.edesc with
   | EUnop(Odot fieldname, e1) ->
       begin match unroll env e1.etyp with
+      | TUnion (id,_)
       | TStruct(id, _) ->
           (try Some(e1, Hashtbl.find bitfield_table (id, fieldname))
            with Not_found -> None)
diff --git a/cparser/Cleanup.ml b/cparser/Cleanup.ml
index 254f6fed..c81fd498 100644
--- a/cparser/Cleanup.ml
+++ b/cparser/Cleanup.ml
@@ -184,6 +184,11 @@ let saturate p =
 
 (* Remove unreferenced definitions *)
 
+let remove_unused_debug =  function
+  | Gdecl (_,id,_,_) ->  Debug.remove_unused id
+  | Gfundef f -> Debug.remove_unused f.fd_name
+  | _ -> ()    
+
 let rec simpl_globdecls accu = function
   | [] -> accu
   | g :: rem ->
@@ -199,7 +204,7 @@ let rec simpl_globdecls accu = function
         | Gpragma s -> true in
       if need
       then simpl_globdecls (g :: accu) rem
-      else simpl_globdecls accu rem
+      else begin remove_unused_debug g.gdesc; simpl_globdecls accu rem end
 
 let program p =
   referenced := IdentSet.empty;
diff --git a/cparser/Cprint.ml b/cparser/Cprint.ml
index 4ceaa016..1af5af1e 100644
--- a/cparser/Cprint.ml
+++ b/cparser/Cprint.ml
@@ -20,6 +20,8 @@ open C
 
 let print_idents_in_full = ref false
 
+let print_debug_idents = ref false
+
 let print_line_numbers = ref false
 
 let location pp (file, lineno) =
@@ -27,7 +29,9 @@ let location pp (file, lineno) =
     fprintf pp "# %d \"%s\"@ " lineno file
 
 let ident pp i =
-  if !print_idents_in_full
+  if !print_debug_idents
+  then fprintf pp "$%d" i.stamp
+  else if !print_idents_in_full
   then fprintf pp "%s$%d" i.name i.stamp
   else fprintf pp "%s" i.name
 
diff --git a/cparser/Cprint.mli b/cparser/Cprint.mli
index d63e341c..349b5f9a 100644
--- a/cparser/Cprint.mli
+++ b/cparser/Cprint.mli
@@ -15,6 +15,7 @@
 
 val print_idents_in_full : bool ref
 val print_line_numbers : bool ref
+val print_debug_idents : bool ref
 
 val location : Format.formatter -> C.location -> unit
 val attributes : Format.formatter -> C.attributes -> unit
diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml
index a3c05c34..0def347f 100644
--- a/cparser/Cutil.ml
+++ b/cparser/Cutil.ml
@@ -273,6 +273,42 @@ let combine_types mode env t1 t2 =
 
   in try Some(comp mode t1 t2) with Incompat -> None
 
+let rec equal_types env t1 t2 =
+  match t1, t2 with
+  | TVoid a1, TVoid a2 ->
+     a1=a2
+  | TInt(ik1, a1), TInt(ik2, a2) ->
+      ik1 = ik2 && a1 = a2
+  | TFloat(fk1, a1), TFloat(fk2, a2) ->
+     fk1 = fk2 && a1 = a2
+  | TPtr(ty1, a1), TPtr(ty2, a2) ->
+      a1 = a2 && equal_types env ty1 ty2
+  | TArray(ty1, sz1, a1), TArray(ty2, sz2, a2) ->
+      let size = begin match sz1,sz2 with
+      | None, None -> true
+      | Some s1, Some s2 -> s1 = s2
+      | _ -> false end in
+      size && a1 = a2 && equal_types env t1 t2
+  | TFun(ty1, params1, vararg1, a1), TFun(ty2, params2, vararg2, a2) ->
+      let params =
+        match params1, params2 with
+        | None, None -> true
+        | None, Some _
+        | Some _, None -> false
+        | Some l1, Some l2 ->
+            try
+              List.for_all2 (fun (_,t1) (_,t2) -> equal_types env t1 t2) l1 l2
+            with _ -> false
+      in params && a1 = a2 && vararg1 = vararg2 && equal_types env ty1 ty2
+  | TNamed _, _ -> equal_types env (unroll env t1) t2
+  | _, TNamed _ -> equal_types env t1 (unroll env t2)
+  | TStruct(s1, a1), TStruct(s2, a2)
+  | TUnion(s1, a1), TUnion(s2, a2)
+  | TEnum(s1, a1), TEnum(s2, a2) ->
+      s1 = s2 && a1 = a2
+  | _, _ ->
+      false
+
 (** Check whether two types are compatible. *)
 
 let compatible_types mode env t1 t2 =
@@ -427,7 +463,6 @@ let sizeof_union env members =
    We lay out fields consecutively, inserting padding to preserve
    their alignment.
    Not done here but in composite_info_decl: rounding size to alignment. *)
-
 let sizeof_struct env members =
   let rec sizeof_rec ofs = function
   | [] ->
@@ -449,6 +484,26 @@ let sizeof_struct env members =
       end
   in sizeof_rec 0 members
 
+(* Simplified version to compute offsets on structs without bitfields *)
+let struct_layout env members =
+  let rec struct_layout_rec mem ofs = function
+    | [] ->
+        mem
+    | [ { fld_typ = TArray(_, None, _) } as m ] ->
+      (* C99: ty[] allowed as last field *)
+      begin match alignof env m.fld_typ with
+      | Some a -> ( m.fld_name,align ofs a)::mem
+      | None -> []
+      end
+    | m :: rem ->
+        match alignof env m.fld_typ, sizeof env m.fld_typ with
+        | Some a, Some s -> 
+            let offset = align ofs a in
+            struct_layout_rec ((m.fld_name,offset)::mem) (offset + s) rem
+        | _, _ -> []
+  in struct_layout_rec [] 0 members
+
+
 (* Determine whether a type is incomplete *)
 
 let incomplete_type env t =
diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli
index b1f77944..a322bfb1 100644
--- a/cparser/Cutil.mli
+++ b/cparser/Cutil.mli
@@ -80,6 +80,8 @@ val combine_types : attr_handling -> Env.t -> typ -> typ -> typ option
      with the same meaning as for [compatible_types].
      When two sets of attributes are compatible, the result of
      [combine_types] carries the union of these two sets of attributes. *)
+val equal_types : Env.t -> typ -> typ -> bool
+   (* Check that the two given types are equal up to typedef use *)
 
 (* Size and alignment *)
 
@@ -105,6 +107,8 @@ val composite_info_decl:
   Env.t -> struct_or_union -> attributes -> Env.composite_info
 val composite_info_def:
   Env.t -> struct_or_union -> attributes -> field list -> Env.composite_info
+val struct_layout:
+  Env.t -> field list -> (string * int) list
 
 (* Type classification functions *)
 
diff --git a/cparser/Elab.ml b/cparser/Elab.ml
index 820f90f5..4d3d1d02 100644
--- a/cparser/Elab.ml
+++ b/cparser/Elab.ml
@@ -56,9 +56,11 @@ let elab_loc l = (l.filename, l.lineno)
 
 let top_declarations = ref ([] : globdecl list)
 
-let emit_elab loc td =
+let emit_elab ?(enter:bool=true) env loc td =
   let loc = elab_loc loc in
-  top_declarations := { gdesc = td; gloc = loc } :: !top_declarations
+  let dec ={ gdesc = td; gloc = loc } in
+  if enter then  Debug.insert_global_declaration env dec;
+  top_declarations := dec :: !top_declarations
 
 let reset() = top_declarations := []
 
@@ -556,9 +558,9 @@ and elab_parameters env params =
   | _ ->
       (* Prototype introduces a new scope *)
       let (vars, _) = mmap elab_parameter (Env.new_scope env) params in
-      (* Catch special case f(void) *)
+      (* Catch special case f(t) where t is void or a typedef to void *)
       match vars with
-        | [ ( {name=""}, TVoid _) ] -> Some []
+        | [ ( {name=""}, t) ] when is_void_type env t -> Some []
         | _ -> Some vars
 
 (* Elaboration of a function parameter *)
@@ -730,7 +732,7 @@ and elab_struct_or_union only kind loc tag optmembers attrs env =
       (* finishing the definition of an incomplete struct or union *)
       let (ci', env') = elab_struct_or_union_info kind loc env members attrs in
       (* Emit a global definition for it *)
-      emit_elab loc (Gcompositedef(kind, tag', attrs, ci'.ci_members));
+      emit_elab env' loc (Gcompositedef(kind, tag', attrs, ci'.ci_members));
       (* Replace infos but keep same ident *)
       (tag', Env.add_composite env' tag' ci')
   | Some(tag', {ci_sizeof = Some _}), Some _
@@ -745,7 +747,7 @@ and elab_struct_or_union only kind loc tag optmembers attrs env =
       (* enter it with a new name *)
       let (tag', env') = Env.enter_composite env tag ci in
       (* emit it *)
-      emit_elab loc (Gcompositedecl(kind, tag', attrs));
+      emit_elab env' loc (Gcompositedecl(kind, tag', attrs));
       (tag', env')
   | _, Some members ->
       (* definition of a complete struct or union *)
@@ -753,12 +755,12 @@ and elab_struct_or_union only kind loc tag optmembers attrs env =
       (* enter it, incomplete, with a new name *)
       let (tag', env') = Env.enter_composite env tag ci1 in
       (* emit a declaration so that inner structs and unions can refer to it *)
-      emit_elab loc (Gcompositedecl(kind, tag', attrs));
+      emit_elab env' loc (Gcompositedecl(kind, tag', attrs));
       (* elaborate the members *)
       let (ci2, env'') =
         elab_struct_or_union_info kind loc env' members attrs in
       (* emit a definition *)
-      emit_elab loc (Gcompositedef(kind, tag', attrs, ci2.ci_members));
+      emit_elab env'' loc (Gcompositedef(kind, tag', attrs, ci2.ci_members));
       (* Replace infos but keep same ident *)
       (tag', Env.add_composite env'' tag' ci2)
 
@@ -809,7 +811,7 @@ and elab_enum only loc tag optmembers attrs env =
       let (dcls, env') = elab_members env 0L members in
       let info = { ei_members = dcls; ei_attr = attrs } in
       let (tag', env'') = Env.enter_enum env' tag info in
-      emit_elab loc (Genumdef(tag', attrs, dcls));
+      emit_elab env' loc (Genumdef(tag', attrs, dcls));
       (tag', env'')
 
 (* Elaboration of a naked type, e.g. in a cast *)
@@ -1312,7 +1314,7 @@ let elab_expr loc env a =
             let ty = TFun(TInt(IInt, []), None, false, []) in
             (* Emit an extern declaration for it *)
             let id = Env.fresh_ident n in
-            emit_elab loc (Gdecl(Storage_extern, id, ty, None));
+            emit_elab env loc (Gdecl(Storage_extern, id, ty, None));
             { edesc = EVar id; etyp = ty }
         | _ -> elab a1 in
       let bl = List.map elab al in
@@ -1784,13 +1786,21 @@ let enter_typedefs loc env sto dl =
   List.fold_left (fun env (s, ty, init) ->
     if init <> NO_INIT then
       error loc "initializer in typedef";
-    if redef Env.lookup_typedef env s then
-      error loc "redefinition of typedef '%s'" s;
-    if redef Env.lookup_ident env s then
-      error loc "redefinition of identifier '%s' as different kind of symbol" s;
-    let (id, env') = Env.enter_typedef env s ty in
-    emit_elab loc (Gtypedef(id, ty));
-    env') env dl
+    match previous_def Env.lookup_typedef env s with
+    | Some (s',ty') ->
+        if equal_types env ty ty' then begin
+          warning loc "redefinition of typedef '%s'" s;
+          env
+        end else begin
+          error loc "redefinition of typedef '%s' with different type" s;
+          env
+        end
+    | None ->
+        if redef Env.lookup_ident env s then
+          error loc "redefinition of identifier '%s' as different kind of symbol" s;
+        let (id, env') = Env.enter_typedef env s ty in
+        emit_elab env loc (Gtypedef(id, ty));
+        env') env dl
 
 let enter_or_refine_ident local loc env s sto ty =
   if redef Env.lookup_typedef env s then
@@ -1865,7 +1875,7 @@ let enter_decdefs local loc env sto dl =
       ((sto', id, ty', init') :: decls, env2)
     else begin
       (* Global definition *)
-      emit_elab loc (Gdecl(sto', id, ty', init'));
+      emit_elab env2 loc (Gdecl(sto', id, ty', init'));
       (decls, env2)
     end in
   let (decls, env') = List.fold_left enter_decdef ([], env) dl in
@@ -1899,7 +1909,7 @@ let elab_fundef env spec name body loc =
   let (func_ty, func_init) = __func__type_and_init s in
   let (func_id, _, env3,func_ty) =
     enter_or_refine_ident true loc env2 "__func__" Storage_static func_ty in
-  emit_elab loc (Gdecl(Storage_static, func_id, func_ty, Some func_init));
+  emit_elab ~enter:false env3 loc (Gdecl(Storage_static, func_id, func_ty, Some func_init));
   (* Elaborate function body *)
   let body' = !elab_funbody_f ty_ret env3 body in
   (* Special treatment of the "main" function *)
@@ -1925,7 +1935,7 @@ let elab_fundef env spec name body loc =
       fd_vararg = vararg;
       fd_locals = [];
       fd_body = body'' } in
-  emit_elab loc (Gfundef fn);
+  emit_elab env1 loc (Gfundef fn);
   env1
 
 let elab_kr_fundef env spec name params defs body loc =
@@ -1997,7 +2007,7 @@ let rec elab_definition (local: bool) (env: Env.t) (def: Cabs.definition)
 
   (* pragma *)
   | PRAGMA(s, loc) ->
-      emit_elab loc (Gpragma s);
+      emit_elab env loc (Gpragma s);
       ([], env)
 
 and elab_definitions local env = function
@@ -2224,7 +2234,9 @@ and elab_block_body env ctx sl =
   | DEFINITION def :: sl1 ->
       let (dcl, env') = elab_definition true env def in
       let loc = elab_loc (get_definitionloc def) in
-      List.map (fun d -> {sdesc = Sdecl d; sloc = loc}) dcl
+      List.map (fun ((sto,id,ty,_) as d) ->
+        Debug.insert_local_declaration sto id ty loc;
+        {sdesc = Sdecl d; sloc = loc}) dcl
       @ elab_block_body env' ctx sl1
   | s :: sl1 ->
       let s' = elab_stmt env ctx s in
@@ -2250,20 +2262,3 @@ let elab_file prog =
   reset();
   ignore (elab_definitions false (Builtins.environment()) prog);
   elaborated_program()
-(*
-  let rec inf = Datatypes.S inf in
-  let ast:Cabs.definition list =
-    Obj.magic
-      (match Parser.translation_unit_file inf (Lexer.tokens_stream lb) with
-         | Parser.Parser.Inter.Fail_pr ->
-             (* Theoretically impossible : implies inconsistencies
-                between grammars. *)
-             Cerrors.fatal_error "Internal error while parsing"
-         | Parser.Parser.Inter.Timeout_pr -> assert false
-         | Parser.Parser.Inter.Parsed_pr (ast, _ ) -> ast)
-  in
-  reset();
-  ignore (elab_definitions false (Builtins.environment()) ast);
-  elaborated_program()
-*)
-
diff --git a/cparser/Lexer.mll b/cparser/Lexer.mll
index 82e6589c..5cfe74fd 100644
--- a/cparser/Lexer.mll
+++ b/cparser/Lexer.mll
@@ -20,16 +20,14 @@ open Pre_parser_aux
 open Cabshelper
 open Camlcoq
 
-let contexts : string list list ref = ref []
-let lexicon : (string, Cabs.cabsloc -> token) Hashtbl.t = Hashtbl.create 0
+module SMap = Map.Make(String)
 
-let init filename channel : Lexing.lexbuf =
-  assert (!contexts = []);
-  Hashtbl.clear lexicon;
-  List.iter
-    (fun (key, builder) -> Hashtbl.add lexicon key builder)
-    [ 
-      ("_Alignas", fun loc -> ALIGNAS loc);
+let contexts_stk : (Cabs.cabsloc -> token) SMap.t list ref = ref []
+
+let init_ctx =
+  List.fold_left (fun ctx (key, builder) -> SMap.add key builder ctx)
+    SMap.empty
+    [ ("_Alignas", fun loc -> ALIGNAS loc);
       ("_Alignof", fun loc -> ALIGNOF loc);
       ("_Bool", fun loc -> UNDERSCORE_BOOL loc);
       ("__alignof", fun loc -> ALIGNOF loc);
@@ -85,37 +83,42 @@ let init filename channel : Lexing.lexbuf =
       ("void", fun loc -> VOID loc);
       ("volatile", fun loc -> VOLATILE loc);
       ("while", fun loc -> WHILE loc);
-    ];
-
-  push_context := begin fun () -> contexts := []::!contexts end;
-  pop_context := begin fun () ->
-    match !contexts with
-      | [] -> assert false
-      | t::q -> List.iter (Hashtbl.remove lexicon) t;
-                contexts := q
+      (let id = "__builtin_va_list" in
+       id, fun loc -> TYPEDEF_NAME (id, ref TypedefId, loc))]
+
+let _ =
+  (* See comments in pre_parser_aux.ml *)
+  open_context := begin fun () ->
+    contexts_stk := List.hd !contexts_stk::!contexts_stk
   end;
 
- declare_varname := begin fun id ->
-   if Hashtbl.mem lexicon id then begin
-     Hashtbl.add lexicon id (fun loc -> VAR_NAME (id, ref VarId, loc));
-     match !contexts with
-       | [] -> ()
-       | t::q -> contexts := (id::t)::q
-     end
+  close_context := begin fun () ->
+    contexts_stk := List.tl !contexts_stk
   end;
 
-  declare_typename := begin fun id ->
-    Hashtbl.add lexicon id (fun loc -> TYPEDEF_NAME (id, ref TypedefId, loc));
-    match !contexts with
-      | [] -> ()
-      | t::q -> contexts := (id::t)::q
+  save_contexts_stk := begin fun () ->
+    let save = !contexts_stk in
+    fun () -> contexts_stk := save
   end;
 
-  !declare_typename "__builtin_va_list";
+  declare_varname := begin fun id ->
+    match !contexts_stk with
+    (* This is the default, so there is no need to have an entry in this case. *)
+    | ctx::stk -> contexts_stk := SMap.remove id ctx::stk
+    | [] -> assert false
+  end;
+
+  declare_typename := begin fun id ->
+    match !contexts_stk with
+    | ctx::stk ->
+      contexts_stk :=
+        SMap.add id (fun loc -> TYPEDEF_NAME (id, ref TypedefId, loc)) ctx::stk
+    | [] -> assert false
+  end
 
+let init filename channel : Lexing.lexbuf =
   let lb = Lexing.from_channel channel in
-  lb.lex_curr_p <-
-    {lb.lex_curr_p with pos_fname = filename; pos_lnum = 1};
+  lb.lex_curr_p <- {lb.lex_curr_p with pos_fname = filename; pos_lnum = 1};
   lb
 
 let currentLoc =
@@ -337,8 +340,8 @@ rule initial = parse
   | ","                           { COMMA(currentLoc lexbuf) }
   | "."                           { DOT(currentLoc lexbuf) }
   | identifier as id              {
-        try Hashtbl.find lexicon id (currentLoc lexbuf)
-        with Not_found -> VAR_NAME (id, ref VarId, currentLoc lexbuf) }
+      try SMap.find id (List.hd !contexts_stk) (currentLoc lexbuf)
+      with Not_found -> VAR_NAME (id, ref VarId, currentLoc lexbuf) }
   | eof                           { EOF }
   | _ as c                        { fatal_error lexbuf "invalid symbol %C" c }
 
@@ -435,7 +438,7 @@ and singleline_comment = parse
   open Parser
   open Aut.GramDefs
 
-  let tokens_stream lexbuf : token coq_Stream =
+  let tokens_stream filename channel : token coq_Stream =
     let tokens = Queue.create () in
     let lexer_wraper lexbuf : Pre_parser.token =
       let res =
@@ -447,8 +450,11 @@ and singleline_comment = parse
       Queue.push res tokens;
       res
     in
+    let lexbuf = Lexing.from_channel channel in
+    lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = filename; pos_lnum = 1};
+    contexts_stk := [init_ctx];
     Pre_parser.translation_unit_file lexer_wraper lexbuf;
-    assert (!contexts = []);
+    assert (List.length !contexts_stk = 1);
     let rec compute_token_stream () =
       let loop t v =
         Cons (Coq_existT (t, Obj.magic v), Lazy.from_fun compute_token_stream)
diff --git a/cparser/Parse.ml b/cparser/Parse.ml
index c9564c08..cfa95688 100644
--- a/cparser/Parse.ml
+++ b/cparser/Parse.ml
@@ -24,12 +24,7 @@ let transform_program t p name =
   (run_pass Unblock.program 'b'
   (run_pass Bitfields.program 'f'
   p)))) in
-  let debug = 
-    if !Clflags.option_g && Configuration.advanced_debug then
-      Some (CtoDwarf.program_to_dwarf p p1 name)
-    else
-      None in
-  (Rename.program p1 (Filename.chop_suffix name ".c")),debug
+  (Rename.program p1 (Filename.chop_suffix name ".c"))
 
 let parse_transformations s =
   let t = ref CharSet.empty in
@@ -46,15 +41,19 @@ let parse_transformations s =
 let preprocessed_file transfs name sourcefile =
   Cerrors.reset();
   let ic = open_in sourcefile in
-  let p,d =
+  let p =
     try
       let t = parse_transformations transfs in
-      let lb = Lexer.init name ic in
       let rec inf = Datatypes.S inf in
       let ast : Cabs.definition list =
         Obj.magic
-          (match Timing.time2 "Parsing"
-                 Parser.translation_unit_file inf (Lexer.tokens_stream lb) with
+          (match Timing.time "Parsing"
+              (* The call to Lexer.tokens_stream results in the pre
+                 parsing of the entire file. This is non-negligeabe,
+                 so we cannot use Timing.time2 *)
+              (fun () ->
+                Parser.translation_unit_file inf (Lexer.tokens_stream name ic)) ()
+           with
              | Parser.Parser.Inter.Fail_pr ->
                  (* Theoretically impossible : implies inconsistencies
                     between grammars. *)
@@ -65,6 +64,6 @@ let preprocessed_file transfs name sourcefile =
       Timing.time2 "Emulations" transform_program t p1 name
     with
     | Cerrors.Abort ->
-        [],None in
+        [] in
   close_in ic;
-  if Cerrors.check_errors() then None,None else Some p,d
+  if Cerrors.check_errors() then None else Some p
diff --git a/cparser/Parse.mli b/cparser/Parse.mli
index ac8feb70..58c3cfb9 100644
--- a/cparser/Parse.mli
+++ b/cparser/Parse.mli
@@ -15,7 +15,7 @@
 
 (* Entry point for the library: parse, elaborate, and transform *)
 
-val preprocessed_file: string -> string -> string -> C.program option * DwarfTypes.dw_entry option
+val preprocessed_file: string -> string -> string -> C.program option
 
 (* first arg: desired transformations
    second arg: source file name before preprocessing
diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml
index 91f50552..c6646b5c 100644
--- a/cparser/Unblock.ml
+++ b/cparser/Unblock.ml
@@ -177,16 +177,89 @@ and expand_init islocal env i =
   in
     expand i
 
+(* Insertion of debug annotation, for -g mode *)
+
+let debug_id = Env.fresh_ident "__builtin_debug"
+let debug_ty =
+  TFun(TVoid [], Some [Env.fresh_ident "kind", TInt(IInt, [])], true, [])
+
+let debug_annot kind args =
+  { sloc = no_loc;
+    sdesc = Sdo { 
+      etyp = TVoid [];
+      edesc = ECall({edesc = EVar debug_id; etyp = debug_ty},
+                    intconst kind IInt :: args)
+    }
+  }
+
+let string_const str =
+  let c = CStr str in { edesc = EConst c; etyp = type_of_constant c }
+
+let integer_const n =
+  intconst (Int64.of_int n) IInt
+
+(* Line number annotation:
+      __builtin_debug(1, "#line:filename:lineno") *)
+(* TODO: consider
+      __builtin_debug(1, "filename", lineno)
+   instead. *)
+
+let debug_lineno (filename, lineno) =
+  debug_annot 1L
+    [string_const (Printf.sprintf "#line:%s:%d" filename lineno)]
+
+(* Scope annotation:
+      __builtin_debug(6, "", scope1, scope2, ..., scopeN)
+*)
+
+let empty_string = string_const ""
+
+let curr_fun_id = ref 0
+
+let debug_var_decl ctx id =
+  Debug.add_lvar_scope !curr_fun_id id (List.hd ctx)
+
+let debug_scope ctx =
+  debug_annot 6L (empty_string :: List.rev_map integer_const ctx)
+
+(* Add line number debug annotation if the line number changes.
+   Add scope debug annotation regardless. *)
+
+
+let add_lineno ctx prev_loc this_loc s =
+  if !Clflags.option_g then
+    sseq no_loc (debug_scope ctx)
+      (if this_loc <> prev_loc && this_loc <> no_loc
+       then sseq no_loc (debug_lineno this_loc) s
+       else s)
+  else s
+
+(* Generate fresh scope identifiers, for blocks that contain at least
+   one declaration *)
+
+let block_contains_decl sl =
+  List.exists
+    (function {sdesc = Sdecl _} -> true | _ -> false)
+    sl
+
+let next_scope_id = ref 0
+
+let new_scope_id () =
+  incr next_scope_id; !next_scope_id
+
 (* Process a block-scoped variable declaration.
    The variable is entered in [local_variables].
    The initializer, if any, is converted into assignments and
    prepended to [k]. *)
 
-let process_decl loc env (sto, id, ty, optinit) k =
+let process_decl loc env ctx (sto, id, ty, optinit) k =
   let ty' = remove_const env ty in
   local_variables := (sto, id, ty', None) :: !local_variables;
+  debug_var_decl ctx id;
+  (* TODO: register the fact that id is declared in scope ctx *)
   match optinit with
-  | None -> k
+  | None ->
+      k
   | Some init ->
       let init' = expand_init true env init in
       let l = local_initializer env { edesc = EVar id; etyp = ty' } init' [] in
@@ -194,57 +267,90 @@ let process_decl loc env (sto, id, ty, optinit) k =
 
 (* Simplification of blocks within a statement *)
 
-let rec unblock_stmt env s =
+let rec unblock_stmt env ctx ploc s =
   match s.sdesc with
   | Sskip -> s
   | Sdo e ->
-      {s with sdesc = Sdo(expand_expr true env e)}
+      add_lineno ctx ploc s.sloc
+        {s with sdesc = Sdo(expand_expr true env e)}
   | Sseq(s1, s2) ->
-      {s with sdesc = Sseq(unblock_stmt env s1, unblock_stmt env s2)}
+      {s with sdesc = Sseq(unblock_stmt env ctx ploc s1,
+                           unblock_stmt env ctx s1.sloc s2)}
   | Sif(e, s1, s2) -> 
-      {s with sdesc = Sif(expand_expr true env e,
-                          unblock_stmt env s1, unblock_stmt env s2)}
+      add_lineno ctx ploc s.sloc
+        {s with sdesc = Sif(expand_expr true env e,
+                            unblock_stmt env ctx s.sloc s1,
+                            unblock_stmt env ctx s.sloc s2)}
   | Swhile(e, s1) -> 
-      {s with sdesc = Swhile(expand_expr true env e, unblock_stmt env s1)}
+      add_lineno ctx ploc s.sloc
+        {s with sdesc = Swhile(expand_expr true env e,
+                               unblock_stmt env ctx s.sloc s1)}
   | Sdowhile(s1, e) ->
-      {s with sdesc = Sdowhile(unblock_stmt env s1, expand_expr true env e)}
+      add_lineno ctx ploc s.sloc
+        {s with sdesc = Sdowhile(unblock_stmt env ctx s.sloc s1,
+                                 expand_expr true env e)}
   | Sfor(s1, e, s2, s3) ->
-      {s with sdesc = Sfor(unblock_stmt env s1,
-                           expand_expr true env e,
-                           unblock_stmt env s2,
-                           unblock_stmt env s3)}
+      add_lineno ctx ploc s.sloc
+        {s with sdesc = Sfor(unblock_stmt env ctx s.sloc s1,
+                             expand_expr true env e,
+                             unblock_stmt env ctx s.sloc s2,
+                             unblock_stmt env ctx s.sloc s3)}
   | Sbreak -> s
   | Scontinue -> s
   | Sswitch(e, s1) ->
-      {s with sdesc = Sswitch(expand_expr true env e, unblock_stmt env s1)}
+      add_lineno ctx ploc s.sloc
+        {s with sdesc = Sswitch(expand_expr true env e,
+                                unblock_stmt env ctx s.sloc s1)}
   | Slabeled(lbl, s1) -> 
-      {s with sdesc = Slabeled(lbl, unblock_stmt env s1)}
-  | Sgoto lbl -> s
-  | Sreturn None -> s
+      add_lineno ctx ploc s.sloc
+        {s with sdesc = Slabeled(lbl, unblock_stmt env ctx s.sloc s1)}
+  | Sgoto lbl ->
+      add_lineno ctx ploc s.sloc s
+  | Sreturn None ->
+      add_lineno ctx ploc s.sloc s
   | Sreturn (Some e) ->
-      {s with sdesc = Sreturn(Some (expand_expr true env e))}
-  | Sblock sl -> unblock_block env sl
-  | Sdecl d -> assert false
+      add_lineno ctx ploc s.sloc 
+        {s with sdesc = Sreturn(Some (expand_expr true env e))}
+  | Sblock sl ->
+      let ctx' =
+        if block_contains_decl sl
+        then
+          let id = new_scope_id () in
+          (match ctx with
+          | [] -> Debug.enter_function_scope !curr_fun_id id
+          | a::_ -> Debug.enter_scope !curr_fun_id a id);
+          id:: ctx
+        else ctx in
+      unblock_block env ctx' ploc sl
+  | Sdecl d ->
+      assert false
   | Sasm(attr, template, outputs, inputs, clob) ->
       let expand_asm_operand (lbl, cstr, e) =
         (lbl, cstr, expand_expr true env e) in
-      {s with sdesc = Sasm(attr, template,
-                           List.map expand_asm_operand outputs,
-                           List.map expand_asm_operand inputs, clob)}
+      add_lineno ctx ploc s.sloc 
+        {s with sdesc = Sasm(attr, template,
+                             List.map expand_asm_operand outputs,
+                             List.map expand_asm_operand inputs, clob)}
 
 
-and unblock_block env = function
+and unblock_block env ctx ploc = function
   | [] -> sskip
   | {sdesc = Sdecl d; sloc = loc} :: sl ->
-      process_decl loc env d (unblock_block env sl)
+      add_lineno ctx ploc loc
+        (process_decl loc env ctx d
+           (unblock_block env ctx loc sl))
   | s :: sl ->
-      sseq s.sloc (unblock_stmt env s) (unblock_block env sl)
+      sseq s.sloc (unblock_stmt env ctx ploc s)
+                  (unblock_block env ctx s.sloc sl)
 
 (* Simplification of blocks and compound literals within a function *)
 
 let unblock_fundef env f =
   local_variables := [];
-  let body = unblock_stmt env f.fd_body in
+  next_scope_id := 0;
+  curr_fun_id:= f.fd_name.stamp;
+  (* TODO: register the parameters as being declared in function scope *)
+  let body = unblock_stmt env [] no_loc f.fd_body in
   let decls = !local_variables in
   local_variables := [];
   { f with fd_locals = f.fd_locals @ decls; fd_body = body }
@@ -299,4 +405,5 @@ let rec unblock_glob env accu = function
 (* Entry point *)
 
 let program p =
+  {gloc = no_loc; gdesc = Gdecl(Storage_extern, debug_id, debug_ty, None)} ::
   unblock_glob (Builtins.environment()) [] p
diff --git a/cparser/pre_parser.mly b/cparser/pre_parser.mly
index 44a06f8a..e73cc22a 100644
--- a/cparser/pre_parser.mly
+++ b/cparser/pre_parser.mly
@@ -57,9 +57,14 @@
 
 (* These precedences declarations solve the conflict in the following declaration :
 
-int f(int (a));
+   int f(int (a));
 
-when a is a TYPEDEF_NAME. It is specified by 6.7.5.3 11.
+   when a is a TYPEDEF_NAME. It is specified by 6.7.5.3 11.
+
+   WARNING: These precedence declarations tend to silently solve other
+   conflicts. So, if you change the grammar (especially or
+   statements), you should check that without these declarations, it
+   has ONLY ONE CONFLICT.
 *)
 %nonassoc TYPEDEF_NAME
 %nonassoc highPrec
@@ -89,25 +94,30 @@ string_literals_list:
 | string_literals_list STRING_LITERAL
     {}
 
-(* WARNING : because of the lookahead token, the context might
-   be pushed or popped one token after the position of this
-   non-terminal !
+(* WARNING : because of the lookahead token, the context might be
+   opened or closed one token after the position of this non-terminal !
 
-   Pushing too late is not dangerous for us, because this does not
+   Opening too late is not dangerous for us, because this does not
    change the token stream. However, we have to make sure the
-   lookahead token present just after popping is not an identifier.
- *)
+   lookahead token present just after closing/declaring/restoring is
+   not an identifier. An easy way to check that is to look at the
+   follow set of the non-terminal in question. The follow sets are
+   given by menhir with option -lg 3. *)
+
+%inline nop: (* empty *) { }
 
-push_context:
-  (* empty *)%prec highPrec { !push_context () }
-pop_context:
-  (* empty *) { !pop_context () }
+open_context:
+  (* empty *)%prec highPrec { !open_context () }
+close_context:
+  (* empty *) { !close_context () }
 in_context(nt):
-  push_context x = nt pop_context { x }
+  open_context x = nt close_context { x }
+
+save_contexts_stk:
+  (* empty *) { !save_contexts_stk () }
 
 declare_varname(nt):
   i = nt { declare_varname i; i }
-
 declare_typename(nt):
   i = nt { declare_typename i; i }
 
@@ -267,39 +277,20 @@ constant_expression:
 | conditional_expression
     {}
 
+(* We separate two kinds of declarations: the typedef declaration and
+   the normal declarations. This makes possible to distinguish /in the
+   grammar/ whether a declaration should add a typename or a varname
+   in the context.  There is an other difference between
+   [init_declarator_list] and [typedef_declarator_list]: the later
+   cannot contain an initialization (this is an error to initialize a
+   typedef). *)
+
 declaration:
 | declaration_specifiers init_declarator_list? SEMICOLON
     {}
 | declaration_specifiers_typedef typedef_declarator_list? SEMICOLON
     {}
 
-declaration_specifiers_no_type:
-| storage_class_specifier_no_typedef declaration_specifiers_no_type?
-| type_qualifier declaration_specifiers_no_type?
-| function_specifier declaration_specifiers_no_type?
-    {}
-
-declaration_specifiers_no_typedef_name:
-| storage_class_specifier_no_typedef declaration_specifiers_no_typedef_name?
-| type_qualifier declaration_specifiers_no_typedef_name?
-| function_specifier declaration_specifiers_no_typedef_name?
-| type_specifier_no_typedef_name declaration_specifiers_no_typedef_name?
-    {}
-
-declaration_specifiers:
-| declaration_specifiers_no_type? i = TYPEDEF_NAME declaration_specifiers_no_type?
-    { set_id_type i TypedefId }
-| declaration_specifiers_no_type? type_specifier_no_typedef_name declaration_specifiers_no_typedef_name?
-    {}
-
-declaration_specifiers_typedef:
-| declaration_specifiers_no_type? TYPEDEF declaration_specifiers_no_type? i = TYPEDEF_NAME declaration_specifiers_no_type?
-| declaration_specifiers_no_type? i = TYPEDEF_NAME declaration_specifiers_no_type? TYPEDEF declaration_specifiers_no_type?
-    { set_id_type i TypedefId }
-| declaration_specifiers_no_type? TYPEDEF declaration_specifiers_no_type? type_specifier_no_typedef_name declaration_specifiers_no_typedef_name?
-| declaration_specifiers_no_type? type_specifier_no_typedef_name declaration_specifiers_no_typedef_name? TYPEDEF declaration_specifiers_no_typedef_name?
-    {}
-
 init_declarator_list:
 | init_declarator
 | init_declarator_list COMMA init_declarator
@@ -326,6 +317,67 @@ storage_class_specifier_no_typedef:
 | REGISTER
     {}
 
+(* [declaration_specifiers_no_type] matches declaration specifiers
+   that do not contain either "typedef" nor type specifiers. *)
+declaration_specifiers_no_type:
+| storage_class_specifier_no_typedef declaration_specifiers_no_type?
+| type_qualifier declaration_specifiers_no_type?
+| function_specifier declaration_specifiers_no_type?
+    {}
+
+(* [declaration_specifiers_no_typedef_name] matches declaration
+   specifiers that contain neither "typedef" nor a typedef name
+   (i.e. type specifier declared using a previous "typedef
+   keyword"). *)
+declaration_specifiers_no_typedef_name:
+| storage_class_specifier_no_typedef declaration_specifiers_no_typedef_name?
+| type_qualifier declaration_specifiers_no_typedef_name?
+| function_specifier declaration_specifiers_no_typedef_name?
+| type_specifier_no_typedef_name declaration_specifiers_no_typedef_name?
+    {}
+
+(* [declaration_specifiers_no_type] matches declaration_specifiers
+   that do not contains "typedef". Moreover, it makes sure that it
+   contains either one typename and not other type specifier or no
+   typename.
+
+   This is a weaker condition than 6.7.2 2. It is necessary to enforce
+   this in the grammar to disambiguate the example in 6.7.7 6:
+
+   typedef signed int t;
+   struct tag {
+     unsigned t:4;
+     const t:5;
+   };
+
+   The first field is a named t, while the second is unnamed of type t.
+*)
+declaration_specifiers:
+| declaration_specifiers_no_type? i = TYPEDEF_NAME declaration_specifiers_no_type?
+    { set_id_type i TypedefId }
+| declaration_specifiers_no_type? type_specifier_no_typedef_name declaration_specifiers_no_typedef_name?
+    {}
+
+(* This matches declaration_specifiers that do contains once the
+   "typedef" keyword. To avoid conflicts, we also encode the
+   constraint described in the comment for [declaration_specifiers]. *)
+declaration_specifiers_typedef:
+| declaration_specifiers_no_type?
+  TYPEDEF declaration_specifiers_no_type?
+  i = TYPEDEF_NAME declaration_specifiers_no_type?
+| declaration_specifiers_no_type?
+  i = TYPEDEF_NAME declaration_specifiers_no_type?
+  TYPEDEF declaration_specifiers_no_type?
+    { set_id_type i TypedefId }
+| declaration_specifiers_no_type?
+  TYPEDEF declaration_specifiers_no_type?
+  type_specifier_no_typedef_name declaration_specifiers_no_typedef_name?
+| declaration_specifiers_no_type?
+  type_specifier_no_typedef_name declaration_specifiers_no_typedef_name?
+  TYPEDEF declaration_specifiers_no_typedef_name?
+    {}
+
+(* A type specifier which is not a typedef name. *)
 type_specifier_no_typedef_name:
 | VOID
 | CHAR
@@ -366,6 +418,8 @@ struct_declaration:
 | specifier_qualifier_list struct_declarator_list? SEMICOLON
     {}
 
+(* As in the standard, except it also encodes the constraint described
+   in the comment above [declaration_specifiers]. *)
 specifier_qualifier_list:
 | type_qualifier_list? i = TYPEDEF_NAME type_qualifier_list?
     { set_id_type i TypedefId }
@@ -460,6 +514,10 @@ function_specifier:
 | INLINE
     {}
 
+(* The semantic action returned by [declarator] is a pair of the
+   identifier being defined and an option of the context stack that
+   has to be restored if entering the body of the function being
+   defined, if so. *)
 declarator:
 | pointer? x = direct_declarator attribute_specifier_list
     { x }
@@ -470,9 +528,11 @@ direct_declarator:
 | LPAREN x = declarator RPAREN
 | x = direct_declarator LBRACK type_qualifier_list? assignment_expression? RBRACK
     { x }
-| x = direct_declarator LPAREN l=in_context(parameter_type_list?) RPAREN
+| x = direct_declarator LPAREN
+    open_context parameter_type_list? restore_fun = save_contexts_stk
+    close_context RPAREN
     { match snd x with
-      | None -> (fst x, Some (match l with None -> [] | Some l -> l))
+      | None -> (fst x, Some restore_fun)
       | Some _ -> x }
 
 pointer:
@@ -542,26 +602,51 @@ designator:
 | DOT i = general_identifier
     { set_id_type i OtherId }
 
-statement_finish:
-| labeled_statement(statement_finish)
-| compound_statement
-| expression_statement
-| selection_statement_finish
-| iteration_statement(statement_finish)
-| jump_statement
-| asm_statement
-    {}
+(* The grammar of statements is replicated three times.
 
-statement_intern:
-| labeled_statement(statement_intern)
-| compound_statement
-| expression_statement
-| selection_statement_intern
-| iteration_statement(statement_intern)
-| jump_statement
-| asm_statement
-    {}
+   [statement_finish_close] should close the current context just
+   before its last token.
 
+   [statement_finish_noclose] should not close the current context. It
+   should modify it only if this modification actually changes the
+   context of the current block.
+
+   [statement_intern_close] is like [statement_finish_close], except
+   it cannot reduce to a single-branch if statement.
+*)
+
+statement_finish_close:
+| labeled_statement(statement_finish_close)
+| compound_statement(nop)
+| expression_statement(close_context)
+| selection_statement_finish(nop)
+| iteration_statement(nop,statement_finish_close)
+| jump_statement(close_context)
+| asm_statement(close_context)
+    {}
+
+statement_finish_noclose:
+| labeled_statement(statement_finish_noclose)
+| compound_statement(open_context)
+| expression_statement(nop)
+| selection_statement_finish(open_context)
+| iteration_statement(open_context,statement_finish_close)
+| jump_statement(nop)
+| asm_statement(nop)
+    {}
+
+statement_intern_close:
+| labeled_statement(statement_intern_close)
+| compound_statement(nop)
+| expression_statement(close_context)
+| selection_statement_intern_close
+| iteration_statement(nop,statement_intern_close)
+| jump_statement(close_context)
+| asm_statement(close_context)
+    {}
+
+(* [labeled_statement(last_statement)] has the same effect on contexts
+   as [last_statement]. *)
 labeled_statement(last_statement):
 | i = general_identifier COLON last_statement
     { set_id_type i OtherId }
@@ -569,10 +654,14 @@ labeled_statement(last_statement):
 | DEFAULT COLON last_statement
     {}
 
-compound_statement:
-| LBRACE in_context(block_item_list?) RBRACE
+(* [compound_statement] uses a local context and closes it before its
+   last token. It uses [openc] to open this local context if needed.
+   That is, if a local context has already been opened, [openc] = [nop],
+   otherwise, [openc] = [open_context]. *)
+compound_statement(openc):
+| LBRACE openc block_item_list? close_context RBRACE
     {}
-| LBRACE in_context(block_item_list?) error
+| LBRACE openc block_item_list? close_context error
     { unclosed "{" "}" $startpos($1) $endpos }
 
 block_item_list:
@@ -581,47 +670,99 @@ block_item_list:
 
 block_item:
 | declaration
-| statement_finish
+| statement_finish_noclose
 | PRAGMA
     {}
 
-expression_statement:
-| expression? SEMICOLON
+(* [expression_statement], [jump_statement] and [asm_statement] close
+   the local context if needed, depending of the close parameter. If
+   there is no local context, [close] = [nop]. Otherwise,
+   [close] = [close_context]. *)
+expression_statement(close):
+| expression? close SEMICOLON
     {}
 
-selection_statement_finish:
-| IF LPAREN expression RPAREN statement_finish
-| IF LPAREN expression RPAREN statement_intern ELSE statement_finish
-| SWITCH LPAREN expression RPAREN statement_finish
+jump_statement(close):
+| GOTO i = general_identifier close SEMICOLON
+    { set_id_type i OtherId }
+| CONTINUE close SEMICOLON
+| BREAK close SEMICOLON
+| RETURN expression? close SEMICOLON
     {}
 
-selection_statement_intern:
-| IF LPAREN expression RPAREN statement_intern ELSE statement_intern
-| SWITCH LPAREN expression RPAREN statement_intern
+asm_statement(close):
+| ASM asm_attributes LPAREN string_literals_list asm_arguments RPAREN close SEMICOLON
     {}
 
-iteration_statement(stmt):
-| WHILE LPAREN expression RPAREN stmt
-| DO statement_finish WHILE LPAREN expression RPAREN SEMICOLON
-| FOR LPAREN expression? SEMICOLON expression? SEMICOLON expression? RPAREN stmt
-| FOR LPAREN push_context declaration expression? SEMICOLON expression? RPAREN stmt pop_context
+(* [selection_statement_finish] and [selection_statement_intern] use a
+   local context and close it before their last token.
+
+   [selection_statement_finish(openc)] uses [openc] to open this local
+   context if needed. That is, if a local context has already been
+   opened, [openc] = [nop], otherwise, [openc] = [open_context].
+
+   [selection_statement_intern_close] is always called with a local
+   context openned. It closes it before its last token.  *)
+
+(* It should be noted that the token [ELSE] should be lookaheaded
+   /outside/ of the local context because if the lookaheaded token is
+   not [ELSE], then this is the end of the statement.
+
+   This is especially important to parse correctly the following
+   example:
+
+     typedef int a;
+
+     int f() {
+       for(int a; ;)
+         if(1);
+       a * x;
+     }
+
+   However, if the lookahead token is [ELSE], we should parse the
+   second branch in the same context as the first branch, so we have
+   to reopen the previously closed context. This is the reason for the
+   save/restore system.
+*)
+
+if_else_statement_begin(openc):
+| IF openc LPAREN expression RPAREN restore_fun = save_contexts_stk
+  statement_intern_close
+    { restore_fun () }
+
+selection_statement_finish(openc):
+| IF openc LPAREN expression RPAREN save_contexts_stk statement_finish_close
+| if_else_statement_begin(openc) ELSE statement_finish_close
+| SWITCH openc LPAREN expression RPAREN statement_finish_close
     {}
 
-jump_statement:
-| GOTO i = general_identifier SEMICOLON
-    { set_id_type i OtherId }
-| CONTINUE SEMICOLON
-| BREAK SEMICOLON
-| RETURN expression? SEMICOLON
+selection_statement_intern_close:
+| if_else_statement_begin(nop) ELSE statement_intern_close
+| SWITCH LPAREN expression RPAREN statement_intern_close
     {}
 
-asm_statement:
-| ASM asm_attributes LPAREN string_literals_list asm_arguments RPAREN SEMICOLON
+(* [iteration_statement] uses a local context and closes it before
+   their last token.
+
+   [iteration_statement] uses [openc] to open this local context if
+   needed. That is, if a local context has already been opened,
+   [openc] = [nop], otherwise, [openc] = [open_context].
+
+   [last_statement] is either [statement_intern_close] or
+   [statement_finish_close]. That is, it should /always/ close the
+   local context. *)
+
+iteration_statement(openc,last_statement):
+| WHILE openc LPAREN expression RPAREN last_statement
+| DO open_context statement_finish_close WHILE
+    openc LPAREN expression RPAREN close_context SEMICOLON
+| FOR openc LPAREN expression? SEMICOLON expression? SEMICOLON expression? RPAREN last_statement
+| FOR openc LPAREN declaration expression? SEMICOLON expression? RPAREN last_statement
     {}
 
 asm_attributes:
 | /* empty */
-| CONST asm_attributes    
+| CONST asm_attributes
 | VOLATILE asm_attributes
     {}
 
@@ -679,22 +820,14 @@ function_definition_begin:
 | declaration_specifiers pointer? x=direct_declarator
     { match x with
       | (_, None) -> $syntaxerror
-      | (i, Some l) ->
-	declare_varname i;
-	!push_context ();
-	List.iter (fun x ->
-	  match x with
-	    | None -> ()
-	    | Some i -> declare_varname i
-	  ) l
+      | (i, Some restore_fun) -> restore_fun ()
     }
-| declaration_specifiers pointer? x=direct_declarator 
-  LPAREN params=identifier_list RPAREN in_context(declaration_list)
+| declaration_specifiers pointer? x=direct_declarator
+  LPAREN params=identifier_list RPAREN open_context declaration_list
     { match x with
       | (_, Some _) -> $syntaxerror
       | (i, None) ->
 	declare_varname i;
-	!push_context ();
 	List.iter declare_varname params
     }
 
@@ -711,8 +844,7 @@ declaration_list:
     { }
 
 function_definition:
-| function_definition_begin LBRACE block_item_list? pop_context RBRACE
+| function_definition_begin LBRACE block_item_list? close_context RBRACE
     { }
-| function_definition_begin LBRACE block_item_list? pop_context error
+| function_definition_begin LBRACE block_item_list? close_context error
     { unclosed "{" "}" $startpos($2) $endpos }
-
diff --git a/cparser/pre_parser_aux.ml b/cparser/pre_parser_aux.ml
index 55dfdfde..c6b48608 100644
--- a/cparser/pre_parser_aux.ml
+++ b/cparser/pre_parser_aux.ml
@@ -18,8 +18,20 @@ type identifier_type =
   | TypedefId
   | OtherId
 
-let push_context:(unit -> unit) ref= ref (fun () -> assert false)
-let pop_context:(unit -> unit) ref = ref (fun () -> assert false)
+(* These functions push and pop a context on the contexts stack. *)
+let open_context:(unit -> unit) ref = ref (fun () -> assert false)
+let close_context:(unit -> unit) ref = ref (fun () -> assert false)
 
+(* Applying once this functions saves the whole contexts stack, and
+   applying it the second time restores it.
+
+   This is mainly used to rollback the context stack to a previous
+   state. This is usefull for example when we pop too much contexts at
+   the end of the first branch of an if statement. See
+   pre_parser.mly. *)
+let save_contexts_stk:(unit -> (unit -> unit)) ref = ref (fun _ -> assert false)
+
+(* Change the context at the top of the top stack of context, by
+   changing an identifier to be a varname or a typename*)
 let declare_varname:(string -> unit) ref = ref (fun _ -> assert false)
 let declare_typename:(string -> unit) ref = ref (fun _ -> assert false)
diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml
deleted file mode 100644
index c2085eb0..00000000
--- a/debug/CtoDwarf.ml
+++ /dev/null
@@ -1,543 +0,0 @@
-(* *********************************************************************)
-(*                                                                     *)
-(*              The Compcert verified compiler                         *)
-(*                                                                     *)
-(*          Bernhard Schommer, AbsInt Angewandte Informatik GmbH       *)
-(*                                                                     *)
-(*  AbsInt Angewandte Informatik GmbH. All rights reserved. This file  *)
-(*  is distributed under the terms of the INRIA Non-Commercial         *)
-(*  License Agreement.                                                 *)
-(*                                                                     *)
-(* *********************************************************************)
-
-open Builtins
-open C
-open Cprint
-open Cutil
-open C2C
-open DwarfTypes
-open DwarfUtil
-open Env
-open Set
-
-(* Functions to translate a C Ast into Dwarf 2 debugging information *)
-
-
-(* Hashtable from type name to entry id *)
-let type_table: (string, int) Hashtbl.t = Hashtbl.create 7
-
-(* Hashtable for typedefname to entry id *)
-let typedef_table: (string, int) Hashtbl.t = Hashtbl.create 7
-
-(* Hashtable from composite table to entry id *)
-let composite_types_table: (int, int) Hashtbl.t = Hashtbl.create 7
-
-(* Hashtable from id of a defined composite types to minimal type info *)
-let composite_declarations: (int, (struct_or_union * string * location)) Hashtbl.t = Hashtbl.create 7
-
-module IntSet = Set.Make(struct type t = int let compare = compare end)
-
-(* Set of all declared composite_types *)
-let composite_defined: IntSet.t ref = ref IntSet.empty
-
-(* Get the type id of a composite_type *)
-let get_composite_type (name: int): int =
-  try 
-    Hashtbl.find composite_types_table name
-  with Not_found ->
-    let id = next_id () in
-    Hashtbl.add composite_types_table name id;
-    id
-
-(* Translate a C.typ to a string needed for hashing *)
-let typ_to_string (ty: typ) =
-  let buf = Buffer.create 7 in
-  let chan = Format.formatter_of_buffer buf in
-  typ chan ty;
-  Format.pp_print_flush chan ();
-  Buffer.contents buf
-
-let rec mmap f env = function
-  | [] -> ([],env)
-  | hd :: tl ->
-      let (hd',env1) = f env hd in
-      let (tl', env2) = mmap f env1 tl in
-      (hd' :: tl', env2)
-
-
-(* Helper functions for the attributes *)
-
-let strip_attributes typ =
-  let strip = List.filter (fun a -> a = AConst || a = AVolatile) in 
-  match typ with
-  | TVoid at -> TVoid (strip at)
-  | TInt (k,at) ->  TInt (k,strip at)
-  | TFloat (k,at) -> TFloat(k,strip at)
-  | TPtr (t,at) -> TPtr(t,strip at)
-  | TArray (t,s,at) -> TArray(t,s,strip at)
-  | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at)
-  | TNamed (n,at) -> TNamed(n,strip at)
-  | TStruct (n,at) -> TStruct(n,strip at)
-  | TUnion (n,at) -> TUnion(n,strip at)
-  | TEnum (n,at) -> TEnum(n,strip at)
-  
-
-let strip_last_attribute typ  = 
-  let rec hd_opt l = match l with
-    [] -> None,[]
-  | AConst::rest -> Some AConst,rest
-  | AVolatile::rest -> Some AVolatile,rest 
-  | _::rest -> hd_opt rest in
-  match typ with
-  | TVoid at -> let l,r = hd_opt at in
-    l,TVoid r
-  | TInt (k,at) -> let l,r = hd_opt at in
-    l,TInt (k,r)
-  | TFloat (k,at) -> let l,r = hd_opt at in
-    l,TFloat (k,r)
-  | TPtr (t,at) -> let l,r = hd_opt at in
-    l,TPtr(t,r)
-  | TArray (t,s,at) -> let l,r = hd_opt at in
-    l,TArray(t,s,r)
-  | TFun (t,arg,v,at) -> let l,r = hd_opt at in
-    l,TFun(t,arg,v,r)
-  | TNamed (n,at) -> let l,r = hd_opt at in
-    l,TNamed(n,r)
-  | TStruct (n,at) -> let l,r = hd_opt at in
-    l,TStruct(n,r)
-  | TUnion (n,at) -> let l,r = hd_opt at in
-    l,TUnion(n,r)
-  | TEnum (n,at) -> let l,r = hd_opt at in
-    l,TEnum(n,r)
-
-(*  Dwarf tag for the void type*)
-let rec void_dwarf_tag =
-  let void = {
-    base_type_byte_size = 0;
-    base_type_encoding = None;
-    base_type_name = "void";
-  } in
-  DW_TAG_base_type void
-
-(* Generate a dwarf tag for the given integer type *)
-and int_to_dwarf_tag k =  
-  let encoding =
-    (match k with
-    | IBool -> DW_ATE_boolean
-    | IChar ->
-        if !Machine.config.Machine.char_signed then 
-          DW_ATE_signed_char 
-        else 
-          DW_ATE_unsigned_char
-    | ILong | ILongLong | IShort | ISChar -> DW_ATE_signed_char
-    | _ -> DW_ATE_unsigned)in
-  let int = {
-    base_type_byte_size = sizeof_ikind k;
-    base_type_encoding = Some encoding;
-    base_type_name = typ_to_string (TInt (k,[]));} in
-  DW_TAG_base_type int
-
-(* Generate a dwarf tag for the given floating point type *)
-and float_to_dwarf_tag k = 
-  let byte_size = sizeof_fkind k in
-  let float = {
-    base_type_byte_size = byte_size;
-    base_type_encoding = Some DW_ATE_float;
-    base_type_name = typ_to_string (TFloat (k,[]));
-  } in
-  DW_TAG_base_type float
-
-(* Generate a dwarf tag for the given function type *)
-and fun_to_dwarf_tag rt args =
-  let ret,et = (match rt with
-  | TVoid _ -> None,[]
-  | _ -> let ret,et = type_to_dwarf rt in
-                Some ret,et) in
-  let prototyped,children,others =
-    (match args with 
-    | None -> 
-        let u = {
-          unspecified_parameter_file_loc = None;
-          unspecified_parameter_artificial = None;
-        } in
-        let u = new_entry (DW_TAG_unspecified_parameter u) in 
-        false,[u],[]
-    | Some [] -> true,[],[]
-    | Some l ->
-        let c,e = mmap (fun acc (_,t) ->
-          let t,e = type_to_dwarf t in
-          let fp =
-            {
-             formal_parameter_file_loc = None;
-             formal_parameter_artificial = None;
-             formal_parameter_location = None;
-             formal_parameter_name = None;
-             formal_parameter_segment = None;
-             formal_parameter_type = t;
-             formal_parameter_variable_parameter = None;
-           } in
-          let entry = new_entry (DW_TAG_formal_parameter fp) in
-          entry,(e@acc)) [] l in
-        true,c,e) in
-  let s = {
-    subroutine_type = ret;
-    subroutine_prototyped = prototyped;
-  } in
-  let s = new_entry (DW_TAG_subroutine_type s) in
-  let s = add_children s children in
-  s.id,((s::others)@et)
-
-(* Generate a dwarf tag for the given array type *)
-and array_to_dwarf_tag child size =
-  let append_opt a b =
-    match a with
-    | None -> b
-    | Some a -> a::b in
-  let size_to_subrange s =
-    match s with 
-    | None -> None
-    | Some i ->
-        let i = Int64.to_int (Int64.sub i Int64.one) in
-        let s =
-          {
-           subrange_type = None;
-           subrange_upper_bound = Some (BoundConst i);
-         } in
-        Some (new_entry (DW_TAG_subrange_type s)) in 
-  let rec aux t = 
-    (match t with
-    | TArray (child,size,_) ->
-        let sub = size_to_subrange size in
-        let t,c,e = aux child in
-        t,append_opt sub c,e
-    | _ -> let t,e = type_to_dwarf t in
-      t,[],e) in
-  let t,children,e = aux child in
-  let sub = size_to_subrange size in
-  let children = List.rev (append_opt sub children) in
-  let arr = {
-    array_type_file_loc = None;
-    array_type = t;
-  } in
-  let arr = new_entry (DW_TAG_array_type arr) in
-  let arr = add_children arr children in
-  arr.id,(arr::e)
-
-(* Translate a typ without attributes to a dwarf_tag *)
-and type_to_dwarf_entry typ typ_string=
-   let id,entries = 
-   (match typ with
-   | TVoid _ -> 
-       let e = new_entry void_dwarf_tag in
-       e.id,[e]
-   | TInt (k,_) ->
-       let e = new_entry (int_to_dwarf_tag k) in
-       e.id,[e]
-   | TFloat (k,_) ->
-       let e = new_entry (float_to_dwarf_tag k) in
-       e.id,[e]
-   | TPtr (t,_) ->
-       let t,e = type_to_dwarf t in
-       let pointer = {pointer_type = t;} in
-       let t = new_entry (DW_TAG_pointer_type pointer) in
-       t.id,t::e
-   | TFun (rt,args,_,_) -> fun_to_dwarf_tag rt args
-   | TStruct (i,_)
-   | TUnion (i,_)
-   | TEnum (i,_) ->
-       let t = get_composite_type i.stamp in
-       t,[]
-   | TNamed (i,at) ->
-       let t = Hashtbl.find typedef_table i.name in
-       t,[]
-   | TArray (child,size,_) -> array_to_dwarf_tag child size)         
-   in
-   Hashtbl.add type_table typ_string id;
-   id,entries
-
-(* Tranlate type with attributes to their corresponding dwarf represenation *)
-and attr_type_to_dwarf typ typ_string =
-  let l,t = strip_last_attribute typ in
-  match l with
-  | Some AConst -> let id,t = type_to_dwarf t in
-    let const_tag = DW_TAG_const_type ({const_type = id;}) in
-    let const_entry = new_entry const_tag in
-    let id = const_entry.id in
-    Hashtbl.add type_table typ_string id;
-    id,const_entry::t
-  | Some AVolatile -> let id,t = type_to_dwarf t in 
-    let volatile_tag = DW_TAG_volatile_type ({volatile_type = id;}) in
-    let volatile_entry = new_entry volatile_tag in
-    let id = volatile_entry.id in
-    Hashtbl.add type_table typ_string id;
-    id,volatile_entry::t
-  | Some (ARestrict|AAlignas _| Attr(_,_)) -> type_to_dwarf t (* This should not happen *)
-  | None -> type_to_dwarf_entry typ typ_string
-        
-(* Translate a given type to its dwarf representation *)
-and type_to_dwarf (typ: typ): int * dw_entry list =
-  match typ with
-   | TStruct (i,_)
-   | TUnion (i,_)
-   | TEnum (i,_) ->
-       let t = get_composite_type i.stamp in
-       t,[]
-   | _ -> 
-       let typ = strip_attributes typ in
-       let typ_string = typ_to_string typ in
-       try
-         Hashtbl.find type_table typ_string,[]
-       with Not_found ->
-         attr_type_to_dwarf typ typ_string
-
-(* Translate a typedef to its corresponding dwarf representation *)
-let typedef_to_dwarf gloc (name,t) =
-  let i,t = type_to_dwarf t in
-  let td = {
-    typedef_file_loc = gloc;
-    typedef_name = name;
-    typedef_type = i;
-  } in 
-  let td = new_entry (DW_TAG_typedef td) in
-  Hashtbl.add typedef_table name td.id;
-  td::t     
-
-(* Translate a global var to its corresponding dwarf representation *)
-let glob_var_to_dwarf (s,n,t,_) gloc =
-   let i,t = type_to_dwarf t in
-   let ext = (match s with
-   | Storage_static -> false
-   | _ -> true) in
-   let decl = {
-     variable_file_loc = (Some gloc);
-     variable_declaration = None;
-     variable_external = Some ext;
-     variable_location = None;
-     variable_name = n.name;
-     variable_segment = None;
-     variable_type = i;
-   } in
-   let decl = new_entry (DW_TAG_variable decl) in
-   t,decl
-
-(* Translate a function definition to its corresponding dwarf representation *)
-let fundef_to_dwarf f gloc =
-  let ret,e = (match f.fd_ret with
-  | TVoid _ -> None,[]
-  | _ -> let i,t = type_to_dwarf f.fd_ret in
-    Some i,t) in
-  let ext = (match f.fd_storage with
-  | Storage_static -> false
-  | _ -> true) in
-  let fdef = {
-    subprogram_file_loc = (Some gloc);
-    subprogram_external = Some ext;
-    subprogram_frame_base = None;
-    subprogram_name = f.fd_name.name;
-    subprogram_prototyped = true;
-    subprogram_type = ret;
-  } in
-  let fp,e =  mmap (fun acc (p,t) ->
-    let t,e = type_to_dwarf t in
-    let fp =
-      {
-       formal_parameter_file_loc = None;
-       formal_parameter_artificial = None;
-       formal_parameter_location = None;
-       formal_parameter_name = (Some p.name);
-       formal_parameter_segment = None;
-       formal_parameter_type = t;
-       formal_parameter_variable_parameter = None;
-     } in
-    let entry = new_entry (DW_TAG_formal_parameter fp) in
-    entry,(e@acc)) e f.fd_params in
-  let fdef = new_entry (DW_TAG_subprogram fdef) in
-  let fdef = add_children fdef fp in
-  e,fdef
-
-(* Translate a enum definition to its corresponding dwarf representation *)
-let enum_to_dwarf (n,at,e) gloc =
-  let enumerator_to_dwarf (i,c,_)=
-    let tag =      
-      {
-       enumerator_file_loc = None;
-       enumerator_value = Int64.to_int c;
-       enumerator_name = i.name;
-     } in
-    new_entry (DW_TAG_enumerator tag) in
-  let bs = sizeof_ikind enum_ikind in
-  let enum = {
-    enumeration_file_loc = Some gloc;
-    enumeration_byte_size = bs;
-    enumeration_declaration = None;
-    enumeration_name = if n.name <> "" then Some n.name else None;
-  } in
-  let id = get_composite_type n.stamp in
-  let child = List.map enumerator_to_dwarf e in
-  let enum = 
-    {
-     tag = DW_TAG_enumeration_type enum;
-     children = child;
-     id = id;
-   } in
-  [enum]
-  
-(* Translate a struct definition to its corresponding dwarf representation *)
-let struct_to_dwarf (n,at,m) env gloc =
-  let info = Env.find_struct env n in
-  let tag =DW_TAG_structure_type {
-    structure_file_loc = Some gloc;
-    structure_byte_size = info.ci_sizeof;
-    structure_declaration = None;
-    structure_name = if n.name <> "" then Some n.name else None;
-  } in
-  let id = get_composite_type n.stamp in
-  let rec pack acc bcc l m =
-    match m with
-    | [] -> acc,bcc,[]
-    | m::ms as ml ->
-        (match m.fld_bitfield with
-        | None -> acc,bcc,ml
-        | Some n ->
-            if n = 0 then
-              acc,bcc,ms (* bit width 0 means end of pack *)
-            else if l + n > 8 * !Machine.config.Machine.sizeof_int then
-              acc,bcc,ml (* doesn't fit in current word *)
-            else
-              let t,e = type_to_dwarf m.fld_typ in
-              let um = {
-                member_file_loc = None;
-                member_byte_size = Some !Machine.config.Machine.sizeof_int;
-                member_bit_offset = Some l;
-                member_bit_size = Some n;
-                member_data_member_location = None;
-                member_declaration = None;
-                member_name = if m.fld_name <> "" then Some m.fld_name else None;
-                member_type = t;
-              } in
-              pack ((new_entry (DW_TAG_member um))::acc) (e@bcc) (l + n) ms)
-  and translate acc bcc m =
-    match m with
-      [] -> acc,bcc
-    | m::ms as ml ->
-        (match m.fld_bitfield with
-        | None -> 
-            let t,e = type_to_dwarf m.fld_typ in
-            let um = {
-              member_file_loc = None;
-              member_byte_size = None;
-              member_bit_offset = None;
-              member_bit_size = None;
-              member_data_member_location = None;
-              member_declaration = None;
-              member_name = if m.fld_name <> "" then Some m.fld_name else None;
-              member_type = t;
-            } in
-            translate ((new_entry (DW_TAG_member um))::acc) (e@bcc) ms
-        | Some _ -> let acc,bcc,rest = pack acc bcc 0 ml in 
-          translate acc bcc rest)
-  in
-  let children,e = translate [] []  m in
-  let children,e = List.rev children,e in
-  let sou = {
-    tag = tag;
-    children = children;
-    id = id;} in
-  e@[sou]
-
-(* Translate a union definition to its corresponding dwarf representation *)
-let union_to_dwarf (n,at,m) env gloc = 
-  let info = Env.find_union env n in
-  let tag = DW_TAG_union_type {
-    union_file_loc = Some gloc;
-    union_byte_size = info.ci_sizeof;
-    union_declaration = None;
-    union_name = if n.name <> "" then Some n.name else None;
-  } in
-  let id = get_composite_type n.stamp in
-  let children,e = mmap 
-      (fun  acc f ->
-        let t,e = type_to_dwarf f.fld_typ in
-        let um = {
-          member_file_loc = None;
-          member_byte_size = None;
-          member_bit_offset = None;
-          member_bit_size = None;
-          member_data_member_location = None;
-          member_declaration = None;
-          member_name = if f.fld_name <> "" then Some f.fld_name else None;
-          member_type = t;
-        } in
-        new_entry (DW_TAG_member um),e@acc)[] m in
-  let sou = {
-    tag = tag;
-    children = children;
-    id = id;} in
-  e@[sou]
-
-(* Translate global declarations to there dwarf representation *)
-let globdecl_to_dwarf env (typs,decls) decl =
-  PrintAsmaux.add_file (fst decl.gloc);
-  match decl.gdesc with
-  | Gtypedef (n,t) -> let ret = typedef_to_dwarf (Some decl.gloc) (n.name,t)  in
-    typs@ret,decls
-  | Gdecl d -> let t,d = glob_var_to_dwarf d decl.gloc in
-    typs@t,d::decls
-  | Gfundef f ->   let t,d = fundef_to_dwarf f decl.gloc in
-    typs@t,d::decls
-  | Genumdef (n,at,e) ->
-      composite_defined:= IntSet.add n.stamp !composite_defined;
-      let ret = enum_to_dwarf (n,at,e) decl.gloc in
-      typs@ret,decls
-  | Gcompositedef (Struct,n,at,m) ->
-      composite_defined:= IntSet.add n.stamp !composite_defined;
-      let ret = struct_to_dwarf (n,at,m) env decl.gloc in
-      typs@ret,decls
-  | Gcompositedef (Union,n,at,m) ->
-      composite_defined:= IntSet.add n.stamp !composite_defined;
-      let ret = union_to_dwarf (n,at,m) env decl.gloc in
-      typs@ret,decls
-  | Gcompositedecl (sou,i,_) -> Hashtbl.add composite_declarations i.stamp (sou,i.name,decl.gloc);
-      typs,decls
-  | Gpragma _ -> typs,decls       
-
-let forward_declaration_to_dwarf sou name loc stamp =
-  let id = get_composite_type stamp in
-  let tag = match sou with
-  | Struct ->
-      DW_TAG_structure_type{
-      structure_file_loc = Some loc;
-      structure_byte_size = None;
-      structure_declaration = Some true;
-      structure_name = if name <> "" then Some name else None;
-    } 
-  | Union ->
-      DW_TAG_union_type {
-      union_file_loc = Some loc;
-      union_byte_size = None;
-      union_declaration = Some true;
-      union_name = if name <> "" then Some name else None;
-    } in
-  {tag = tag; children = []; id = id}
-  
-
-(* Compute the dwarf representations of global declarations. The second program argument is the 
-   program after the bitfield and packed struct transformation *)
-let program_to_dwarf prog prog1 name =
-  Hashtbl.reset type_table;
-  Hashtbl.reset composite_types_table;
-  Hashtbl.reset typedef_table;
-  let prog = cleanupGlobals (prog) in
-  let env = translEnv Env.empty prog1 in
-  reset_id ();
-  let typs = List.map (typedef_to_dwarf None) C2C.builtins.typedefs in
-  let typs = List.concat typs in
-  let typs,defs = List.fold_left (globdecl_to_dwarf env) (typs,[]) prog in
-  let typs = Hashtbl.fold (fun i (sou,name,loc) typs -> if not (IntSet.mem i !composite_defined) then
-    (forward_declaration_to_dwarf sou name loc i)::typs else typs) composite_declarations typs in
-  let defs =  typs @ defs in
-  let cp = {
-    compile_unit_name = name;
-  } in
-  let cp = new_entry (DW_TAG_compile_unit cp) in
-  add_children cp defs
diff --git a/debug/Debug.ml b/debug/Debug.ml
new file mode 100644
index 00000000..161ee3ed
--- /dev/null
+++ b/debug/Debug.ml
@@ -0,0 +1,123 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Bernhard Schommer, AbsInt Angewandte Informatik GmbH       *)
+(*                                                                     *)
+(*  AbsInt Angewandte Informatik GmbH. All rights reserved. This file  *)
+(*  is distributed under the terms of the INRIA Non-Commercial         *)
+(*  License Agreement.                                                 *)
+(*                                                                     *)
+(* *********************************************************************)
+
+open AST
+open BinNums
+open C
+open Camlcoq
+open Dwarfgen
+open DwarfTypes
+
+(* Interface for generating and printing debug information *)
+
+(* Record used for stroring references to the actual implementation functions *)
+type implem = 
+    {
+     mutable init: string -> unit;
+     mutable atom_function: ident -> atom -> unit;
+     mutable atom_global_variable: ident -> atom -> unit;
+     mutable set_composite_size: ident -> struct_or_union -> int option -> unit;
+     mutable set_member_offset: ident -> string -> int -> unit;
+     mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit;
+     mutable insert_global_declaration: Env.t -> globdecl -> unit;
+     mutable add_fun_addr: atom -> (int * int) -> unit;
+     mutable generate_debug_info: (atom -> string) -> string -> debug_entries option;
+     mutable all_files_iter: (string -> unit) -> unit;
+     mutable insert_local_declaration:  storage -> ident -> typ -> location -> unit;
+     mutable atom_local_variable: ident -> atom -> unit;
+     mutable enter_scope: int -> int -> int -> unit;
+     mutable enter_function_scope: int -> int -> unit;
+     mutable add_lvar_scope: int -> ident -> int -> unit;
+     mutable open_scope: atom -> int -> positive -> unit;
+     mutable close_scope: atom -> int -> positive -> unit;
+     mutable start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit;
+     mutable end_live_range: (atom * atom) -> positive -> unit;
+     mutable stack_variable: (atom * atom) -> int * int builtin_arg -> unit;
+     mutable function_end: atom -> positive -> unit;
+     mutable add_label: atom -> positive -> int -> unit;
+     mutable atom_parameter: ident -> ident -> atom -> unit;
+     mutable add_compilation_section_start: string -> int -> unit;
+     mutable add_compilation_section_end: string -> int -> unit;
+     mutable compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit;
+     mutable compute_gnu_file_enum: (string -> unit) -> unit;
+     mutable exists_section: string -> bool;
+     mutable remove_unused: ident -> unit;
+     mutable variable_printed: string -> unit;
+     mutable add_diab_info: string -> (int * int * string) -> unit;
+   }
+
+let implem =
+  {
+   init = (fun _ -> ());
+   atom_function = (fun _ _ -> ());
+   atom_global_variable = (fun _ _ -> ());
+   set_composite_size = (fun _ _ _ -> ());
+   set_member_offset = (fun _ _  _ -> ());
+   set_bitfield_offset = (fun _ _ _ _ _ -> ());
+   insert_global_declaration = (fun _ _ -> ());
+   add_fun_addr = (fun _ _ -> ());
+   generate_debug_info = (fun _  _ -> None);
+   all_files_iter = (fun _ -> ());
+   insert_local_declaration = (fun  _ _ _ _ -> ());
+   atom_local_variable = (fun _ _ -> ());
+   enter_scope = (fun _ _ _  -> ());
+   enter_function_scope = (fun _ _ -> ());
+   add_lvar_scope = (fun _ _ _ -> ());
+   open_scope = (fun _ _ _ -> ());
+   close_scope = (fun _ _ _ -> ());
+   start_live_range = (fun _ _ _ -> ());
+   end_live_range = (fun _ _ -> ());
+   stack_variable = (fun _ _ -> ());
+   function_end = (fun _ _ -> ());
+   add_label = (fun _ _ _ -> ());
+   atom_parameter = (fun _ _ _ -> ());
+   add_compilation_section_start = (fun _ _ -> ());
+   add_compilation_section_end = (fun _ _ -> ());
+   compute_diab_file_enum = (fun _ _ _ -> ());
+   compute_gnu_file_enum = (fun _ -> ());
+   exists_section = (fun _ -> true);
+   remove_unused = (fun _ -> ());
+   variable_printed = (fun _ -> ());
+   add_diab_info = (fun _ _ -> ());
+}
+
+let init_compile_unit name = implem.init name
+let atom_function id atom = implem.atom_function id atom
+let atom_global_variable id atom = implem.atom_global_variable id atom
+let set_composite_size id sou size = implem.set_composite_size id sou size
+let set_member_offset id field off = implem.set_member_offset id field off
+let set_bitfield_offset id field off underlying size = implem.set_bitfield_offset id field off underlying size
+let insert_global_declaration env dec = implem.insert_global_declaration env dec
+let add_fun_addr atom addr = implem.add_fun_addr atom addr
+let generate_debug_info fun_s var_s = implem.generate_debug_info fun_s var_s
+let all_files_iter f = implem.all_files_iter f
+let insert_local_declaration sto id ty loc = implem.insert_local_declaration sto id ty loc
+let atom_local_variable id atom = implem.atom_local_variable id atom
+let enter_scope p_id id = implem.enter_scope p_id id
+let enter_function_scope fun_id sc_id = implem.enter_function_scope fun_id sc_id
+let add_lvar_scope fun_id var_id s_id = implem.add_lvar_scope fun_id var_id s_id
+let open_scope atom id lbl = implem.open_scope atom id lbl
+let close_scope atom id lbl = implem.close_scope atom id lbl
+let start_live_range atom lbl loc = implem.start_live_range atom lbl loc
+let end_live_range atom lbl = implem.end_live_range atom lbl
+let stack_variable atom loc = implem.stack_variable atom loc
+let function_end atom loc = implem.function_end atom loc
+let add_label atom p lbl = implem.add_label atom p lbl
+let atom_parameter fid pid atom = implem.atom_parameter fid pid atom
+let add_compilation_section_start sec addr = implem.add_compilation_section_start sec addr
+let add_compilation_section_end sec addr = implem.add_compilation_section_end sec addr
+let exists_section sec = implem.exists_section sec
+let compute_diab_file_enum end_l entry_l line_e = implem.compute_diab_file_enum end_l entry_l line_e
+let compute_gnu_file_enum f = implem.compute_gnu_file_enum f
+let remove_unused ident = implem.remove_unused ident
+let variable_printed ident = implem.variable_printed ident
+let add_diab_info sec addr = implem.add_diab_info sec addr
diff --git a/debug/Debug.mli b/debug/Debug.mli
new file mode 100644
index 00000000..577b0ef8
--- /dev/null
+++ b/debug/Debug.mli
@@ -0,0 +1,88 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Bernhard Schommer, AbsInt Angewandte Informatik GmbH       *)
+(*                                                                     *)
+(*  AbsInt Angewandte Informatik GmbH. All rights reserved. This file  *)
+(*  is distributed under the terms of the INRIA Non-Commercial         *)
+(*  License Agreement.                                                 *)
+(*                                                                     *)
+(* *********************************************************************)
+
+open AST
+open C
+open Camlcoq
+open DwarfTypes
+open BinNums
+
+
+(* Record used for stroring references to the actual implementation functions *)
+type implem = 
+    {
+     mutable init: string -> unit;
+     mutable atom_function: ident -> atom -> unit;
+     mutable atom_global_variable: ident -> atom -> unit;
+     mutable set_composite_size: ident -> struct_or_union -> int option -> unit;
+     mutable set_member_offset: ident -> string -> int -> unit;
+     mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit;
+     mutable insert_global_declaration: Env.t -> globdecl -> unit;
+     mutable add_fun_addr: atom -> (int * int) -> unit;
+     mutable generate_debug_info: (atom -> string) -> string -> debug_entries option;
+     mutable all_files_iter: (string -> unit) -> unit;
+     mutable insert_local_declaration:  storage -> ident -> typ -> location -> unit;
+     mutable atom_local_variable: ident -> atom -> unit;
+     mutable enter_scope: int -> int -> int -> unit;
+     mutable enter_function_scope: int -> int -> unit;
+     mutable add_lvar_scope: int -> ident -> int -> unit;
+     mutable open_scope: atom -> int -> positive -> unit;
+     mutable close_scope: atom -> int -> positive -> unit;
+     mutable start_live_range: (atom * atom) -> positive -> int * int builtin_arg -> unit;
+     mutable end_live_range: (atom * atom) -> positive -> unit;
+     mutable stack_variable: (atom * atom) -> int * int builtin_arg -> unit;
+     mutable function_end: atom -> positive -> unit;
+     mutable add_label: atom -> positive -> int -> unit;
+     mutable atom_parameter: ident -> ident -> atom -> unit;
+     mutable add_compilation_section_start: string -> int -> unit;
+     mutable add_compilation_section_end: string -> int -> unit;
+     mutable compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit;
+     mutable compute_gnu_file_enum: (string -> unit) -> unit;
+     mutable exists_section: string -> bool;
+     mutable remove_unused: ident -> unit;
+     mutable variable_printed: string -> unit;
+     mutable add_diab_info: string -> (int * int * string) -> unit;
+   }
+
+val implem: implem
+
+val init_compile_unit: string -> unit
+val atom_function: ident -> atom -> unit
+val atom_global_variable: ident -> atom -> unit
+val set_composite_size: ident -> struct_or_union -> int option -> unit
+val set_member_offset: ident -> string -> int -> unit
+val set_bitfield_offset: ident -> string -> int -> string -> int -> unit
+val insert_global_declaration:  Env.t -> globdecl -> unit
+val add_fun_addr: atom -> (int * int) -> unit
+val all_files_iter: (string -> unit) -> unit
+val insert_local_declaration: storage -> ident -> typ -> location -> unit
+val atom_local_variable: ident -> atom -> unit
+val enter_scope: int -> int -> int -> unit
+val enter_function_scope: int -> int -> unit
+val add_lvar_scope: int -> ident -> int -> unit
+val open_scope: atom -> int -> positive -> unit
+val close_scope: atom -> int -> positive -> unit
+val start_live_range: (atom * atom) -> positive -> (int * int builtin_arg) -> unit
+val end_live_range: (atom * atom) -> positive -> unit
+val stack_variable: (atom * atom) -> int * int builtin_arg -> unit
+val function_end: atom -> positive -> unit
+val add_label: atom -> positive -> int -> unit
+val generate_debug_info: (atom -> string) -> string -> debug_entries option
+val atom_parameter: ident -> ident -> atom -> unit
+val add_compilation_section_start: string -> int -> unit
+val add_compilation_section_end: string -> int -> unit
+val compute_diab_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit
+val compute_gnu_file_enum: (string -> unit) -> unit
+val exists_section: string -> bool
+val remove_unused: ident -> unit
+val variable_printed: string -> unit
+val add_diab_info: string -> (int * int * string) -> unit
diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml
new file mode 100644
index 00000000..d1747f8e
--- /dev/null
+++ b/debug/DebugInformation.ml
@@ -0,0 +1,704 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Bernhard Schommer, AbsInt Angewandte Informatik GmbH       *)
+(*                                                                     *)
+(*  AbsInt Angewandte Informatik GmbH. All rights reserved. This file  *)
+(*  is distributed under the terms of the INRIA Non-Commercial         *)
+(*  License Agreement.                                                 *)
+(*                                                                     *)
+(* *********************************************************************)
+
+open AST
+open BinNums
+open C
+open Camlcoq
+open Cutil
+open DebugTypes
+
+(* This implements an interface for the collection of debugging 
+   information. *)
+
+(* Simple id generator *)
+let id = ref 0
+
+let next_id () =
+  let nid = !id in
+  incr id; nid
+
+let reset_id () =
+  id := 0
+
+(* Auximilary functions *)
+let list_replace c f l =
+  List.map (fun a -> if c a then f a else a) l
+
+(* The name of the current compilation unit *)
+let file_name: string ref = ref ""
+
+(** All files used in the debug entries *)
+module StringSet = Set.Make(String)
+let all_files : StringSet.t ref = ref StringSet.empty
+let add_file file =
+  all_files := StringSet.add file !all_files
+
+(* All types encountered *)
+let types: (int,debug_types) Hashtbl.t = Hashtbl.create 7
+
+(* Lookup table for types *)
+let lookup_types: (string, int) Hashtbl.t = Hashtbl.create 7
+
+(* Translate a C.typ to a string needed for hashing *)
+let typ_to_string (ty: typ) =
+  let buf = Buffer.create 7 in
+  let chan = Format.formatter_of_buffer buf in
+  Cprint.print_debug_idents := true;
+  Cprint.typ chan ty;
+  Cprint.print_debug_idents := false;
+  Format.pp_print_flush chan ();
+  Buffer.contents buf
+
+(* Helper functions for the attributes *)
+let strip_attributes typ =
+  let strip =  List.filter (fun a -> a = AConst || a = AVolatile) in 
+  match typ with
+  | TVoid at -> TVoid (strip at)
+  | TInt (k,at) ->  TInt (k,strip at)
+  | TFloat (k,at) -> TFloat(k,strip at)
+  | TPtr (t,at) -> TPtr(t,strip at)
+  | TArray (t,s,at) -> TArray(t,s,strip at)
+  | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at)
+  | TNamed (n,at) -> TNamed(n,strip at)
+  | TStruct (n,at) -> TStruct(n,strip at)
+  | TUnion (n,at) -> TUnion(n,strip at)
+  | TEnum (n,at) -> TEnum(n,strip at)
+
+let strip_last_attribute typ  = 
+  let rec hd_opt l = match l with
+    [] -> None,[]
+  | AConst::rest -> Some AConst,rest
+  | AVolatile::rest -> Some AVolatile,rest 
+  | _::rest -> hd_opt rest in
+  match typ with
+  | TVoid at -> let l,r = hd_opt at in
+    l,TVoid r
+  | TInt (k,at) -> let l,r = hd_opt at in
+    l,TInt (k,r)
+  | TFloat (k,at) -> let l,r = hd_opt at in
+    l,TFloat (k,r)
+  | TPtr (t,at) -> let l,r = hd_opt at in
+    l,TPtr(t,r)
+  | TArray (t,s,at) -> let l,r = hd_opt at in
+    l,TArray(t,s,r)
+  | TFun (t,arg,v,at) -> let l,r = hd_opt at in
+    l,TFun(t,arg,v,r)
+  | TNamed (n,at) -> let l,r = hd_opt at in
+    l,TNamed(n,r)
+  | TStruct (n,at) -> let l,r = hd_opt at in
+    l,TStruct(n,r)
+  | TUnion (n,at) -> let l,r = hd_opt at in
+    l,TUnion(n,r)
+  | TEnum (n,at) -> let l,r = hd_opt at in
+    l,TEnum(n,r)
+
+(* Does the type already exist? *)
+let exist_type (ty: typ) =
+  (* We are only interrested in Const and Volatile *)
+  let ty = strip_attributes ty in
+  Hashtbl.mem lookup_types (typ_to_string ty)
+
+(* Find the type id to an type *)
+let find_type (ty: typ) =
+  (* We are only interrested in Const and Volatile *)
+  let ty = strip_attributes ty in
+  Hashtbl.find lookup_types (typ_to_string ty)
+
+(* Add type and information *)
+let insert_type (ty: typ) =
+  let insert d_ty ty =
+    let id = next_id () 
+    and name = typ_to_string ty in
+    Hashtbl.add types id d_ty;
+    Hashtbl.add lookup_types name id;
+    id in
+  (* We are only interrested in Const and Volatile *)
+  let ty = strip_attributes ty in
+  let rec typ_aux ty = 
+    try find_type ty with
+    | Not_found ->
+        let d_ty =
+          match ty with
+          | TVoid _ -> Void
+          | TInt (k,_) -> 
+              IntegerType ({int_kind = k })
+          | TFloat (k,_) ->
+              FloatType ({float_kind = k})
+          | TPtr (t,_) ->
+              let id = attr_aux t in
+              PointerType ({pts = id})
+          | TArray (t,s,_) ->
+              let rec size acc t = (match t with
+              | TArray (child,s,_) ->
+                  size (s::acc) child
+              | _ -> t,List.rev acc) in
+              let t,s = size [s] t in
+              let id = attr_aux t in
+              let arr = {
+                arr_type = id;
+                arr_size= s;
+              } in
+              ArrayType arr
+          | TFun (t,param,va,_) ->
+              let param,prot = (match param with 
+              | None -> [],false
+              | Some p -> List.map (fun (i,t) -> let t = attr_aux t in 
+                {
+                 param_type = t;
+                 param_name = i.name;               
+               }) p,true) in
+              let ret = (match t with 
+              | TVoid _ -> None
+              | _ -> Some (attr_aux t)) in
+              let ftype = {
+                fun_return_type = ret;
+                fun_prototyped = prot;
+                fun_params = param;
+              } in
+              FunctionType ftype
+          | TNamed (id,_) ->
+              let typ = try
+                let _,t =
+                  List.find (fun a -> fst a = id.name) CBuiltins.builtins.Builtins.typedefs in
+                Some (attr_aux t)
+              with Not_found -> None in
+              let t = {
+                typedef_file_loc = None;
+                typedef_name = id.name;
+                typ = typ;
+              } in
+              Typedef t
+          | TStruct (id,_) ->
+              let str =
+                {
+                 ct_name = id.name;
+                 ct_sou = Struct;
+                 ct_file_loc = None;
+                 ct_members = [];
+                 ct_declaration = true;
+                 ct_sizeof = None;
+               } in
+              CompositeType str
+          | TUnion (id,_) ->
+              let union =
+                {
+                 ct_name = id.name;
+                 ct_sou = Union;
+                 ct_file_loc = None;
+                 ct_members = [];
+                 ct_declaration = true;
+                 ct_sizeof = None;
+               } in
+              CompositeType union
+          | TEnum (id,_) ->
+              let enum = 
+                {
+                 enum_name = id.name;
+                 enum_byte_size = None;
+                 enum_file_loc = None;
+                 enum_enumerators = [];
+               } in
+              EnumType enum in
+        insert d_ty ty
+  and attr_aux ty = 
+    try
+      find_type ty
+    with
+      Not_found ->
+        match strip_last_attribute ty with
+        | Some AConst,t -> 
+            let id = attr_aux t in
+            let const = { cst_type = id} in
+            insert (ConstType const) ty
+        | Some AVolatile,t ->
+            let id = attr_aux t in
+            let volatile = {vol_type = id} in
+            insert (VolatileType volatile) ty
+        | Some (ARestrict|AAlignas _| Attr(_,_)),t ->
+            attr_aux t
+        | None,t -> typ_aux t
+  in
+  attr_aux ty
+
+(* Replace the composite information *)
+let replace_composite id f =
+  let str = Hashtbl.find types id in
+  match str with
+  | CompositeType comp -> let comp' = f comp in
+    if comp <> comp' then Hashtbl.replace types id (CompositeType comp')
+  | _ -> assert false (* This should never happen *)
+
+(* Replace the enum information *)
+let replace_enum id f =
+  let str = Hashtbl.find types id in
+  match str with
+  | EnumType comp -> let comp' = f comp in
+    if comp <> comp' then Hashtbl.replace types id (EnumType comp')
+  | _ -> assert false (* This should never happen *)
+
+(* Replace the typdef information *)
+let replace_typedef id f =
+  let typdef = Hashtbl.find types id in
+  match typdef with
+  | Typedef typ -> let typ' = f typ in
+    if typ <> typ' then Hashtbl.replace types id (Typedef typ')
+  | _ -> assert false (* This should never happen *)
+
+
+(* All global definitions encountered *)
+let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7
+
+(* Mapping from stamp to debug id *)
+let stamp_to_definition: (int,int) Hashtbl.t = Hashtbl.create 7
+
+(* Mapping from name to debug id *)
+let name_to_definition: (string,int) Hashtbl.t = Hashtbl.create 7
+
+(* Mapping from atom to debug id *)
+let atom_to_definition: (atom, int) Hashtbl.t = Hashtbl.create 7
+
+let find_gvar_stamp id =
+  let id = (Hashtbl.find stamp_to_definition id) in
+  let var = Hashtbl.find definitions id in
+  match var with
+  | GlobalVariable var -> id,var
+  |  _ -> assert false
+
+let find_fun_stamp id =
+  let id = (Hashtbl.find stamp_to_definition id) in
+  let f = Hashtbl.find definitions id in
+  match f with
+  | Function f -> id,f
+  |  _ -> assert false
+
+let find_fun_atom id =
+  let id = (Hashtbl.find atom_to_definition id) in
+  let f = Hashtbl.find definitions id in
+  match f with
+  | Function f -> id,f
+  |  _ -> assert false
+
+let replace_var id var =
+  let var = GlobalVariable var in
+  Hashtbl.replace definitions id var
+
+let replace_fun id f =
+  let f = Function f in
+  Hashtbl.replace definitions id f
+
+(* All local variables *)
+let local_variables: (int, local_information) Hashtbl.t = Hashtbl.create 7
+
+(* Mapping from stampt to the debug id of the local variable *)
+let stamp_to_local: (int,int) Hashtbl.t = Hashtbl.create 7
+
+(* Mapping form atom to the debug id of the local variable *)
+let atom_to_local: (atom, int) Hashtbl.t = Hashtbl.create 7
+
+(* Map from scope id + function id to debug id *)
+let scope_to_local: (int * int,int) Hashtbl.t = Hashtbl.create 7
+
+(* Map from scope id + function atom to debug id *)
+let atom_to_scope: (atom * int, int) Hashtbl.t = Hashtbl.create 7
+
+let find_lvar_stamp id =
+  let id = (Hashtbl.find stamp_to_local id) in
+  let v = Hashtbl.find local_variables id in
+  match v with
+  | LocalVariable v -> id,v
+  | _ -> assert false
+
+let replace_lvar id var =
+  let var = LocalVariable var in
+  Hashtbl.replace local_variables id var
+
+let find_scope_id fid id =
+  let id = Hashtbl.find scope_to_local (fid,id) in
+  let v = Hashtbl.find local_variables id in
+  match v with
+  | Scope v -> id,v
+  | _ -> assert false
+
+let replace_scope id var =
+  let var = Scope var in
+  Hashtbl.replace local_variables id var
+
+let gen_comp_typ sou id at = 
+  if sou = Struct then
+    TStruct (id,at)
+  else
+    TUnion (id,at)
+
+let remove_unused id =
+  try
+    let id' = Hashtbl.find stamp_to_definition id.stamp in
+    Hashtbl.remove definitions id';
+    Hashtbl.remove stamp_to_definition id.stamp
+  with Not_found -> ()
+
+let insert_global_declaration env dec=
+  add_file (fst dec.gloc);
+  let insert d_dec stamp =
+    let id = next_id () in
+    Hashtbl.add definitions id d_dec;
+    Hashtbl.add stamp_to_definition stamp id
+  in
+  match dec.gdesc with
+  | Gdecl (sto,id,ty,init) ->
+      if  not (is_function_type env ty) then begin
+        if not (Hashtbl.mem stamp_to_definition id.stamp)  then begin
+          let at_decl,ext = (match sto with
+          | Storage_extern -> init = None,true
+          | Storage_static -> false,false
+          | _ -> false,true) in
+          let ty = insert_type ty in
+          let decl = {
+            gvar_name = id.name;
+            gvar_atom = None;
+            gvar_file_loc = dec.gloc;
+            gvar_declaration = at_decl;
+            gvar_external = ext;
+            gvar_type = ty;
+          } in
+          insert (GlobalVariable decl) id.stamp
+        end else if init <> None || sto <> Storage_extern then begin (* It is a definition *)
+          let id,var = find_gvar_stamp id.stamp in
+          replace_var id ({var with gvar_declaration = false;})
+        end
+      end else begin
+        (* Implict declarations need special handling *)
+        let id' = try Hashtbl.find name_to_definition id.name with Not_found -> 
+          let id' = next_id () in
+          Hashtbl.add name_to_definition id.name id';id' in
+        Hashtbl.add stamp_to_definition id.stamp id'
+      end       
+  | Gfundef f ->
+      let ret =  (match f.fd_ret with
+      | TVoid _ -> None
+      | _ -> Some (insert_type f.fd_ret)) in
+      let ext =  (match f.fd_storage with
+      | Storage_static -> false
+      | _ -> true) in
+      let params = List.map (fun (p,ty) ->
+        let ty = insert_type ty in
+        {
+         parameter_name = p.name;
+         parameter_ident = p.stamp;
+         parameter_atom = None;
+         parameter_type = ty;
+       }) f.fd_params in
+      let fd =
+      { 
+        fun_name = f.fd_name.name;
+        fun_atom = None;
+        fun_file_loc = dec.gloc;
+        fun_external = ext;
+        fun_return_type = ret;
+        fun_vararg = f.fd_vararg;
+        fun_parameter = params;
+        fun_low_pc = None;
+        fun_high_pc = None;
+        fun_scope = None;
+      } in
+      begin
+        let id' = try Hashtbl.find name_to_definition f.fd_name.name with Not_found -> 
+          let id' = next_id () in
+          Hashtbl.add name_to_definition f.fd_name.name id';id' in
+        Hashtbl.add stamp_to_definition f.fd_name.stamp id';
+        Hashtbl.add definitions id' (Function fd)
+      end
+  | Gcompositedecl (sou,id,at) -> 
+      ignore (insert_type (gen_comp_typ sou id at));
+      let id = find_type (gen_comp_typ sou id []) in
+      replace_composite id (fun comp -> if comp.ct_file_loc = None then
+        {comp with ct_file_loc = Some (dec.gloc);}
+      else comp)
+  | Gcompositedef (sou,id,at,fi) -> 
+      ignore (insert_type (gen_comp_typ sou id at));
+      let id = find_type (gen_comp_typ sou id []) in
+      let fi = List.filter (fun f -> f.fld_name <> "") fi in (* Fields without names need no info *)
+      let fields = List.map (fun f ->
+        {
+         cfd_name = f.fld_name;
+         cfd_typ = insert_type f.fld_typ;
+         cfd_bit_size = f.fld_bitfield;
+         cfd_bit_offset = None;
+         cfd_byte_offset = None;
+         cfd_byte_size = None;
+         cfd_bitfield = None;
+       }) fi in
+      replace_composite id (fun comp ->
+        let loc = if comp.ct_file_loc = None then Some dec.gloc else comp.ct_file_loc in
+        {comp with ct_file_loc = loc; ct_members = fields; ct_declaration = false;})
+  | Gtypedef (id,t) -> 
+      let id = insert_type (TNamed (id,[])) in
+      let tid = insert_type t in
+      replace_typedef id (fun typ -> {typ with typedef_file_loc = Some dec.gloc; typ = Some tid;});
+  | Genumdef (n,at,e) -> 
+      ignore(insert_type (TEnum (n,at)));
+      let id = find_type (TEnum (n,[])) in
+      let enumerator = List.map (fun (i,c,_) ->
+        {    
+             enumerator_name = i.name;
+             enumerator_const = c;
+       }) e in
+      replace_enum id (fun en ->
+        {en with enum_file_loc = Some dec.gloc; enum_enumerators = enumerator;})
+  | Gpragma _ -> ()
+
+let set_member_offset str field offset =
+  let id = find_type (TStruct (str,[])) in
+  replace_composite id (fun comp ->
+    let name f = f.cfd_name = field || match f.cfd_bitfield with Some n -> n = field | _ -> false in 
+    let members = list_replace name (fun a -> {a with cfd_byte_offset = Some offset;}) comp.ct_members in
+    {comp with ct_members = members;})
+
+let set_composite_size comp sou size =
+  let id = find_type (gen_comp_typ sou comp []) in
+  replace_composite id (fun comp -> {comp with ct_sizeof = size;}) 
+
+let set_bitfield_offset str field offset underlying size =
+  let id = find_type (TStruct (str,[])) in
+  replace_composite id (fun comp ->
+    let name f = f.cfd_name = field in
+    let members = list_replace name (fun a -> 
+      {a with cfd_bit_offset = Some offset; cfd_bitfield = Some underlying; cfd_byte_size = Some size})
+        comp.ct_members in
+    {comp with ct_members = members;})
+
+let atom_global_variable id atom = 
+  try
+    let id,var = find_gvar_stamp id.stamp in
+    replace_var id ({var with gvar_atom = Some atom;});
+    Hashtbl.add atom_to_definition atom id 
+  with Not_found -> ()
+    
+let atom_function id atom =
+  try
+    let id',f = find_fun_stamp id.stamp in
+    replace_fun id' ({f with fun_atom = Some atom;});
+    Hashtbl.add atom_to_definition atom id';
+    Hashtbl.iter (fun (fid,sid) tid -> if fid = id.stamp then 
+      Hashtbl.add atom_to_scope (atom,sid) tid) scope_to_local
+  with Not_found -> ()
+
+let atom_parameter fid id atom =
+  try
+    let fid',f = find_fun_stamp fid.stamp in
+    let name p = p.parameter_ident = id.stamp in
+    let params = list_replace name (fun p -> {p with parameter_atom = Some atom;}) f.fun_parameter in
+    replace_fun fid' ({f with fun_parameter = params;})
+  with Not_found -> ()
+    
+let add_fun_addr atom (high,low) =
+  try
+    let id,f = find_fun_atom atom in
+    replace_fun id ({f with fun_high_pc = Some high; fun_low_pc = Some low;})
+  with Not_found -> ()
+
+let atom_local_variable id atom =
+  try
+    let id,var = find_lvar_stamp id.stamp in
+    replace_lvar id ({var with lvar_atom = Some atom;});
+    Hashtbl.add atom_to_local atom id
+  with Not_found -> ()
+
+let add_lvar_scope f_id var_id s_id =
+  try
+    let s_id',scope = find_scope_id f_id s_id in
+    let var_id,_ = find_lvar_stamp var_id.stamp in 
+    replace_scope s_id' ({scope_variables = var_id::scope.scope_variables;})
+  with Not_found -> ()
+
+let insert_local_declaration sto id ty loc =
+  add_file (fst loc);
+  let ty = insert_type ty in
+  let var = {
+    lvar_name = id.name;
+    lvar_atom = None;
+    lvar_file_loc = loc;
+    lvar_type = ty;
+    lvar_static = sto = Storage_static;
+    } in
+  let id' = next_id () in
+  Hashtbl.add local_variables id' (LocalVariable var);
+  Hashtbl.add stamp_to_local id.stamp id'
+
+let new_scope f_id sc_id =
+  let scope = {scope_variables = [];} in
+  let id = next_id () in
+  Hashtbl.add local_variables id (Scope scope);
+  Hashtbl.add scope_to_local (f_id,sc_id) id;
+  id
+
+let enter_function_scope fun_id sc_id =
+  try
+    let id = new_scope fun_id sc_id in
+    let fun_id,f = find_fun_stamp fun_id in
+    replace_fun fun_id ({f with fun_scope = Some id})
+  with Not_found -> ()
+
+let enter_scope f_id p_id id =
+  try
+    let id' = new_scope f_id id in
+    let p_id',scope = find_scope_id f_id p_id in
+    replace_scope p_id' ({scope_variables = id'::scope.scope_variables;})
+  with Not_found  -> ()
+
+
+type scope_range =
+    {
+     start_addr: positive option;
+     end_addr: positive option;
+   }
+
+type var_range =
+    {
+     range_start: positive option;
+     range_end:   positive option;
+     var_loc:     int * int builtin_arg;
+   }
+
+type var_location =
+  | RangeLoc of var_range list
+  | FunctionLoc of  int * int builtin_arg (* Stack allocated variables *)
+
+let var_locations: (atom * atom,var_location) Hashtbl.t = Hashtbl.create 7
+
+let scope_ranges: (int,scope_range list) Hashtbl.t = Hashtbl.create 7
+
+let label_translation: (atom * positive, int) Hashtbl.t = Hashtbl.create 7
+
+let add_label atom p i =
+  Hashtbl.add label_translation (atom,p) i
+
+(* Auxiliary data structures and functions *)
+module IntSet = Set.Make(struct
+  type t = int
+  let compare (x:int) (y:int) = compare x y
+end)
+
+let open_scopes: IntSet.t ref = ref IntSet.empty
+let open_vars: atom list ref = ref []
+
+let open_scope atom s_id lbl =
+  try
+    let s_id = Hashtbl.find atom_to_scope (atom,s_id) in
+    let old_r = try Hashtbl.find scope_ranges s_id with Not_found -> [] in
+    let n_scop = { start_addr = Some lbl; end_addr = None;} in
+    open_scopes := IntSet.add s_id !open_scopes;
+    Hashtbl.replace scope_ranges s_id (n_scop::old_r)
+  with Not_found -> ()
+
+let close_scope atom s_id lbl =
+  try
+    let s_id = Hashtbl.find atom_to_scope (atom,s_id) in
+    let old_r = try Hashtbl.find scope_ranges s_id with Not_found -> [] in
+    let last_r,rest = 
+      begin
+        match old_r with
+        | a::rest -> a,rest
+        | _ -> assert false (* We must have an opening scope *)
+      end in
+    let new_r = ({last_r with end_addr = Some lbl;})::rest in
+    open_scopes := IntSet.remove s_id !open_scopes;
+    Hashtbl.replace scope_ranges s_id new_r
+  with Not_found -> ()
+
+let start_live_range (f,v) lbl loc =
+  let old_r = begin try Hashtbl.find var_locations (f,v) with Not_found -> (RangeLoc []) end in
+  match old_r with
+  | RangeLoc old_r ->
+      let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in
+      open_vars := v::!open_vars;
+      Hashtbl.replace var_locations (f,v) (RangeLoc (n_r::old_r))
+  | _ -> () (* Parameter that is passed as variable *)
+
+let end_live_range (f,v) lbl =
+  try
+    let old_r = Hashtbl.find var_locations (f,v) in
+    match old_r with
+    | RangeLoc (n_r::old_r) ->
+        if n_r.range_end = None then (* We can skip non open locations *)
+          let n_r = {n_r with  range_end = Some lbl} in
+          Hashtbl.replace var_locations (f,v) (RangeLoc (n_r::old_r))
+    | _ -> ()
+  with Not_found -> ()
+
+let stack_variable (f,v) (sp,loc) =
+  Hashtbl.add var_locations (f,v) (FunctionLoc (sp,loc))
+
+let function_end atom loc =
+  IntSet.iter (fun id -> close_scope atom id loc) !open_scopes;
+  open_scopes := IntSet.empty;
+  List.iter (fun id-> end_live_range (atom,id) loc) !open_vars;
+  open_vars:= []
+
+let compilation_section_start: (string,int) Hashtbl.t = Hashtbl.create 7
+let compilation_section_end: (string,int) Hashtbl.t = Hashtbl.create 7
+
+let diab_additional: (string,int * int * string) Hashtbl.t = Hashtbl.create 7
+
+let add_compilation_section_start sec addr =
+  Hashtbl.add compilation_section_start sec addr
+
+let add_compilation_section_end sec addr =
+  Hashtbl.add compilation_section_end sec addr
+
+let add_diab_info sec addr =
+  Hashtbl.add diab_additional sec addr
+
+let exists_section sec =
+  Hashtbl.mem compilation_section_start sec
+
+let filenum: (string * string,int) Hashtbl.t = Hashtbl.create 7
+
+let compute_diab_file_enum end_label entry_label line_end =
+  Hashtbl.iter (fun sec (_,_,secname) ->
+    Hashtbl.add compilation_section_end sec (end_label secname);
+    StringSet.iter (fun file ->
+      let lbl = entry_label file in
+      Hashtbl.add filenum (sec,file) lbl) !all_files;
+    line_end ()) diab_additional
+
+let compute_gnu_file_enum f =
+  StringSet.iter f !all_files
+
+let printed_vars: StringSet.t ref = ref StringSet.empty
+
+let variable_printed id =
+  printed_vars := StringSet.add id !printed_vars
+
+let init name =
+  id := 0;
+  file_name := name;
+  Hashtbl.reset types;
+  Hashtbl.reset lookup_types;
+  Hashtbl.reset definitions;
+  Hashtbl.reset stamp_to_definition;
+  Hashtbl.reset name_to_definition;
+  Hashtbl.reset atom_to_definition;
+  Hashtbl.reset local_variables;
+  Hashtbl.reset stamp_to_local;
+  Hashtbl.reset atom_to_local;
+  Hashtbl.reset scope_to_local;
+  Hashtbl.reset atom_to_scope;
+  Hashtbl.reset compilation_section_start;
+  Hashtbl.reset compilation_section_end;
+  Hashtbl.reset diab_additional;
+  Hashtbl.reset filenum;
+  Hashtbl.reset var_locations;
+  Hashtbl.reset scope_ranges;
+  Hashtbl.reset label_translation;
+  all_files := StringSet.singleton name;
+  printed_vars := StringSet.empty;
diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml
new file mode 100644
index 00000000..7ee56ff1
--- /dev/null
+++ b/debug/DebugInit.ml
@@ -0,0 +1,95 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Bernhard Schommer, AbsInt Angewandte Informatik GmbH       *)
+(*                                                                     *)
+(*  AbsInt Angewandte Informatik GmbH. All rights reserved. This file  *)
+(*  is distributed under the terms of the INRIA Non-Commercial         *)
+(*  License Agreement.                                                 *)
+(*                                                                     *)
+(* *********************************************************************)
+
+open AST
+open BinNums
+open C
+open Camlcoq
+open Dwarfgen
+open DwarfTypes
+open Debug
+
+let init_debug () =
+  implem.init <- DebugInformation.init;
+  implem.atom_function <- DebugInformation.atom_function;
+  implem.atom_global_variable <- DebugInformation.atom_global_variable;
+  implem.set_composite_size <- DebugInformation.set_composite_size;
+  implem.set_member_offset <- DebugInformation.set_member_offset;
+  implem.set_bitfield_offset <- DebugInformation.set_bitfield_offset;
+  implem.insert_global_declaration <- DebugInformation.insert_global_declaration;
+  implem.add_fun_addr <- DebugInformation.add_fun_addr;
+  implem.generate_debug_info <- 
+    if Configuration.system = "diab" then
+      (fun a b -> Some (Dwarfgen.gen_diab_debug_info a b))
+    else
+      (fun a b -> Some (Dwarfgen.gen_gnu_debug_info a b));
+  implem.all_files_iter <- (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files);
+  implem.insert_local_declaration <- DebugInformation.insert_local_declaration;
+  implem.atom_local_variable <- DebugInformation.atom_local_variable;
+  implem.enter_scope <- DebugInformation.enter_scope;
+  implem.enter_function_scope <- DebugInformation.enter_function_scope;
+  implem.add_lvar_scope <- DebugInformation.add_lvar_scope;
+  implem.open_scope <- DebugInformation.open_scope;
+  implem.close_scope <- DebugInformation.close_scope;
+  implem.start_live_range <- DebugInformation.start_live_range;
+  implem.end_live_range <- DebugInformation.end_live_range;
+  implem.stack_variable <- DebugInformation.stack_variable;
+  implem.function_end <- DebugInformation.function_end;
+  implem.add_label <- DebugInformation.add_label;
+  implem.atom_parameter <- DebugInformation.atom_parameter;
+  implem.add_compilation_section_start <- DebugInformation.add_compilation_section_start;
+  implem.add_compilation_section_end <- DebugInformation.add_compilation_section_end;
+  implem.compute_diab_file_enum <- DebugInformation.compute_diab_file_enum;
+  implem.compute_gnu_file_enum <- DebugInformation.compute_gnu_file_enum;
+  implem.exists_section <- DebugInformation.exists_section;
+  implem.remove_unused <- DebugInformation.remove_unused;
+  implem.variable_printed <- DebugInformation.variable_printed;
+  implem.add_diab_info <- DebugInformation.add_diab_info
+
+let init_none () =
+  implem.init <- (fun _ -> ());
+  implem.atom_function <- (fun _ _ -> ());
+  implem.atom_global_variable <- (fun _ _ -> ());
+  implem.set_composite_size <- (fun _ _ _ -> ());
+  implem.set_member_offset <- (fun _ _ _ -> ());
+  implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ());
+  implem.insert_global_declaration <- (fun _ _ -> ());
+  implem.add_fun_addr <- (fun _ _ -> ());
+  implem.generate_debug_info <- (fun _ _ -> None);
+  implem.all_files_iter <- (fun _ -> ());
+  implem.insert_local_declaration <- (fun  _ _ _ _ -> ());
+  implem.atom_local_variable <- (fun _ _ -> ());
+  implem.enter_scope <- (fun _ _  _ -> ());
+  implem.enter_function_scope <- (fun _ _ -> ());
+  implem.add_lvar_scope <- (fun _ _ _ -> ());
+  implem.open_scope <- (fun _ _ _ -> ());
+  implem.close_scope <- (fun _ _ _ -> ());
+  implem.start_live_range <- (fun _ _ _ -> ());
+  implem.end_live_range <- (fun _ _ -> ());
+  implem.stack_variable <- (fun _ _ -> ());
+  implem.function_end <- (fun _ _ -> ());
+  implem.add_label <- (fun _ _ _ -> ());
+  implem.atom_parameter <- (fun _ _ _ -> ());
+  implem.add_compilation_section_start <- (fun _ _ -> ());
+  implem.add_compilation_section_end <- (fun _ _ -> ());
+  implem.compute_diab_file_enum <- (fun _ _ _ -> ());
+  implem.compute_gnu_file_enum <- (fun _ -> ());
+  implem.exists_section <- (fun _ -> true);
+  implem.remove_unused <- (fun _ -> ());
+  implem.variable_printed <- (fun _ -> ());
+  implem.add_diab_info <- (fun _ _ -> ())
+
+let init () =
+  if !Clflags.option_g && Configuration.advanced_debug then
+    init_debug ()
+  else
+    init_none ()
diff --git a/debug/DebugTypes.mli b/debug/DebugTypes.mli
new file mode 100644
index 00000000..6a4f619c
--- /dev/null
+++ b/debug/DebugTypes.mli
@@ -0,0 +1,160 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Bernhard Schommer, AbsInt Angewandte Informatik GmbH       *)
+(*                                                                     *)
+(*  AbsInt Angewandte Informatik GmbH. All rights reserved. This file  *)
+(*  is distributed under the terms of the INRIA Non-Commercial         *)
+(*  License Agreement.                                                 *)
+(*                                                                     *)
+(* *********************************************************************)
+
+open C
+open Camlcoq
+
+(* Types for the information of type info *)
+type composite_field =
+    {
+     cfd_name:        string;
+     cfd_typ:         int;
+     cfd_bit_size:    int option;
+     cfd_bit_offset:  int option;
+     cfd_byte_offset: int option;
+     cfd_byte_size:   int option;
+     cfd_bitfield:    string option;
+   }
+
+type composite_type =
+    {
+     ct_name:        string;
+     ct_sou:         struct_or_union;
+     ct_file_loc:    location option;
+     ct_members:     composite_field list;
+     ct_sizeof:      int option;
+     ct_declaration: bool;
+   }
+
+type ptr_type = {
+    pts: int
+  }
+
+type const_type = {
+    cst_type: int
+  }
+
+type volatile_type = {
+    vol_type: int
+  }
+
+
+type array_type = {
+    arr_type: int;
+    arr_size: int64 option list;
+  }
+
+type typedef = {
+    typedef_file_loc: location option;
+    typedef_name:     string;
+    typ:              int option;
+  }
+
+type enumerator = {
+    enumerator_name:     string;
+    enumerator_const:    int64;
+  }
+
+type enum_type = {
+    enum_name:        string;
+    enum_byte_size:   int option;
+    enum_file_loc:    location option;
+    enum_enumerators: enumerator list; 
+  }
+
+type int_type = {
+    int_kind: ikind;
+  }
+
+type float_type = {
+    float_kind: fkind;
+  }
+
+type parameter_type = {
+    param_type: int;
+    param_name: string;
+  }
+
+type function_type = {
+    fun_return_type: int option;
+    fun_prototyped:  bool;
+    fun_params:      parameter_type list;
+  }
+
+type debug_types =
+  | IntegerType of int_type
+  | FloatType of float_type
+  | PointerType of ptr_type
+  | ArrayType of array_type
+  | CompositeType of composite_type
+  | EnumType of enum_type
+  | FunctionType of function_type
+  | Typedef of typedef
+  | ConstType of const_type
+  | VolatileType of volatile_type
+  | Void
+
+(* Types for global definitions *)
+
+(* Information for a global variable *)
+type global_variable_information = {
+    gvar_name:        string;
+    gvar_atom:        atom option;
+    gvar_file_loc:    location;
+    gvar_declaration: bool;
+    gvar_external:    bool;
+    gvar_type:        int;
+  }
+
+type parameter_information = 
+ {
+  parameter_name:     string;
+  parameter_ident:    int;
+  parameter_atom:     atom option;
+  parameter_type:     int;
+}
+
+type function_information = {
+    fun_name:        string;
+    fun_atom:        atom option;
+    fun_file_loc:    location;
+    fun_external:    bool;
+    fun_return_type: int option; (* Again the special case of void functions *)
+    fun_vararg:      bool;
+    fun_parameter:   parameter_information list;
+    fun_low_pc:      int option;
+    fun_high_pc:     int option;
+    fun_scope:       int option;
+  }
+
+type definition_type =
+  | GlobalVariable of global_variable_information
+  | Function of function_information
+
+
+(* Information for local variables *)
+type local_variable_information = {
+    lvar_name:    string;
+    lvar_atom:    atom option;
+    lvar_file_loc:location;
+    lvar_type:    int;
+    lvar_static:  bool;  (* Static variable are mapped to symbols *)
+  }
+
+type scope_information = 
+  {
+   scope_variables: int list; (* Variable and Scope ids *)
+ }
+
+type local_information =
+  | LocalVariable of local_variable_information
+  | Scope of scope_information
diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml
index 15843eb9..1bd54470 100644
--- a/debug/DwarfPrinter.ml
+++ b/debug/DwarfPrinter.ml
@@ -19,14 +19,13 @@ open PrintAsmaux
 open Sections
 
 (* The printer is parameterized over target specific functions and a set of dwarf type constants *)
-module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
+module DwarfPrinter(Target: DWARF_TARGET):
     sig
-      val print_debug: out_channel -> dw_entry -> unit
+      val print_debug: out_channel -> debug_entries -> unit
     end =
   struct
 
     open Target
-    open DwarfAbbrevs
 
     (* Byte value to string *)
     let string_of_byte value =
@@ -36,6 +35,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
     let print_label oc lbl =
       fprintf oc "%a:\n" label lbl
 
+    (* Print a positive label *)
+    let print_plabel oc lbl =
+      print_label oc (transl_label lbl)
+
     (* Helper functions for abbreviation printing *)
     let add_byte buf value =
       Buffer.add_string buf (string_of_byte value)
@@ -64,18 +67,15 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
 
     let add_low_pc = add_abbr_entry (0x11,low_pc_type_abbr)
 
-    let add_fun_pc sp buf =
-      match get_fun_addr sp.subprogram_name with
-      | None ->()
-      | Some (a,b) -> add_high_pc buf; add_low_pc buf
-
     let add_declaration = add_abbr_entry (0x3c,declaration_type_abbr)
 
     let add_location loc buf =
       match loc with
       | None -> ()
-      | Some (LocConst _) -> add_abbr_entry (0x2,location_const_type_abbr) buf
-      | Some (LocBlock _) -> add_abbr_entry (0x2,location_block_type_abbr) buf
+      | Some (LocRef _) -> add_abbr_entry (0x2,location_ref_type_abbr) buf
+      | Some (LocList _ )
+      | Some (LocSymbol _)
+      | Some (LocSimple _) -> add_abbr_entry (0x2,location_block_type_abbr) buf
 
     (* Dwarf entity to string function *)
     let abbrev_string_of_entity entity has_sibling =
@@ -105,8 +105,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
       | DW_TAG_compile_unit e ->
           prologue 0x11;
           add_abbr_entry (0x1b,comp_dir_type_abbr) buf;
-          add_high_pc buf;
           add_low_pc buf;
+          add_high_pc buf;
           add_abbr_entry (0x13,language_type_abbr) buf;
           add_name buf;
           add_abbr_entry (0x25,producer_type_abbr) buf;
@@ -129,32 +129,31 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
           prologue 0x5;
           add_attr_some e.formal_parameter_file_loc add_file_loc;
           add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr));
-          add_location  e.formal_parameter_location buf;
           add_attr_some e.formal_parameter_name add_name;
-          add_location e.formal_parameter_segment buf;
           add_type buf;
-          add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr))
+          add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr));
+          add_location  e.formal_parameter_location buf
       | DW_TAG_label _ ->
           prologue 0xa;
           add_low_pc buf;
           add_name buf;
-      | DW_TAG_lexical_block _ ->
+      | DW_TAG_lexical_block a ->
           prologue 0xb;
-          add_high_pc buf;
-          add_low_pc buf
+          add_attr_some a.lexical_block_high_pc add_high_pc;
+          add_attr_some a.lexical_block_low_pc add_low_pc
       | DW_TAG_member e ->
           prologue 0xd;
           add_attr_some e.member_file_loc add_file_loc;
-          add_attr_some e.member_byte_size add_member_size;
-          add_attr_some e.member_bit_offset (add_abbr_entry (0xd,bit_offset_type_abbr));
-          add_attr_some e.member_bit_size (add_abbr_entry (0xc,bit_size_type_abbr));
+          add_attr_some e.member_byte_size add_byte_size;
+          add_attr_some e.member_bit_offset (add_abbr_entry (0xc,bit_offset_type_abbr));
+          add_attr_some e.member_bit_size (add_abbr_entry (0xd,bit_size_type_abbr));
+          add_attr_some e.member_declaration add_declaration;
+          add_attr_some e.member_name add_name;
+          add_type buf;
           (match e.member_data_member_location with
           | None -> ()
           | Some (DataLocBlock __) -> add_abbr_entry (0x38,data_location_block_type_abbr) buf
-          | Some (DataLocRef _) -> add_abbr_entry (0x38,data_location_ref_type_abbr) buf);
-          add_attr_some e.member_declaration add_declaration;
-          add_attr_some e.member_name add_name;
-          add_type buf
+          | Some (DataLocRef _) -> add_abbr_entry (0x38,data_location_ref_type_abbr) buf)
       | DW_TAG_pointer_type _ ->
           prologue 0xf;
           add_type buf
@@ -166,9 +165,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
           add_attr_some e.structure_name add_name
       | DW_TAG_subprogram e ->
           prologue 0x2e;
-          add_attr_some e.subprogram_file_loc add_file_loc;
+          add_file_loc buf;
           add_attr_some e.subprogram_external (add_abbr_entry (0x3f,external_type_abbr));
-          add_fun_pc e buf;
+          add_attr_some e.subprogram_high_pc add_high_pc;
+          add_attr_some e.subprogram_low_pc add_low_pc;
           add_name buf;
           add_abbr_entry (0x27,prototyped_type_abbr) buf;
           add_attr_some e.subprogram_type add_type;
@@ -200,12 +200,11 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
           add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr))
       | DW_TAG_variable e ->
           prologue 0x34;
-          add_attr_some e.variable_file_loc add_file_loc;
+          add_file_loc buf;
           add_attr_some e.variable_declaration add_declaration;
           add_attr_some e.variable_external (add_abbr_entry (0x3f,external_type_abbr));
           add_location  e.variable_location buf;
           add_name buf;
-          add_location e.variable_segment buf;
           add_type buf
       | DW_TAG_volatile_type _ ->
           prologue 0x35;
@@ -246,10 +245,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
     let print_abbrev oc =
       let abbrevs = Hashtbl.fold (fun s i acc -> (s,i)::acc) abbrev_mapping [] in
       let abbrevs = List.sort (fun (_,a) (_,b) -> Pervasives.compare a b) abbrevs in
-      fprintf oc "	.section	%s\n" (name_of_section Section_debug_abbrev);
-      let lbl = new_label () in
-      abbrev_start_addr := lbl;
-      print_label oc lbl;
+      section oc Section_debug_abbrev;
+      print_label oc !abbrev_start_addr;
       List.iter (fun (s,id) ->
         fprintf oc "	.uleb128	%d\n" id;
         output_string oc s;
@@ -259,6 +256,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
 
     let debug_start_addr = ref (-1)
 
+    let debug_stmt_list = ref (-1)
+
     let entry_labels: (int,int) Hashtbl.t = Hashtbl.create 7
 
     (* Translate the ids to address labels *)
@@ -270,15 +269,28 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
         Hashtbl.add entry_labels id label;
         label
 
+    let loc_labels: (int,int) Hashtbl.t = Hashtbl.create 7
+
+    (* Translate the ids to address labels *)
+    let loc_to_label id =
+      try
+        Hashtbl.find loc_labels id
+      with Not_found ->
+        let label = new_label () in
+        Hashtbl.add loc_labels id label;
+        label
+
+    let print_loc_ref oc r =
+      let ref = loc_to_label r in
+      fprintf oc "	.4byte		%a\n" label ref
+
+
     (* Helper functions for debug printing *)
     let print_opt_value oc o f =
       match o with
       | None -> ()
       | Some o -> f oc o
 
-    let print_file_loc oc f =
-      print_opt_value oc f print_file_loc
-
     let print_flag oc b =
       output_string oc (string_of_byte b)
 
@@ -294,16 +306,77 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
     let print_byte oc b =
       fprintf oc "	.byte		0x%X\n" b
 
-    let print_loc oc loc =
-      ()
-
-    let print_data_location oc dl =
-      ()
+    let print_2byte oc b =
+      fprintf oc "	.2byte		0x%X\n" b
 
     let print_ref oc r =
       let ref = entry_to_label r in
       fprintf oc "	.4byte		%a\n" label ref
 
+    let print_file_loc oc = function
+      | Some (Diab_file_loc (file,col)) ->
+          fprintf oc "	.4byte		%a\n" label file;
+          print_uleb128 oc col
+      | Some (Gnu_file_loc (file,col)) ->
+          fprintf oc "	.4byte		%l\n" file;
+          print_uleb128 oc col 
+     | None -> ()
+
+    let print_loc_expr oc = function
+      | DW_OP_bregx (a,b) ->
+          print_byte oc dw_op_bregx;
+          print_uleb128 oc a;
+          fprintf oc "	.sleb128	%ld\n" b
+      | DW_OP_plus_uconst i ->
+          print_byte oc dw_op_plus_uconst;
+          print_uleb128 oc i
+      | DW_OP_piece i ->
+          print_byte oc dw_op_piece;
+          print_uleb128 oc i
+      | DW_OP_reg i ->
+          if i < 32 then
+            print_byte oc (dw_op_reg0 + i)
+          else begin
+            print_byte oc dw_op_regx;
+            print_uleb128 oc i
+          end
+
+    let print_loc oc loc =
+      match loc with
+      | LocSymbol s ->
+          print_sleb128 oc 5;
+          print_byte oc dw_op_addr;
+          fprintf oc "	.4byte		%a\n" symbol s
+      | LocSimple e ->
+          print_sleb128 oc (size_of_loc_expr e);
+          print_loc_expr oc e
+      | LocList e ->
+          let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in
+          print_sleb128 oc size;
+          List.iter (print_loc_expr oc) e
+      | LocRef f ->  print_loc_ref oc f
+
+    let print_list_loc oc = function
+      | LocSymbol s ->
+          print_2byte oc 5;
+          print_byte oc dw_op_addr;
+          fprintf oc "	.4byte		%a\n" symbol s
+      | LocSimple e ->
+          print_2byte oc (size_of_loc_expr e);
+          print_loc_expr oc e
+      | LocList e ->
+          let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in
+          print_2byte oc size;
+          List.iter (print_loc_expr oc) e
+      | LocRef f ->  print_loc_ref oc f
+
+    let print_data_location oc dl =
+      match dl with
+      | DataLocBlock e ->
+          print_sleb128 oc (size_of_loc_expr e);
+          print_loc_expr oc e
+      | _ -> ()
+
     let print_addr oc a =
       fprintf oc "	.4byte		%a\n" label a
 
@@ -334,14 +407,20 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
       print_string oc bt.base_type_name
 
     let print_compilation_unit oc tag =
-      let prod_name = sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:%s" Version.version Configuration.arch in
+      let version_string =  
+        if Version.buildnr <> "" && Version.tag <> "" then
+          sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag
+        else
+          Version.version in
+      let prod_name = sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:(%s,%s,%s,%s)" 
+          version_string Configuration.arch Configuration.system Configuration.abi Configuration.model in
       print_string oc (Sys.getcwd ());
-      print_addr oc (get_end_addr ());
-      print_addr oc (get_start_addr ());
+      print_addr oc tag.compile_unit_low_pc;
+      print_addr oc tag.compile_unit_high_pc;
       print_uleb128 oc 1;
       print_string oc tag.compile_unit_name;
       print_string oc prod_name;
-      print_addr oc (get_stmt_list_addr ())
+      print_addr oc !debug_stmt_list
 
     let print_const_type oc ct =
       print_ref oc ct.const_type
@@ -360,29 +439,30 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
     let print_formal_parameter oc fp =
       print_file_loc oc fp.formal_parameter_file_loc;
       print_opt_value oc fp.formal_parameter_artificial print_flag;
-      print_opt_value oc fp.formal_parameter_location print_loc;
       print_opt_value oc fp.formal_parameter_name print_string;
-      print_opt_value oc fp.formal_parameter_segment print_loc;
       print_ref oc fp.formal_parameter_type;
-      print_opt_value oc fp.formal_parameter_variable_parameter print_flag
+      print_opt_value oc fp.formal_parameter_variable_parameter print_flag;
+      print_opt_value oc fp.formal_parameter_location print_loc
 
     let print_tag_label oc tl =
       print_ref oc tl.label_low_pc;
       print_string oc tl.label_name
 
+
     let print_lexical_block oc lb =
-      print_ref oc lb.lexical_block_high_pc;
-      print_ref oc lb.lexical_block_low_pc
+      print_opt_value oc lb.lexical_block_high_pc print_addr;
+      print_opt_value oc lb.lexical_block_low_pc print_addr
 
     let print_member oc mb =
       print_file_loc oc mb.member_file_loc;
       print_opt_value oc mb.member_byte_size print_byte;
       print_opt_value oc mb.member_bit_offset print_byte;
       print_opt_value oc mb.member_bit_size print_byte;
-      print_opt_value oc mb.member_data_member_location print_data_location;
       print_opt_value oc mb.member_declaration print_flag;
       print_opt_value oc mb.member_name print_string;
-      print_ref oc mb.member_type
+      print_ref oc mb.member_type;
+      print_opt_value oc mb.member_data_member_location print_data_location
+
 
     let print_pointer oc pt =
       print_ref oc pt.pointer_type
@@ -398,11 +478,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
       fprintf oc "	.4byte		%a\n" label s
      
     let print_subprogram oc sp =
-      let addr = get_fun_addr sp.subprogram_name  in
-      print_file_loc oc sp.subprogram_file_loc;
+      print_file_loc oc (Some sp.subprogram_file_loc);
       print_opt_value oc sp.subprogram_external print_flag;
-      print_opt_value oc sp.subprogram_frame_base print_loc;
-      print_opt_value oc addr print_subprogram_addr;
+      print_opt_value oc sp.subprogram_high_pc print_addr;
+      print_opt_value oc sp.subprogram_low_pc print_addr;
       print_string oc sp.subprogram_name;
       print_flag oc sp.subprogram_prototyped;
       print_opt_value oc sp.subprogram_type print_ref
@@ -431,12 +510,11 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
       print_opt_value oc up.unspecified_parameter_artificial print_flag
 
     let print_variable oc var =
-      print_file_loc oc var.variable_file_loc;
+      print_file_loc oc (Some var.variable_file_loc);
       print_opt_value oc var.variable_declaration print_flag;
       print_opt_value oc var.variable_external print_flag;
       print_opt_value oc var.variable_location print_loc;
       print_string oc var.variable_name;
-      print_opt_value oc var.variable_segment print_loc;
       print_ref oc var.variable_type
 
     let print_volatile_type oc vt =
@@ -482,16 +560,16 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
           print_sleb128 oc 0) entry
 
     (* Print the debug abbrev section *)
-    let print_debug_abbrev oc entry =
-      compute_abbrev entry;
+    let print_debug_abbrev oc entries =
+      List.iter (fun (_,_,_,e,_) -> compute_abbrev e) entries;
       print_abbrev oc
 
     (* Print the debug info section *)
-    let print_debug_info oc entry =
-      let debug_start = new_label () in
-      debug_start_addr:= debug_start;
-      fprintf oc"	.section	%s\n" (name_of_section Section_debug_info);
-      print_label oc debug_start;
+    let print_debug_info oc start line_start entry  =
+      Hashtbl.reset entry_labels;
+      debug_start_addr:= start;
+      debug_stmt_list:= line_start;
+      print_label oc start;
       let debug_length_start = new_label ()  (* Address used for length calculation *)
       and debug_end = new_label () in
       fprintf oc "	.4byte		%a-%a\n" label debug_end label debug_length_start;
@@ -503,10 +581,58 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS):
       print_sleb128 oc 0;
       print_label oc debug_end (* End of the debug section *)
 
+    let print_location_entry oc c_low l =
+      print_label oc (loc_to_label l.loc_id);
+      List.iter (fun (b,e,loc) ->
+        fprintf oc "	.4byte		%a-%a\n" label b label c_low;
+        fprintf oc "	.4byte		%a-%a\n" label e label c_low;
+        print_list_loc oc loc) l.loc;
+      fprintf oc "	.4byte	0\n";
+      fprintf oc "	.4byte	0\n"
+
+    let print_location_entry_abs oc l =
+      print_label oc (loc_to_label l.loc_id);
+      List.iter (fun (b,e,loc) ->
+        fprintf oc "	.4byte		%a\n" label b;
+        fprintf oc "	.4byte		%a\n" label e;
+        print_list_loc oc loc) l.loc;
+      fprintf oc "	.4byte	0\n";
+      fprintf oc "	.4byte	0\n"
+
+
+    let print_location_list oc (c_low,l) =
+      let f =  match c_low with
+      | Some s -> print_location_entry oc s
+      | None -> print_location_entry_abs oc in
+     List.iter f l
+
+    let print_diab_entries oc entries =
+      let abbrev_start = new_label () in
+      abbrev_start_addr := abbrev_start;  
+      print_debug_abbrev oc entries;
+      List.iter (fun (s,d,l,e,_) ->
+        section oc (Section_debug_info s);      
+        print_debug_info oc d l e) entries;
+      section oc Section_debug_loc;
+      List.iter (fun (_,_,_,_,l) -> print_location_list oc l) entries
+
+    let print_gnu_entries oc cp loc =
+      compute_abbrev cp;
+      let line_start = new_label ()
+      and start = new_label ()
+      and  abbrev_start = new_label () in
+      abbrev_start_addr := abbrev_start;
+      section oc (Section_debug_info "");
+      print_debug_info oc start line_start cp;
+      print_abbrev oc;
+      section oc Section_debug_loc;
+      print_location_list oc loc;
+      section oc (Section_debug_line "");
+      print_label oc line_start
 
     (* Print the debug info and abbrev section *)
-    let print_debug oc entry =
-      print_debug_abbrev oc entry;
-      print_debug_info oc entry
+    let print_debug oc = function
+      | Diab entries -> print_diab_entries oc entries
+      | Gnu (cp,loc) -> print_gnu_entries oc cp loc
 
   end
diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli
index 9e0e6693..e1e10601 100644
--- a/debug/DwarfPrinter.mli
+++ b/debug/DwarfPrinter.mli
@@ -12,7 +12,7 @@
 
 open DwarfTypes
 
-module DwarfPrinter: functor (Target: DWARF_TARGET) -> functor (DwarfAbbrevs: DWARF_ABBREVS) ->
+module DwarfPrinter: functor (Target: DWARF_TARGET) ->
   sig
-    val print_debug: out_channel -> dw_entry -> unit
+    val print_debug: out_channel -> debug_entries -> unit
   end
diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli
index eaf07e1e..8f03eb8d 100644
--- a/debug/DwarfTypes.mli
+++ b/debug/DwarfTypes.mli
@@ -12,6 +12,8 @@
 
 (* Types used for writing dwarf debug information *)
 
+open BinNums
+open Camlcoq
 open Sections
 
 (* Basic types for the value of attributes *)
@@ -36,12 +38,20 @@ type address = int
 
 type block = string
 
-type location_value =
-  | LocConst of constant
-  | LocBlock of block
+type location_expression =
+  | DW_OP_plus_uconst of constant
+  | DW_OP_bregx of int * int32
+  | DW_OP_piece of int
+  | DW_OP_reg of int
 
+type location_value =
+  | LocSymbol of atom
+  | LocRef of address
+  | LocSimple of location_expression
+  | LocList of location_expression list
+        
 type data_location_value =
-  | DataLocBlock of block
+  | DataLocBlock of location_expression
   | DataLocRef of reference
 
 type bound_value =
@@ -50,8 +60,10 @@ type bound_value =
 
 (* Types representing the attribute information per tag value *)
 
-type file_loc = string * constant
-
+type file_loc = 
+  | Diab_file_loc of int * constant
+  | Gnu_file_loc of int * constant
+     
 type dw_tag_array_type =
     {
      array_type_file_loc: file_loc option;
@@ -67,7 +79,9 @@ type dw_tag_base_type =
 
 type dw_tag_compile_unit =
     {
-     compile_unit_name:            string;
+     compile_unit_name:      string;
+     compile_unit_low_pc:    int;
+     compile_unit_high_pc:   int;
    }
 
 type dw_tag_const_type =
@@ -94,11 +108,10 @@ type dw_tag_formal_parameter =
     {
      formal_parameter_file_loc:           file_loc       option;
      formal_parameter_artificial:         flag           option;
-     formal_parameter_location:           location_value option;
      formal_parameter_name:               string         option;
-     formal_parameter_segment:            location_value option;
      formal_parameter_type:               reference;
      formal_parameter_variable_parameter: flag           option;
+     formal_parameter_location:           location_value option;
    }
 
 type dw_tag_label =
@@ -109,8 +122,8 @@ type dw_tag_label =
 
 type dw_tag_lexical_block =
     {
-     lexical_block_high_pc: address;
-     lexical_block_low_pc:  address;
+     lexical_block_high_pc: address option;
+     lexical_block_low_pc:  address option;
    }
 
 type dw_tag_member =
@@ -140,12 +153,13 @@ type dw_tag_structure_type =
 
 type dw_tag_subprogram =
     {
-     subprogram_file_loc:   file_loc       option;
-     subprogram_external:   flag           option;
-     subprogram_frame_base: location_value option;
+     subprogram_file_loc:   file_loc;
+     subprogram_external:   flag      option;
      subprogram_name:       string;
      subprogram_prototyped: flag;
-     subprogram_type:       reference      option;
+     subprogram_type:       reference option;
+     subprogram_high_pc:    reference option;
+     subprogram_low_pc:     reference option;
    }
 
 type dw_tag_subrange_type =
@@ -183,13 +197,12 @@ type dw_tag_unspecified_parameter =
 
 type dw_tag_variable =
     {
-     variable_file_loc:    file_loc       option;
+     variable_file_loc:    file_loc;
      variable_declaration: flag           option;
      variable_external:    flag           option;
-     variable_location:    location_value option;
      variable_name:        string;
-     variable_segment:     location_value option;
      variable_type:        reference;
+     variable_location:    location_value option;
    }
 
 type dw_tag_volatile_type =
@@ -228,46 +241,26 @@ type dw_entry =
      id:       reference;
    }
 
-(* Module type for a matching from type to dwarf encoding *)
-module type DWARF_ABBREVS =
-  sig
-    val sibling_type_abbr: int
-    val file_loc_type_abbr: int * int
-    val type_abbr: int
-    val name_type_abbr: int
-    val encoding_type_abbr: int
-    val byte_size_type_abbr: int
-    val member_size_abbr: int
-    val high_pc_type_abbr: int
-    val low_pc_type_abbr: int
-    val stmt_list_type_abbr: int
-    val declaration_type_abbr: int
-    val external_type_abbr: int
-    val prototyped_type_abbr: int
-    val bit_offset_type_abbr: int
-    val comp_dir_type_abbr: int
-    val language_type_abbr: int
-    val producer_type_abbr: int
-    val value_type_abbr: int
-    val artificial_type_abbr: int
-    val variable_parameter_type_abbr: int
-    val bit_size_type_abbr: int
-    val location_const_type_abbr: int
-    val location_block_type_abbr: int
-    val data_location_block_type_abbr: int
-    val data_location_ref_type_abbr: int
-    val bound_const_type_abbr: int
-    val bound_ref_type_abbr: int
-  end
+(* The type for the location list. *)
+type location_entry =
+    {
+     loc:     (int * int * location_value) list;
+     loc_id:  reference;
+   }
+type dw_locations = int option * location_entry list
+
+type diab_entries =  (string * int * int * dw_entry * dw_locations) list
+
+type gnu_entries = dw_entry * dw_locations
+
+type debug_entries =
+  | Diab of diab_entries
+  | Gnu of gnu_entries
 
 (* The target specific functions for printing the debug information *)
 module type DWARF_TARGET=
   sig
     val label: out_channel -> int -> unit
-    val print_file_loc: out_channel -> file_loc -> unit
-    val get_start_addr: unit -> int
-    val get_end_addr: unit -> int
-    val get_stmt_list_addr: unit -> int    
-    val name_of_section: section_name -> string
-    val get_fun_addr: string -> (int * int) option
+    val section: out_channel -> section_name -> unit
+    val symbol: out_channel -> atom -> unit
   end
diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml
index f47c2b58..16e446ee 100644
--- a/debug/DwarfUtil.ml
+++ b/debug/DwarfUtil.ml
@@ -14,18 +14,8 @@
 
 open DwarfTypes
 
-let id = ref 0
-
-let next_id () =
-  let nid = !id in
-  incr id; nid
-
-let reset_id () =
-  id := 0
-
 (* Generate a new entry from a given tag *)
-let new_entry tag =
-  let id = next_id () in
+let new_entry id tag =
   {
    tag = tag;
    children = [];
@@ -86,34 +76,67 @@ let dw_form_ref8     = 0x14
 let dw_ref_udata     = 0x15
 let dw_ref_indirect  = 0x16
 
+(* Operation encoding *)
+let dw_op_addr = 0x3
+let dw_op_plus_uconst = 0x23
+let dw_op_reg0 = 0x50
+let dw_op_regx = 0x90
+let dw_op_bregx = 0x92
+let dw_op_piece = 0x93
+
+
 (* Default corresponding encoding for the different abbreviations *)
-module DefaultAbbrevs =
-  struct
-    let sibling_type_abbr = dw_form_ref4
-    let file_loc_type_abbr = dw_form_data4,dw_form_udata
-    let type_abbr = dw_form_ref_addr
-    let name_type_abbr = dw_form_string
-    let encoding_type_abbr = dw_form_data1
-    let byte_size_type_abbr = dw_form_data1
-    let member_size_abbr = dw_form_udata
-    let high_pc_type_abbr = dw_form_addr
-    let low_pc_type_abbr = dw_form_addr
-    let stmt_list_type_abbr = dw_form_data4
-    let declaration_type_abbr = dw_form_flag
-    let external_type_abbr = dw_form_flag
-    let prototyped_type_abbr = dw_form_flag
-    let bit_offset_type_abbr = dw_form_data1
-    let comp_dir_type_abbr = dw_form_string
-    let language_type_abbr = dw_form_udata
-    let producer_type_abbr = dw_form_string
-    let value_type_abbr = dw_form_sdata
-    let artificial_type_abbr = dw_form_flag
-    let variable_parameter_type_abbr = dw_form_flag
-    let bit_size_type_abbr = dw_form_data1
-    let location_const_type_abbr = dw_form_data4
-    let location_block_type_abbr = dw_form_block
-    let data_location_block_type_abbr = dw_form_block
-    let data_location_ref_type_abbr = dw_form_ref4
-    let bound_const_type_abbr = dw_form_udata
-    let bound_ref_type_abbr=dw_form_ref4
-  end
+let sibling_type_abbr = dw_form_ref4
+let file_loc_type_abbr = dw_form_data4,dw_form_udata
+let type_abbr = dw_form_ref_addr
+let name_type_abbr = dw_form_string
+let encoding_type_abbr = dw_form_data1
+let byte_size_type_abbr = dw_form_data1
+let member_size_abbr = dw_form_udata
+let high_pc_type_abbr = dw_form_addr
+let low_pc_type_abbr = dw_form_addr
+let stmt_list_type_abbr = dw_form_data4
+let declaration_type_abbr = dw_form_flag
+let external_type_abbr = dw_form_flag
+let prototyped_type_abbr = dw_form_flag
+let bit_offset_type_abbr = dw_form_data1
+let comp_dir_type_abbr = dw_form_string
+let language_type_abbr = dw_form_udata
+let producer_type_abbr = dw_form_string
+let value_type_abbr = dw_form_sdata
+let artificial_type_abbr = dw_form_flag
+let variable_parameter_type_abbr = dw_form_flag
+let bit_size_type_abbr = dw_form_data1
+let location_ref_type_abbr = dw_form_data4
+let location_block_type_abbr = dw_form_block
+let data_location_block_type_abbr = dw_form_block
+let data_location_ref_type_abbr = dw_form_ref4
+let bound_const_type_abbr = dw_form_udata
+let bound_ref_type_abbr=dw_form_ref4
+
+(* Sizeof functions for the encoding of uleb128 and sleb128 *)
+let sizeof_uleb128 value =
+  let size = ref 1 in
+  let value = ref (value lsr 7) in
+  while !value <> 0 do
+    value := !value lsr 7;
+    incr size;
+  done;
+  !size
+
+let sizeof_sleb128 value =
+  let size = ref 1 in
+  let byte = ref (value land 0x7f) in
+  let value = ref (value lsr 7) in
+  while not ((!value = 0 && (!byte land 0x40) = 0) || (!value = -1 && ((!byte land 0x40) <> 0))) do
+    byte := !value land 0x7f;
+    value := !value lsr 7;
+    incr size;
+  done;
+  !size
+
+let size_of_loc_expr = function
+  | DW_OP_bregx (a,b) -> 1 + (sizeof_uleb128 a)  + (sizeof_sleb128 (Int32.to_int b))
+  | DW_OP_plus_uconst a
+  | DW_OP_piece a -> 1 + (sizeof_uleb128 a)
+  | DW_OP_reg i -> if i < 32 then 1 else  2
diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml
new file mode 100644
index 00000000..eff80110
--- /dev/null
+++ b/debug/Dwarfgen.ml
@@ -0,0 +1,490 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Bernhard Schommer, AbsInt Angewandte Informatik GmbH       *)
+(*                                                                     *)
+(*  AbsInt Angewandte Informatik GmbH. All rights reserved. This file  *)
+(*  is distributed under the terms of the INRIA Non-Commercial         *)
+(*  License Agreement.                                                 *)
+(*                                                                     *)
+(* *********************************************************************)
+
+open AST
+open C
+open Camlcoq
+open Cutil
+open DebugInformation
+open DebugTypes
+open DwarfTypes
+open DwarfUtil
+
+(* Generate the dwarf DIE's from the information collected in DebugInformation *)
+
+(* Helper function to get values that must be set. *)
+let get_opt_val = function
+  | Some a -> a
+  | None -> assert false
+
+(* Auxiliary data structures and functions *)
+module IntSet = Set.Make(struct
+  type t = int
+  let compare (x:int) (y:int) = compare x y
+end)
+
+let rec mmap f env = function
+  | [] -> ([],env)
+  | hd :: tl ->
+      let (hd',env1) = f env hd in
+      let (tl', env2) = mmap f env1 tl in
+      (hd' :: tl', env2)
+
+let rec mmap_opt f env = function
+  | [] -> ([],env)
+  | hd :: tl ->
+      let (hd',env1) = f env hd in
+      let (tl', env2) = mmap_opt f env1 tl in
+      begin
+        match hd' with
+        | Some hd -> (hd :: tl', env2)
+        | None -> tl',env2
+      end
+
+(* Functions to translate the basetypes. *)
+let int_type_to_entry id i =
+   let encoding =
+    (match i.int_kind with
+    | IBool -> DW_ATE_boolean
+    | IChar ->
+        if !Machine.config.Machine.char_signed then 
+          DW_ATE_signed_char 
+        else 
+          DW_ATE_unsigned_char
+    | IInt | ILong | ILongLong | IShort | ISChar -> DW_ATE_signed
+    | _ -> DW_ATE_unsigned)in
+  let int = {
+    base_type_byte_size = sizeof_ikind i.int_kind;
+    base_type_encoding = Some encoding;
+    base_type_name = typ_to_string (TInt (i.int_kind,[]));} in
+  new_entry id (DW_TAG_base_type int)
+
+let float_type_to_entry id f = 
+  let byte_size = sizeof_fkind f.float_kind in
+  let float = {
+    base_type_byte_size = byte_size;
+    base_type_encoding = Some DW_ATE_float;
+    base_type_name = typ_to_string (TFloat (f.float_kind,[]));
+  } in
+  new_entry id (DW_TAG_base_type float)
+
+let void_to_entry id =
+  let void = {
+    base_type_byte_size = 0;
+    base_type_encoding = None;
+    base_type_name = "void";
+  } in
+  new_entry id (DW_TAG_base_type void)
+
+let file_loc_opt file = function
+  | None -> None
+  | Some (f,l) ->
+    try 
+      Some (file (f,l))
+    with Not_found -> None
+
+let typedef_to_entry file id t =
+  let i = get_opt_val t.typ in
+  let td = {
+    typedef_file_loc = file_loc_opt file t.typedef_file_loc;
+    typedef_name = t.typedef_name;
+    typedef_type = i;
+  } in
+  new_entry id (DW_TAG_typedef td) 
+
+let pointer_to_entry id p =
+  let p = {pointer_type = p.pts} in
+  new_entry id (DW_TAG_pointer_type p)
+
+let array_to_entry id arr =
+  let arr_tag = {
+    array_type_file_loc = None;
+    array_type = arr.arr_type;
+  } in
+  let arr_entry = new_entry id (DW_TAG_array_type arr_tag) in
+  let children = List.map (fun a ->
+    let r = match a with
+    | None -> None
+    | Some i ->
+        let bound = Int64.to_int (Int64.sub i Int64.one) in
+        Some (BoundConst bound) in
+    let s = {
+       subrange_type = None;
+       subrange_upper_bound = r;
+    } in
+    new_entry (next_id ()) (DW_TAG_subrange_type s)) arr.arr_size in
+  add_children arr_entry children
+
+let const_to_entry id c =
+  new_entry id (DW_TAG_const_type ({const_type = c.cst_type}))
+
+let volatile_to_entry id v =
+  new_entry id (DW_TAG_volatile_type ({volatile_type = v.vol_type}))
+
+let enum_to_entry file id e =
+  let enumerator_to_entry e =
+    let tag =
+      {
+       enumerator_file_loc = None;
+       enumerator_value = Int64.to_int (e.enumerator_const);
+       enumerator_name = e.enumerator_name;
+     } in
+    new_entry (next_id ()) (DW_TAG_enumerator tag) in
+  let bs = sizeof_ikind enum_ikind in
+  let enum = {
+    enumeration_file_loc = file_loc_opt file e.enum_file_loc;
+    enumeration_byte_size = bs;
+    enumeration_declaration = Some false;
+    enumeration_name = Some e.enum_name;
+  } in
+  let enum = new_entry id (DW_TAG_enumeration_type enum) in
+  let child = List.map enumerator_to_entry e.enum_enumerators in
+  add_children enum child
+
+let fun_type_to_entry id f =
+  let children = if f.fun_prototyped then
+    let u = {
+      unspecified_parameter_file_loc = None;
+      unspecified_parameter_artificial = None;
+    } in
+    [new_entry (next_id ()) (DW_TAG_unspecified_parameter u)]
+  else
+    List.map (fun p ->
+      let fp = {
+        formal_parameter_file_loc = None;
+        formal_parameter_artificial = None;
+        formal_parameter_name = if p.param_name <> "" then Some p.param_name else None;
+        formal_parameter_type = p.param_type;
+        formal_parameter_variable_parameter = None;
+        formal_parameter_location = None;
+      } in
+      new_entry (next_id ()) (DW_TAG_formal_parameter fp)) f.fun_params;
+  in
+  let s = {
+    subroutine_type = f.fun_return_type;
+    subroutine_prototyped = f.fun_prototyped
+  } in
+  let s = new_entry id (DW_TAG_subroutine_type s) in
+  add_children s children
+
+let member_to_entry mem =
+  let mem = {
+    member_file_loc = None;
+    member_byte_size = mem.cfd_byte_size;
+    member_bit_offset = mem.cfd_bit_offset;
+    member_bit_size = mem.cfd_bit_size;
+    member_data_member_location =
+    (match mem.cfd_byte_offset with 
+    | None -> None 
+    | Some s -> Some (DataLocBlock (DW_OP_plus_uconst s)));
+    member_declaration = None;
+    member_name = Some (mem.cfd_name);
+    member_type = mem.cfd_typ;
+  } in
+  new_entry (next_id ()) (DW_TAG_member mem)
+
+let struct_to_entry file id s =
+  let tag = {
+     structure_file_loc = file_loc_opt file s.ct_file_loc;
+     structure_byte_size = s.ct_sizeof;
+     structure_declaration = if s.ct_declaration then Some s.ct_declaration else None;
+     structure_name = if s.ct_name <> "" then Some s.ct_name else None;
+  } in
+  let entry = new_entry id (DW_TAG_structure_type tag) in
+  let child = List.map member_to_entry s.ct_members in
+  add_children entry child
+
+let union_to_entry file id s =
+  let tag = {
+    union_file_loc =  file_loc_opt file s.ct_file_loc;
+    union_byte_size = s.ct_sizeof;
+    union_declaration = if s.ct_declaration then Some s.ct_declaration else None;
+    union_name = if s.ct_name <> "" then Some s.ct_name else None;
+  } in
+  let entry = new_entry id (DW_TAG_union_type tag) in
+  let child = List.map member_to_entry s.ct_members in
+  add_children entry child
+
+let composite_to_entry file id s =
+  match s.ct_sou with
+  | Struct -> struct_to_entry file id s
+  | Union -> union_to_entry file id s
+
+let infotype_to_entry file id = function
+  | IntegerType i -> int_type_to_entry id i
+  | FloatType f -> float_type_to_entry id f
+  | PointerType p -> pointer_to_entry id p
+  | ArrayType arr -> array_to_entry id arr
+  | CompositeType c -> composite_to_entry file id c
+  | EnumType e -> enum_to_entry file id e
+  | FunctionType f -> fun_type_to_entry id f
+  | Typedef t -> typedef_to_entry file id t
+  | ConstType c -> const_to_entry id c
+  | VolatileType v -> volatile_to_entry id v
+  | Void -> void_to_entry id
+
+let needs_types id d =
+  let add_type id d =
+    if not (IntSet.mem id d) then
+        IntSet.add id d,true
+      else 
+        d,false in
+  let t = Hashtbl.find types id in
+  match t with
+  | IntegerType _ 
+  | FloatType _
+  | Void
+  | EnumType _ -> d,false
+  | Typedef t ->
+      add_type (get_opt_val t.typ) d
+  | PointerType p -> 
+      add_type p.pts d
+  | ArrayType arr -> 
+      add_type arr.arr_type d
+  | ConstType c ->
+      add_type c.cst_type d
+  | VolatileType v ->
+      add_type v.vol_type d
+  | FunctionType f ->
+      let d,c = match f.fun_return_type with
+      | Some t -> add_type t d 
+      | None -> d,false in
+      List.fold_left (fun (d,c) p ->
+        let d,c' = add_type p.param_type d in
+        d,c||c') (d,c) f.fun_params
+  | CompositeType c -> 
+      List.fold_left (fun (d,c) f ->
+        let d,c' = add_type f.cfd_typ d in
+        d,c||c') (d,false) c.ct_members
+
+let gen_types file needed =
+  let rec aux d =
+    let d,c = IntSet.fold (fun id (d,c) ->
+      let d,c' = needs_types id d in
+      d,c||c') d (d,false) in
+    if c then
+      aux d
+    else
+      d in
+  let typs = aux needed in
+  List.rev (Hashtbl.fold (fun id t acc -> 
+    if IntSet.mem id typs then
+      (infotype_to_entry file id t)::acc
+    else 
+      acc) types [])
+
+let global_variable_to_entry file acc id v =
+  let loc = match v.gvar_atom with
+  | Some a when StringSet.mem (extern_atom a) !printed_vars ->
+        Some (LocSymbol a)
+  | _ -> None in
+  let var = {
+    variable_file_loc = file v.gvar_file_loc;
+    variable_declaration = Some v.gvar_declaration;
+    variable_external = Some v.gvar_external;
+    variable_name = v.gvar_name;
+    variable_type = v.gvar_type;
+    variable_location = loc;
+  } in
+  new_entry id (DW_TAG_variable var),IntSet.add v.gvar_type acc
+
+let gen_splitlong op_hi op_lo =
+  let op_piece = DW_OP_piece 4 in
+  op_piece::op_hi@(op_piece::op_lo)
+  
+let translate_function_loc a = function 
+  | BA_addrstack (ofs) ->
+      let ofs = camlint_of_coqint ofs in
+      Some (LocSimple (DW_OP_bregx (a,ofs))),[]
+  | BA_splitlong (BA_addrstack hi,BA_addrstack lo)->
+      let hi = camlint_of_coqint hi 
+      and lo = camlint_of_coqint lo in
+      if lo = Int32.add hi 4l then
+        Some (LocSimple (DW_OP_bregx (a,hi))),[]
+      else
+        let op_hi = [DW_OP_bregx (a,hi)]
+        and op_lo = [DW_OP_bregx (a,lo)] in
+        Some (LocList (gen_splitlong op_hi op_lo)),[]
+  | _ -> None,[]
+      
+let range_entry_loc (sp,l) =
+  let rec aux = function
+    | BA i ->  [DW_OP_reg i]
+    | BA_addrstack ofs -> 
+        let ofs = camlint_of_coqint ofs in
+        [DW_OP_bregx (sp,ofs)]
+    | BA_splitlong (hi,lo) ->
+        let hi = aux hi
+        and lo = aux lo in
+        gen_splitlong hi lo
+    | _ -> assert false in
+  match aux l with
+  | [] -> assert false
+  | [a] -> LocSimple a
+  | a::rest -> LocList (a::rest)
+
+let location_entry f_id atom =
+  try
+    begin 
+      match (Hashtbl.find var_locations (f_id,atom)) with
+      | FunctionLoc (a,r) ->
+          translate_function_loc a r
+      | RangeLoc l ->
+          let l = List.rev_map (fun i -> 
+            let hi = get_opt_val i.range_start
+            and lo = get_opt_val i.range_end in
+            let hi = Hashtbl.find label_translation (f_id,hi)
+            and lo = Hashtbl.find label_translation (f_id,lo) in
+            hi,lo,range_entry_loc i.var_loc) l in
+          let id = next_id () in
+        Some (LocRef id),[{loc = l;loc_id = id;}]
+    end
+  with Not_found -> None,[]
+
+let function_parameter_to_entry f_id (acc,bcc) p =
+  let loc,loc_list = location_entry f_id (get_opt_val p.parameter_atom) in
+  let p = {
+    formal_parameter_file_loc = None;
+    formal_parameter_artificial = None;
+    formal_parameter_name = Some p.parameter_name;
+    formal_parameter_type = p.parameter_type;
+    formal_parameter_variable_parameter = None;
+    formal_parameter_location = loc;
+  } in
+  new_entry (next_id ()) (DW_TAG_formal_parameter p),(IntSet.add p.formal_parameter_type acc,loc_list@bcc)
+
+let rec local_variable_to_entry file f_id (acc,bcc) v id =
+  match v.lvar_atom with
+  | None -> None,(acc,bcc)
+  | Some loc ->
+      let loc,loc_list = location_entry f_id loc in
+      let var = {
+        variable_file_loc = file v.lvar_file_loc;
+        variable_declaration = None;
+        variable_external = None;
+        variable_name = v.lvar_name;
+        variable_type = v.lvar_type;
+        variable_location = loc;
+      } in
+      Some (new_entry id (DW_TAG_variable var)),(IntSet.add v.lvar_type acc,loc_list@bcc)
+
+and scope_to_entry file f_id acc sc id =
+  let l_pc,h_pc = try
+    let r = Hashtbl.find scope_ranges id in
+    let lbl l = match l with 
+    | Some l -> Some (Hashtbl.find label_translation (f_id,l)) 
+    | None -> None in
+    begin
+      match r with
+      | [] -> None,None
+      | [a] -> lbl a.start_addr, lbl a.end_addr
+      | a::rest -> lbl (List.hd (List.rev rest)).start_addr,lbl a.end_addr
+    end
+  with Not_found -> None,None in
+  let scope = {
+    lexical_block_high_pc = h_pc;
+    lexical_block_low_pc = l_pc;
+  } in
+  let vars,acc = mmap_opt (local_to_entry file f_id) acc sc.scope_variables in
+  let entry = new_entry id (DW_TAG_lexical_block scope) in
+  add_children entry vars,acc
+
+and local_to_entry file f_id acc id =
+  match Hashtbl.find local_variables id with
+  | LocalVariable v -> local_variable_to_entry file f_id acc v id
+  | Scope v -> let s,acc = 
+      (scope_to_entry file f_id acc v id) in 
+    Some s,acc
+
+let fun_scope_to_entries file f_id acc id =
+  match id with
+  | None -> [],acc
+  | Some id ->
+      let sc = Hashtbl.find local_variables id in
+      (match sc with
+      | Scope sc ->mmap_opt (local_to_entry file f_id) acc sc.scope_variables
+      | _ -> assert false)
+
+let function_to_entry file (acc,bcc) id f =
+  let f_tag = {
+    subprogram_file_loc = file f.fun_file_loc;
+    subprogram_external = Some f.fun_external;
+    subprogram_name = f.fun_name;
+    subprogram_prototyped = true;
+    subprogram_type = f.fun_return_type;
+    subprogram_high_pc = f.fun_high_pc;
+    subprogram_low_pc = f.fun_low_pc;
+  } in
+  let f_id = get_opt_val f.fun_atom in
+  let acc = match f.fun_return_type with Some s -> IntSet.add s acc | None -> acc in
+  let f_entry =  new_entry id (DW_TAG_subprogram f_tag) in
+  let params,(acc,bcc) = mmap (function_parameter_to_entry f_id) (acc,bcc) f.fun_parameter in
+  let vars,(acc,bcc) = fun_scope_to_entries file f_id (acc,bcc) f.fun_scope in
+  add_children f_entry (params@vars),(acc,bcc)
+     
+let definition_to_entry file (acc,bcc) id t =
+  match t with
+  | GlobalVariable g -> let e,acc = global_variable_to_entry file acc id g in
+    e,(acc,bcc)
+  | Function f -> function_to_entry file (acc,bcc) id f
+
+module StringMap = Map.Make(String)
+
+let diab_file_loc sec (f,l)  =
+  Diab_file_loc (Hashtbl.find filenum (sec,f),l)
+
+let gen_diab_debug_info sec_name var_section : debug_entries =
+  let defs = Hashtbl.fold (fun id t acc ->
+    let s = match t with
+    | GlobalVariable _ -> var_section
+    | Function f -> sec_name (get_opt_val f.fun_atom) in
+    let old = try StringMap.find s acc with Not_found -> [] in
+    StringMap.add s ((id,t)::old) acc) definitions StringMap.empty in
+  let entries = StringMap.fold (fun s defs acc ->
+    let defs,(ty,locs) = List.fold_left (fun (acc,bcc) (id,t) -> 
+      let t,bcc = definition_to_entry (diab_file_loc s) bcc id t in
+      t::acc,bcc) ([],(IntSet.empty,[])) defs in
+    let low_pc = Hashtbl.find compilation_section_start s
+    and line_start,debug_start,_ = Hashtbl.find diab_additional s
+    and high_pc = Hashtbl.find compilation_section_end s in
+    let cp = {
+      compile_unit_name = !file_name;
+      compile_unit_low_pc = low_pc;
+      compile_unit_high_pc = high_pc; 
+    } in
+    let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in
+    let cp = add_children cp ((gen_types (diab_file_loc s) ty) @ defs) in
+    (s,debug_start,line_start,cp,(Some low_pc,locs))::acc) defs [] in
+  Diab entries
+
+let gnu_file_loc (f,l) =
+    Gnu_file_loc ((fst (Hashtbl.find Fileinfo.filename_info f),l))
+
+let gen_gnu_debug_info sec_name var_section : debug_entries =
+  let low_pc = Hashtbl.find compilation_section_start ".text"
+  and high_pc = Hashtbl.find compilation_section_end ".text" in
+  let defs,(ty,locs),sec = Hashtbl.fold (fun  id t (acc,bcc,sec) -> 
+    let s = match t with
+    | GlobalVariable _ -> var_section
+    | Function f -> sec_name (get_opt_val f.fun_atom) in
+    let t,bcc = definition_to_entry gnu_file_loc bcc id t in
+    t::acc,bcc,StringSet.add s sec) definitions ([],(IntSet.empty,[]),StringSet.empty) in
+  let types = gen_types gnu_file_loc ty in
+  let cp = {
+    compile_unit_name = !file_name;
+    compile_unit_low_pc = low_pc;
+    compile_unit_high_pc = high_pc; 
+  } in
+  let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in
+  let cp = add_children cp (types@defs) in
+  let loc_pc = if StringSet.cardinal sec > 1 then None else Some low_pc in
+  Gnu (cp,(loc_pc,locs))
diff --git a/driver/Driver.ml b/driver/Driver.ml
index f53de821..c7d9984e 100644
--- a/driver/Driver.ml
+++ b/driver/Driver.ml
@@ -108,6 +108,7 @@ let preprocess ifile ofile =
 (* From preprocessed C to Csyntax *)
 
 let parse_c_file sourcename ifile =
+  Debug.init_compile_unit sourcename;
   Sections.initialize();
   (* Simplification options *)
   let simplifs =
@@ -117,10 +118,10 @@ let parse_c_file sourcename ifile =
   ^ (if !option_fpacked_structs then "p" else "")
   in
   (* Parsing and production of a simplified C AST *)
-  let ast,debug =
+  let ast =
     match Parse.preprocessed_file simplifs sourcename ifile with
-    | None,_ -> exit 2
-    | Some p,d -> p,d in
+    | None -> exit 2
+    | Some p -> p in
   (* Save C AST if requested *)
   if !option_dparse then begin
     let ofile = output_filename sourcename ".c" ".parsed.c" in
@@ -141,7 +142,7 @@ let parse_c_file sourcename ifile =
     PrintCsyntax.print_program (Format.formatter_of_out_channel oc) csyntax;
     close_out oc
   end;
-  csyntax,debug
+  csyntax,None
 
 (* Dump Asm code in binary format for the validator *)
 
@@ -571,8 +572,10 @@ let cmdline_actions =
   Prefix "-L", Self push_linker_arg;
   Exact "-T", String (fun s -> if Configuration.system = "diab" then 
     push_linker_arg ("-Wm"^s) 
-  else
-    push_linker_arg ("-T "^s));
+  else begin
+      push_linker_arg ("-T");
+      push_linker_arg(s)
+    end);
   Prefix "-Wl,", Self push_linker_arg;
 (* Tracing options *)
   Exact "-dparse", Set option_dparse;
@@ -682,6 +685,7 @@ let _ =
     Builtins.set C2C.builtins;
     CPragmas.initialize();
     parse_cmdline cmdline_actions;
+    DebugInit.init (); (* Initialize the debug functions *)
     let nolink = !option_c || !option_S || !option_E || !option_interp in
     if nolink && !option_o <> None && !num_source_files >= 2 then begin
       eprintf "Ambiguous '-o' option (multiple source files)\n";
diff --git a/exportclight/ExportClight.ml b/exportclight/ExportClight.ml
index 9563d551..82066cc9 100644
--- a/exportclight/ExportClight.ml
+++ b/exportclight/ExportClight.ml
@@ -250,10 +250,6 @@ let external_function p = function
       fprintf p "(EF_vload %s)" (name_of_chunk chunk)
   | EF_vstore chunk ->
       fprintf p "(EF_vstore %s)" (name_of_chunk chunk)
-  | EF_vload_global(chunk, id, ofs) ->
-      fprintf p "(EF_vload_global %s %a %a)" (name_of_chunk chunk) ident id coqint ofs
-  | EF_vstore_global(chunk, id, ofs) ->
-      fprintf p "(EF_vstore_global %s %a %a)" (name_of_chunk chunk) ident id coqint ofs
   | EF_malloc -> fprintf p "EF_malloc"
   | EF_free -> fprintf p "EF_free"
   | EF_memcpy(sz, al) ->
@@ -264,6 +260,8 @@ let external_function p = function
   | EF_annot_val(text, targ) ->
       assertions := (text, [targ]) :: !assertions;
       fprintf p "(EF_annot_val %ld%%positive %a)" (P.to_int32 text) asttype targ
+  | EF_debug(kind, text, targs) -> 
+      fprintf p "(EF_debug %ld%%positive %ld%%positive %a)" (P.to_int32 kind) (P.to_int32 text) (print_list asttype) targs
   | EF_inline_asm(text, sg, clob) ->
       fprintf p "@[<hov 2>(EF_inline_asm %ld%%positive@ %a@ %a)@]"
               (P.to_int32 text)
diff --git a/extraction/extraction.v b/extraction/extraction.v
index 6327f871..dc7522b8 100644
--- a/extraction/extraction.v
+++ b/extraction/extraction.v
@@ -168,4 +168,5 @@ Separate Extraction
    Machregs.mregs_for_operation Machregs.mregs_for_builtin
    Machregs.two_address_op Machregs.is_stack_reg
    AST.signature_main
+   AST.transform_partial_ident_program
    Parser.translation_unit_file.
diff --git a/flocq/Appli/Fappli_IEEE.v b/flocq/Appli/Fappli_IEEE.v
index 9b5826c1..23999a50 100644
--- a/flocq/Appli/Fappli_IEEE.v
+++ b/flocq/Appli/Fappli_IEEE.v
@@ -48,9 +48,9 @@ Section Binary.
 
 Implicit Arguments exist [[A] [P]].
 
-(** prec is the number of bits of the mantissa including the implicit one
-    emax is the exponent of the infinities
-    Typically p=24 and emax = 128 in single precision *)
+(** [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).
 Hypothesis Hmax : (prec < emax)%Z.
@@ -74,8 +74,7 @@ Definition valid_binary x :=
   end.
 
 (** Basic type used for representing binary FP numbers.
-    Note that there is exactly one such object per FP datum.
-    NaNs do not have any payload. They cannot be distinguished. *)
+    Note that there is exactly one such object per FP datum. *)
 
 Definition nan_pl := {pl | (Zpos (digits2_pos pl) <? prec)%Z  = true}.
 
@@ -382,6 +381,8 @@ Proof.
 now intros [| |? []|].
 Qed.
 
+(** Opposite *)
+
 Definition Bopp opp_nan x :=
   match x with
   | B754_nan sx plx =>
@@ -647,7 +648,8 @@ generalize (prec_gt_0 prec).
 clear -Hmax ; omega.
 Qed.
 
-(** mantissa, round and sticky bits *)
+(** Truncation *)
+
 Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }.
 
 Definition shr_1 mrs :=
@@ -695,7 +697,7 @@ Qed.
 
 Definition shr mrs e n :=
   match n with
-  | Zpos p => (iter_pos p _ shr_1 mrs, (e + n)%Z)
+  | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z)
   | _ => (mrs, e)
   end.
 
@@ -746,24 +748,24 @@ destruct n as [|n|n].
 now destruct l as [|[| |]].
 2: now destruct l as [|[| |]].
 unfold shr.
-rewrite iter_nat_of_P.
+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 [|[| |]].
-simpl nat_rect.
+rewrite iter_nat_S.
 rewrite inj_S.
 unfold Zsucc.
-rewrite  Zplus_assoc.
+rewrite Zplus_assoc.
 revert IHn0.
 apply inbetween_shr_1.
 clear -Hm.
 induction n0.
 now destruct l as [|[| |]].
-simpl.
+rewrite iter_nat_S.
 revert IHn0.
-generalize (iter_nat n0 shr_record shr_1 (shr_record_of_loc m l)).
+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 [|].
@@ -827,6 +829,8 @@ intros H.
 now inversion H.
 Qed.
 
+(** Rounding modes *)
+
 Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA.
 
 Definition round_mode m :=
@@ -927,7 +931,6 @@ destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2).
 rewrite shr_m_shr_record_of_loc.
 intros Hm2.
 rewrite Hm2.
-intros z.
 repeat split.
 rewrite Rlt_bool_true.
 repeat split.
@@ -1178,6 +1181,8 @@ destruct x as [sx|sx|sx [plx Hplx]|sx mx ex Hx], y as [sy|sy|sy [ply Hply]|sy my
 apply B2FF_FF2B.
 Qed.
 
+(** Normalization and rounding *)
+
 Definition shl_align mx ex ex' :=
   match (ex' - ex)%Z with
   | Zneg d => (shift_pos d mx, ex')
@@ -1361,6 +1366,7 @@ now apply F2R_lt_0_compat.
 Qed.
 
 (** Addition *)
+
 Definition Bplus plus_nan m x y :=
   let f pl := B754_nan (fst pl) (snd pl) in
   match x, y with
@@ -1475,7 +1481,7 @@ 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 (canonic_canonic_mantissa sx _ _ Hx') (canonic_canonic_mantissa sy _ _ Hy').
-clear -Bx By Hs.
+clear -Bx By Hs prec_gt_0_.
 intros Cx Cy.
 destruct sx.
 (* ... *)
@@ -1542,6 +1548,8 @@ now apply f_equal.
 apply Sz.
 Qed.
 
+(** Subtraction *)
+
 Definition Bminus minus_nan m x y := Bplus minus_nan m x (Bopp pair y).
 
 Theorem Bminus_correct :
@@ -1571,6 +1579,7 @@ rewrite is_finite_Bopp. auto. now destruct y as [ | | | ].
 Qed.
 
 (** Division *)
+
 Definition Fdiv_core_binary m1 e1 m2 e2 :=
   let d1 := Zdigits2 m1 in
   let d2 := Zdigits2 m2 in
@@ -1737,6 +1746,7 @@ now rewrite B2FF_FF2B.
 Qed.
 
 (** Square root *)
+
 Definition Fsqrt_core_binary m e :=
   let d := Zdigits2 m in
   let s := Zmax (2 * prec - d) 0 in
diff --git a/flocq/Appli/Fappli_IEEE_bits.v b/flocq/Appli/Fappli_IEEE_bits.v
index 5a77bf57..87aa1046 100644
--- a/flocq/Appli/Fappli_IEEE_bits.v
+++ b/flocq/Appli/Fappli_IEEE_bits.v
@@ -617,7 +617,7 @@ apply refl_equal.
 Qed.
 
 Definition default_nan_pl32 : bool * nan_pl 24 :=
-  (false, exist _ (iter_nat 22 _ xO xH) (refl_equal true)).
+  (false, exist _ (iter_nat xO 22 xH) (refl_equal true)).
 
 Definition unop_nan_pl32 (f : binary32) : bool * nan_pl 24 :=
   match f with
@@ -660,7 +660,7 @@ apply refl_equal.
 Qed.
 
 Definition default_nan_pl64 : bool * nan_pl 53 :=
-  (false, exist _ (iter_nat 51 _ xO xH) (refl_equal true)).
+  (false, exist _ (iter_nat xO 51 xH) (refl_equal true)).
 
 Definition unop_nan_pl64 (f : binary64) : bool * nan_pl 53 :=
   match f with
diff --git a/flocq/Appli/Fappli_double_round.v b/flocq/Appli/Fappli_double_round.v
index f83abc47..3ff6c31a 100644
--- a/flocq/Appli/Fappli_double_round.v
+++ b/flocq/Appli/Fappli_double_round.v
@@ -72,12 +72,15 @@ assert (Hx2 : x - round beta fexp1 Zfloor x
               < / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)).
 { now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. }
 set (x'' := round beta fexp2 (Znearest choice2) x).
-assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x)));
-  [now unfold x''; apply ulp_half_error|].
+assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))).
+apply Rle_trans with (/ 2 * ulp beta fexp2 x).
+now unfold x''; apply error_le_half_ulp...
+rewrite ulp_neq_0;[now right|now apply Rgt_not_eq].
 assert (Pxx' : 0 <= x - x').
 { apply Rle_0_minus.
   apply round_DN_pt.
   exact Vfexp1. }
+rewrite 2!ulp_neq_0 in Hx2; try (apply Rgt_not_eq; assumption).
 assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (ln_beta x))).
 { replace (x'' - x') with (x'' - x + (x - x')) by ring.
   apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)).
@@ -114,6 +117,7 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx''].
                              + (bpow (ln_beta x)
                                 - / 2 * bpow (fexp2 (ln_beta x)))) by ring.
       apply Rplus_le_lt_compat; [exact Hr1|].
+      rewrite ulp_neq_0 in Hx1;[idtac| now apply Rgt_not_eq].
       now rewrite Rabs_right; [|apply Rle_ge; apply Rlt_le].
     - unfold x'' in Nzx'' |- *.
       now apply ln_beta_round_ge; [|apply valid_rnd_N|]. }
@@ -168,12 +172,14 @@ assert (Pxx' : 0 <= x - x').
   apply round_DN_pt.
   exact Vfexp1. }
 assert (x < bpow (ln_beta x) - / 2 * bpow (fexp2 (ln_beta x)));
-  [|now apply double_round_lt_mid_further_place'].
+  [|apply double_round_lt_mid_further_place'; try assumption]...
+2: rewrite ulp_neq_0;[assumption|now apply Rgt_not_eq].
 destruct (Req_dec x' 0) as [Zx'|Nzx'].
 - (* x' = 0 *)
   rewrite Zx' in Hx2; rewrite Rminus_0_r in Hx2.
   apply (Rlt_le_trans _ _ _ Hx2).
   rewrite Rmult_minus_distr_l.
+  rewrite 2!ulp_neq_0;[idtac|now apply Rgt_not_eq|now apply Rgt_not_eq].
   apply Rplus_le_compat_r.
   apply (Rmult_le_reg_r (bpow (- ln_beta x))); [now apply bpow_gt_0|].
   unfold ulp, canonic_exp; bpow_simplify.
@@ -199,7 +205,7 @@ destruct (Req_dec x' 0) as [Zx'|Nzx'].
   { apply (Rplus_le_reg_r (ulp beta fexp1 x)); ring_simplify.
     rewrite <- ulp_DN.
     - change (round _ _ _ _) with x'.
-      apply succ_le_bpow.
+      apply id_p_ulp_le_bpow.
       + exact Px'.
       + change x' with (round beta fexp1 Zfloor x).
         now apply generic_format_round; [|apply valid_rnd_DN].
@@ -210,10 +216,14 @@ destruct (Req_dec x' 0) as [Zx'|Nzx'].
     - exact Vfexp1.
     - exact Px'. }
   fold (canonic_exp beta fexp2 x); fold (ulp beta fexp2 x).
-  assert (/ 2 * ulp beta fexp1 x <= ulp beta fexp1 x); [|lra].
+  assert (/ 2 * ulp beta fexp1 x <= ulp beta fexp1 x).
   rewrite <- (Rmult_1_l (ulp _ _ _)) at 2.
   apply Rmult_le_compat_r; [|lra].
-  apply bpow_ge_0.
+  apply ulp_ge_0.
+  rewrite 2!ulp_neq_0 in Hx2;[|now apply Rgt_not_eq|now apply Rgt_not_eq].
+  rewrite ulp_neq_0 in Hx';[|now apply Rgt_not_eq].
+  rewrite ulp_neq_0 in H;[|now apply Rgt_not_eq].
+  lra.
 Qed.
 
 Lemma double_round_lt_mid_same_place :
@@ -256,7 +266,7 @@ assert (H : Rabs (x * bpow (- fexp1 (ln_beta x)) -
     rewrite <- (Rmult_0_r (/ 2)).
     apply Rmult_lt_compat_l; [lra|].
     apply bpow_gt_0.
-  - exact Hx. }
+  - rewrite ulp_neq_0 in Hx;try apply Rgt_not_eq; assumption. }
 unfold round at 2.
 unfold F2R, scaled_mantissa, canonic_exp; simpl.
 rewrite Hf2f1.
@@ -320,8 +330,10 @@ unfold double_round_eq.
 set (x' := round beta fexp1 Zceil x).
 set (x'' := round beta fexp2 (Znearest choice2) x).
 intros Hx1 Hx2.
-assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x)));
-  [now unfold x''; apply ulp_half_error|].
+assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))).
+  apply Rle_trans with (/2* ulp beta fexp2 x).
+  now unfold x''; apply error_le_half_ulp...
+  rewrite ulp_neq_0;[now right|now apply Rgt_not_eq].
 assert (Px'x : 0 <= x' - x).
 { apply Rle_0_minus.
   apply round_UP_pt.
@@ -335,6 +347,7 @@ assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (ln_beta x))).
   apply Rplus_le_lt_compat.
   - exact Hr1.
   - rewrite Rabs_minus_sym.
+   rewrite 2!ulp_neq_0 in Hx2; try (apply Rgt_not_eq; assumption).
     now rewrite Rabs_right; [|now apply Rle_ge]; apply Hx2. }
 destruct (Req_dec x'' 0) as [Zx''|Nzx''].
 - (* x'' = 0 *)
@@ -382,7 +395,8 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx''].
     apply (Rlt_le_trans _ _ _ Hx2).
     apply Rmult_le_compat_l; [lra|].
     generalize (bpow_ge_0 beta (fexp2 (ln_beta x))).
-    unfold ulp, canonic_exp; lra.
+    rewrite 2!ulp_neq_0; try (apply Rgt_not_eq; assumption).
+    unfold canonic_exp; lra.
   + apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
     rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
       [|now apply Rle_ge; apply bpow_ge_0].
@@ -422,7 +436,7 @@ assert (Hx''pow : x'' = bpow (ln_beta x)).
   { apply Rle_lt_trans with (x + / 2 * ulp beta fexp2 x).
     - apply (Rplus_le_reg_r (- x)); ring_simplify.
       apply Rabs_le_inv.
-      apply ulp_half_error.
+      apply error_le_half_ulp.
       exact Vfexp2.
     - apply Rplus_lt_compat_r.
       rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le].
@@ -442,15 +456,17 @@ assert (Hx''pow : x'' = bpow (ln_beta x)).
   apply (Rlt_le_trans _ _ _ H'x'').
   apply Rplus_le_compat_l.
   rewrite <- (Rmult_1_l (Fcore_Raux.bpow _ _)).
+  rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
   apply Rmult_le_compat_r; [now apply bpow_ge_0|].
   lra. }
 assert (Hr : Rabs (x - x'') < / 2 * ulp beta fexp1 x).
 { apply Rle_lt_trans with (/ 2 * ulp beta fexp2 x).
   - rewrite Rabs_minus_sym.
-    apply ulp_half_error.
+    apply error_le_half_ulp.
     exact Vfexp2.
   - apply Rmult_lt_compat_l; [lra|].
-    unfold ulp, canonic_exp; apply bpow_lt.
+    rewrite 2!ulp_neq_0; try now apply Rgt_not_eq.
+    unfold canonic_exp; apply bpow_lt.
     omega. }
 unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
 assert (Hf : (0 <= ln_beta x - fexp1 (ln_beta x''))%Z).
@@ -475,6 +491,7 @@ rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x'')))%Z).
     rewrite <- Rabs_mult.
     rewrite Rmult_minus_distr_r.
     bpow_simplify.
+   rewrite ulp_neq_0 in Hr;[idtac|now apply Rgt_not_eq].
     rewrite <- Hx''pow; exact Hr.
 - rewrite Z2R_Zpower; [|exact Hf].
   apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x'')))); [now apply bpow_gt_0|].
@@ -522,7 +539,7 @@ assert (H : Rabs (Z2R (Zceil (x * bpow (- fexp1 (ln_beta x))))
     + apply Rle_0_minus.
       apply round_UP_pt.
       exact Vfexp1.
-  - exact Hx. }
+  -  rewrite ulp_neq_0 in Hx;[exact Hx|now apply Rgt_not_eq]. }
 unfold double_round_eq, round at 2.
 unfold F2R, scaled_mantissa, canonic_exp; simpl.
 rewrite Hf2f1.
@@ -761,9 +778,10 @@ destruct (Req_dec y 0) as [Zy|Nzy].
 - (* y = 0 *)
   now rewrite Zy; rewrite Rplus_0_r.
 - (* y <> 0 *)
-  apply (ln_beta_succ beta fexp); [assumption|assumption|].
+  apply (ln_beta_plus_eps beta fexp); [assumption|assumption|].
   split; [assumption|].
-  unfold ulp, canonic_exp.
+  rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
+  unfold canonic_exp.
   destruct (ln_beta y) as (ey, Hey); simpl in *.
   apply Rlt_le_trans with (bpow ey).
   + now rewrite <- (Rabs_right y); [apply Hey|apply Rle_ge].
@@ -797,8 +815,7 @@ apply ln_beta_unique.
 split.
 - apply Rabs_ge; right.
   assert (Hy : y < ulp beta fexp (bpow (ln_beta x - 1))).
-  { unfold ulp, canonic_exp.
-    rewrite ln_beta_bpow.
+  { rewrite ulp_bpow.
     replace (_ + _)%Z with (ln_beta x : Z) by ring.
     rewrite <- (Rabs_right y); [|now apply Rle_ge; apply Rlt_le].
     apply Rlt_le_trans with (bpow (ln_beta y)).
@@ -808,7 +825,8 @@ split.
   apply Rle_trans with (bpow (ln_beta x - 1)
                         + ulp beta fexp (bpow (ln_beta x - 1))).
   + now apply Rplus_le_compat_l; apply Rlt_le.
-  + apply succ_le_lt; [|exact Fx|now split; [apply bpow_gt_0|]].
+  + rewrite <- succ_eq_pos;[idtac|apply bpow_ge_0].
+    apply succ_le_lt; [apply Vfexp|idtac|exact Fx|assumption].
     apply (generic_format_bpow beta fexp (ln_beta x - 1)).
     replace (_ + _)%Z with (ln_beta x : Z) by ring.
     assert (fexp (ln_beta x) < ln_beta x)%Z; [|omega].
@@ -1039,13 +1057,15 @@ apply double_round_lt_mid.
   apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 2 P2 fexp1 x y Px
                                                                Py Hly Lxy Fx))).
   ring_simplify.
-  unfold ulp, canonic_exp; rewrite Lxy.
+  rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
+  unfold canonic_exp; rewrite Lxy.
   apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
   bpow_simplify.
   apply (Rle_trans _ _ _ Bpow2).
   rewrite <- (Rmult_1_r (/ 2)) at 3.
   apply Rmult_le_compat_l; lra.
-- unfold ulp, round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy.
+- rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
+  unfold round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy.
   intro Hf2'.
   apply (Rmult_lt_reg_r (bpow (- fexp1 (ln_beta x))));
     [now apply bpow_gt_0|].
@@ -1056,7 +1076,8 @@ apply double_round_lt_mid.
   apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 2 P2 fexp1 x y Px
                                                                Py Hly Lxy Fx))).
   apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
-  unfold ulp, canonic_exp; rewrite Lxy, Rmult_minus_distr_r; bpow_simplify.
+  rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
+  unfold canonic_exp; rewrite Lxy, Rmult_minus_distr_r; bpow_simplify.
   apply (Rle_trans _ _ _ Bpow2).
   rewrite <- (Rmult_1_r (/ 2)) at 3; rewrite <- Rmult_minus_distr_l.
   apply Rmult_le_compat_l; [lra|].
@@ -1391,7 +1412,8 @@ apply double_round_gt_mid.
     [now apply double_round_minus_aux2_aux; try assumption; omega|].
     apply (Rlt_le_trans _ _ _ Ly).
     now apply bpow_le.
-  + unfold ulp, canonic_exp.
+  + rewrite ulp_neq_0;[idtac|now apply sym_not_eq, Rlt_not_eq, Rgt_minus].
+    unfold canonic_exp.
     replace (_ - 2)%Z with (fexp1 (ln_beta (x - y)) - 1 - 1)%Z by ring.
     unfold Zminus at 1; rewrite bpow_plus.
     rewrite Rmult_comm.
@@ -1423,7 +1445,8 @@ apply double_round_gt_mid.
   + unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
     rewrite Zmult_1_r; apply Rinv_le; [lra|].
     now change 2 with (Z2R 2); apply Z2R_le.
-  + unfold ulp, canonic_exp.
+  + rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus.
+    unfold canonic_exp.
     apply (Rplus_le_reg_r (bpow (fexp2 (ln_beta (x - y))))); ring_simplify.
     apply Rle_trans with (2 * bpow (fexp1 (ln_beta (x - y)) - 1)).
     * rewrite Rmult_plus_distr_r; rewrite Rmult_1_l.
@@ -1868,19 +1891,22 @@ apply double_round_lt_mid.
   apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 1 P1 fexp1 x y Px
                                                                Py Hly Lxy Fx))).
   ring_simplify.
-  unfold ulp, canonic_exp; rewrite Lxy.
+  rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
+  unfold canonic_exp; rewrite Lxy.
   apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x))));
     [now apply bpow_gt_0|].
   bpow_simplify.
   apply (Rle_trans _ _ _ Bpow3); lra.
-- unfold ulp, round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy.
+- rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
+  unfold round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy.
   intro Hf2'.
   unfold midp.
   apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))); ring_simplify.
   rewrite <- Rmult_minus_distr_l.
   apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 1 P1 fexp1 x y Px
                                                                Py Hly Lxy Fx))).
-  unfold ulp, canonic_exp; rewrite Lxy.
+  rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
+  unfold canonic_exp; rewrite Lxy.
   apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x))));
     [now apply bpow_gt_0|].
   rewrite (Rmult_assoc (/ 2)).
@@ -2106,7 +2132,8 @@ apply double_round_gt_mid.
     [now apply double_round_minus_aux2_aux|].
     apply (Rlt_le_trans _ _ _ Ly).
     now apply bpow_le.
-  + unfold ulp, canonic_exp.
+  + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rgt_minus].
+    unfold canonic_exp.
     unfold Zminus at 1; rewrite bpow_plus.
     rewrite Rmult_comm.
     apply Rmult_le_compat_r; [now apply bpow_ge_0|].
@@ -2124,7 +2151,8 @@ apply double_round_gt_mid.
   apply (Rlt_le_trans _ _ _ Ly).
   apply Rle_trans with (bpow (fexp1 (ln_beta (x - y)) - 1));
     [now apply bpow_le|].
-  unfold ulp, canonic_exp.
+  rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus.
+  unfold canonic_exp.
   apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x - y)))));
     [now apply bpow_gt_0|].
   rewrite Rmult_assoc.
@@ -2533,7 +2561,7 @@ destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx].
   now apply (generic_inclusion_ln_beta beta fexp1); [omega|].
 - (* ~ generic_format beta fexp1 x *)
   assert (Hceil : round beta fexp1 Zceil x = rd + u1);
-  [now apply ulp_DN_UP|].
+  [now apply round_UP_DN_ulp|].
   assert (Hf2' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|].
   destruct (Rlt_or_le (x - rd) (/ 2 * (u1 - u2))).
   + (* x - rd < / 2 * (u1 - u2) *)
@@ -2589,10 +2617,11 @@ assert (Hbeta : (2 <= beta)%Z).
 { destruct beta as (beta_val,beta_prop).
   now apply Zle_bool_imp_le. }
 set (a := round beta fexp1 Zfloor (sqrt x)).
-set (u1 := ulp beta fexp1 (sqrt x)).
-set (u2 := ulp beta fexp2 (sqrt x)).
+set (u1 := bpow (fexp1 (ln_beta (sqrt x)))).
+set (u2 := bpow (fexp2 (ln_beta (sqrt x)))).
 set (b := / 2 * (u1 - u2)).
 set (b' := / 2 * (u1 + u2)).
+unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0.
 apply Rnot_ge_lt; intro H; apply Rge_le in H.
 assert (Fa : generic_format beta fexp1 a).
 { unfold a.
@@ -2619,7 +2648,7 @@ assert (Pb : 0 < b).
   rewrite <- (Rmult_0_r (/ 2)).
   apply Rmult_lt_compat_l; [lra|].
   apply Rlt_Rminus.
-  unfold u2, u1, ulp, canonic_exp.
+  unfold u2, u1.
   apply bpow_lt.
   omega. }
 assert (Pb' : 0 < b').
@@ -2686,7 +2715,7 @@ destruct (Req_dec a 0) as [Za|Nza].
 - (* a <> 0 *)
   assert (Pa : 0 < a); [lra|].
   assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)).
-  { unfold a; apply ln_beta_round_DN.
+  { unfold a; apply ln_beta_DN.
     - exact Vfexp1.
     - now fold a. }
   assert (Hl' : 0 < - (u2 * a) + b * b).
@@ -2697,12 +2726,14 @@ destruct (Req_dec a 0) as [Za|Nza].
     replace (_ / 8) with (/ 4 * (u2 ^ 2 + u1 ^ 2)) by field.
     apply Rlt_le_trans with (u2 * bpow (ln_beta (sqrt x))).
     - apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|].
-      unfold u1, ulp, canonic_exp; rewrite <- Hla.
-      apply Rlt_le_trans with (a + ulp beta fexp1 a).
+      unfold u1; rewrite <- Hla.
+      apply Rlt_le_trans with (a + bpow (fexp1 (ln_beta a))).
       + apply Rplus_lt_compat_l.
-        rewrite <- (Rmult_1_l (ulp _ _ _)).
+        rewrite <- (Rmult_1_l (bpow _)) at 2.
         apply Rmult_lt_compat_r; [apply bpow_gt_0|lra].
-      + apply (succ_le_bpow _ _ _ _ Pa Fa).
+      + apply Rle_trans with (a+ ulp beta fexp1 a).
+        right; now rewrite ulp_neq_0.
+        apply (id_p_ulp_le_bpow _ _ _ _ Pa Fa).
         apply Rabs_lt_inv, bpow_ln_beta_gt.
     - apply Rle_trans with (bpow (- 2) * u1 ^ 2).
       + unfold pow; rewrite Rmult_1_r.
@@ -2745,9 +2776,10 @@ destruct (Req_dec a 0) as [Za|Nza].
     apply Rlt_le_trans with (bpow (ln_beta (sqrt x)) * u2).
     - apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|].
       apply Rlt_le_trans with (a + u1); [lra|].
-      unfold u1.
-      rewrite <- ulp_DN; [|exact Vfexp1|exact Pa]; fold a.
-      apply succ_le_bpow.
+      unfold u1; fold (canonic_exp beta fexp1 (sqrt x)).
+      rewrite <- canonic_exp_DN; [|exact Vfexp1|exact Pa]; fold a.
+      rewrite <- ulp_neq_0; trivial.
+      apply id_p_ulp_le_bpow.
       + exact Pa.
       + now apply round_DN_pt.
       + apply Rle_lt_trans with (sqrt x).
@@ -2782,21 +2814,6 @@ destruct (Req_dec a 0) as [Za|Nza].
   + now apply Rle_trans with x.
 Qed.
 
-(* --> Fcore_Raux *)
-Lemma sqrt_neg : forall x, x <= 0 -> sqrt x = 0.
-Proof.
-intros x Npx.
-destruct (Req_dec x 0) as [Zx|Nzx].
-- (* x = 0 *)
-  rewrite Zx.
-  exact sqrt_0.
-- (* x < 0 *)
-  unfold sqrt.
-  destruct Rcase_abs.
-  + reflexivity.
-  + casetype False.
-    now apply Nzx, Rle_antisym; [|apply Rge_le].
-Qed.
 
 Lemma double_round_sqrt :
   forall fexp1 fexp2 : Z -> Z,
@@ -3028,10 +3045,11 @@ Lemma double_round_sqrt_beta_ge_4_aux :
 Proof.
 intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx.
 set (a := round beta fexp1 Zfloor (sqrt x)).
-set (u1 := ulp beta fexp1 (sqrt x)).
-set (u2 := ulp beta fexp2 (sqrt x)).
+set (u1 := bpow (fexp1 (ln_beta (sqrt x)))).
+set (u2 := bpow (fexp2 (ln_beta (sqrt x)))).
 set (b := / 2 * (u1 - u2)).
 set (b' := / 2 * (u1 + u2)).
+unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0.
 apply Rnot_ge_lt; intro H; apply Rge_le in H.
 assert (Fa : generic_format beta fexp1 a).
 { unfold a.
@@ -3125,7 +3143,7 @@ destruct (Req_dec a 0) as [Za|Nza].
 - (* a <> 0 *)
   assert (Pa : 0 < a); [lra|].
   assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)).
-  { unfold a; apply ln_beta_round_DN.
+  { unfold a; apply ln_beta_DN.
     - exact Vfexp1.
     - now fold a. }
   assert (Hl' : 0 < - (u2 * a) + b * b).
@@ -3136,12 +3154,13 @@ destruct (Req_dec a 0) as [Za|Nza].
     replace (_ / 8) with (/ 4 * (u2 ^ 2 + u1 ^ 2)) by field.
     apply Rlt_le_trans with (u2 * bpow (ln_beta (sqrt x))).
     - apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|].
-      unfold u1, ulp, canonic_exp; rewrite <- Hla.
+      unfold u1; rewrite <- Hla.
       apply Rlt_le_trans with (a + ulp beta fexp1 a).
       + apply Rplus_lt_compat_l.
         rewrite <- (Rmult_1_l (ulp _ _ _)).
+        rewrite ulp_neq_0; trivial.
         apply Rmult_lt_compat_r; [apply bpow_gt_0|lra].
-      + apply (succ_le_bpow _ _ _ _ Pa Fa).
+      + apply (id_p_ulp_le_bpow _ _ _ _ Pa Fa).
         apply Rabs_lt_inv, bpow_ln_beta_gt.
     - apply Rle_trans with (bpow (- 1) * u1 ^ 2).
       + unfold pow; rewrite Rmult_1_r.
@@ -3184,9 +3203,10 @@ destruct (Req_dec a 0) as [Za|Nza].
     apply Rlt_le_trans with (bpow (ln_beta (sqrt x)) * u2).
     - apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|].
       apply Rlt_le_trans with (a + u1); [lra|].
-      unfold u1.
-      rewrite <- ulp_DN; [|exact Vfexp1|exact Pa]; fold a.
-      apply succ_le_bpow.
+      unfold u1; fold (canonic_exp beta fexp1 (sqrt x)).
+      rewrite <- canonic_exp_DN; [|exact Vfexp1|exact Pa]; fold a.
+      rewrite <- ulp_neq_0; trivial.
+      apply id_p_ulp_le_bpow.
       + exact Pa.
       + now apply round_DN_pt.
       + apply Rle_lt_trans with (sqrt x).
@@ -3504,9 +3524,11 @@ assert (Hf : F2R f = x).
   rewrite (Rmult_assoc _ (Z2R n)).
   rewrite Rinv_r;
     [rewrite Rmult_1_r|change 0 with (Z2R 0); apply Z2R_neq; omega].
-  simpl; fold (canonic_exp beta fexp1 x); fold (ulp beta fexp1 x); fold u.
-  rewrite Xmid at 2.
+  simpl; fold (canonic_exp beta fexp1 x).
+  rewrite <- 2!ulp_neq_0; try now apply Rgt_not_eq.
+  fold u; rewrite Xmid at 2.
   apply f_equal2; [|reflexivity].
+  rewrite ulp_neq_0; try now apply Rgt_not_eq.
   destruct (Req_dec rd 0) as [Zrd|Nzrd].
   - (* rd = 0 *)
     rewrite Zrd.
@@ -3657,7 +3679,7 @@ split.
   replace (bpow _) with (bpow (ln_beta x) - / 2 * u2 + / 2 * u2) by ring.
   apply Rplus_lt_le_compat; [exact Hx|].
   apply Rabs_le_inv.
-  now apply ulp_half_error.
+  now apply error_le_half_ulp.
 Qed.
 
 Lemma double_round_all_mid_cases :
@@ -3714,7 +3736,7 @@ destruct (Ztrichotomy (ln_beta x) (fexp1 (ln_beta x) - 1)) as [Hlt|[Heq|Hgt]].
           now apply (generic_inclusion_ln_beta beta fexp1); [omega|].
         - (* ~ generic_format beta fexp1 x *)
           assert (Hceil : round beta fexp1 Zceil x = x' + u1);
-          [now apply ulp_DN_UP|].
+          [now apply round_UP_DN_ulp|].
           assert (Hf2' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z);
             [omega|].
           assert (midp' fexp1 x + / 2 * ulp beta fexp2 x < x);
@@ -3769,12 +3791,15 @@ assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z);
 assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z);
   [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
 set (p := bpow (ln_beta (x / y))).
-set (u2 := ulp beta fexp2 (x / y)).
+set (u2 := bpow (fexp2 (ln_beta (x / y)))).
 revert Fx Fy.
 unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
 set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))).
 set (my := Ztrunc (y * bpow (- fexp1 (ln_beta y)))).
 intros Fx Fy.
+rewrite ulp_neq_0.
+2: apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac].
+2: now apply Rinv_neq_0_compat, Rgt_not_eq.
 intro Hl.
 assert (Hr : x / y < p);
   [now apply Rabs_lt_inv; apply bpow_ln_beta_gt|].
@@ -3903,6 +3928,9 @@ assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z);
   [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
 assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z);
   [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
+assert (S : (x / y <> 0)%R).
+apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac].
+now apply Rinv_neq_0_compat, Rgt_not_eq.
 cut (~ (/ 2 * (ulp beta fexp1 (x / y) - ulp beta fexp2 (x / y))
         <= x / y - round beta fexp1 Zfloor (x / y)
         < / 2 * ulp beta fexp1 (x / y))).
@@ -3913,9 +3941,10 @@ cut (~ (/ 2 * (ulp beta fexp1 (x / y) - ulp beta fexp2 (x / y))
   - apply (Rplus_lt_reg_l (round beta fexp1 Zfloor (x / y))).
     ring_simplify.
     apply H'. }
-set (u1 := ulp beta fexp1 (x / y)).
-set (u2 := ulp beta fexp2 (x / y)).
+set (u1 := bpow (fexp1 (ln_beta (x / y)))).
+set (u2 := bpow (fexp2 (ln_beta (x / y)))).
 set (x' := round beta fexp1 Zfloor (x / y)).
+rewrite 2!ulp_neq_0; trivial.
 revert Fx Fy.
 unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
 set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))).
@@ -4098,9 +4127,13 @@ cut (~ (/ 2 * ulp beta fexp1 (x / y)
   - apply (Rplus_le_reg_l (round beta fexp1 Zfloor (x / y))).
     ring_simplify.
     apply H'. }
-set (u1 := ulp beta fexp1 (x / y)).
-set (u2 := ulp beta fexp2 (x / y)).
+set (u1 := bpow (fexp1 (ln_beta (x / y)))).
+set (u2 := bpow (fexp2 (ln_beta (x / y)))).
 set (x' := round beta fexp1 Zfloor (x / y)).
+assert (S : (x / y <> 0)%R).
+apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac].
+now apply Rinv_neq_0_compat, Rgt_not_eq.
+rewrite 2!ulp_neq_0; trivial.
 revert Fx Fy.
 unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
 set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))).
diff --git a/flocq/Appli/Fappli_rnd_odd.v b/flocq/Appli/Fappli_rnd_odd.v
index b3244589..4741047f 100644
--- a/flocq/Appli/Fappli_rnd_odd.v
+++ b/flocq/Appli/Fappli_rnd_odd.v
@@ -356,6 +356,80 @@ simpl; ring.
 apply Rgt_not_eq, bpow_gt_0.
 Qed.
 
+
+
+Theorem Rnd_odd_pt_unicity :
+  forall x f1 f2 : R,
+  Rnd_odd_pt x f1 -> Rnd_odd_pt x f2 ->
+  f1 = f2.
+Proof.
+intros x f1 f2 (Ff1,H1) (Ff2,H2).
+(* *)
+case (generic_format_EM beta fexp x); intros L.
+apply trans_eq with x.
+case H1; try easy.
+intros (J,_); case J; intros J'.
+apply Rnd_DN_pt_idempotent with format; assumption.
+apply Rnd_UP_pt_idempotent with format; assumption.
+case H2; try easy.
+intros (J,_); case J; intros J'; apply sym_eq.
+apply Rnd_DN_pt_idempotent with format; assumption.
+apply Rnd_UP_pt_idempotent with format; assumption.
+(* *)
+destruct H1 as [H1|(H1,H1')].
+contradict L; now rewrite <- H1.
+destruct H2 as [H2|(H2,H2')].
+contradict L; now rewrite <- H2.
+destruct H1 as [H1|H1]; destruct H2 as [H2|H2].
+apply Rnd_DN_pt_unicity with format x; assumption.
+destruct H1' as (ff,(K1,(K2,K3))).
+destruct H2' as (gg,(L1,(L2,L3))).
+absurd (true = false); try discriminate.
+rewrite <- L3.
+apply trans_eq with (negb (Zeven (Fnum ff))).
+rewrite K3; easy.
+apply sym_eq.
+generalize (DN_UP_parity_generic beta fexp).
+unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption...
+rewrite <- K1; apply Rnd_DN_pt_unicity with (generic_format beta fexp) x; try easy...
+now apply round_DN_pt...
+rewrite <- L1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy...
+now apply round_UP_pt...
+(* *)
+destruct H1' as (ff,(K1,(K2,K3))).
+destruct H2' as (gg,(L1,(L2,L3))).
+absurd (true = false); try discriminate.
+rewrite <- K3.
+apply trans_eq with (negb (Zeven (Fnum gg))).
+rewrite L3; easy.
+apply sym_eq.
+generalize (DN_UP_parity_generic beta fexp).
+unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption...
+rewrite <- L1; apply Rnd_DN_pt_unicity with (generic_format beta fexp) x; try easy...
+now apply round_DN_pt...
+rewrite <- K1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy...
+now apply round_UP_pt...
+apply Rnd_UP_pt_unicity with format x; assumption.
+Qed.
+
+
+
+Theorem Rnd_odd_pt_monotone :
+  round_pred_monotone (Rnd_odd_pt).
+Proof with auto with typeclass_instances.
+intros x y f g H1 H2 Hxy.
+apply Rle_trans with (round beta fexp Zrnd_odd x).
+right; apply Rnd_odd_pt_unicity with x; try assumption.
+apply round_odd_pt.
+apply Rle_trans with (round beta fexp Zrnd_odd y).
+apply round_le...
+right; apply Rnd_odd_pt_unicity with y; try assumption.
+apply round_odd_pt.
+Qed.
+
+
+
+
 End Fcore_rnd_odd.
 
 Section Odd_prop_aux.
@@ -462,7 +536,7 @@ Lemma ln_beta_d:  (0< F2R d)%R ->
     (ln_beta beta (F2R d) = ln_beta beta x :>Z).
 Proof with auto with typeclass_instances.
 intros Y.
-rewrite d_eq; apply ln_beta_round_DN...
+rewrite d_eq; apply ln_beta_DN...
 now rewrite <- d_eq.
 Qed.
 
@@ -861,13 +935,9 @@ case K2; clear K2; intros K2.
 case (Rle_or_lt  x m); intros Y;[destruct Y|idtac].
 (* . *)
 apply trans_eq with (F2R d).
-apply round_N_DN_betw with (F2R u)...
+apply round_N_eq_DN_pt with (F2R u)...
 apply DN_odd_d_aux; split; try left; assumption.
 apply UP_odd_d_aux; split; try left; assumption.
-split.
-apply round_ge_generic...
-apply generic_format_fexpe_fexp, Hd.
-apply Hd.
 assert (o <= (F2R d + F2R u) / 2)%R.
 apply round_le_generic...
 apply Fm.
@@ -876,10 +946,7 @@ destruct H1; trivial.
 apply P.
 now apply Rlt_not_eq.
 trivial.
-apply sym_eq, round_N_DN_betw with (F2R u)...
-split.
-apply Hd.
-exact H0.
+apply sym_eq, round_N_eq_DN_pt with (F2R u)...
 (* . *)
 replace o with x.
 reflexivity.
@@ -887,10 +954,9 @@ apply sym_eq, round_generic...
 rewrite H0; apply Fm.
 (* . *)
 apply trans_eq with (F2R u).
-apply round_N_UP_betw with (F2R d)...
+apply round_N_eq_UP_pt with (F2R d)...
 apply DN_odd_d_aux; split; try left; assumption.
 apply UP_odd_d_aux; split; try left; assumption.
-split.
 assert ((F2R d + F2R u) / 2 <= o)%R.
 apply round_ge_generic...
 apply Fm.
@@ -899,13 +965,7 @@ destruct H0; trivial.
 apply P.
 now apply Rgt_not_eq.
 rewrite <- H0; trivial.
-apply round_le_generic...
-apply generic_format_fexpe_fexp, Hu.
-apply Hu.
-apply sym_eq, round_N_UP_betw with (F2R d)...
-split.
-exact Y.
-apply Hu.
+apply sym_eq, round_N_eq_UP_pt with (F2R d)...
 Qed.
 
 
diff --git a/flocq/Core/Fcore_FIX.v b/flocq/Core/Fcore_FIX.v
index a3b8d4d0..e224a64a 100644
--- a/flocq/Core/Fcore_FIX.v
+++ b/flocq/Core/Fcore_FIX.v
@@ -22,6 +22,7 @@ Require Import Fcore_Raux.
 Require Import Fcore_defs.
 Require Import Fcore_rnd.
 Require Import Fcore_generic_fmt.
+Require Import Fcore_ulp.
 Require Import Fcore_rnd_ne.
 
 Section RND_FIX.
@@ -84,4 +85,16 @@ intros ex ey H.
 apply Zle_refl.
 Qed.
 
+Theorem ulp_FIX: forall x, ulp beta FIX_exp x = bpow emin.
+Proof.
+intros x; unfold ulp.
+case Req_bool_spec; intros Zx.
+case (negligible_exp_spec FIX_exp).
+intros T; specialize (T (emin-1)%Z); contradict T.
+unfold FIX_exp; omega.
+intros n _; reflexivity.
+reflexivity.
+Qed.
+
+
 End RND_FIX.
diff --git a/flocq/Core/Fcore_FLT.v b/flocq/Core/Fcore_FLT.v
index 273ff69f..372af6ad 100644
--- a/flocq/Core/Fcore_FLT.v
+++ b/flocq/Core/Fcore_FLT.v
@@ -25,6 +25,7 @@ Require Import Fcore_generic_fmt.
 Require Import Fcore_float_prop.
 Require Import Fcore_FLX.
 Require Import Fcore_FIX.
+Require Import Fcore_ulp.
 Require Import Fcore_rnd_ne.
 
 Section RND_FLT.
@@ -222,7 +223,6 @@ Theorem generic_format_FLT_FIX :
   generic_format beta (FIX_exp emin) x ->
   generic_format beta FLT_exp x.
 Proof with auto with typeclass_instances.
-clear prec_gt_0_.
 apply generic_inclusion_le...
 intros e He.
 unfold FIX_exp.
@@ -231,6 +231,75 @@ omega.
 apply Zle_refl.
 Qed.
 
+Theorem ulp_FLT_small: forall x, (Rabs x < bpow (emin+prec))%R ->
+    ulp beta FLT_exp x = bpow emin.
+Proof with auto with typeclass_instances.
+intros x Hx.
+unfold ulp; case Req_bool_spec; intros Hx2.
+(* x = 0 *)
+case (negligible_exp_spec FLT_exp).
+intros T; specialize (T (emin-1)%Z); contradict T.
+apply Zle_not_lt; unfold FLT_exp.
+apply Zle_trans with (2:=Z.le_max_r _ _); omega.
+assert (V:FLT_exp emin = emin).
+unfold FLT_exp; apply Z.max_r.
+unfold Prec_gt_0 in prec_gt_0_; omega.
+intros n H2; rewrite <-V.
+apply f_equal, fexp_negligible_exp_eq...
+omega.
+(* x <> 0 *)
+apply f_equal; unfold canonic_exp, FLT_exp.
+apply Z.max_r.
+assert (ln_beta beta x-1 < emin+prec)%Z;[idtac|omega].
+destruct (ln_beta beta x) as (e,He); simpl.
+apply lt_bpow with beta.
+apply Rle_lt_trans with (2:=Hx).
+now apply He.
+Qed.
+
+Theorem ulp_FLT_le: forall x, (bpow (emin+prec) <= Rabs x)%R ->
+  (ulp beta FLT_exp x <= Rabs x * bpow (1-prec))%R.
+Proof.
+intros x Hx.
+assert (x <> 0)%R.
+intros Z; contradict Hx; apply Rgt_not_le, Rlt_gt.
+rewrite Z, Rabs_R0; apply bpow_gt_0.
+rewrite ulp_neq_0; try assumption.
+unfold canonic_exp, FLT_exp.
+destruct (ln_beta beta x) as (e,He).
+apply Rle_trans with (bpow (e-1)*bpow (1-prec))%R.
+rewrite <- bpow_plus.
+right; apply f_equal.
+apply trans_eq with (e-prec)%Z;[idtac|ring].
+simpl; apply Z.max_l.
+assert (emin+prec <= e)%Z; try omega.
+apply le_bpow with beta.
+apply Rle_trans with (1:=Hx).
+left; now apply He.
+apply Rmult_le_compat_r.
+apply bpow_ge_0.
+now apply He.
+Qed.
+
+
+Theorem ulp_FLT_ge: forall x, (Rabs x * bpow (-prec) < ulp beta FLT_exp x)%R.
+Proof.
+intros x; case (Req_dec x 0); intros Hx.
+rewrite Hx, ulp_FLT_small, Rabs_R0, Rmult_0_l; try apply bpow_gt_0.
+rewrite Rabs_R0; apply bpow_gt_0.
+rewrite ulp_neq_0; try exact Hx.
+unfold canonic_exp, FLT_exp.
+apply Rlt_le_trans with (bpow (ln_beta beta x)*bpow (-prec))%R.
+apply Rmult_lt_compat_r.
+apply bpow_gt_0.
+now apply bpow_ln_beta_gt.
+rewrite <- bpow_plus.
+apply bpow_le.
+apply Z.le_max_l.
+Qed.
+
+
+
 (** FLT is a nice format: it has a monotone exponent... *)
 Global Instance FLT_exp_monotone : Monotone_exp FLT_exp.
 Proof.
diff --git a/flocq/Core/Fcore_FLX.v b/flocq/Core/Fcore_FLX.v
index 800540f2..55f6db61 100644
--- a/flocq/Core/Fcore_FLX.v
+++ b/flocq/Core/Fcore_FLX.v
@@ -24,6 +24,7 @@ Require Import Fcore_rnd.
 Require Import Fcore_generic_fmt.
 Require Import Fcore_float_prop.
 Require Import Fcore_FIX.
+Require Import Fcore_ulp.
 Require Import Fcore_rnd_ne.
 
 Section RND_FLX.
@@ -211,6 +212,43 @@ now apply FLXN_format_generic.
 now apply generic_format_FLXN.
 Qed.
 
+Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R.
+Proof.
+unfold ulp; rewrite Req_bool_true; trivial.
+case (negligible_exp_spec FLX_exp).
+intros _; reflexivity.
+intros n H2; contradict H2.
+unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; omega.
+Qed.
+
+Theorem ulp_FLX_le: forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R.
+Proof.
+intros x; case (Req_dec x 0); intros Hx.
+rewrite Hx, ulp_FLX_0, Rabs_R0.
+right; ring.
+rewrite ulp_neq_0; try exact Hx.
+unfold canonic_exp, FLX_exp.
+replace (ln_beta beta x - prec)%Z with ((ln_beta beta x - 1) + (1-prec))%Z by ring.
+rewrite bpow_plus.
+apply Rmult_le_compat_r.
+apply bpow_ge_0.
+now apply bpow_ln_beta_le.
+Qed.
+
+
+Theorem ulp_FLX_ge: forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R.
+Proof.
+intros x; case (Req_dec x 0); intros Hx.
+rewrite Hx, ulp_FLX_0, Rabs_R0.
+right; ring.
+rewrite ulp_neq_0; try exact Hx.
+unfold canonic_exp, FLX_exp.
+unfold Zminus; rewrite bpow_plus.
+apply Rmult_le_compat_r.
+apply bpow_ge_0.
+left; now apply bpow_ln_beta_gt.
+Qed.
+
 (** FLX is a nice format: it has a monotone exponent... *)
 Global Instance FLX_exp_monotone : Monotone_exp FLX_exp.
 Proof.
diff --git a/flocq/Core/Fcore_FTZ.v b/flocq/Core/Fcore_FTZ.v
index 5f3e5337..2ebc7851 100644
--- a/flocq/Core/Fcore_FTZ.v
+++ b/flocq/Core/Fcore_FTZ.v
@@ -23,6 +23,7 @@ Require Import Fcore_defs.
 Require Import Fcore_rnd.
 Require Import Fcore_generic_fmt.
 Require Import Fcore_float_prop.
+Require Import Fcore_ulp.
 Require Import Fcore_FLX.
 
 Section RND_FTZ.
@@ -182,7 +183,6 @@ Theorem FTZ_format_FLXN :
   (bpow (emin + prec - 1) <= Rabs x)%R ->
   FLXN_format beta prec x -> FTZ_format x.
 Proof.
-clear prec_gt_0_.
 intros x Hx Fx.
 apply FTZ_format_generic.
 apply generic_format_FLXN in Fx.
@@ -195,6 +195,21 @@ apply Zle_refl.
 omega.
 Qed.
 
+Theorem ulp_FTZ_0: ulp beta FTZ_exp 0 = bpow (emin+prec-1).
+Proof with auto with typeclass_instances.
+unfold ulp; rewrite Req_bool_true; trivial.
+case (negligible_exp_spec FTZ_exp).
+intros T; specialize (T (emin-1)%Z); contradict T.
+apply Zle_not_lt; unfold FTZ_exp; unfold Prec_gt_0 in prec_gt_0_.
+rewrite Zlt_bool_true; omega.
+assert (V:(FTZ_exp (emin+prec-1) = emin+prec-1)%Z).
+unfold FTZ_exp; rewrite Zlt_bool_true; omega.
+intros n H2; rewrite <-V.
+apply f_equal, fexp_negligible_exp_eq...
+omega.
+Qed.
+
+
 Section FTZ_round.
 
 (** Rounding with FTZ *)
diff --git a/flocq/Core/Fcore_Raux.v b/flocq/Core/Fcore_Raux.v
index 3758324f..d728e0ba 100644
--- a/flocq/Core/Fcore_Raux.v
+++ b/flocq/Core/Fcore_Raux.v
@@ -207,6 +207,27 @@ rewrite 3!(Rmult_comm r).
 now apply Rmult_min_distr_r.
 Qed.
 
+Lemma Rmin_opp: forall x y, (Rmin (-x) (-y) = - Rmax x y)%R.
+Proof.
+intros x y.
+apply Rmax_case_strong; intros H.
+rewrite Rmin_left; trivial.
+now apply Ropp_le_contravar.
+rewrite Rmin_right; trivial.
+now apply Ropp_le_contravar.
+Qed.
+
+Lemma Rmax_opp: forall x y, (Rmax (-x) (-y) = - Rmin x y)%R.
+Proof.
+intros x y.
+apply Rmin_case_strong; intros H.
+rewrite Rmax_left; trivial.
+now apply Ropp_le_contravar.
+rewrite Rmax_right; trivial.
+now apply Ropp_le_contravar.
+Qed.
+
+
 Theorem exp_le :
   forall x y : R,
   (x <= y)%R -> (exp x <= exp y)%R.
@@ -1930,6 +1951,16 @@ destruct (ln_beta x) as (ex, Ex) ; simpl.
 now apply Ex.
 Qed.
 
+Theorem bpow_ln_beta_le :
+  forall x, (x <> 0)%R ->
+    (bpow (ln_beta x-1) <= Rabs x)%R.
+Proof.
+intros x Hx.
+destruct (ln_beta x) as (ex, Ex) ; simpl.
+now apply Ex.
+Qed.
+
+
 Theorem ln_beta_le_Zpower :
   forall m e,
   m <> Z0 ->
@@ -2306,6 +2337,160 @@ Qed.
 
 End cond_Ropp.
 
+
+(** LPO taken from Coquelicot *)
+
+Theorem LPO_min :
+  forall P : nat -> Prop, (forall n, P n \/ ~ P n) ->
+  {n : nat | P n /\ forall i, (i < n)%nat -> ~ P i} + {forall n, ~ P n}.
+Proof.
+assert (Hi: forall n, (0 < INR n + 1)%R).
+  intros N.
+  rewrite <- S_INR.
+  apply lt_0_INR.
+  apply lt_0_Sn.
+intros P HP.
+set (E y := exists n, (P n /\ y = / (INR n + 1))%R \/ (~ P n /\ y = 0)%R).
+assert (HE: forall n, P n -> E (/ (INR n + 1))%R).
+  intros n Pn.
+  exists n.
+  left.
+  now split.
+assert (BE: is_upper_bound E 1).
+  intros x [y [[_ ->]|[_ ->]]].
+  rewrite <- Rinv_1 at 2.
+  apply Rinv_le.
+  exact Rlt_0_1.
+  rewrite <- S_INR.
+  apply (le_INR 1), le_n_S, le_0_n.
+  exact Rle_0_1.
+destruct (completeness E) as [l [ub lub]].
+  now exists 1%R.
+  destruct (HP O) as [H0|H0].
+  exists 1%R.
+  exists O.
+  left.
+  apply (conj H0).
+  rewrite Rplus_0_l.
+  apply sym_eq, Rinv_1.
+  exists 0%R.
+  exists O.
+  right.
+  now split.
+destruct (Rle_lt_dec l 0) as [Hl|Hl].
+  right.
+  intros n Pn.
+  apply Rle_not_lt with (1 := Hl).
+  apply Rlt_le_trans with (/ (INR n + 1))%R.
+  now apply Rinv_0_lt_compat.
+  apply ub.
+  now apply HE.
+left.
+set (N := Zabs_nat (up (/l) - 2)).
+exists N.
+assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R).
+  unfold N.
+  rewrite INR_IZR_INZ.
+  rewrite inj_Zabs_nat.
+  replace (IZR (up (/ l)) - 1)%R with (IZR (up (/ l) - 2) + 1)%R.
+  apply (f_equal (fun v => IZR v + 1)%R).
+  apply Zabs_eq.
+  apply Zle_minus_le_0.
+  apply (Zlt_le_succ 1).
+  apply lt_IZR.
+  apply Rle_lt_trans with (/l)%R.
+  apply Rmult_le_reg_r with (1 := Hl).
+  rewrite Rmult_1_l, Rinv_l by now apply Rgt_not_eq.
+  apply lub.
+  exact BE.
+  apply archimed.
+  rewrite minus_IZR.
+  simpl.
+  ring.
+assert (H: forall i, (i < N)%nat -> ~ P i).
+  intros i HiN Pi.
+  unfold is_upper_bound in ub.
+  refine (Rle_not_lt _ _ (ub (/ (INR i + 1))%R _) _).
+  now apply HE.
+  rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq.
+  apply Rinv_1_lt_contravar.
+  rewrite <- S_INR.
+  apply (le_INR 1).
+  apply le_n_S.
+  apply le_0_n.
+  apply Rlt_le_trans with (INR N + 1)%R.
+  apply Rplus_lt_compat_r.
+  now apply lt_INR.
+  rewrite HN.
+  apply Rplus_le_reg_r with (-/l + 1)%R.
+  ring_simplify.
+  apply archimed.
+destruct (HP N) as [PN|PN].
+  now split.
+elimtype False.
+refine (Rle_not_lt _ _ (lub (/ (INR (S N) + 1))%R _) _).
+  intros x [y [[Py ->]|[_ ->]]].
+  destruct (eq_nat_dec y N) as [HyN|HyN].
+  elim PN.
+  now rewrite <- HyN.
+  apply Rinv_le.
+  apply Hi.
+  apply Rplus_le_compat_r.
+  apply Rnot_lt_le.
+  intros Hy.
+  refine (H _ _ Py).
+  apply INR_lt in Hy.
+  clear -Hy HyN.
+  omega.
+  now apply Rlt_le, Rinv_0_lt_compat.
+rewrite S_INR, HN.
+ring_simplify (IZR (up (/ l)) - 1 + 1)%R.
+rewrite <- (Rinv_involutive l) at 2 by now apply Rgt_not_eq.
+apply Rinv_1_lt_contravar.
+rewrite <- Rinv_1.
+apply Rinv_le.
+exact Hl.
+now apply lub.
+apply archimed.
+Qed.
+
+Theorem LPO :
+  forall P : nat -> Prop, (forall n, P n \/ ~ P n) ->
+  {n : nat | P n} + {forall n, ~ P n}.
+Proof.
+intros P HP.
+destruct (LPO_min P HP) as [[n [Pn _]]|Pn].
+left.
+now exists n.
+now right.
+Qed.
+
+
+Lemma LPO_Z : forall P : Z -> Prop, (forall n, P n \/ ~P n) ->
+  {n : Z| P n} + {forall n, ~ P n}.
+Proof.
+intros P H.
+destruct (LPO (fun n => P (Z.of_nat n))) as [J|J].
+intros n; apply H.
+destruct J as (n, Hn).
+left; now exists (Z.of_nat n).
+destruct (LPO (fun n => P (-Z.of_nat n)%Z)) as [K|K].
+intros n; apply H.
+destruct K as (n, Hn).
+left; now exists (-Z.of_nat n)%Z.
+right; intros n; case (Zle_or_lt 0 n); intros M.
+rewrite <- (Zabs_eq n); trivial.
+rewrite <- Zabs2Nat.id_abs.
+apply J.
+rewrite <- (Zopp_involutive n).
+rewrite <- (Z.abs_neq n).
+rewrite <- Zabs2Nat.id_abs.
+apply K.
+omega.
+Qed.
+
+
+
 (** A little tactic to simplify terms of the form [bpow a * bpow b]. *)
 Ltac bpow_simplify :=
   (* bpow ex * bpow ey ~~> bpow (ex + ey) *)
diff --git a/flocq/Core/Fcore_Zaux.v b/flocq/Core/Fcore_Zaux.v
index 4702d62e..f6731b4c 100644
--- a/flocq/Core/Fcore_Zaux.v
+++ b/flocq/Core/Fcore_Zaux.v
@@ -927,3 +927,65 @@ intros [|a|a] [|b|b] ; try rewrite Zpos_div_eucl_aux_correct ; easy.
 Qed.
 
 End faster_div.
+
+Section Iter.
+
+Context {A : Type}.
+Variable (f : A -> A).
+
+Fixpoint iter_nat (n : nat) (x : A) {struct n} : A :=
+  match n with
+  | S n' => iter_nat n' (f x)
+  | O => x
+  end.
+
+Lemma iter_nat_plus :
+  forall (p q : nat) (x : A),
+  iter_nat (p + q) x = iter_nat p (iter_nat q x).
+Proof.
+induction q.
+now rewrite plus_0_r.
+intros x.
+rewrite <- plus_n_Sm.
+apply IHq.
+Qed.
+
+Lemma iter_nat_S :
+  forall (p : nat) (x : A),
+  iter_nat (S p) x = f (iter_nat p x).
+Proof.
+induction p.
+easy.
+simpl.
+intros x.
+apply IHp.
+Qed.
+
+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.
+
+Lemma iter_pos_nat :
+  forall (p : positive) (x : A),
+  iter_pos p x = iter_nat (Pos.to_nat p) x.
+Proof.
+induction p ; intros x.
+rewrite Pos2Nat.inj_xI.
+simpl.
+rewrite plus_0_r.
+rewrite iter_nat_plus.
+rewrite (IHp (f x)).
+apply IHp.
+rewrite Pos2Nat.inj_xO.
+simpl.
+rewrite plus_0_r.
+rewrite iter_nat_plus.
+rewrite (IHp x).
+apply IHp.
+easy.
+Qed.
+
+End Iter.
diff --git a/flocq/Core/Fcore_digits.v b/flocq/Core/Fcore_digits.v
index 13174d29..d40c1a09 100644
--- a/flocq/Core/Fcore_digits.v
+++ b/flocq/Core/Fcore_digits.v
@@ -21,7 +21,7 @@ Require Import ZArith.
 Require Import Zquot.
 Require Import Fcore_Zaux.
 
-(** Computes the number of bits (radix 2) of a positive integer.
+(** Number of bits (radix 2) of a positive integer.
 
 It serves as an upper bound on the number of digits to ensure termination.
 *)
@@ -466,6 +466,8 @@ now apply Hd.
 now rewrite 3!Zdigit_lt.
 Qed.
 
+(** Left and right shifts *)
+
 Definition Zscale n k :=
   if Zle_bool 0 k then (n * Zpower beta k)%Z else Z.quot n (Zpower beta (-k)).
 
@@ -545,6 +547,8 @@ rewrite Zle_bool_true with (1 := Hk).
 now apply Zscale_mul_pow.
 Qed.
 
+(** Slice of an integer *)
+
 Definition Zslice n k1 k2 :=
   if Zle_bool 0 k2 then Z.rem (Zscale n (-k1)) (Zpower beta k2) else Z0.
 
@@ -756,6 +760,7 @@ Fixpoint Zdigits_aux (nb pow : Z) (n : nat) { struct n } : Z :=
 End digits_aux.
 
 (** Number of digits of an integer *)
+
 Definition Zdigits n :=
   match n with
   | Z0 => Z0
@@ -1011,7 +1016,7 @@ generalize (Zpower_gt_Zdigits e x).
 omega.
 Qed.
 
-(** Characterizes the number digits of a product.
+(** Number of digits of a product.
 
 This strong version is needed for proofs of division and square root
 algorithms, since they involve operation remainders.
@@ -1126,6 +1131,8 @@ Qed.
 
 End Fcore_digits.
 
+(** Specialized version for computing the number of bits of an integer *)
+
 Section Zdigits2.
 
 Theorem Z_of_nat_S_digits2_Pnat :
diff --git a/flocq/Core/Fcore_float_prop.v b/flocq/Core/Fcore_float_prop.v
index e1535bc9..8199ede6 100644
--- a/flocq/Core/Fcore_float_prop.v
+++ b/flocq/Core/Fcore_float_prop.v
@@ -233,6 +233,37 @@ rewrite <- F2R_0 with (Fexp f).
 now apply F2R_lt_compat.
 Qed.
 
+Theorem F2R_neq_0_compat :
+ forall f : float beta,
+  (Fnum f <> 0)%Z ->
+  (F2R f <> 0)%R.
+Proof.
+intros f H H1.
+apply H.
+now apply F2R_eq_0_reg with (Fexp f).
+Qed.
+
+
+Lemma Fnum_ge_0_compat: forall (f : float beta),
+  (0 <= F2R f)%R -> (0 <= Fnum f)%Z.
+Proof.
+intros f H.
+case (Zle_or_lt 0 (Fnum f)); trivial.
+intros H1; contradict H.
+apply Rlt_not_le.
+now apply F2R_lt_0_compat.
+Qed.
+
+Lemma Fnum_le_0_compat: forall (f : float beta),
+  (F2R f <= 0)%R -> (Fnum f <= 0)%Z.
+Proof.
+intros f H.
+case (Zle_or_lt (Fnum f) 0); trivial.
+intros H1; contradict H.
+apply Rlt_not_le.
+now apply F2R_gt_0_compat.
+Qed.
+
 (** Floats and bpow *)
 Theorem F2R_bpow :
   forall e : Z,
diff --git a/flocq/Core/Fcore_generic_fmt.v b/flocq/Core/Fcore_generic_fmt.v
index 45729f2a..bac65b9d 100644
--- a/flocq/Core/Fcore_generic_fmt.v
+++ b/flocq/Core/Fcore_generic_fmt.v
@@ -1015,7 +1015,7 @@ Qed.
 
 End monotone.
 
-Theorem round_abs_abs' :
+Theorem round_abs_abs :
   forall P : R -> R -> Prop,
   ( forall rnd (Hr : Valid_rnd rnd) x, (0 <= x)%R -> P x (round rnd x) ) ->
   forall rnd {Hr : Valid_rnd rnd} x, P (Rabs x) (Rabs (round rnd x)).
@@ -1043,18 +1043,6 @@ apply round_le...
 now apply Rlt_le.
 Qed.
 
-(* TODO: remove *)
-Theorem round_abs_abs :
-  forall P : R -> R -> Prop,
-  ( forall rnd (Hr : Valid_rnd rnd) x, P x (round rnd x) ) ->
-  forall rnd {Hr : Valid_rnd rnd} x, P (Rabs x) (Rabs (round rnd x)).
-Proof.
-intros P HP.
-apply round_abs_abs'.
-intros.
-now apply HP.
-Qed.
-
 Theorem round_bounded_large :
   forall rnd {Hr : Valid_rnd rnd} x ex,
   (fexp ex < ex)%Z ->
@@ -1064,7 +1052,7 @@ Proof with auto with typeclass_instances.
 intros rnd Hr x ex He.
 apply round_abs_abs...
 clear rnd Hr x.
-intros rnd' Hr x.
+intros rnd' Hr x _.
 apply round_bounded_large_pos...
 Qed.
 
@@ -1076,7 +1064,7 @@ Proof.
 intros rnd Hr x ex H1 H2.
 generalize Rabs_R0.
 rewrite <- H2 at 1.
-apply (round_abs_abs' (fun t rt => forall (ex : Z),
+apply (round_abs_abs (fun t rt => forall (ex : Z),
 (bpow (ex - 1) <= t < bpow ex)%R ->
 rt = 0%R -> (ex <= fexp ex)%Z)); trivial.
 clear; intros rnd Hr x Hx.
@@ -1496,7 +1484,7 @@ right.
 now rewrite Zmax_l with (1 := Zlt_le_weak _ _ He).
 Qed.
 
-Theorem ln_beta_round_DN :
+Theorem ln_beta_DN :
   forall x,
   (0 < round Zfloor x)%R ->
   (ln_beta beta (round Zfloor x) = ln_beta beta x :> Z).
@@ -1513,7 +1501,6 @@ now apply Rgt_not_eq.
 now apply Rlt_le.
 Qed.
 
-(* TODO: remove *)
 Theorem canonic_exp_DN :
   forall x,
   (0 < round Zfloor x)%R ->
@@ -1521,7 +1508,7 @@ Theorem canonic_exp_DN :
 Proof.
 intros x Hd.
 apply (f_equal fexp).
-now apply ln_beta_round_DN.
+now apply ln_beta_DN.
 Qed.
 
 Theorem scaled_mantissa_DN :
@@ -2312,7 +2299,7 @@ intros x Gx.
 apply generic_format_abs_inv.
 apply generic_format_abs in Gx.
 revert rnd valid_rnd x Gx.
-refine (round_abs_abs' _ (fun x y => generic_format fexp1 x -> generic_format fexp1 y) _).
+refine (round_abs_abs _ (fun x y => generic_format fexp1 x -> generic_format fexp1 y) _).
 intros rnd valid_rnd x [Hx|Hx] Gx.
 (* x > 0 *)
 generalize (ln_beta_generic_gt _ x (Rgt_not_eq _ _ Hx) Gx).
diff --git a/flocq/Core/Fcore_rnd.v b/flocq/Core/Fcore_rnd.v
index 94c94203..171c27fc 100644
--- a/flocq/Core/Fcore_rnd.v
+++ b/flocq/Core/Fcore_rnd.v
@@ -39,7 +39,7 @@ exists f.
 intros g Hg.
 now apply H2 with (3 := Rle_refl x).
 (* . *)
-exists (projT1 (completeness _ H3 H1)).
+exists (proj1_sig (completeness _ H3 H1)).
 destruct completeness as (f1, (H4, H5)).
 simpl.
 destruct H1 as (f2, H1).
@@ -58,7 +58,7 @@ Theorem round_fun_of_pred :
   { f : R -> R | forall x, rnd x (f x) }.
 Proof.
 intros rnd H.
-exists (fun x => projT1 (round_val_of_pred rnd H x)).
+exists (fun x => proj1_sig (round_val_of_pred rnd H x)).
 intros x.
 now destruct round_val_of_pred as (f, H1).
 Qed.
diff --git a/flocq/Core/Fcore_rnd_ne.v b/flocq/Core/Fcore_rnd_ne.v
index 6829c0c8..1f265406 100644
--- a/flocq/Core/Fcore_rnd_ne.v
+++ b/flocq/Core/Fcore_rnd_ne.v
@@ -164,7 +164,7 @@ now apply Rlt_le.
 assert (Hxe2 : (fexp (ex + 1) <= ex)%Z) by now apply valid_exp.
 assert (Hud: (F2R xu = F2R xd + ulp beta fexp x)%R).
 rewrite Hxu, Hxd.
-now apply ulp_DN_UP.
+now apply round_UP_DN_ulp.
 destruct (total_order_T (bpow ex) (F2R xu)) as [[Hu2|Hu2]|Hu2].
 (* - xu > bpow ex  *)
 elim (Rlt_not_le _ _ Hu2).
@@ -191,7 +191,8 @@ rewrite Rmult_plus_distr_r.
 rewrite Z2R_Zpower, <- bpow_plus.
 ring_simplify (ex - fexp ex + fexp ex)%Z.
 rewrite Hu2, Hud.
-unfold ulp, canonic_exp.
+rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
+unfold canonic_exp.
 rewrite ln_beta_unique with beta x ex.
 unfold F2R.
 simpl. ring.
@@ -223,7 +224,8 @@ specialize (H ex).
 omega.
 (* - xu < bpow ex *)
 revert Hud.
-unfold ulp, F2R.
+rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
+unfold F2R.
 rewrite Hd, Hu.
 unfold canonic_exp.
 rewrite ln_beta_unique with beta (F2R xu) ex.
diff --git a/flocq/Core/Fcore_ulp.v b/flocq/Core/Fcore_ulp.v
index 04bed01c..1c27de31 100644
--- a/flocq/Core/Fcore_ulp.v
+++ b/flocq/Core/Fcore_ulp.v
@@ -32,9 +32,79 @@ Notation bpow e := (bpow beta e).
 
 Variable fexp : Z -> Z.
 
+(** Definition and basic properties about the minimal exponent, when it exists *)
+
+Lemma Z_le_dec_aux: forall x y : Z, (x <= y)%Z \/ ~ (x <= y)%Z.
+intros.
+destruct (Z_le_dec x y).
+now left.
+now right.
+Qed.
+
+
+(** [negligible_exp] is either none (as in FLX) or Some n such that n <= fexp n. *)
+Definition negligible_exp: option Z :=
+  match (LPO_Z _ (fun z => Z_le_dec_aux z (fexp z))) with
+   | inleft N => Some (proj1_sig N)
+   | inright _ => None
+ end.
+
+
+Inductive negligible_exp_prop: option Z -> Prop :=
+  | negligible_None: (forall n, (fexp n < n)%Z) -> negligible_exp_prop None
+  | negligible_Some: forall n, (n <= fexp n)%Z -> negligible_exp_prop (Some n).
+
+
+Lemma negligible_exp_spec: negligible_exp_prop negligible_exp.
+Proof.
+unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn].
+now apply negligible_Some.
+apply negligible_None.
+intros n; specialize (Hn n); omega.
+Qed.
+
+Lemma negligible_exp_spec': (negligible_exp = None /\ forall n, (fexp n < n)%Z)
+           \/ exists n, (negligible_exp = Some n /\ (n <= fexp n)%Z).
+Proof.
+unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn].
+right; simpl; exists n; now split.
+left; split; trivial.
+intros n; specialize (Hn n); omega.
+Qed.
+
 Context { valid_exp : Valid_exp fexp }.
 
-Definition ulp x := bpow (canonic_exp beta fexp x).
+Lemma fexp_negligible_exp_eq: forall n m, (n <= fexp n)%Z -> (m <= fexp m)%Z -> fexp n = fexp m.
+Proof.
+intros n m Hn Hm.
+case (Zle_or_lt n m); intros H.
+apply valid_exp; omega.
+apply sym_eq, valid_exp; omega.
+Qed.
+
+
+(** Definition and basic properties about the ulp *)
+(** Now includes a nice ulp(0): ulp(0) is now 0 when there is no minimal
+   exponent, such as in FLX, and beta^(fexp n) when there is a n such
+   that n <= fexp n. For instance, the value of ulp(O) is then
+   beta^emin in FIX and FLT. The main lemma to use is ulp_neq_0 that
+   is equivalent to the previous "unfold ulp" provided the value is
+   not zero. *)
+
+Definition ulp x := match Req_bool x 0 with
+  | true   => match negligible_exp with
+            | Some n => bpow (fexp n)
+            | None => 0%R
+            end
+  | false  => bpow (canonic_exp beta fexp x)
+ end.
+
+Lemma ulp_neq_0 : forall x:R, (x <> 0)%R -> ulp x = bpow (canonic_exp beta fexp x).
+Proof.
+intros  x Hx.
+unfold ulp; case (Req_bool_spec x); trivial.
+intros H; now contradict H.
+Qed.
 
 Notation F := (generic_format beta fexp).
 
@@ -43,17 +113,37 @@ Theorem ulp_opp :
 Proof.
 intros x.
 unfold ulp.
+case Req_bool_spec; intros H1.
+rewrite Req_bool_true; trivial.
+rewrite <- (Ropp_involutive x), H1; ring.
+rewrite Req_bool_false.
 now rewrite canonic_exp_opp.
+intros H2; apply H1; rewrite H2; ring.
 Qed.
 
 Theorem ulp_abs :
   forall x, ulp (Rabs x) = ulp x.
 Proof.
 intros x.
-unfold ulp.
+unfold ulp; case (Req_bool_spec x 0); intros H1.
+rewrite Req_bool_true; trivial.
+now rewrite H1, Rabs_R0.
+rewrite Req_bool_false.
 now rewrite canonic_exp_abs.
+now apply Rabs_no_R0.
 Qed.
 
+Theorem ulp_ge_0:
+  forall x, (0 <= ulp x)%R.
+Proof.
+intros x; unfold ulp; case Req_bool_spec; intros.
+case negligible_exp; intros.
+apply bpow_ge_0.
+apply Rle_refl.
+apply bpow_ge_0.
+Qed.
+
+
 Theorem ulp_le_id:
   forall x,
     (0 < x)%R ->
@@ -63,7 +153,9 @@ Proof.
 intros x Zx Fx.
 rewrite <- (Rmult_1_l (ulp x)).
 pattern x at 2; rewrite Fx.
-unfold F2R, ulp; simpl.
+rewrite ulp_neq_0.
+2: now apply Rgt_not_eq.
+unfold F2R; simpl.
 apply Rmult_le_compat_r.
 apply bpow_ge_0.
 replace 1%R with (Z2R (Zsucc 0)) by reflexivity.
@@ -86,12 +178,15 @@ now apply Rabs_pos_lt.
 now apply generic_format_abs.
 Qed.
 
-Theorem ulp_DN_UP :
+
+(* was ulp_DN_UP *)
+Theorem round_UP_DN_ulp :
   forall x, ~ F x ->
   round beta fexp Zceil x = (round beta fexp Zfloor x + ulp x)%R.
 Proof.
 intros x Fx.
-unfold round, ulp. simpl.
+rewrite ulp_neq_0.
+unfold round. simpl.
 unfold F2R. simpl.
 rewrite Zceil_floor_neq.
 rewrite Z2R_plus. simpl.
@@ -103,459 +198,233 @@ rewrite <- H.
 rewrite Ztrunc_Z2R.
 rewrite H.
 now rewrite scaled_mantissa_mult_bpow.
+intros V; apply Fx.
+rewrite V.
+apply generic_format_0.
 Qed.
 
-(** The successor of x is x + ulp x *)
-Theorem succ_le_bpow :
-  forall x e, (0 < x)%R -> F x ->
-  (x < bpow e)%R ->
-  (x + ulp x <= bpow e)%R.
-Proof.
-intros x e Zx Fx Hx.
-pattern x at 1 ; rewrite Fx.
-unfold ulp, F2R. simpl.
-pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
-rewrite <- Rmult_plus_distr_r.
-change 1%R with (Z2R 1).
-rewrite <- Z2R_plus.
-change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow e)%R.
-apply F2R_p1_le_bpow.
-apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
-now rewrite <- Fx.
-now rewrite <- Fx.
-Qed.
 
-Theorem ln_beta_succ :
-  forall x, (0 < x)%R -> F x ->
-  forall eps, (0 <= eps < ulp x)%R ->
-  ln_beta beta (x + eps) = ln_beta beta x :> Z.
-Proof.
-intros x Zx Fx eps Heps.
-destruct (ln_beta beta x) as (ex, He).
-simpl.
-specialize (He (Rgt_not_eq _ _ Zx)).
-apply ln_beta_unique.
+Theorem ulp_bpow :
+  forall e, ulp (bpow e) = bpow (fexp (e + 1)).
+intros e.
+rewrite ulp_neq_0.
+apply f_equal.
+apply canonic_exp_fexp.
 rewrite Rabs_pos_eq.
-rewrite Rabs_pos_eq in He.
 split.
-apply Rle_trans with (1 := proj1 He).
-pattern x at 1 ; rewrite <- Rplus_0_r.
-now apply Rplus_le_compat_l.
-apply Rlt_le_trans with (x + ulp x)%R.
-now apply Rplus_lt_compat_l.
-pattern x at 1 ; rewrite Fx.
-unfold ulp, F2R. simpl.
-pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
-rewrite <- Rmult_plus_distr_r.
-change 1%R with (Z2R 1).
-rewrite <- Z2R_plus.
-change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow ex)%R.
-apply F2R_p1_le_bpow.
-apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
-now rewrite <- Fx.
-now rewrite <- Fx.
-now apply Rlt_le.
-apply Rplus_le_le_0_compat.
-now apply Rlt_le.
-apply Heps.
+ring_simplify (e + 1 - 1)%Z.
+apply Rle_refl.
+apply bpow_lt.
+apply Zlt_succ.
+apply bpow_ge_0.
+apply Rgt_not_eq, Rlt_gt, bpow_gt_0.
 Qed.
 
-Theorem round_DN_succ :
-  forall x, (0 < x)%R -> F x ->
-  forall eps, (0 <= eps < ulp x)%R ->
-  round beta fexp Zfloor (x + eps) = x.
+
+Lemma generic_format_ulp_0:
+  F (ulp 0).
 Proof.
-intros x Zx Fx eps Heps.
-pattern x at 2 ; rewrite Fx.
-unfold round.
-unfold scaled_mantissa. simpl.
-unfold canonic_exp at 1 2.
-rewrite ln_beta_succ ; trivial.
-apply (f_equal (fun m => F2R (Float beta m _))).
-rewrite Ztrunc_floor.
-apply Zfloor_imp.
-split.
-apply (Rle_trans _ _ _ (Zfloor_lb _)).
-apply Rmult_le_compat_r.
-apply bpow_ge_0.
-pattern x at 1 ; rewrite <- Rplus_0_r.
-now apply Rplus_le_compat_l.
-apply Rlt_le_trans with ((x + ulp x) * bpow (- canonic_exp beta fexp x))%R.
-apply Rmult_lt_compat_r.
-apply bpow_gt_0.
-now apply Rplus_lt_compat_l.
-rewrite Rmult_plus_distr_r.
-rewrite Z2R_plus.
-apply Rplus_le_compat.
-pattern x at 1 3 ; rewrite Fx.
-unfold F2R. simpl.
-rewrite Rmult_assoc.
-rewrite <- bpow_plus.
-rewrite Zplus_opp_r.
-rewrite Rmult_1_r.
-rewrite Zfloor_Z2R.
-apply Rle_refl.
 unfold ulp.
-rewrite <- bpow_plus.
-rewrite Zplus_opp_r.
-apply Rle_refl.
-apply Rmult_le_pos.
-now apply Rlt_le.
-apply bpow_ge_0.
+rewrite Req_bool_true; trivial.
+case negligible_exp_spec.
+intros _; apply generic_format_0.
+intros n H1.
+apply generic_format_bpow.
+now apply valid_exp.
 Qed.
 
-Theorem generic_format_succ :
-  forall x, (0 < x)%R -> F x ->
-  F (x + ulp x).
+Lemma generic_format_bpow_ge_ulp_0:  forall e,
+    (ulp 0 <= bpow e)%R -> F (bpow e).
 Proof.
-intros x Zx Fx.
-destruct (ln_beta beta x) as (ex, Ex).
-specialize (Ex (Rgt_not_eq _ _ Zx)).
-assert (Ex' := Ex).
-rewrite Rabs_pos_eq in Ex'.
-destruct (succ_le_bpow x ex) ; try easy.
-unfold generic_format, scaled_mantissa, canonic_exp.
-rewrite ln_beta_unique with beta (x + ulp x)%R ex.
-pattern x at 1 3 ; rewrite Fx.
-unfold ulp, scaled_mantissa.
-rewrite canonic_exp_fexp with (1 := Ex).
-unfold F2R. simpl.
-rewrite Rmult_plus_distr_r.
-rewrite Rmult_assoc.
-rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r.
-change (bpow 0) with (Z2R 1).
-rewrite <- Z2R_plus.
-rewrite Ztrunc_Z2R.
-rewrite Z2R_plus.
-rewrite Rmult_plus_distr_r.
-now rewrite Rmult_1_l.
-rewrite Rabs_pos_eq.
-split.
-apply Rle_trans with (1 := proj1 Ex').
-pattern x at 1 ; rewrite <- Rplus_0_r.
-apply Rplus_le_compat_l.
-apply bpow_ge_0.
-exact H.
-apply Rplus_le_le_0_compat.
-now apply Rlt_le.
-apply bpow_ge_0.
-rewrite H.
+intros e; unfold ulp.
+rewrite Req_bool_true; trivial.
+case negligible_exp_spec.
+intros H1 _.
 apply generic_format_bpow.
-apply valid_exp.
-destruct (Zle_or_lt ex (fexp ex)) ; trivial.
-elim Rlt_not_le with (1 := Zx).
-rewrite Fx.
-replace (Ztrunc (scaled_mantissa beta fexp x)) with Z0.
-rewrite F2R_0.
-apply Rle_refl.
-unfold scaled_mantissa.
-rewrite canonic_exp_fexp with (1 := Ex).
-destruct (mantissa_small_pos beta fexp x ex) ; trivial.
-rewrite Ztrunc_floor.
-apply sym_eq.
-apply Zfloor_imp.
-split.
-now apply Rlt_le.
-exact H2.
-now apply Rlt_le.
-now apply Rlt_le.
+specialize (H1 (e+1)%Z); omega.
+intros n H1 H2.
+apply generic_format_bpow.
+case (Zle_or_lt (e+1) (fexp (e+1))); intros H4.
+absurd (e+1 <= e)%Z.
+omega.
+apply Zle_trans with (1:=H4).
+replace (fexp (e+1)) with (fexp n).
+now apply le_bpow with beta.
+now apply fexp_negligible_exp_eq.
+omega.
 Qed.
 
-Theorem round_UP_succ :
-  forall x, (0 < x)%R -> F x ->
-  forall eps, (0 < eps <= ulp x)%R ->
-  round beta fexp Zceil (x + eps) = (x + ulp x)%R.
-Proof with auto with typeclass_instances.
-intros x Zx Fx eps (Heps1,[Heps2|Heps2]).
-assert (Heps: (0 <= eps < ulp x)%R).
-split.
-now apply Rlt_le.
-exact Heps2.
-assert (Hd := round_DN_succ x Zx Fx eps Heps).
-rewrite ulp_DN_UP.
-rewrite Hd.
-unfold ulp, canonic_exp.
-now rewrite ln_beta_succ.
-intros Fs.
-rewrite round_generic in Hd...
-apply Rgt_not_eq with (2 := Hd).
-pattern x at 2 ; rewrite <- Rplus_0_r.
-now apply Rplus_lt_compat_l.
-rewrite Heps2.
-apply round_generic...
-now apply generic_format_succ.
+(** The three following properties are equivalent:
+      [Exp_not_FTZ] ;  forall x, F (ulp x) ; forall x, ulp 0 <= ulp x *)
+
+Lemma generic_format_ulp: Exp_not_FTZ fexp ->
+  forall x,  F (ulp x).
+Proof.
+unfold Exp_not_FTZ; intros H x.
+case (Req_dec x 0); intros Hx.
+rewrite Hx; apply generic_format_ulp_0.
+rewrite (ulp_neq_0 _ Hx).
+apply generic_format_bpow; unfold canonic_exp.
+apply H.
 Qed.
 
-Theorem succ_le_lt:
-  forall x y,
-  F x -> F y ->
-  (0 < x < y)%R ->
-  (x + ulp x <= y)%R.
-Proof with auto with typeclass_instances.
-intros x y Hx Hy H.
-case (Rle_or_lt (ulp x) (y-x)); intros H1.
-apply Rplus_le_reg_r with (-x)%R.
-now ring_simplify (x+ulp x + -x)%R.
-replace y with (x+(y-x))%R by ring.
-absurd (x < y)%R.
-2: apply H.
-apply Rle_not_lt; apply Req_le.
-rewrite <- round_DN_succ with (eps:=(y-x)%R); try easy.
-ring_simplify (x+(y-x))%R.
-apply sym_eq.
-apply round_generic...
-split; trivial.
-apply Rlt_le; now apply Rlt_Rminus.
+Lemma not_FTZ_generic_format_ulp:
+   (forall x,  F (ulp x)) -> Exp_not_FTZ fexp.
+intros H e.
+specialize (H (bpow (e-1))).
+rewrite ulp_neq_0 in H.
+2: apply Rgt_not_eq, bpow_gt_0.
+unfold canonic_exp in H.
+rewrite ln_beta_bpow in H.
+apply generic_format_bpow_inv' in H...
+now replace (e-1+1)%Z with e in H by ring.
 Qed.
 
-(** Error of a rounding, expressed in number of ulps *)
-Theorem ulp_error :
-  forall rnd { Zrnd : Valid_rnd rnd } x,
-  (Rabs (round beta fexp rnd x - x) < ulp x)%R.
-Proof with auto with typeclass_instances.
-intros rnd Zrnd x.
-destruct (generic_format_EM beta fexp x) as [Hx|Hx].
-(* x = rnd x *)
-rewrite round_generic...
-unfold Rminus.
-rewrite Rplus_opp_r, Rabs_R0.
-apply bpow_gt_0.
-(* x <> rnd x *)
-destruct (round_DN_or_UP beta fexp rnd x) as [H|H] ; rewrite H ; clear H.
-(* . *)
-rewrite Rabs_left1.
-rewrite Ropp_minus_distr.
-apply Rplus_lt_reg_l with (round beta fexp Zfloor x).
-rewrite <- ulp_DN_UP with (1 := Hx).
-ring_simplify.
-assert (Hu: (x <= round beta fexp Zceil x)%R).
-apply round_UP_pt...
-destruct Hu as [Hu|Hu].
-exact Hu.
-elim Hx.
-rewrite Hu.
-apply generic_format_round...
-apply Rle_minus.
-apply round_DN_pt...
-(* . *)
-rewrite Rabs_pos_eq.
-rewrite ulp_DN_UP with (1 := Hx).
-apply Rplus_lt_reg_r with (x - ulp x)%R.
-ring_simplify.
-assert (Hd: (round beta fexp Zfloor x <= x)%R).
-apply round_DN_pt...
-destruct Hd as [Hd|Hd].
-exact Hd.
-elim Hx.
-rewrite <- Hd.
-apply generic_format_round...
-apply Rle_0_minus.
-apply round_UP_pt...
+
+Lemma ulp_ge_ulp_0: Exp_not_FTZ fexp ->
+  forall x,  (ulp 0 <= ulp x)%R.
+Proof.
+unfold Exp_not_FTZ; intros H x.
+case (Req_dec x 0); intros Hx.
+rewrite Hx; now right.
+unfold ulp at 1.
+rewrite Req_bool_true; trivial.
+case negligible_exp_spec'.
+intros (H1,H2); rewrite H1; apply ulp_ge_0.
+intros (n,(H1,H2)); rewrite H1.
+rewrite ulp_neq_0; trivial.
+apply bpow_le; unfold canonic_exp.
+generalize (ln_beta beta x); intros l.
+case (Zle_or_lt l (fexp l)); intros Hl.
+rewrite (fexp_negligible_exp_eq n l); trivial; apply Zle_refl.
+case (Zle_or_lt (fexp n) (fexp l)); trivial; intros K.
+absurd (fexp n <= fexp l)%Z.
+omega.
+apply Zle_trans with (2:= H _).
+apply Zeq_le, sym_eq, valid_exp; trivial.
+omega.
 Qed.
 
-Theorem ulp_half_error :
-  forall choice x,
-  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp x)%R.
-Proof with auto with typeclass_instances.
-intros choice x.
-destruct (generic_format_EM beta fexp x) as [Hx|Hx].
-(* x = rnd x *)
-rewrite round_generic...
-unfold Rminus.
-rewrite Rplus_opp_r, Rabs_R0.
-apply Rmult_le_pos.
-apply Rlt_le.
-apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
-apply bpow_ge_0.
-(* x <> rnd x *)
-set (d := round beta fexp Zfloor x).
-destruct (round_N_pt beta fexp choice x) as (Hr1, Hr2).
-destruct (Rle_or_lt (x - d) (d + ulp x - x)) as [H|H].
-(* . rnd(x) = rndd(x) *)
-apply Rle_trans with (Rabs (d - x)).
-apply Hr2.
-apply (round_DN_pt beta fexp x).
-rewrite Rabs_left1.
-rewrite Ropp_minus_distr.
-apply Rmult_le_reg_r with 2%R.
-now apply (Z2R_lt 0 2).
-apply Rplus_le_reg_r with (d - x)%R.
-ring_simplify.
-apply Rle_trans with (1 := H).
-right. field.
-apply Rle_minus.
-apply (round_DN_pt beta fexp x).
-(* . rnd(x) = rndu(x) *)
-assert (Hu: (d + ulp x)%R = round beta fexp Zceil x).
-unfold d.
-now rewrite <- ulp_DN_UP.
-apply Rle_trans with (Rabs (d + ulp x - x)).
-apply Hr2.
-rewrite Hu.
-apply (round_UP_pt beta fexp x).
-rewrite Rabs_pos_eq.
-apply Rmult_le_reg_r with 2%R.
-now apply (Z2R_lt 0 2).
-apply Rplus_le_reg_r with (- (d + ulp x - x))%R.
-ring_simplify.
-apply Rlt_le.
-apply Rlt_le_trans with (1 := H).
-right. field.
-apply Rle_0_minus.
-rewrite Hu.
-apply (round_UP_pt beta fexp x).
+Lemma not_FTZ_ulp_ge_ulp_0:
+   (forall x,  (ulp 0 <= ulp x)%R) -> Exp_not_FTZ fexp.
+Proof.
+intros H e.
+apply generic_format_bpow_inv' with beta.
+apply generic_format_bpow_ge_ulp_0.
+replace e with ((e-1)+1)%Z by ring.
+rewrite <- ulp_bpow.
+apply H.
 Qed.
 
-Theorem ulp_le :
+
+
+Theorem ulp_le_pos :
   forall { Hm : Monotone_exp fexp },
   forall x y: R,
-  (0 < x)%R -> (x <= y)%R ->
+  (0 <= x)%R -> (x <= y)%R ->
   (ulp x <= ulp y)%R.
-Proof.
+Proof with auto with typeclass_instances.
 intros Hm x y Hx Hxy.
+destruct Hx as [Hx|Hx].
+rewrite ulp_neq_0.
+rewrite ulp_neq_0.
 apply bpow_le.
 apply Hm.
 now apply ln_beta_le.
+apply Rgt_not_eq, Rlt_gt.
+now apply Rlt_le_trans with (1:=Hx).
+now apply Rgt_not_eq.
+rewrite <- Hx.
+apply ulp_ge_ulp_0.
+apply monotone_exp_not_FTZ...
 Qed.
 
-Theorem ulp_bpow :
-  forall e, ulp (bpow e) = bpow (fexp (e + 1)).
-intros e.
-unfold ulp.
-apply f_equal.
-apply canonic_exp_fexp.
-rewrite Rabs_pos_eq.
-split.
-ring_simplify (e + 1 - 1)%Z.
-apply Rle_refl.
-apply bpow_lt.
-apply Zlt_succ.
-apply bpow_ge_0.
-Qed.
 
-Theorem ulp_DN :
-  forall x,
-  (0 < round beta fexp Zfloor x)%R ->
-  ulp (round beta fexp Zfloor x) = ulp x.
+Theorem ulp_le :
+  forall { Hm : Monotone_exp fexp },
+  forall x y: R,
+  (Rabs x <= Rabs y)%R ->
+  (ulp x <= ulp y)%R.
 Proof.
-intros x Hd.
-unfold ulp.
-now rewrite canonic_exp_DN with (2 := Hd).
+intros Hm x y Hxy.
+rewrite <- ulp_abs.
+rewrite <- (ulp_abs y).
+apply ulp_le_pos; trivial.
+apply Rabs_pos.
 Qed.
 
-Theorem ulp_error_f :
-  forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x,
-  (round beta fexp rnd x <> 0)%R ->
-  (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R.
-Proof with auto with typeclass_instances.
-intros Hm rnd Zrnd x Hfx.
-case (round_DN_or_UP beta fexp rnd x); intros Hx.
-(* *)
-case (Rle_or_lt 0 (round beta fexp Zfloor x)).
-intros H; destruct H.
-rewrite Hx at 2.
-rewrite ulp_DN; trivial.
-apply ulp_error...
-rewrite Hx in Hfx; contradict Hfx; auto with real.
-intros H.
-apply Rlt_le_trans with (1:=ulp_error _ _).
-rewrite <- (ulp_opp x), <- (ulp_opp (round beta fexp rnd x)).
-apply ulp_le; trivial.
-apply Ropp_0_gt_lt_contravar; apply Rlt_gt.
-case (Rle_or_lt 0 x); trivial.
-intros H1; contradict H.
-apply Rle_not_lt.
-apply round_ge_generic...
-apply generic_format_0.
-apply Ropp_le_contravar; rewrite Hx.
-apply (round_DN_pt beta fexp x).
-(* *)
-rewrite Hx; case (Rle_or_lt 0 (round beta fexp Zceil x)).
-intros H; destruct H.
-apply Rlt_le_trans with (1:=ulp_error _ _).
-apply ulp_le; trivial.
-case (Rle_or_lt x 0); trivial.
-intros H1; contradict H.
-apply Rle_not_lt.
-apply round_le_generic...
-apply generic_format_0.
-apply round_UP_pt...
-rewrite Hx in Hfx; contradict Hfx; auto with real.
-intros H.
-rewrite <- (ulp_opp (round beta fexp Zceil x)).
-rewrite <- round_DN_opp.
-rewrite ulp_DN; trivial.
-replace (round beta fexp Zceil x - x)%R with (-((round beta fexp Zfloor (-x) - (-x))))%R.
-rewrite Rabs_Ropp.
-apply ulp_error...
-rewrite round_DN_opp; ring.
-rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption.
-Qed.
 
-Theorem ulp_half_error_f :
-  forall { Hm : Monotone_exp fexp },
-  forall choice x,
-  (round beta fexp (Znearest choice) x <> 0)%R ->
-  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp (round beta fexp (Znearest choice) x))%R.
-Proof with auto with typeclass_instances.
-intros Hm choice x Hfx.
-case (round_DN_or_UP beta fexp (Znearest choice) x); intros Hx.
-(* *)
-case (Rle_or_lt 0 (round beta fexp Zfloor x)).
-intros H; destruct H.
-rewrite Hx at 2.
-rewrite ulp_DN; trivial.
-apply ulp_half_error.
-rewrite Hx in Hfx; contradict Hfx; auto with real.
-intros H.
-apply Rle_trans with (1:=ulp_half_error _ _).
-apply Rmult_le_compat_l.
-auto with real.
-rewrite <- (ulp_opp x), <- (ulp_opp (round beta fexp (Znearest choice) x)).
-apply ulp_le; trivial.
-apply Ropp_0_gt_lt_contravar; apply Rlt_gt.
-case (Rle_or_lt 0 x); trivial.
-intros H1; contradict H.
-apply Rle_not_lt.
-apply round_ge_generic...
-apply generic_format_0.
-apply Ropp_le_contravar; rewrite Hx.
-apply (round_DN_pt beta fexp x).
-(* *)
-case (Rle_or_lt 0 (round beta fexp Zceil x)).
-intros H; destruct H.
-apply Rle_trans with (1:=ulp_half_error _ _).
-apply Rmult_le_compat_l.
-auto with real.
-apply ulp_le; trivial.
-case (Rle_or_lt x 0); trivial.
-intros H1; contradict H.
-apply Rle_not_lt.
-apply round_le_generic...
-apply generic_format_0.
-rewrite Hx; apply (round_UP_pt beta fexp x).
-rewrite Hx in Hfx; contradict Hfx; auto with real.
-intros H.
-rewrite Hx at 2; rewrite <- (ulp_opp (round beta fexp Zceil x)).
-rewrite <- round_DN_opp.
-rewrite ulp_DN; trivial.
-pattern x at 1 2; rewrite <- Ropp_involutive.
-rewrite round_N_opp.
-unfold Rminus.
-rewrite <- Ropp_plus_distr, Rabs_Ropp.
-apply ulp_half_error.
-rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption.
-Qed.
 
-(** Predecessor *)
-Definition pred x :=
+(** Definition and properties of pred and succ *)
+
+Definition pred_pos x :=
   if Req_bool x (bpow (ln_beta beta x - 1)) then
     (x - bpow (fexp (ln_beta beta x - 1)))%R
   else
     (x - ulp x)%R.
 
-Theorem pred_ge_bpow :
+Definition succ x :=
+   if (Rle_bool 0 x) then
+          (x+ulp x)%R
+   else
+     (- pred_pos (-x))%R.
+
+Definition pred x := (- succ (-x))%R.
+
+Theorem pred_eq_pos:
+  forall x, (0 <= x)%R -> (pred x = pred_pos x)%R.
+Proof.
+intros x Hx; unfold pred, succ.
+case Rle_bool_spec; intros Hx'.
+assert (K:(x = 0)%R).
+apply Rle_antisym; try assumption.
+apply Ropp_le_cancel.
+now rewrite Ropp_0.
+rewrite K; unfold pred_pos.
+rewrite Req_bool_false.
+2: apply Rlt_not_eq, bpow_gt_0.
+rewrite Ropp_0; ring.
+now rewrite 2!Ropp_involutive.
+Qed.
+
+Theorem succ_eq_pos:
+  forall x, (0 <= x)%R -> (succ x = x + ulp x)%R.
+Proof.
+intros x Hx; unfold succ.
+now rewrite Rle_bool_true.
+Qed.
+
+Lemma pred_eq_opp_succ_opp: forall x, pred x = (- succ (-x))%R.
+Proof.
+reflexivity.
+Qed.
+
+Lemma succ_eq_opp_pred_opp: forall x, succ x = (- pred (-x))%R.
+Proof.
+intros x; unfold pred.
+now rewrite 2!Ropp_involutive.
+Qed.
+
+Lemma succ_opp: forall x, (succ (-x) = - pred x)%R.
+Proof.
+intros x; rewrite succ_eq_opp_pred_opp.
+now rewrite Ropp_involutive.
+Qed.
+
+Lemma pred_opp: forall x, (pred (-x) = - succ x)%R.
+Proof.
+intros x; rewrite pred_eq_opp_succ_opp.
+now rewrite Ropp_involutive.
+Qed.
+
+
+
+
+(** pred and succ are in the format *)
+
+(* cannont be x <> ulp 0, due to the counter-example 1-bit FP format fexp: e -> e-1 *)
+(* was pred_ge_bpow *)
+Theorem id_m_ulp_ge_bpow :
   forall x e,  F x ->
   x <> ulp x ->
   (bpow e < x)%R ->
@@ -573,7 +442,8 @@ omega.
 case (Zle_lt_or_eq _ _ H); intros Hm.
 (* *)
 pattern x at 1 ; rewrite Fx.
-unfold ulp, F2R. simpl.
+rewrite ulp_neq_0.
+unfold F2R. simpl.
 pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
 rewrite <- Rmult_minus_distr_r.
 change 1%R with (Z2R 1).
@@ -581,15 +451,44 @@ rewrite <- Z2R_minus.
 change (bpow e <= F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) - 1) (canonic_exp beta fexp x)))%R.
 apply bpow_le_F2R_m1; trivial.
 now rewrite <- Fx.
+apply Rgt_not_eq, Rlt_gt.
+apply Rlt_trans with (2:=Hx), bpow_gt_0.
 (* *)
 contradict Hx'.
 pattern x at 1; rewrite Fx.
 rewrite  <- Hm.
-unfold ulp, F2R; simpl.
+rewrite ulp_neq_0.
+unfold F2R; simpl.
 now rewrite Rmult_1_l.
+apply Rgt_not_eq, Rlt_gt.
+apply Rlt_trans with (2:=Hx), bpow_gt_0.
 Qed.
 
-Lemma generic_format_pred_1:
+(* was succ_le_bpow *)
+Theorem id_p_ulp_le_bpow :
+  forall x e, (0 < x)%R -> F x ->
+  (x < bpow e)%R ->
+  (x + ulp x <= bpow e)%R.
+Proof.
+intros x e Zx Fx Hx.
+pattern x at 1 ; rewrite Fx.
+rewrite ulp_neq_0.
+unfold F2R. simpl.
+pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
+rewrite <- Rmult_plus_distr_r.
+change 1%R with (Z2R 1).
+rewrite <- Z2R_plus.
+change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow e)%R.
+apply F2R_p1_le_bpow.
+apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
+now rewrite <- Fx.
+now rewrite <- Fx.
+now apply Rgt_not_eq.
+Qed.
+
+
+
+Lemma generic_format_pred_aux1:
   forall x, (0 < x)%R -> F x ->
   x <> bpow (ln_beta beta x - 1) ->
   F (x - ulp x).
@@ -606,7 +505,8 @@ now apply Rlt_le.
 unfold generic_format, scaled_mantissa, canonic_exp.
 rewrite ln_beta_unique with beta (x - ulp x)%R ex.
 pattern x at 1 3 ; rewrite Fx.
-unfold ulp, scaled_mantissa.
+rewrite ulp_neq_0.
+unfold scaled_mantissa.
 rewrite canonic_exp_fexp with (1 := Ex).
 unfold F2R. simpl.
 rewrite Rmult_minus_distr_r.
@@ -618,23 +518,27 @@ rewrite Ztrunc_Z2R.
 rewrite Z2R_minus.
 rewrite Rmult_minus_distr_r.
 now rewrite Rmult_1_l.
+now apply Rgt_not_eq.
 rewrite Rabs_pos_eq.
 split.
-apply pred_ge_bpow; trivial.
-unfold ulp; intro H.
+apply id_m_ulp_ge_bpow; trivial.
+rewrite ulp_neq_0.
+intro H.
 assert (ex-1 < canonic_exp beta fexp x  < ex)%Z.
 split ; apply (lt_bpow beta) ; rewrite <- H ; easy.
 clear -H0. omega.
+now apply Rgt_not_eq.
 apply Ex'.
 apply Rle_lt_trans with (2 := proj2 Ex').
 pattern x at 3 ; rewrite <- Rplus_0_r.
 apply Rplus_le_compat_l.
 rewrite <-Ropp_0.
 apply Ropp_le_contravar.
-apply bpow_ge_0.
+apply ulp_ge_0.
 apply Rle_0_minus.
 pattern x at 2; rewrite Fx.
-unfold ulp, F2R; simpl.
+rewrite ulp_neq_0.
+unfold F2R; simpl.
 pattern (bpow (canonic_exp beta fexp x)) at 1; rewrite <- Rmult_1_l.
 apply Rmult_le_compat_r.
 apply bpow_ge_0.
@@ -646,9 +550,10 @@ rewrite <- Fx.
 apply Rle_lt_trans with (2:=proj1 Ex').
 apply bpow_ge_0.
 omega.
+now apply Rgt_not_eq.
 Qed.
 
-Lemma generic_format_pred_2 :
+Lemma generic_format_pred_aux2 :
   forall x, (0 < x)%R -> F x ->
   let e := ln_beta_val beta x (ln_beta beta x) in
   x =  bpow (e - 1) ->
@@ -712,109 +617,210 @@ rewrite Hx, He.
 ring.
 Qed.
 
-Theorem generic_format_pred :
+
+Theorem generic_format_succ_aux1 :
   forall x, (0 < x)%R -> F x ->
-  F (pred x).
+  F (x + ulp x).
 Proof.
 intros x Zx Fx.
+destruct (ln_beta beta x) as (ex, Ex).
+specialize (Ex (Rgt_not_eq _ _ Zx)).
+assert (Ex' := Ex).
+rewrite Rabs_pos_eq in Ex'.
+destruct (id_p_ulp_le_bpow x ex) ; try easy.
+unfold generic_format, scaled_mantissa, canonic_exp.
+rewrite ln_beta_unique with beta (x + ulp x)%R ex.
+pattern x at 1 3 ; rewrite Fx.
+rewrite ulp_neq_0.
+unfold scaled_mantissa.
+rewrite canonic_exp_fexp with (1 := Ex).
+unfold F2R. simpl.
+rewrite Rmult_plus_distr_r.
+rewrite Rmult_assoc.
+rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r.
+change (bpow 0) with (Z2R 1).
+rewrite <- Z2R_plus.
+rewrite Ztrunc_Z2R.
+rewrite Z2R_plus.
+rewrite Rmult_plus_distr_r.
+now rewrite Rmult_1_l.
+now apply Rgt_not_eq.
+rewrite Rabs_pos_eq.
+split.
+apply Rle_trans with (1 := proj1 Ex').
+pattern x at 1 ; rewrite <- Rplus_0_r.
+apply Rplus_le_compat_l.
+apply ulp_ge_0.
+exact H.
+apply Rplus_le_le_0_compat.
+now apply Rlt_le.
+apply ulp_ge_0.
+rewrite H.
+apply generic_format_bpow.
+apply valid_exp.
+destruct (Zle_or_lt ex (fexp ex)) ; trivial.
+elim Rlt_not_le with (1 := Zx).
+rewrite Fx.
+replace (Ztrunc (scaled_mantissa beta fexp x)) with Z0.
+rewrite F2R_0.
+apply Rle_refl.
+unfold scaled_mantissa.
+rewrite canonic_exp_fexp with (1 := Ex).
+destruct (mantissa_small_pos beta fexp x ex) ; trivial.
+rewrite Ztrunc_floor.
+apply sym_eq.
+apply Zfloor_imp.
+split.
+now apply Rlt_le.
+exact H2.
+now apply Rlt_le.
+now apply Rlt_le.
+Qed.
+
+Theorem generic_format_pred_pos :
+  forall x, F x -> (0 < x)%R ->
+  F (pred_pos x).
+Proof.
+intros x Fx Zx.
+unfold pred_pos; case Req_bool_spec; intros H.
+now apply generic_format_pred_aux2.
+now apply generic_format_pred_aux1.
+Qed.
+
+
+Theorem generic_format_succ :
+  forall x, F x ->
+  F (succ x).
+Proof.
+intros x Fx.
+unfold succ; case Rle_bool_spec; intros Zx.
+destruct Zx as [Zx|Zx].
+now apply generic_format_succ_aux1.
+rewrite <- Zx, Rplus_0_l.
+apply generic_format_ulp_0.
+apply generic_format_opp.
+apply generic_format_pred_pos.
+now apply generic_format_opp.
+now apply Ropp_0_gt_lt_contravar.
+Qed.
+
+Theorem generic_format_pred :
+  forall x, F x ->
+  F (pred x).
+Proof.
+intros x Fx.
 unfold pred.
-case Req_bool_spec; intros H.
-now apply generic_format_pred_2.
-now apply generic_format_pred_1.
+apply generic_format_opp.
+apply generic_format_succ.
+now apply generic_format_opp.
 Qed.
 
-Theorem generic_format_plus_ulp :
-  forall { monotone_exp : Monotone_exp fexp },
+
+
+Theorem pred_pos_lt_id :
   forall x, (x <> 0)%R ->
-  F x -> F (x + ulp x).
-Proof with auto with typeclass_instances.
-intros monotone_exp x Zx Fx.
-destruct (Rtotal_order x 0) as [Hx|[Hx|Hx]].
-rewrite <- Ropp_involutive.
-apply generic_format_opp.
-rewrite Ropp_plus_distr, <- ulp_opp.
-apply generic_format_opp in Fx.
-destruct (Req_dec (-x) (bpow (ln_beta beta (-x) - 1))) as [Hx'|Hx'].
-rewrite Hx' in Fx |- *.
-apply generic_format_bpow_inv' in Fx...
-unfold ulp, canonic_exp.
-rewrite ln_beta_bpow.
-revert Fx.
-generalize (ln_beta_val _ _ (ln_beta beta (-x)) - 1)%Z.
-clear -monotone_exp valid_exp.
-intros e He.
-destruct (Zle_lt_or_eq _ _ He) as [He1|He1].
-assert (He2 : e = (e - fexp (e + 1) + fexp (e + 1))%Z) by ring.
-rewrite He2 at 1.
-rewrite bpow_plus.
-assert (Hb := Z2R_Zpower beta _ (Zle_minus_le_0 _ _ He)).
-match goal with |- F (?a * ?b + - ?b) =>
-  replace (a * b + -b)%R with ((a - 1) * b)%R by ring end.
-rewrite <- Hb.
-rewrite <- (Z2R_minus _ 1).
-change (F (F2R (Float beta (Zpower beta (e - fexp (e + 1)) - 1) (fexp (e + 1))))).
-apply generic_format_F2R.
-intros Zb.
-unfold canonic_exp.
-rewrite ln_beta_F2R with (1 := Zb).
-rewrite (ln_beta_unique beta _ (e - fexp (e + 1))).
-apply monotone_exp.
-rewrite <- He2.
-apply Zle_succ.
-rewrite Rabs_pos_eq.
-rewrite Z2R_minus, Hb.
-split.
-apply Rplus_le_reg_r with (- bpow (e - fexp (e + 1) - 1) + Z2R 1)%R.
-apply Rmult_le_reg_r with (bpow (-(e - fexp (e+1) - 1))).
+  (pred_pos x < x)%R.
+Proof.
+intros x Zx.
+unfold pred_pos.
+case Req_bool_spec; intros H.
+(* *)
+rewrite <- Rplus_0_r.
+apply Rplus_lt_compat_l.
+rewrite <- Ropp_0.
+apply Ropp_lt_contravar.
 apply bpow_gt_0.
-ring_simplify.
-apply Rle_trans with R1.
-rewrite Rmult_1_l.
-apply (bpow_le _ _ 0).
-clear -He1 ; omega.
-rewrite Ropp_mult_distr_l_reverse.
-rewrite <- 2!bpow_plus.
-ring_simplify (e - fexp (e + 1) - 1 + - (e - fexp (e + 1) - 1))%Z.
-ring_simplify (- (e - fexp (e + 1) - 1) + (e - fexp (e + 1)))%Z.
-rewrite bpow_1.
-rewrite <- (Z2R_plus (-1) _).
-apply (Z2R_le 1).
-generalize (Zle_bool_imp_le _ _ (radix_prop beta)).
-clear ; omega.
-rewrite <- (Rplus_0_r (bpow (e - fexp (e + 1)))) at 2.
+(* *)
+rewrite <- Rplus_0_r.
 apply Rplus_lt_compat_l.
-now apply (Z2R_lt (-1) 0).
-rewrite Z2R_minus.
-apply Rle_0_minus.
-rewrite Hb.
-apply (bpow_le _ 0).
-now apply Zle_minus_le_0.
-rewrite He1, Rplus_opp_r.
-apply generic_format_0.
-apply generic_format_pred_1 ; try easy.
 rewrite <- Ropp_0.
-now apply Ropp_lt_contravar.
-now elim Zx.
-now apply generic_format_succ.
+apply Ropp_lt_contravar.
+rewrite ulp_neq_0; trivial.
+apply bpow_gt_0.
 Qed.
 
-Theorem generic_format_minus_ulp :
-  forall { monotone_exp : Monotone_exp fexp },
+Theorem succ_gt_id :
   forall x, (x <> 0)%R ->
-  F x -> F (x - ulp x).
+  (x < succ x)%R.
 Proof.
-intros monotone_exp x Zx Fx.
-replace (x - ulp x)%R with (-(-x + ulp x))%R by ring.
-apply generic_format_opp.
-rewrite <- ulp_opp.
-apply generic_format_plus_ulp.
-contradict Zx.
-rewrite <- (Ropp_involutive x), Zx.
-apply Ropp_0.
-now apply generic_format_opp.
+intros x Zx; unfold succ.
+case Rle_bool_spec; intros Hx.
+pattern x at 1; rewrite <- (Rplus_0_r x).
+apply Rplus_lt_compat_l.
+rewrite ulp_neq_0; trivial.
+apply bpow_gt_0.
+pattern x at 1; rewrite <- (Ropp_involutive x).
+apply Ropp_lt_contravar.
+apply pred_pos_lt_id.
+now auto with real.
 Qed.
 
-Lemma pred_plus_ulp_1 :
+
+Theorem pred_lt_id :
+  forall x,  (x <> 0)%R ->
+  (pred x < x)%R.
+Proof.
+intros x Zx; unfold pred.
+pattern x at 2; rewrite <- (Ropp_involutive x).
+apply Ropp_lt_contravar.
+apply succ_gt_id.
+now auto with real.
+Qed.
+
+Theorem succ_ge_id :
+  forall x, (x <= succ x)%R.
+Proof.
+intros x; case (Req_dec x 0).
+intros V; rewrite V.
+unfold succ; rewrite Rle_bool_true;[idtac|now right].
+rewrite Rplus_0_l; apply ulp_ge_0.
+intros; left; now apply succ_gt_id.
+Qed.
+
+
+Theorem pred_le_id :
+  forall x,  (pred x <= x)%R.
+Proof.
+intros x; unfold pred.
+pattern x at 2; rewrite <- (Ropp_involutive x).
+apply Ropp_le_contravar.
+apply succ_ge_id.
+Qed.
+
+
+Theorem pred_pos_ge_0 :
+  forall x,
+  (0 < x)%R -> F x -> (0 <= pred_pos x)%R.
+Proof.
+intros x Zx Fx.
+unfold pred_pos.
+case Req_bool_spec; intros H.
+(* *)
+apply Rle_0_minus.
+rewrite H.
+apply bpow_le.
+destruct (ln_beta beta x) as (ex,Ex) ; simpl.
+rewrite ln_beta_bpow.
+ring_simplify (ex - 1 + 1 - 1)%Z.
+apply generic_format_bpow_inv with beta; trivial.
+simpl in H.
+rewrite <- H; assumption.
+apply Rle_0_minus.
+now apply ulp_le_id.
+Qed.
+
+Theorem pred_ge_0 :
+  forall x,
+  (0 < x)%R -> F x -> (0 <= pred x)%R.
+Proof.
+intros x Zx Fx.
+rewrite pred_eq_pos.
+now apply pred_pos_ge_0.
+now left.
+Qed.
+
+
+Lemma pred_pos_plus_ulp_aux1 :
   forall x, (0 < x)%R -> F x ->
   x <> bpow (ln_beta beta x - 1) ->
   ((x - ulp x) + ulp (x-ulp x) = x)%R.
@@ -822,24 +828,40 @@ Proof.
 intros x Zx Fx Hx.
 replace (ulp (x - ulp x)) with (ulp x).
 ring.
-unfold ulp at 1 2; apply f_equal.
+assert (H:(x <> 0)%R) by auto with real.
+assert (H':(x <> bpow (canonic_exp beta fexp x))%R).
+unfold canonic_exp; intros M.
+case_eq (ln_beta beta x); intros ex Hex T.
+assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z).
+rewrite T; reflexivity.
+rewrite Lex in *.
+clear T; simpl in *; specialize (Hex H).
+rewrite Rabs_right in Hex.
+2: apply Rle_ge; apply Rlt_le; easy.
+assert (ex-1 < fexp ex  < ex)%Z.
+split ; apply (lt_bpow beta); rewrite <- M;[idtac|easy].
+destruct (proj1 Hex);[trivial|idtac].
+contradict Hx; auto with real.
+omega.
+rewrite 2!ulp_neq_0; try auto with real.
+apply f_equal.
 unfold canonic_exp; apply f_equal.
-destruct (ln_beta beta x) as (ex, Hex).
-simpl in *.
-assert (x <> 0)%R by auto with real.
+case_eq (ln_beta beta x); intros ex Hex T.
+assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z).
+rewrite T; reflexivity.
+rewrite Lex in *; simpl in *; clear T.
 specialize (Hex H).
-apply sym_eq.
-apply ln_beta_unique.
+apply sym_eq, ln_beta_unique.
 rewrite Rabs_right.
 rewrite Rabs_right in Hex.
 2: apply Rle_ge; apply Rlt_le; easy.
 split.
 destruct Hex as ([H1|H1],H2).
-apply pred_ge_bpow; trivial.
-unfold ulp; intros H3.
-assert (ex-1 < canonic_exp beta fexp x  < ex)%Z.
-split ; apply (lt_bpow beta) ; rewrite <- H3 ; easy.
-omega.
+apply Rle_trans with (x-ulp x)%R.
+apply id_m_ulp_ge_bpow; trivial.
+rewrite ulp_neq_0; trivial.
+rewrite ulp_neq_0; trivial.
+right; unfold canonic_exp; now rewrite Lex.
 contradict Hx; auto with real.
 apply Rle_lt_trans with (2:=proj2 Hex).
 rewrite <- Rplus_0_r.
@@ -849,9 +871,10 @@ apply Ropp_le_contravar.
 apply bpow_ge_0.
 apply Rle_ge.
 apply Rle_0_minus.
-pattern x at 2; rewrite Fx.
-unfold ulp, F2R; simpl.
-pattern (bpow (canonic_exp beta fexp x)) at 1; rewrite <- Rmult_1_l.
+rewrite Fx.
+unfold F2R, canonic_exp; simpl.
+rewrite Lex.
+pattern (bpow (fexp ex)) at 1; rewrite <- Rmult_1_l.
 apply Rmult_le_compat_r.
 apply bpow_ge_0.
 replace 1%R with (Z2R (Zsucc 0)) by reflexivity.
@@ -861,7 +884,8 @@ apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
 now rewrite <- Fx.
 Qed.
 
-Lemma pred_plus_ulp_2 :
+
+Lemma pred_pos_plus_ulp_aux2 :
   forall x, (0 < x)%R -> F x ->
   let e := ln_beta_val beta x (ln_beta beta x) in
   x =  bpow (e - 1) ->
@@ -876,7 +900,8 @@ apply generic_format_bpow_inv with beta; trivial.
 rewrite <- Hxe; assumption.
 case (Zle_lt_or_eq _ _ He); clear He; intros He.
 (* *)
-unfold ulp; apply f_equal.
+rewrite ulp_neq_0; trivial.
+apply f_equal.
 unfold canonic_exp; apply f_equal.
 apply sym_eq.
 apply ln_beta_unique.
@@ -915,90 +940,271 @@ contradict Zp.
 rewrite Hxe, He; ring.
 Qed.
 
-Theorem pred_plus_ulp :
+Lemma pred_pos_plus_ulp_aux3 :
   forall x, (0 < x)%R -> F x ->
-  (pred x <> 0)%R ->
-  (pred x + ulp (pred x) = x)%R.
+  let e := ln_beta_val beta x (ln_beta beta x) in
+  x =  bpow (e - 1) ->
+  (x - bpow (fexp (e-1)) = 0)%R ->
+  (ulp 0 = x)%R.
 Proof.
-intros x Zx Fx.
-unfold pred.
-case Req_bool_spec; intros H Zp.
-now apply pred_plus_ulp_2.
-now apply pred_plus_ulp_1.
+intros x Hx Fx e H1 H2.
+assert (H3:(x = bpow (fexp (e - 1)))).
+now apply Rminus_diag_uniq.
+assert (H4: (fexp (e-1) = e-1)%Z).
+apply bpow_inj with beta.
+now rewrite <- H1.
+unfold ulp; rewrite Req_bool_true; trivial.
+case negligible_exp_spec.
+intros K.
+specialize (K (e-1)%Z).
+contradict K; omega.
+intros n Hn.
+rewrite H3; apply f_equal.
+case (Zle_or_lt n (e-1)); intros H6.
+apply valid_exp; omega.
+apply sym_eq, valid_exp; omega.
 Qed.
 
-Theorem pred_lt_id :
-  forall x,
-  (pred x < x)%R.
+
+
+
+(** The following one is false for x = 0 in FTZ *)
+
+Theorem pred_pos_plus_ulp :
+  forall x, (0 < x)%R -> F x ->
+  (pred_pos x + ulp (pred_pos x) = x)%R.
 Proof.
-intros.
-unfold pred.
+intros x Zx Fx.
+unfold pred_pos.
 case Req_bool_spec; intros H.
-(* *)
-rewrite <- Rplus_0_r.
-apply Rplus_lt_compat_l.
-rewrite <- Ropp_0.
-apply Ropp_lt_contravar.
+case (Req_EM_T (x - bpow (fexp (ln_beta_val beta x (ln_beta beta x) -1))) 0); intros H1.
+rewrite H1, Rplus_0_l.
+now apply pred_pos_plus_ulp_aux3.
+now apply pred_pos_plus_ulp_aux2.
+now apply pred_pos_plus_ulp_aux1.
+Qed.
+
+
+
+
+(** Rounding x + small epsilon *)
+
+Theorem ln_beta_plus_eps:
+  forall x, (0 < x)%R -> F x ->
+  forall eps, (0 <= eps < ulp x)%R ->
+  ln_beta beta (x + eps) = ln_beta beta x :> Z.
+Proof.
+intros x Zx Fx eps Heps.
+destruct (ln_beta beta x) as (ex, He).
+simpl.
+specialize (He (Rgt_not_eq _ _ Zx)).
+apply ln_beta_unique.
+rewrite Rabs_pos_eq.
+rewrite Rabs_pos_eq in He.
+split.
+apply Rle_trans with (1 := proj1 He).
+pattern x at 1 ; rewrite <- Rplus_0_r.
+now apply Rplus_le_compat_l.
+apply Rlt_le_trans with (x + ulp x)%R.
+now apply Rplus_lt_compat_l.
+pattern x at 1 ; rewrite Fx.
+rewrite ulp_neq_0.
+unfold F2R. simpl.
+pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
+rewrite <- Rmult_plus_distr_r.
+change 1%R with (Z2R 1).
+rewrite <- Z2R_plus.
+change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow ex)%R.
+apply F2R_p1_le_bpow.
+apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
+now rewrite <- Fx.
+now rewrite <- Fx.
+now apply Rgt_not_eq.
+now apply Rlt_le.
+apply Rplus_le_le_0_compat.
+now apply Rlt_le.
+apply Heps.
+Qed.
+
+Theorem round_DN_plus_eps_pos:
+  forall x, (0 <= x)%R -> F x ->
+  forall eps, (0 <= eps < ulp x)%R ->
+  round beta fexp Zfloor (x + eps) = x.
+Proof.
+intros x Zx Fx eps Heps.
+destruct Zx as [Zx|Zx].
+(* . 0 < x *)
+pattern x at 2 ; rewrite Fx.
+unfold round.
+unfold scaled_mantissa. simpl.
+unfold canonic_exp at 1 2.
+rewrite ln_beta_plus_eps ; trivial.
+apply (f_equal (fun m => F2R (Float beta m _))).
+rewrite Ztrunc_floor.
+apply Zfloor_imp.
+split.
+apply (Rle_trans _ _ _ (Zfloor_lb _)).
+apply Rmult_le_compat_r.
+apply bpow_ge_0.
+pattern x at 1 ; rewrite <- Rplus_0_r.
+now apply Rplus_le_compat_l.
+apply Rlt_le_trans with ((x + ulp x) * bpow (- canonic_exp beta fexp x))%R.
+apply Rmult_lt_compat_r.
 apply bpow_gt_0.
-(* *)
-rewrite <- Rplus_0_r.
-apply Rplus_lt_compat_l.
-rewrite <- Ropp_0.
-apply Ropp_lt_contravar.
+now apply Rplus_lt_compat_l.
+rewrite Rmult_plus_distr_r.
+rewrite Z2R_plus.
+apply Rplus_le_compat.
+pattern x at 1 3 ; rewrite Fx.
+unfold F2R. simpl.
+rewrite Rmult_assoc.
+rewrite <- bpow_plus.
+rewrite Zplus_opp_r.
+rewrite Rmult_1_r.
+rewrite Zfloor_Z2R.
+apply Rle_refl.
+rewrite ulp_neq_0.
+2: now apply Rgt_not_eq.
+rewrite <- bpow_plus.
+rewrite Zplus_opp_r.
+apply Rle_refl.
+apply Rmult_le_pos.
+now apply Rlt_le.
+apply bpow_ge_0.
+(* . x=0 *)
+rewrite <- Zx, Rplus_0_l; rewrite <- Zx in Heps.
+case (proj1 Heps); intros P.
+unfold round, scaled_mantissa, canonic_exp.
+revert Heps; unfold ulp.
+rewrite Req_bool_true; trivial.
+case negligible_exp_spec.
+intros _ (H1,H2).
+absurd (0 < 0)%R; auto with real.
+now apply Rle_lt_trans with (1:=H1).
+intros n Hn H.
+assert (fexp (ln_beta beta eps) = fexp n).
+apply valid_exp; try assumption.
+assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega].
+apply lt_bpow with beta.
+apply Rle_lt_trans with (2:=proj2 H).
+destruct (ln_beta beta eps) as (e,He).
+simpl; rewrite Rabs_pos_eq in He.
+now apply He, Rgt_not_eq.
+now left.
+replace (Zfloor (eps * bpow (- fexp (ln_beta beta eps)))) with 0%Z.
+unfold F2R; simpl; ring.
+apply sym_eq, Zfloor_imp.
+split.
+apply Rmult_le_pos.
+now left.
+apply bpow_ge_0.
+apply Rmult_lt_reg_r with (bpow (fexp n)).
 apply bpow_gt_0.
+rewrite Rmult_assoc, <- bpow_plus.
+rewrite H0; ring_simplify (-fexp n + fexp n)%Z.
+simpl; rewrite Rmult_1_l, Rmult_1_r.
+apply H.
+rewrite <- P, round_0; trivial.
+apply valid_rnd_DN.
 Qed.
 
-Theorem pred_ge_0 :
-  forall x,
-  (0 < x)%R -> F x -> (0 <= pred x)%R.
-intros x Zx Fx.
-unfold pred.
-case Req_bool_spec; intros H.
-(* *)
-apply Rle_0_minus.
-rewrite H.
-apply bpow_le.
-destruct (ln_beta beta x) as (ex,Ex) ; simpl.
-rewrite ln_beta_bpow.
-ring_simplify (ex - 1 + 1 - 1)%Z.
-apply generic_format_bpow_inv with beta; trivial.
-simpl in H.
-rewrite <- H; assumption.
-apply Rle_0_minus.
-now apply ulp_le_id.
+
+Theorem round_UP_plus_eps_pos :
+  forall x, (0 <= x)%R -> F x ->
+  forall eps, (0 < eps <= ulp x)%R ->
+  round beta fexp Zceil (x + eps) = (x + ulp x)%R.
+Proof with auto with typeclass_instances.
+intros x Zx Fx eps.
+case Zx; intros Zx1.
+(* . 0 < x *)
+intros (Heps1,[Heps2|Heps2]).
+assert (Heps: (0 <= eps < ulp x)%R).
+split.
+now apply Rlt_le.
+exact Heps2.
+assert (Hd := round_DN_plus_eps_pos x Zx Fx eps Heps).
+rewrite round_UP_DN_ulp.
+rewrite Hd.
+rewrite 2!ulp_neq_0.
+unfold canonic_exp.
+now rewrite ln_beta_plus_eps.
+now apply Rgt_not_eq.
+now apply Rgt_not_eq, Rplus_lt_0_compat.
+intros Fs.
+rewrite round_generic in Hd...
+apply Rgt_not_eq with (2 := Hd).
+pattern x at 2 ; rewrite <- Rplus_0_r.
+now apply Rplus_lt_compat_l.
+rewrite Heps2.
+apply round_generic...
+now apply generic_format_succ_aux1.
+(* . x=0 *)
+rewrite <- Zx1, 2!Rplus_0_l.
+intros Heps.
+case (proj2 Heps).
+unfold round, scaled_mantissa, canonic_exp.
+unfold ulp.
+rewrite Req_bool_true; trivial.
+case negligible_exp_spec.
+intros H2.
+intros J; absurd (0 < 0)%R; auto with real.
+apply Rlt_trans with eps; try assumption; apply Heps.
+intros n Hn H.
+assert (fexp (ln_beta beta eps) = fexp n).
+apply valid_exp; try assumption.
+assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega].
+apply lt_bpow with beta.
+apply Rle_lt_trans with (2:=H).
+destruct (ln_beta beta eps) as (e,He).
+simpl; rewrite Rabs_pos_eq in He.
+now apply He, Rgt_not_eq.
+now left.
+replace (Zceil (eps * bpow (- fexp (ln_beta beta eps)))) with 1%Z.
+unfold F2R; simpl; rewrite H0; ring.
+apply sym_eq, Zceil_imp.
+split.
+simpl; apply Rmult_lt_0_compat.
+apply Heps.
+apply bpow_gt_0.
+apply Rmult_le_reg_r with (bpow (fexp n)).
+apply bpow_gt_0.
+rewrite Rmult_assoc, <- bpow_plus.
+rewrite H0; ring_simplify (-fexp n + fexp n)%Z.
+simpl; rewrite Rmult_1_l, Rmult_1_r.
+now left.
+intros P; rewrite P.
+apply round_generic...
+apply generic_format_ulp_0.
 Qed.
 
-Theorem round_UP_pred :
-  forall x, (0 < pred x)%R -> F x ->
+
+Theorem round_UP_pred_plus_eps_pos :
+  forall x, (0 < x)%R -> F x ->
   forall eps, (0 < eps <= ulp (pred x) )%R ->
   round beta fexp Zceil (pred x + eps) = x.
 Proof.
 intros x Hx Fx eps Heps.
-rewrite round_UP_succ; trivial.
-apply pred_plus_ulp; trivial.
-apply Rlt_trans with (1:=Hx).
-apply pred_lt_id.
-now apply Rgt_not_eq.
+rewrite round_UP_plus_eps_pos; trivial.
+rewrite pred_eq_pos.
+apply pred_pos_plus_ulp; trivial.
+now left.
+now apply pred_ge_0.
 apply generic_format_pred; trivial.
-apply Rlt_trans with (1:=Hx).
-apply pred_lt_id.
 Qed.
 
-Theorem round_DN_pred :
-  forall x, (0 < pred x)%R -> F x ->
+Theorem round_DN_minus_eps_pos :
+  forall x,  (0 < x)%R -> F x ->
   forall eps, (0 < eps <= ulp (pred x))%R ->
   round beta fexp Zfloor (x - eps) = pred x.
 Proof.
-intros x Hpx Fx eps Heps.
-assert (Hx:(0 < x)%R).
-apply Rlt_trans with (1:=Hpx).
-apply pred_lt_id.
-replace (x-eps)%R with (pred x + (ulp (pred x)-eps))%R.
-2: pattern x at 3; rewrite <- (pred_plus_ulp x); trivial.
+intros x Hpx Fx eps.
+rewrite pred_eq_pos;[intros Heps|now left].
+replace (x-eps)%R with (pred_pos x + (ulp (pred_pos x)-eps))%R.
+2: pattern x at 3; rewrite <- (pred_pos_plus_ulp x); trivial.
 2: ring.
-2: now apply Rgt_not_eq.
-rewrite round_DN_succ; trivial.
-now apply generic_format_pred.
+rewrite round_DN_plus_eps_pos; trivial.
+now apply pred_pos_ge_0.
+now apply generic_format_pred_pos.
 split.
 apply Rle_0_minus.
 now apply Heps.
@@ -1009,15 +1215,96 @@ apply Ropp_lt_contravar.
 now apply Heps.
 Qed.
 
-Lemma le_pred_lt_aux :
+
+Theorem round_DN_plus_eps:
+  forall x, F x ->
+  forall eps, (0 <= eps < if (Rle_bool 0 x) then (ulp x)
+                                     else (ulp (pred (-x))))%R ->
+  round beta fexp Zfloor (x + eps) = x.
+Proof.
+intros x Fx eps Heps.
+case (Rle_or_lt 0 x); intros Zx.
+apply round_DN_plus_eps_pos; try assumption.
+split; try apply Heps.
+rewrite Rle_bool_true in Heps; trivial.
+now apply Heps.
+(* *)
+rewrite Rle_bool_false in Heps; trivial.
+rewrite <- (Ropp_involutive (x+eps)).
+pattern x at 2; rewrite <- (Ropp_involutive x).
+rewrite round_DN_opp.
+apply f_equal.
+replace (-(x+eps))%R with (pred (-x) + (ulp (pred (-x)) - eps))%R.
+rewrite round_UP_pred_plus_eps_pos; try reflexivity.
+now apply Ropp_0_gt_lt_contravar.
+now apply generic_format_opp.
+split.
+apply Rplus_lt_reg_l with eps; ring_simplify.
+apply Heps.
+apply Rplus_le_reg_l with (eps-ulp (pred (- x)))%R; ring_simplify.
+apply Heps.
+unfold pred.
+rewrite Ropp_involutive.
+unfold succ; rewrite Rle_bool_false; try assumption.
+rewrite Ropp_involutive; unfold Rminus.
+rewrite <- Rplus_assoc, pred_pos_plus_ulp.
+ring.
+now apply Ropp_0_gt_lt_contravar.
+now apply generic_format_opp.
+Qed.
+
+
+Theorem round_UP_plus_eps :
+  forall x, F x ->
+  forall eps, (0 < eps <= if (Rle_bool 0 x) then (ulp x)
+                                     else (ulp (pred (-x))))%R ->
+  round beta fexp Zceil (x + eps) = (succ x)%R.
+Proof with auto with typeclass_instances.
+intros x Fx eps Heps.
+case (Rle_or_lt 0 x); intros Zx.
+rewrite succ_eq_pos; try assumption.
+rewrite Rle_bool_true in Heps; trivial.
+apply round_UP_plus_eps_pos; assumption.
+(* *)
+rewrite Rle_bool_false in Heps; trivial.
+rewrite <- (Ropp_involutive (x+eps)).
+rewrite <- (Ropp_involutive (succ x)).
+rewrite round_UP_opp.
+apply f_equal.
+replace (-(x+eps))%R with (-succ x + (-eps + ulp (pred (-x))))%R.
+apply round_DN_plus_eps_pos.
+rewrite <- pred_opp.
+apply pred_ge_0.
+now apply Ropp_0_gt_lt_contravar.
+now apply generic_format_opp.
+now apply generic_format_opp, generic_format_succ.
+split.
+apply Rplus_le_reg_l with eps; ring_simplify.
+apply Heps.
+unfold pred; rewrite Ropp_involutive.
+apply Rplus_lt_reg_l with (eps-ulp (- succ x))%R; ring_simplify.
+apply Heps.
+unfold succ; rewrite Rle_bool_false; try assumption.
+apply trans_eq with (-x +-eps)%R;[idtac|ring].
+pattern (-x)%R at 3; rewrite <- (pred_pos_plus_ulp (-x)).
+rewrite pred_eq_pos.
+ring.
+left; now apply Ropp_0_gt_lt_contravar.
+now apply Ropp_0_gt_lt_contravar.
+now apply generic_format_opp.
+Qed.
+
+
+Lemma le_pred_pos_lt :
   forall x y,
   F x -> F y ->
-  (0 < x < y)%R ->
-  (x <= pred y)%R.
+  (0 <= x < y)%R ->
+  (x <= pred_pos y)%R.
 Proof with auto with typeclass_instances.
-intros x y Hx Hy H.
+intros x y Fx Fy H.
+case (proj1 H); intros V.
 assert (Zy:(0 < y)%R).
-apply Rlt_trans with (1:=proj1 H).
+apply Rle_lt_trans with (1:=proj1 H).
 apply H.
 (* *)
 assert (Zp: (0 < pred y)%R).
@@ -1025,7 +1312,8 @@ assert (Zp:(0 <= pred y)%R).
 apply pred_ge_0 ; trivial.
 destruct Zp; trivial.
 generalize H0.
-unfold pred.
+rewrite pred_eq_pos;[idtac|now left].
+unfold pred_pos.
 destruct (ln_beta beta y) as (ey,Hey); simpl.
 case Req_bool_spec; intros Hy2.
 (* . *)
@@ -1058,7 +1346,7 @@ absurd (0 < Ztrunc (scaled_mantissa beta fexp x) < 1)%Z.
 omega.
 split.
 apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
-now rewrite <- Hx.
+now rewrite <- Fx.
 apply lt_Z2R.
 apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp x)).
 apply bpow_gt_0.
@@ -1082,7 +1370,8 @@ intros Hy3.
 assert (y = bpow (fexp ey))%R.
 apply Rminus_diag_uniq.
 rewrite Hy3.
-unfold ulp, canonic_exp.
+rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
+unfold canonic_exp.
 rewrite (ln_beta_unique beta y ey); trivial.
 apply Hey.
 now apply Rgt_not_eq.
@@ -1104,68 +1393,701 @@ apply ln_beta_unique.
 apply Hey.
 now apply Rgt_not_eq.
 (* *)
-case (Rle_or_lt (ulp (pred y)) (y-x)); intros H1.
+case (Rle_or_lt (ulp (pred_pos y)) (y-x)); intros H1.
 (* . *)
-apply Rplus_le_reg_r with (-x + ulp (pred y))%R.
-ring_simplify (x+(-x+ulp (pred y)))%R.
+apply Rplus_le_reg_r with (-x + ulp (pred_pos y))%R.
+ring_simplify (x+(-x+ulp (pred_pos y)))%R.
 apply Rle_trans with (1:=H1).
-rewrite <- (pred_plus_ulp y) at 1; trivial.
+rewrite <- (pred_pos_plus_ulp y) at 1; trivial.
 apply Req_le; ring.
-now apply Rgt_not_eq.
 (* . *)
 replace x with (y-(y-x))%R by ring.
-rewrite <- round_DN_pred with (eps:=(y-x)%R); try easy.
+rewrite <- pred_eq_pos;[idtac|now left].
+rewrite <- round_DN_minus_eps_pos with (eps:=(y-x)%R); try easy.
 ring_simplify (y-(y-x))%R.
 apply Req_le.
 apply sym_eq.
 apply round_generic...
 split; trivial.
 now apply Rlt_Rminus.
+rewrite pred_eq_pos;[idtac|now left].
 now apply Rlt_le.
+rewrite <- V; apply pred_pos_ge_0; trivial.
+apply Rle_lt_trans with (1:=proj1 H); apply H.
+Qed.
+
+Theorem succ_le_lt_aux:
+  forall x y,
+  F x -> F y ->
+  (0 <= x)%R -> (x < y)%R ->
+  (succ x <= y)%R.
+Proof with auto with typeclass_instances.
+intros x y Hx Hy Zx H.
+rewrite succ_eq_pos; trivial.
+case (Rle_or_lt (ulp x) (y-x)); intros H1.
+apply Rplus_le_reg_r with (-x)%R.
+now ring_simplify (x+ulp x + -x)%R.
+replace y with (x+(y-x))%R by ring.
+absurd (x < y)%R.
+2: apply H.
+apply Rle_not_lt; apply Req_le.
+rewrite <- round_DN_plus_eps_pos with (eps:=(y-x)%R); try easy.
+ring_simplify (x+(y-x))%R.
+apply sym_eq.
+apply round_generic...
+split; trivial.
+apply Rlt_le; now apply Rlt_Rminus.
+Qed.
+
+Theorem succ_le_lt:
+  forall x y,
+  F x -> F y ->
+  (x < y)%R ->
+  (succ x <= y)%R.
+Proof with auto with typeclass_instances.
+intros x y Fx Fy H.
+destruct (Rle_or_lt 0 x) as [Hx|Hx].
+now apply succ_le_lt_aux.
+unfold succ; rewrite Rle_bool_false; try assumption.
+case (Rle_or_lt y 0); intros Hy.
+rewrite <- (Ropp_involutive y).
+apply Ropp_le_contravar.
+apply le_pred_pos_lt.
+now apply generic_format_opp.
+now apply generic_format_opp.
+split.
+rewrite <- Ropp_0; now apply Ropp_le_contravar.
+now apply Ropp_lt_contravar.
+apply Rle_trans with (-0)%R.
+apply Ropp_le_contravar.
+apply pred_pos_ge_0.
+rewrite <- Ropp_0; now apply Ropp_lt_contravar.
+now apply generic_format_opp.
+rewrite Ropp_0; now left.
 Qed.
 
 Theorem le_pred_lt :
   forall x y,
   F x -> F y ->
-  (0 < y)%R ->
   (x < y)%R ->
   (x <= pred y)%R.
 Proof.
-intros x y Fx Fy Hy Hxy.
-destruct (Rle_or_lt x 0) as [Hx|Hx].
-apply Rle_trans with (1 := Hx).
-now apply pred_ge_0.
-apply le_pred_lt_aux ; try easy.
-now split.
+intros x y Fx Fy Hxy.
+rewrite <- (Ropp_involutive x).
+unfold pred; apply Ropp_le_contravar.
+apply succ_le_lt.
+now apply generic_format_opp.
+now apply generic_format_opp.
+now apply Ropp_lt_contravar.
 Qed.
 
 
-Theorem pred_succ : forall { monotone_exp : Monotone_exp fexp },
-  forall x, F x -> (0 < x)%R -> pred (x + ulp x)=x.
+Theorem lt_succ_le:
+  forall x y,
+  F x -> F y -> (y <> 0)%R ->
+  (x <= y)%R ->
+  (x < succ y)%R.
 Proof.
-intros L x Fx Hx.
-assert (x <= pred (x + ulp x))%R.
-apply le_pred_lt.
-assumption.
-now apply generic_format_succ.
-replace 0%R with (0+0)%R by ring; apply Rplus_lt_compat; try apply Hx.
+intros x y Fx Fy Zy Hxy.
+case (Rle_or_lt (succ y) x); trivial; intros H.
+absurd (succ y = y)%R.
+apply Rgt_not_eq.
+now apply succ_gt_id.
+apply Rle_antisym.
+now apply Rle_trans with x.
+apply succ_ge_id.
+Qed.
+
+
+Theorem succ_pred_aux : forall x, F x -> (0 < x)%R -> succ (pred x)=x.
+Proof.
+intros x Fx Hx.
+rewrite pred_eq_pos;[idtac|now left].
+rewrite succ_eq_pos.
+2: now apply pred_pos_ge_0.
+now apply pred_pos_plus_ulp.
+Qed.
+
+Theorem pred_succ_aux_0 : (pred (succ 0)=0)%R.
+Proof.
+unfold succ; rewrite Rle_bool_true.
+2: apply Rle_refl.
+rewrite Rplus_0_l.
+rewrite pred_eq_pos.
+2: apply ulp_ge_0.
+unfold ulp; rewrite Req_bool_true; trivial.
+case negligible_exp_spec'.
+(* *)
+intros (H1,H2); rewrite H1.
+unfold pred_pos; rewrite Req_bool_false.
+2: apply Rlt_not_eq, bpow_gt_0.
+unfold ulp; rewrite Req_bool_true; trivial.
+rewrite H1; ring.
+(* *)
+intros (n,(H1,H2)); rewrite H1.
+unfold pred_pos.
+rewrite ln_beta_bpow.
+replace (fexp n + 1 - 1)%Z with (fexp n) by ring.
+rewrite Req_bool_true; trivial.
+apply Rminus_diag_eq, f_equal.
+apply sym_eq, valid_exp; omega.
+Qed.
+
+Theorem pred_succ_aux : forall x, F x -> (0 < x)%R -> pred (succ x)=x.
+Proof.
+intros x Fx Hx.
+rewrite succ_eq_pos;[idtac|now left].
+rewrite pred_eq_pos.
+2: apply Rplus_le_le_0_compat;[now left| apply ulp_ge_0].
+unfold pred_pos.
+case Req_bool_spec; intros H1.
+(* *)
+pose (l:=(ln_beta beta (x+ulp x))).
+rewrite H1 at 1; fold l.
+apply Rplus_eq_reg_r with (ulp x).
+rewrite H1; fold l.
+rewrite (ulp_neq_0 x) at 3.
+2: now apply Rgt_not_eq.
+unfold canonic_exp.
+replace (fexp (ln_beta beta x)) with (fexp (l-1))%Z.
+ring.
+apply f_equal, sym_eq.
+apply Zle_antisym.
+assert (ln_beta beta x - 1 < l - 1)%Z;[idtac|omega].
+apply lt_bpow with beta.
+unfold l; rewrite <- H1.
+apply Rle_lt_trans with x.
+destruct (ln_beta beta x) as (e,He); simpl.
+rewrite <- (Rabs_right x) at 1.
+2: apply Rle_ge; now left.
+now apply He, Rgt_not_eq.
+apply Rplus_lt_reg_l with (-x)%R; ring_simplify.
+rewrite ulp_neq_0.
 apply bpow_gt_0.
-apply Rplus_lt_reg_r with (-x)%R; ring_simplify.
+now apply Rgt_not_eq.
+apply le_bpow with beta.
+unfold l; rewrite <- H1.
+apply id_p_ulp_le_bpow; trivial.
+rewrite <- (Rabs_right x) at 1.
+2: apply Rle_ge; now left.
+apply bpow_ln_beta_gt.
+(* *)
+replace (ulp (x+ ulp x)) with (ulp x).
+ring.
+rewrite ulp_neq_0 at 1.
+2: now apply Rgt_not_eq.
+rewrite ulp_neq_0 at 1.
+2: apply Rgt_not_eq, Rlt_gt.
+2: apply Rlt_le_trans with (1:=Hx).
+2: apply Rplus_le_reg_l with (-x)%R; ring_simplify.
+2: apply ulp_ge_0.
+apply f_equal; unfold canonic_exp; apply f_equal.
+apply sym_eq, ln_beta_unique.
+rewrite Rabs_right.
+2: apply Rle_ge; left.
+2: apply Rlt_le_trans with (1:=Hx).
+2: apply Rplus_le_reg_l with (-x)%R; ring_simplify.
+2: apply ulp_ge_0.
+destruct (ln_beta beta x) as (e,He); simpl.
+rewrite Rabs_right in He.
+2: apply Rle_ge; now left.
+split.
+apply Rle_trans with x.
+apply He, Rgt_not_eq; assumption.
+apply Rplus_le_reg_l with (-x)%R; ring_simplify.
+apply ulp_ge_0.
+case (Rle_lt_or_eq_dec (x+ulp x) (bpow e)); trivial.
+apply id_p_ulp_le_bpow; trivial.
+apply He, Rgt_not_eq; assumption.
+intros K; contradict H1.
+rewrite K, ln_beta_bpow.
+apply f_equal; ring.
+Qed.
+
+
+
+Theorem succ_pred : forall x, F x -> succ (pred x)=x.
+Proof.
+intros x Fx.
+case (Rle_or_lt 0 x); intros Hx.
+destruct Hx as [Hx|Hx].
+now apply succ_pred_aux.
+rewrite <- Hx.
+rewrite pred_eq_opp_succ_opp, succ_opp, Ropp_0.
+rewrite pred_succ_aux_0; ring.
+rewrite pred_eq_opp_succ_opp, succ_opp.
+rewrite pred_succ_aux.
+ring.
+now apply generic_format_opp.
+now apply Ropp_0_gt_lt_contravar.
+Qed.
+
+Theorem pred_succ : forall x, F x -> pred (succ x)=x.
+Proof.
+intros x Fx.
+case (Rle_or_lt 0 x); intros Hx.
+destruct Hx as [Hx|Hx].
+now apply pred_succ_aux.
+rewrite <- Hx.
+apply pred_succ_aux_0.
+rewrite succ_eq_opp_pred_opp, pred_opp.
+rewrite succ_pred_aux.
+ring.
+now apply generic_format_opp.
+now apply Ropp_0_gt_lt_contravar.
+Qed.
+
+
+Theorem round_UP_pred_plus_eps :
+  forall x, F x ->
+  forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x)
+                                     else (ulp (pred x)))%R ->
+  round beta fexp Zceil (pred x + eps) = x.
+Proof.
+intros x Fx eps Heps.
+rewrite round_UP_plus_eps.
+now apply succ_pred.
+now apply generic_format_pred.
+unfold pred at 4.
+rewrite Ropp_involutive, pred_succ.
+rewrite ulp_opp.
+generalize Heps; case (Rle_bool_spec x 0); intros H1 H2.
+rewrite Rle_bool_false; trivial.
+case H1; intros H1'.
+apply Rlt_le_trans with (2:=H1).
+apply pred_lt_id.
+now apply Rlt_not_eq.
+rewrite H1'; unfold pred, succ.
+rewrite Ropp_0; rewrite Rle_bool_true;[idtac|now right].
+rewrite Rplus_0_l.
+rewrite <- Ropp_0; apply Ropp_lt_contravar.
+apply Rlt_le_trans with (1:=proj1 H2).
+apply Rle_trans with (1:=proj2 H2).
+rewrite Ropp_0, H1'.
+now right.
+rewrite Rle_bool_true; trivial.
+now apply pred_ge_0.
+now apply generic_format_opp.
+Qed.
+
+
+Theorem round_DN_minus_eps:
+  forall x,  F x ->
+  forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x)
+                                     else (ulp (pred x)))%R ->
+  round beta fexp Zfloor (x - eps) = pred x.
+Proof.
+intros x Fx eps Heps.
+replace (x-eps)%R with (-(-x+eps))%R by ring.
+rewrite round_DN_opp.
+unfold pred; apply f_equal.
+pattern (-x)%R at 1; rewrite <- (pred_succ (-x)).
+apply round_UP_pred_plus_eps.
+now apply generic_format_succ, generic_format_opp.
+rewrite pred_succ.
+rewrite ulp_opp.
+generalize Heps; case (Rle_bool_spec x 0); intros H1 H2.
+rewrite Rle_bool_false; trivial.
+case H1; intros H1'.
+apply Rlt_le_trans with (-x)%R.
+now apply Ropp_0_gt_lt_contravar.
+apply succ_ge_id.
+rewrite H1', Ropp_0, succ_eq_pos;[idtac|now right].
+rewrite Rplus_0_l.
+apply Rlt_le_trans with (1:=proj1 H2).
+rewrite H1' in H2; apply H2.
+rewrite Rle_bool_true.
+now rewrite succ_opp, ulp_opp.
+rewrite succ_opp.
+rewrite <- Ropp_0; apply Ropp_le_contravar.
+now apply pred_ge_0.
+now apply generic_format_opp.
+now apply generic_format_opp.
+Qed.
+
+(** Error of a rounding, expressed in number of ulps *)
+(** false for x=0 in the FLX format *)
+(* was ulp_error *)
+Theorem error_lt_ulp :
+  forall rnd { Zrnd : Valid_rnd rnd } x,
+   (x <> 0)%R ->
+  (Rabs (round beta fexp rnd x - x) < ulp x)%R.
+Proof with auto with typeclass_instances.
+intros rnd Zrnd x Zx.
+destruct (generic_format_EM beta fexp x) as [Hx|Hx].
+(* x = rnd x *)
+rewrite round_generic...
+unfold Rminus.
+rewrite Rplus_opp_r, Rabs_R0.
+rewrite ulp_neq_0; trivial.
 apply bpow_gt_0.
-apply Rle_antisym; trivial.
-apply Rplus_le_reg_r with (ulp (pred (x + ulp x))).
-rewrite pred_plus_ulp.
-apply Rplus_le_compat_l.
-now apply ulp_le.
-replace 0%R with (0+0)%R by ring; apply Rplus_lt_compat; try apply Hx.
+(* x <> rnd x *)
+destruct (round_DN_or_UP beta fexp rnd x) as [H|H] ; rewrite H ; clear H.
+(* . *)
+rewrite Rabs_left1.
+rewrite Ropp_minus_distr.
+apply Rplus_lt_reg_l with (round beta fexp Zfloor x).
+rewrite <- round_UP_DN_ulp with (1 := Hx).
+ring_simplify.
+assert (Hu: (x <= round beta fexp Zceil x)%R).
+apply round_UP_pt...
+destruct Hu as [Hu|Hu].
+exact Hu.
+elim Hx.
+rewrite Hu.
+apply generic_format_round...
+apply Rle_minus.
+apply round_DN_pt...
+(* . *)
+rewrite Rabs_pos_eq.
+rewrite round_UP_DN_ulp with (1 := Hx).
+apply Rplus_lt_reg_r with (x - ulp x)%R.
+ring_simplify.
+assert (Hd: (round beta fexp Zfloor x <= x)%R).
+apply round_DN_pt...
+destruct Hd as [Hd|Hd].
+exact Hd.
+elim Hx.
+rewrite <- Hd.
+apply generic_format_round...
+apply Rle_0_minus.
+apply round_UP_pt...
+Qed.
+
+(* was ulp_error_le *)
+Theorem error_le_ulp :
+  forall rnd { Zrnd : Valid_rnd rnd } x,
+  (Rabs (round beta fexp rnd x - x) <= ulp x)%R.
+Proof with auto with typeclass_instances.
+intros  rnd Zrnd x.
+case (Req_dec x 0).
+intros Zx; rewrite Zx, round_0...
+unfold Rminus; rewrite Rplus_0_l, Ropp_0, Rabs_R0.
+apply ulp_ge_0.
+intros Zx; left.
+now apply error_lt_ulp.
+Qed.
+
+(* was ulp_half_error *)
+Theorem error_le_half_ulp :
+  forall choice x,
+  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp x)%R.
+Proof with auto with typeclass_instances.
+intros choice x.
+destruct (generic_format_EM beta fexp x) as [Hx|Hx].
+(* x = rnd x *)
+rewrite round_generic...
+unfold Rminus.
+rewrite Rplus_opp_r, Rabs_R0.
+apply Rmult_le_pos.
+apply Rlt_le.
+apply Rinv_0_lt_compat.
+now apply (Z2R_lt 0 2).
+apply ulp_ge_0.
+(* x <> rnd x *)
+set (d := round beta fexp Zfloor x).
+destruct (round_N_pt beta fexp choice x) as (Hr1, Hr2).
+destruct (Rle_or_lt (x - d) (d + ulp x - x)) as [H|H].
+(* . rnd(x) = rndd(x) *)
+apply Rle_trans with (Rabs (d - x)).
+apply Hr2.
+apply (round_DN_pt beta fexp x).
+rewrite Rabs_left1.
+rewrite Ropp_minus_distr.
+apply Rmult_le_reg_r with 2%R.
+now apply (Z2R_lt 0 2).
+apply Rplus_le_reg_r with (d - x)%R.
+ring_simplify.
+apply Rle_trans with (1 := H).
+right. field.
+apply Rle_minus.
+apply (round_DN_pt beta fexp x).
+(* . rnd(x) = rndu(x) *)
+assert (Hu: (d + ulp x)%R = round beta fexp Zceil x).
+unfold d.
+now rewrite <- round_UP_DN_ulp.
+apply Rle_trans with (Rabs (d + ulp x - x)).
+apply Hr2.
+rewrite Hu.
+apply (round_UP_pt beta fexp x).
+rewrite Rabs_pos_eq.
+apply Rmult_le_reg_r with 2%R.
+now apply (Z2R_lt 0 2).
+apply Rplus_le_reg_r with (- (d + ulp x - x))%R.
+ring_simplify.
+apply Rlt_le.
+apply Rlt_le_trans with (1 := H).
+right. field.
+apply Rle_0_minus.
+rewrite Hu.
+apply (round_UP_pt beta fexp x).
+Qed.
+
+
+Theorem ulp_DN :
+  forall x,
+  (0 < round beta fexp Zfloor x)%R ->
+  ulp (round beta fexp Zfloor x) = ulp x.
+Proof with auto with typeclass_instances.
+intros x Hd.
+rewrite 2!ulp_neq_0.
+now rewrite canonic_exp_DN with (2 := Hd).
+intros T; contradict Hd; rewrite T, round_0...
+apply Rlt_irrefl.
+now apply Rgt_not_eq.
+Qed.
+
+Theorem round_neq_0_negligible_exp:
+    negligible_exp=None -> forall rnd { Zrnd : Valid_rnd rnd } x,
+   (x <> 0)%R ->  (round beta fexp rnd x <> 0)%R.
+Proof with auto with typeclass_instances.
+intros H rndn Hrnd x Hx K.
+case negligible_exp_spec'.
+intros (_,Hn).
+destruct (ln_beta beta x) as (e,He).
+absurd (fexp e < e)%Z.
+apply Zle_not_lt.
+apply exp_small_round_0 with beta rndn x...
+apply (Hn e).
+intros (n,(H1,_)).
+rewrite H in H1; discriminate.
+Qed.
+
+
+(** allows rnd x to be 0 *)
+(* was ulp_error_f *)
+Theorem error_lt_ulp_round :
+  forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x,
+  ( x <> 0)%R ->
+  (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R.
+Proof with auto with typeclass_instances.
+intros Hm.
+(* wlog *)
+cut (forall rnd : R -> Z, Valid_rnd rnd -> forall x : R, (0 < x)%R  ->
+    (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R).
+intros M rnd Hrnd x Zx.
+case (Rle_or_lt 0 x).
+intros H; destruct H.
+now apply M.
+contradict H; now apply sym_not_eq.
+intros H.
+rewrite <- (Ropp_involutive x).
+rewrite round_opp, ulp_opp.
+replace (- round beta fexp (Zrnd_opp rnd) (- x) - - - x)%R with
+    (-(round beta fexp (Zrnd_opp rnd) (- x) - (-x)))%R by ring.
+rewrite Rabs_Ropp.
+apply M.
+now apply valid_rnd_opp.
+now apply Ropp_0_gt_lt_contravar.
+(* 0 < x *)
+intros rnd Hrnd x Hx.
+case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)).
+apply round_ge_generic...
+apply generic_format_0.
+now left.
+(* . 0 < round Zfloor x *)
+intros Hx2.
+apply Rlt_le_trans with (ulp x).
+apply error_lt_ulp...
+now apply Rgt_not_eq.
+rewrite <- ulp_DN; trivial.
+apply ulp_le_pos.
+now left.
+case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V.
+apply Rle_refl.
+apply Rle_trans with x.
+apply round_DN_pt...
+apply round_UP_pt...
+(* . 0 = round Zfloor x *)
+intros Hx2.
+case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V; clear V.
+(* .. round down -- difficult case *)
+rewrite <- Hx2.
+unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp.
+unfold ulp; rewrite Req_bool_true; trivial.
+case negligible_exp_spec.
+(* without minimal exponent *)
+intros K; contradict Hx2.
+apply Rlt_not_eq.
+apply F2R_gt_0_compat; simpl.
+apply Zlt_le_trans with 1%Z.
+apply Pos2Z.is_pos.
+apply Zfloor_lub.
+simpl; unfold scaled_mantissa, canonic_exp.
+destruct (ln_beta beta x) as (e,He); simpl.
+apply Rle_trans with (bpow (e-1) * bpow (- fexp e))%R.
+rewrite <- bpow_plus.
+replace 1%R with (bpow 0) by reflexivity.
+apply bpow_le.
+specialize (K e); omega.
+apply Rmult_le_compat_r.
+apply bpow_ge_0.
+rewrite <- (Rabs_pos_eq x).
+now apply He, Rgt_not_eq.
+now left.
+(* with a minimal exponent *)
+intros n Hn.
+rewrite Rabs_pos_eq;[idtac|now left].
+case (Rle_or_lt (bpow (fexp n)) x); trivial.
+intros K; contradict Hx2.
+apply Rlt_not_eq.
+apply Rlt_le_trans with (bpow (fexp n)).
 apply bpow_gt_0.
-now apply generic_format_succ.
-apply Rgt_not_eq.
-now apply Rlt_le_trans with x.
+apply round_ge_generic...
+apply generic_format_bpow.
+now apply valid_exp.
+(* .. round up *)
+apply Rlt_le_trans with (ulp x).
+apply error_lt_ulp...
+now apply Rgt_not_eq.
+apply ulp_le_pos.
+now left.
+apply round_UP_pt...
+Qed.
+
+(** allows both x and rnd x to be 0 *)
+(* was ulp_half_error_f *)
+Theorem error_le_half_ulp_round :
+  forall { Hm : Monotone_exp fexp },
+  forall choice x,
+  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp (round beta fexp (Znearest choice) x))%R.
+Proof with auto with typeclass_instances.
+intros Hm choice x.
+case (Req_dec (round beta fexp (Znearest choice) x) 0); intros Hfx.
+(* *)
+case (Req_dec x 0); intros Hx.
+apply Rle_trans with (1:=error_le_half_ulp _ _).
+rewrite Hx, round_0...
+right; ring.
+generalize (error_le_half_ulp choice x).
+rewrite Hfx.
+unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp.
+intros N.
+unfold ulp; rewrite Req_bool_true; trivial.
+case negligible_exp_spec'.
+intros (H1,H2).
+contradict Hfx.
+apply round_neq_0_negligible_exp...
+intros (n,(H1,Hn)); rewrite H1.
+apply Rle_trans with (1:=N).
+right; apply f_equal.
+rewrite ulp_neq_0; trivial.
+apply f_equal.
+unfold canonic_exp.
+apply valid_exp; trivial.
+assert (ln_beta beta x -1 < fexp n)%Z;[idtac|omega].
+apply lt_bpow with beta.
+destruct (ln_beta beta x) as (e,He).
+simpl.
+apply Rle_lt_trans with (Rabs x).
+now apply He.
+apply Rle_lt_trans with (Rabs (round beta fexp (Znearest choice) x - x)).
+right; rewrite Hfx; unfold Rminus; rewrite Rplus_0_l.
+apply sym_eq, Rabs_Ropp.
+apply Rlt_le_trans with (ulp 0).
+rewrite <- Hfx.
+apply error_lt_ulp_round...
+unfold ulp; rewrite Req_bool_true, H1; trivial.
+now right.
+(* *)
+case (round_DN_or_UP beta fexp (Znearest choice) x); intros Hx.
+(* . *)
+case (Rle_or_lt 0 (round beta fexp Zfloor x)).
+intros H; destruct H.
+rewrite Hx at 2.
+rewrite ulp_DN; trivial.
+apply error_le_half_ulp.
+rewrite Hx in Hfx; contradict Hfx; auto with real.
+intros H.
+apply Rle_trans with (1:=error_le_half_ulp _ _).
+apply Rmult_le_compat_l.
+auto with real.
+apply ulp_le.
+rewrite Hx; rewrite (Rabs_left1 x), Rabs_left; try assumption.
+apply Ropp_le_contravar.
+apply (round_DN_pt beta fexp x).
+case (Rle_or_lt x 0); trivial.
+intros H1; contradict H.
+apply Rle_not_lt.
+apply round_ge_generic...
+apply generic_format_0.
+now left.
+(* . *)
+case (Rle_or_lt 0 (round beta fexp Zceil x)).
+intros H; destruct H.
+apply Rle_trans with (1:=error_le_half_ulp _ _).
+apply Rmult_le_compat_l.
+auto with real.
+apply ulp_le_pos; trivial.
+case (Rle_or_lt 0 x); trivial.
+intros H1; contradict H.
+apply Rle_not_lt.
+apply round_le_generic...
+apply generic_format_0.
+now left.
+rewrite Hx; apply (round_UP_pt beta fexp x).
+rewrite Hx in Hfx; contradict Hfx; auto with real.
+intros H.
+rewrite Hx at 2; rewrite <- (ulp_opp (round beta fexp Zceil x)).
+rewrite <- round_DN_opp.
+rewrite ulp_DN; trivial.
+pattern x at 1 2; rewrite <- Ropp_involutive.
+rewrite round_N_opp.
+unfold Rminus.
+rewrite <- Ropp_plus_distr, Rabs_Ropp.
+apply error_le_half_ulp.
+rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption.
 Qed.
 
 
-Theorem lt_UP_le_DN :
+Theorem pred_le: forall x y,
+   F x -> F y -> (x <= y)%R -> (pred x <= pred y)%R.
+Proof.
+intros x y Fx Fy Hxy.
+assert (V:( ((x = 0) /\ (y = 0)) \/ (x <>0 \/ x < y))%R).
+case (Req_dec x 0); intros Zx.
+case Hxy; intros Zy.
+now right; right.
+left; split; trivial; now rewrite <- Zy.
+now right; left.
+destruct V as [(V1,V2)|V].
+rewrite V1,V2; now right.
+apply le_pred_lt; try assumption.
+apply generic_format_pred; try assumption.
+case V; intros V1.
+apply Rlt_le_trans with (2:=Hxy).
+now apply pred_lt_id.
+apply Rle_lt_trans with (2:=V1).
+now apply pred_le_id.
+Qed.
+
+Theorem succ_le: forall x y,
+   F x -> F y -> (x <= y)%R -> (succ x <= succ y)%R.
+Proof.
+intros x y Fx Fy Hxy.
+rewrite 2!succ_eq_opp_pred_opp.
+apply Ropp_le_contravar, pred_le; try apply generic_format_opp; try assumption.
+now apply Ropp_le_contravar.
+Qed.
+
+Theorem pred_le_inv: forall x y, F x -> F y
+   -> (pred x <= pred y)%R -> (x <= y)%R.
+Proof.
+intros x y Fx Fy Hxy.
+rewrite <- (succ_pred x), <- (succ_pred y); try assumption.
+apply succ_le; trivial; now apply generic_format_pred.
+Qed.
+
+Theorem succ_le_inv: forall x y, F x -> F y
+   -> (succ x <= succ y)%R -> (x <= y)%R.
+Proof.
+intros x y Fx Fy Hxy.
+rewrite <- (pred_succ x), <- (pred_succ y); try assumption.
+apply pred_le; trivial; now apply generic_format_succ.
+Qed.
+
+(* was lt_UP_le_DN *)
+Theorem le_round_DN_lt_UP :
   forall x y, F y ->
   (y < round beta fexp Zceil x -> y <= round beta fexp Zfloor x)%R.
 Proof with auto with typeclass_instances.
@@ -1178,26 +2100,58 @@ apply round_UP_pt...
 now apply Rlt_le.
 Qed.
 
+(* was lt_DN_le_UP *)
+Theorem round_UP_le_gt_DN :
+  forall x y, F y ->
+   (round beta fexp Zfloor x < y -> round beta fexp Zceil x <= y)%R.
+Proof with auto with typeclass_instances.
+intros x y Fy Hlt.
+apply round_UP_pt...
+apply Rnot_lt_le.
+contradict Hlt.
+apply RIneq.Rle_not_lt.
+apply round_DN_pt...
+now apply Rlt_le.
+Qed.
+
+
+
 Theorem pred_UP_le_DN :
-  forall x, (0 < round beta fexp Zceil x)%R ->
-  (pred (round beta fexp Zceil x) <= round beta fexp Zfloor x)%R.
+  forall x, (pred (round beta fexp Zceil x) <= round beta fexp Zfloor x)%R.
 Proof with auto with typeclass_instances.
-intros x Pxu.
+intros x.
 destruct (generic_format_EM beta fexp x) as [Fx|Fx].
 rewrite !round_generic...
-now apply Rlt_le; apply pred_lt_id.
+apply pred_le_id.
+case (Req_dec (round beta fexp Zceil x) 0); intros Zx.
+rewrite Zx; unfold pred; rewrite Ropp_0.
+unfold succ; rewrite Rle_bool_true;[idtac|now right].
+rewrite Rplus_0_l; unfold ulp; rewrite Req_bool_true; trivial.
+case negligible_exp_spec'.
+intros (H1,H2).
+contradict Zx; apply round_neq_0_negligible_exp...
+intros L; apply Fx; rewrite L; apply generic_format_0.
+intros (n,(H1,Hn)); rewrite H1.
+case (Rle_or_lt (- bpow (fexp n)) (round beta fexp Zfloor x)); trivial; intros K.
+absurd (round beta fexp Zceil x <= - bpow (fexp n))%R.
+apply Rlt_not_le.
+rewrite Zx, <- Ropp_0.
+apply Ropp_lt_contravar, bpow_gt_0.
+apply round_UP_le_gt_DN; try assumption.
+apply generic_format_opp, generic_format_bpow.
+now apply valid_exp.
 assert (let u := round beta fexp Zceil x in pred u < u)%R as Hup.
-  now apply pred_lt_id.
-apply lt_UP_le_DN...
+now apply pred_lt_id.
+apply le_round_DN_lt_UP...
 apply generic_format_pred...
 now apply round_UP_pt.
 Qed.
 
 Theorem pred_UP_eq_DN :
-  forall x, (0 < round beta fexp Zceil x)%R -> ~ F x ->
+  forall x,  ~ F x ->
   (pred (round beta fexp Zceil x) = round beta fexp Zfloor x)%R.
 Proof with auto with typeclass_instances.
-intros x Px Fx.
+intros x Fx.
 apply Rle_antisym.
 now apply pred_UP_le_DN.
 apply le_pred_lt; try apply generic_format_round...
@@ -1205,212 +2159,200 @@ pose proof round_DN_UP_lt _ _ _ Fx as HE.
 now apply Rlt_trans with (1 := proj1 HE) (2 := proj2 HE).
 Qed.
 
+Theorem succ_DN_eq_UP :
+  forall x,  ~ F x ->
+  (succ (round beta fexp Zfloor x) = round beta fexp Zceil x)%R.
+Proof with auto with typeclass_instances.
+intros x Fx.
+rewrite <- pred_UP_eq_DN; trivial.
+rewrite succ_pred; trivial.
+apply generic_format_round...
+Qed.
+
+
+(* was betw_eq_DN *)
+Theorem round_DN_eq_betw: forall x d, F d
+     -> (d <= x < succ d)%R
+        -> round beta fexp Zfloor x = d.
+Proof with auto with typeclass_instances.
+intros x d Fd (Hxd1,Hxd2).
+generalize (round_DN_pt beta fexp x); intros (T1,(T2,T3)).
+apply sym_eq, Rle_antisym.
+now apply T3.
+destruct (generic_format_EM beta fexp x) as [Fx|NFx].
+rewrite round_generic...
+apply succ_le_inv; try assumption.
+apply succ_le_lt; try assumption.
+apply generic_format_succ...
+apply succ_le_inv; try assumption.
+rewrite succ_DN_eq_UP; trivial.
+apply round_UP_pt...
+apply generic_format_succ...
+now left.
+Qed.
+
+(* was betw_eq_UP *)
+Theorem round_UP_eq_betw: forall x u, F u
+    -> (pred u < x <= u)%R
+    -> round beta fexp Zceil x = u.
+Proof with auto with typeclass_instances.
+intros x u Fu Hux.
+rewrite <- (Ropp_involutive (round beta fexp Zceil x)).
+rewrite <- round_DN_opp.
+rewrite <- (Ropp_involutive u).
+apply f_equal.
+apply round_DN_eq_betw; try assumption.
+now apply generic_format_opp.
+split;[now apply Ropp_le_contravar|idtac].
+rewrite succ_opp.
+now apply Ropp_lt_contravar.
+Qed.
 
 
 
 
 (** Properties of rounding to nearest and ulp *)
 
-Theorem rnd_N_le_half_an_ulp: forall choice u v,
-  F u -> (0 < u)%R -> (v < u + (ulp u)/2)%R
+Theorem round_N_le_midp: forall choice u v,
+  F u -> (v < (u + succ u)/2)%R
       -> (round beta fexp (Znearest choice)  v <= u)%R.
 Proof with auto with typeclass_instances.
-intros choice u v Fu Hu H.
+intros choice u v Fu H.
 (* . *)
-assert (0 < ulp u / 2)%R.
-unfold Rdiv; apply Rmult_lt_0_compat.
-unfold ulp; apply bpow_gt_0.
-auto with real.
-(* . *)
-assert (ulp u / 2 < ulp u)%R.
-apply Rlt_le_trans with (ulp u *1)%R;[idtac|right; ring].
-unfold Rdiv; apply Rmult_lt_compat_l.
-apply bpow_gt_0.
+assert (V: ((succ u = 0 /\ u = 0) \/ u < succ u)%R).
+specialize (succ_ge_id u); intros P; destruct P as [P|P].
+now right.
+case (Req_dec u 0); intros Zu.
+left; split; trivial.
+now rewrite <- P.
+right; now apply succ_gt_id.
+(* *)
+destruct V as [(V1,V2)|V].
+rewrite V2; apply round_le_generic...
+apply generic_format_0.
+left; apply Rlt_le_trans with (1:=H).
+rewrite V1,V2; right; field.
+(* *)
+assert (T: (u < (u + succ u) / 2 < succ u)%R).
+split.
 apply Rmult_lt_reg_l with 2%R.
-auto with real.
-apply Rle_lt_trans with 1%R.
+now auto with real.
+apply Rplus_lt_reg_l with (-u)%R.
+apply Rle_lt_trans with u;[right; ring|idtac].
+apply Rlt_le_trans with (1:=V).
 right; field.
-rewrite Rmult_1_r; auto with real.
+apply Rmult_lt_reg_l with 2%R.
+now auto with real.
+apply Rplus_lt_reg_l with (-succ u)%R.
+apply Rle_lt_trans with u;[right; field|idtac].
+apply Rlt_le_trans with (1:=V).
+right; ring.
 (* *)
-apply Rnd_N_pt_monotone with F v (u + ulp u / 2)%R...
+destruct T as (T1,T2).
+apply Rnd_N_pt_monotone with F v ((u + succ u) / 2)%R...
 apply round_N_pt...
-apply Rnd_DN_pt_N with (u+ulp u)%R.
-pattern u at 3; replace u with (round beta fexp Zfloor (u + ulp u / 2)).
+apply Rnd_DN_pt_N with (succ u)%R.
+pattern u at 3; replace u with (round beta fexp Zfloor ((u + succ u) / 2)).
 apply round_DN_pt...
-apply round_DN_succ; try assumption.
+apply round_DN_eq_betw; trivial.
 split; try left; assumption.
-replace (u+ulp u)%R with (round beta fexp Zceil (u + ulp u / 2)).
+pattern (succ u) at 2; replace (succ u) with (round beta fexp Zceil ((u + succ u) / 2)).
 apply round_UP_pt...
-apply round_UP_succ; try assumption...
+apply round_UP_eq_betw; trivial.
+apply generic_format_succ...
+rewrite pred_succ; trivial.
 split; try left; assumption.
 right; field.
 Qed.
 
 
-Theorem rnd_N_ge_half_an_ulp_pred: forall choice u v,
- F u -> (0 < pred u)%R -> (u - (ulp (pred u))/2 < v)%R
+Theorem round_N_ge_midp: forall choice u v,
+ F u ->  ((u + pred u)/2 < v)%R
       -> (u <= round beta fexp (Znearest choice)  v)%R.
 Proof with auto with typeclass_instances.
-intros choice u v Fu Hu H.
-(* . *)
-assert (0 < u)%R.
-apply Rlt_trans with (1:= Hu).
-apply pred_lt_id.
-assert (0 < ulp (pred u) / 2)%R.
-unfold Rdiv; apply Rmult_lt_0_compat.
-unfold ulp; apply bpow_gt_0.
-auto with real.
-assert (ulp (pred u) / 2 < ulp (pred u))%R.
-apply Rlt_le_trans with (ulp (pred u) *1)%R;[idtac|right; ring].
-unfold Rdiv; apply Rmult_lt_compat_l.
-apply bpow_gt_0.
-apply Rmult_lt_reg_l with 2%R.
-auto with real.
-apply Rle_lt_trans with 1%R.
-right; field.
-rewrite Rmult_1_r; auto with real.
-(* *)
-apply Rnd_N_pt_monotone with F (u - ulp (pred u) / 2)%R v...
-2: apply round_N_pt...
-apply Rnd_UP_pt_N with (pred u).
-pattern (pred u) at 2; replace (pred u) with (round beta fexp Zfloor (u - ulp (pred u) / 2)).
-apply round_DN_pt...
-replace  (u - ulp (pred u) / 2)%R  with (pred u + ulp (pred u) / 2)%R.
-apply round_DN_succ; try assumption.
-apply generic_format_pred; assumption.
-split; [left|idtac]; assumption.
-pattern u at 3; rewrite <- (pred_plus_ulp u); try assumption.
-field.
-now apply Rgt_not_eq.
-pattern u at 3; replace u with (round beta fexp Zceil (u - ulp (pred u) / 2)).
-apply round_UP_pt...
-replace  (u - ulp (pred u) / 2)%R  with (pred u + ulp (pred u) / 2)%R.
-apply trans_eq with (pred u +ulp(pred u))%R.
-apply round_UP_succ; try assumption...
-apply generic_format_pred; assumption.
-split; [idtac|left]; assumption.
-apply pred_plus_ulp; try assumption.
-now apply Rgt_not_eq.
-pattern u at 3; rewrite <- (pred_plus_ulp u); try assumption.
-field.
-now apply Rgt_not_eq.
-pattern u at 4; rewrite <- (pred_plus_ulp u); try assumption.
+intros choice u v Fu H.
+rewrite <- (Ropp_involutive v).
+rewrite round_N_opp.
+rewrite <- (Ropp_involutive u).
+apply Ropp_le_contravar.
+apply round_N_le_midp.
+now apply generic_format_opp.
+apply Ropp_lt_cancel.
+rewrite Ropp_involutive.
+apply Rle_lt_trans with (2:=H).
+unfold pred.
 right; field.
-now apply Rgt_not_eq.
 Qed.
 
 
-Theorem rnd_N_ge_half_an_ulp: forall choice u v,
-  F u -> (0 < u)%R -> (u <> bpow (ln_beta beta u - 1))%R
-        -> (u - (ulp u)/2 < v)%R
-        -> (u <= round beta fexp (Znearest choice) v)%R.
+Lemma round_N_eq_DN: forall choice x,
+       let d:=round beta fexp Zfloor x in
+       let u:=round beta fexp Zceil x in
+      (x<(d+u)/2)%R ->
+     round beta fexp (Znearest choice) x = d.
 Proof with auto with typeclass_instances.
-intros choice u v Fu Hupos Hu H.
-(* *)
-assert (bpow (ln_beta beta u-1) <= pred u)%R.
-apply le_pred_lt; try assumption.
-apply generic_format_bpow.
-assert (canonic_exp beta fexp u < ln_beta beta u)%Z.
-apply ln_beta_generic_gt; try assumption.
-now apply Rgt_not_eq.
-unfold canonic_exp in H0.
-ring_simplify (ln_beta beta u - 1 + 1)%Z.
-omega.
-destruct ln_beta as (e,He); simpl in *.
-assert (bpow (e - 1) <= Rabs u)%R.
-apply He.
-now apply Rgt_not_eq.
-rewrite Rabs_right in H0.
-case H0; auto.
-intros T; contradict T.
-now apply sym_not_eq.
-apply Rle_ge; now left.
-assert (Hu2:(ulp (pred u) = ulp u)).
-unfold ulp, canonic_exp.
-apply f_equal; apply f_equal.
-apply ln_beta_unique.
-rewrite Rabs_right.
-split.
-assumption.
-apply Rlt_trans with (1:=pred_lt_id _).
-destruct ln_beta as (e,He); simpl in *.
-rewrite Rabs_right in He.
-apply He.
-now apply Rgt_not_eq.
-apply Rle_ge; now left.
-apply Rle_ge, pred_ge_0; assumption.
-apply rnd_N_ge_half_an_ulp_pred; try assumption.
-apply Rlt_le_trans with (2:=H0).
-apply bpow_gt_0.
-rewrite Hu2; assumption.
+intros choice x d u H.
+apply Rle_antisym.
+destruct (generic_format_EM beta fexp x) as [Fx|Fx].
+rewrite round_generic...
+apply round_DN_pt; trivial; now right.
+apply round_N_le_midp.
+apply round_DN_pt...
+apply Rlt_le_trans with (1:=H).
+right; apply f_equal2; trivial; apply f_equal.
+now apply sym_eq, succ_DN_eq_UP.
+apply round_ge_generic; try apply round_DN_pt...
 Qed.
 
-
-Lemma round_N_DN_betw: forall choice x d u,
-   Rnd_DN_pt (generic_format beta fexp) x d ->
-   Rnd_UP_pt (generic_format beta fexp) x u ->
-     (d<=x<(d+u)/2)%R ->
+Lemma round_N_eq_DN_pt: forall choice x d u,
+      Rnd_DN_pt F x d -> Rnd_UP_pt F x u ->
+      (x<(d+u)/2)%R ->
      round beta fexp (Znearest choice) x = d.
 Proof with auto with typeclass_instances.
 intros choice x d u Hd Hu H.
-apply Rnd_N_pt_unicity with (generic_format beta fexp) x d u; try assumption.
-intros Y.
-absurd (x < (d+u)/2)%R; try apply H.
-apply Rle_not_lt; right.
-apply Rplus_eq_reg_r with (-x)%R.
-apply trans_eq with (- (x-d)/2 + (u-x)/2)%R.
-field.
-rewrite Y; field.
-apply round_N_pt...
-apply Rnd_DN_UP_pt_N with d u...
-apply Hd.
-right; apply trans_eq with (-(d-x))%R;[idtac|ring].
-apply Rabs_left1.
-apply Rplus_le_reg_l with x; ring_simplify.
-apply H.
-rewrite Rabs_left1.
-apply Rplus_le_reg_l with (d+x)%R.
-apply Rmult_le_reg_l with (/2)%R.
-auto with real.
-apply Rle_trans with x.
-right; field.
-apply Rle_trans with ((d+u)/2)%R.
-now left.
-right; field.
-apply Rplus_le_reg_l with x; ring_simplify.
-apply H.
+assert (H0:(d = round beta fexp Zfloor x)%R).
+apply Rnd_DN_pt_unicity with (1:=Hd).
+apply round_DN_pt...
+rewrite H0.
+apply round_N_eq_DN.
+rewrite <- H0.
+rewrite Rnd_UP_pt_unicity with F x (round beta fexp Zceil x) u; try assumption.
+apply round_UP_pt...
 Qed.
 
+Lemma round_N_eq_UP: forall choice x,
+      let d:=round beta fexp Zfloor x in
+      let u:=round beta fexp Zceil x in
+     ((d+u)/2 < x)%R ->
+     round beta fexp (Znearest choice) x = u.
+Proof with auto with typeclass_instances.
+intros choice x d u H.
+apply Rle_antisym.
+apply round_le_generic; try apply round_UP_pt...
+destruct (generic_format_EM beta fexp x) as [Fx|Fx].
+rewrite round_generic...
+apply round_UP_pt; trivial; now right.
+apply round_N_ge_midp.
+apply round_UP_pt...
+apply Rle_lt_trans with (2:=H).
+right; apply f_equal2; trivial; rewrite Rplus_comm; apply f_equal2; trivial.
+now apply pred_UP_eq_DN.
+Qed.
 
-Lemma round_N_UP_betw: forall choice x d u,
-   Rnd_DN_pt (generic_format beta fexp) x d ->
-   Rnd_UP_pt (generic_format beta fexp) x u ->
-     ((d+u)/2 < x <= u)%R ->
+Lemma round_N_eq_UP_pt: forall choice x d u,
+      Rnd_DN_pt F x d -> Rnd_UP_pt F x u ->
+      ((d+u)/2 < x)%R ->
      round beta fexp (Znearest choice) x = u.
 Proof with auto with typeclass_instances.
 intros choice x d u Hd Hu H.
-rewrite <- (Ropp_involutive (round beta fexp (Znearest choice) x )),
-  <- (Ropp_involutive u) .
-apply f_equal.
-rewrite <- (Ropp_involutive x) .
-rewrite round_N_opp, Ropp_involutive.
-apply round_N_DN_betw with (-d)%R.
-replace u with (round beta fexp Zceil x).
-rewrite <- round_DN_opp.
-apply round_DN_pt...
-apply Rnd_UP_pt_unicity with (generic_format beta fexp) x...
-apply round_UP_pt...
-replace d with (round beta fexp Zfloor x).
-rewrite <- round_UP_opp.
+assert (H0:(u = round beta fexp Zceil x)%R).
+apply Rnd_UP_pt_unicity with (1:=Hu).
 apply round_UP_pt...
-apply Rnd_DN_pt_unicity with (generic_format beta fexp) x...
+rewrite H0.
+apply round_N_eq_UP.
+rewrite <- H0.
+rewrite Rnd_DN_pt_unicity with F x (round beta fexp Zfloor x) d; try assumption.
 apply round_DN_pt...
-split.
-apply Ropp_le_contravar, H.
-apply Rlt_le_trans with (-((d + u) / 2))%R.
-apply Ropp_lt_contravar, H.
-unfold Rdiv; right; ring.
 Qed.
 
-
 End Fcore_ulp.
diff --git a/flocq/Flocq_version.v b/flocq/Flocq_version.v
index d2d9d3fb..c391f590 100644
--- a/flocq/Flocq_version.v
+++ b/flocq/Flocq_version.v
@@ -25,7 +25,8 @@ Definition Flocq_version := Eval vm_compute in
   let fix parse s major minor :=
     match s with
     | String "."%char t => parse t (major * 100 + minor)%N N0
-    | String h t => parse t major (minor + N_of_ascii h - N_of_ascii "0"%char)%N
+    | String h t =>
+      parse t major (minor * 10 + N_of_ascii h - N_of_ascii "0"%char)%N
     | Empty_string => (major * 100 + minor)%N
     end in
-  parse "2.4.0"%string N0 N0.
+  parse "2.5.0"%string N0 N0.
diff --git a/flocq/Prop/Fprop_div_sqrt_error.v b/flocq/Prop/Fprop_div_sqrt_error.v
index ec00ca4e..9d29001d 100644
--- a/flocq/Prop/Fprop_div_sqrt_error.v
+++ b/flocq/Prop/Fprop_div_sqrt_error.v
@@ -95,9 +95,6 @@ intros e; apply Zle_refl.
 now rewrite F2R_opp, F2R_mult, <- Hr1, <- Hy1.
 (* *)
 destruct (relative_error_FLX_ex beta prec (prec_gt_0 prec) rnd (x / y)%R) as (eps,(Heps1,Heps2)).
-apply Rmult_integral_contrapositive_currified.
-exact Zx.
-now apply Rinv_neq_0_compat.
 rewrite Heps2.
 rewrite <- Rabs_Ropp.
 replace (-(x + - (x / y * (1 + eps) * y)))%R with (x * eps)%R by now field.
@@ -135,8 +132,11 @@ now apply Rabs_pos_lt.
 rewrite Rabs_Ropp.
 replace (bpow (Fexp fr)) with (ulp beta (FLX_exp prec) (F2R fr)).
 rewrite <- Hr1.
-apply ulp_error_f...
-unfold ulp; apply f_equal.
+apply error_lt_ulp_round...
+apply Rmult_integral_contrapositive_currified; try apply Rinv_neq_0_compat; assumption.
+rewrite ulp_neq_0.
+2: now rewrite <- Hr1.
+apply f_equal.
 now rewrite Hr2, <- Hr1.
 replace (prec+(Fexp fr+Fexp fy))%Z with ((prec+Fexp fy)+Fexp fr)%Z by ring.
 rewrite bpow_plus.
@@ -246,8 +246,10 @@ apply Rmult_le_compat_r.
 apply Rabs_pos.
 apply Rle_trans with (/2*ulp beta  (FLX_exp prec) (F2R fr))%R.
 rewrite <- Hr1.
-apply ulp_half_error_f...
-right; unfold ulp; apply f_equal.
+apply error_le_half_ulp_round...
+right; rewrite ulp_neq_0.
+2: now rewrite <- Hr1.
+apply f_equal.
 rewrite Hr2, <- Hr1; trivial.
 rewrite Rmult_assoc, Rmult_comm.
 replace (prec+(Fexp fr+Fexp fr))%Z with (Fexp fr + (prec+Fexp fr))%Z by ring.
diff --git a/flocq/Prop/Fprop_mult_error.v b/flocq/Prop/Fprop_mult_error.v
index e84e80b4..7c71627b 100644
--- a/flocq/Prop/Fprop_mult_error.v
+++ b/flocq/Prop/Fprop_mult_error.v
@@ -126,8 +126,9 @@ apply Zplus_le_compat_r.
 rewrite ln_beta_unique with (1 := Hexy).
 apply ln_beta_le_bpow with (1 := Hz).
 replace (bpow (exy - prec)) with (ulp beta (FLX_exp prec) (x * y)).
-apply ulp_error...
-unfold ulp, canonic_exp.
+apply error_lt_ulp...
+rewrite ulp_neq_0; trivial.
+unfold canonic_exp.
 now rewrite ln_beta_unique with (1 := Hexy).
 apply Hc1.
 reflexivity.
diff --git a/flocq/Prop/Fprop_relative.v b/flocq/Prop/Fprop_relative.v
index f0a8f344..585b71da 100644
--- a/flocq/Prop/Fprop_relative.v
+++ b/flocq/Prop/Fprop_relative.v
@@ -35,7 +35,7 @@ Section relative_error_conversion.
 Variable rnd : R -> Z.
 Context { valid_rnd : Valid_rnd rnd }.
 
-Lemma relative_error_lt_conversion' :
+Lemma relative_error_lt_conversion :
   forall x b, (0 < b)%R ->
   (x <> 0 -> Rabs (round beta fexp rnd x - x) < b * Rabs x)%R ->
   exists eps,
@@ -62,19 +62,6 @@ rewrite Rinv_l with (1 := Hx0).
 now rewrite Rabs_R1, Rmult_1_r.
 Qed.
 
-(* TODO: remove *)
-Lemma relative_error_lt_conversion :
-  forall x b, (0 < b)%R ->
-  (Rabs (round beta fexp rnd x - x) < b * Rabs x)%R ->
-  exists eps,
-  (Rabs eps < b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
-Proof.
-intros x b Hb0 Hxb.
-apply relative_error_lt_conversion'.
-exact Hb0.
-now intros _.
-Qed.
-
 Lemma relative_error_le_conversion :
   forall x b, (0 <= b)%R ->
   (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R ->
@@ -113,16 +100,15 @@ Theorem relative_error :
   forall x,
   (bpow emin <= Rabs x)%R ->
   (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R.
-Proof.
+Proof with auto with typeclass_instances.
 intros x Hx.
-apply Rlt_le_trans with (ulp beta fexp x)%R.
-now apply ulp_error.
-unfold ulp, canonic_exp.
 assert (Hx': (x <> 0)%R).
-intros H.
-apply Rlt_not_le with (2 := Hx).
-rewrite H, Rabs_R0.
-apply bpow_gt_0.
+intros T; contradict Hx; rewrite T, Rabs_R0.
+apply Rlt_not_le, bpow_gt_0.
+apply Rlt_le_trans with (ulp beta fexp x)%R.
+now apply error_lt_ulp...
+rewrite ulp_neq_0; trivial.
+unfold canonic_exp.
 destruct (ln_beta beta x) as (ex, He).
 simpl.
 specialize (He Hx').
@@ -150,6 +136,7 @@ Proof with auto with typeclass_instances.
 intros x Hx.
 apply relative_error_lt_conversion...
 apply bpow_gt_0.
+intros _.
 now apply relative_error.
 Qed.
 
@@ -168,28 +155,17 @@ rewrite F2R_0, F2R_Zabs.
 now apply Rabs_pos_lt.
 Qed.
 
-Theorem relative_error_F2R_emin_ex' :
+Theorem relative_error_F2R_emin_ex :
   forall m, let x := F2R (Float beta m emin) in
   exists eps,
   (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
 Proof with auto with typeclass_instances.
 intros m x.
-apply relative_error_lt_conversion'...
+apply relative_error_lt_conversion...
 apply bpow_gt_0.
 now apply relative_error_F2R_emin.
 Qed.
 
-(* TODO: remove *)
-Theorem relative_error_F2R_emin_ex :
-  forall m, let x := F2R (Float beta m emin) in
-  (x <> 0)%R ->
-  exists eps,
-  (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
-Proof with auto with typeclass_instances.
-intros m x _.
-apply relative_error_F2R_emin_ex'.
-Qed.
-
 Theorem relative_error_round :
   (0 < p)%Z ->
   forall x,
@@ -197,14 +173,13 @@ Theorem relative_error_round :
   (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R.
 Proof with auto with typeclass_instances.
 intros Hp x Hx.
-apply Rlt_le_trans with (ulp beta fexp x)%R.
-now apply ulp_error.
 assert (Hx': (x <> 0)%R).
-intros H.
-apply Rlt_not_le with (2 := Hx).
-rewrite H, Rabs_R0.
-apply bpow_gt_0.
-unfold ulp, canonic_exp.
+intros T; contradict Hx; rewrite T, Rabs_R0.
+apply Rlt_not_le, bpow_gt_0.
+apply Rlt_le_trans with (ulp beta fexp x)%R.
+now apply error_lt_ulp.
+rewrite ulp_neq_0; trivial.
+unfold canonic_exp.
 destruct (ln_beta beta x) as (ex, He).
 simpl.
 specialize (He Hx').
@@ -222,7 +197,7 @@ apply bpow_ge_0.
 generalize He.
 apply round_abs_abs...
 clear rnd valid_rnd x Hx Hx' He.
-intros rnd valid_rnd x Hx.
+intros rnd valid_rnd x _ Hx.
 rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
 now apply round_le.
 apply generic_format_bpow.
@@ -257,7 +232,7 @@ Theorem relative_error_N :
 Proof.
 intros x Hx.
 apply Rle_trans with (/2 * ulp beta fexp x)%R.
-now apply ulp_half_error.
+now apply error_le_half_ulp.
 rewrite Rmult_assoc.
 apply Rmult_le_compat_l.
 apply Rlt_le.
@@ -268,7 +243,8 @@ intros H.
 apply Rlt_not_le with (2 := Hx).
 rewrite H, Rabs_R0.
 apply bpow_gt_0.
-unfold ulp, canonic_exp.
+rewrite ulp_neq_0; trivial.
+unfold canonic_exp.
 destruct (ln_beta beta x) as (ex, He).
 simpl.
 specialize (He Hx').
@@ -348,7 +324,7 @@ Theorem relative_error_N_round :
 Proof with auto with typeclass_instances.
 intros Hp x Hx.
 apply Rle_trans with (/2 * ulp beta fexp x)%R.
-now apply ulp_half_error.
+now apply error_le_half_ulp.
 rewrite Rmult_assoc.
 apply Rmult_le_compat_l.
 apply Rlt_le.
@@ -359,7 +335,8 @@ intros H.
 apply Rlt_not_le with (2 := Hx).
 rewrite H, Rabs_R0.
 apply bpow_gt_0.
-unfold ulp, canonic_exp.
+rewrite ulp_neq_0; trivial.
+unfold canonic_exp.
 destruct (ln_beta beta x) as (ex, He).
 simpl.
 specialize (He Hx').
@@ -377,7 +354,7 @@ apply bpow_ge_0.
 generalize He.
 apply round_abs_abs...
 clear rnd valid_rnd x Hx Hx' He.
-intros rnd valid_rnd x Hx.
+intros rnd valid_rnd x _ Hx.
 rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
 now apply round_le.
 apply generic_format_bpow.
@@ -428,17 +405,6 @@ Qed.
 Variable rnd : R -> Z.
 Context { valid_rnd : Valid_rnd rnd }.
 
-(* TODO: remove *)
-Theorem relative_error_FLT_F2R_emin :
-  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
-  (x <> 0)%R ->
-  (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
-Proof with auto with typeclass_instances.
-intros m x Hx.
-apply relative_error_F2R_emin...
-apply relative_error_FLT_aux.
-Qed.
-
 Theorem relative_error_FLT :
   forall x,
   (bpow (emin + prec - 1) <= Rabs x)%R ->
@@ -449,7 +415,7 @@ apply relative_error with (emin + prec - 1)%Z...
 apply relative_error_FLT_aux.
 Qed.
 
-Theorem relative_error_FLT_F2R_emin' :
+Theorem relative_error_FLT_F2R_emin :
   forall m, let x := F2R (Float beta m emin) in
   (x <> 0)%R ->
   (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
@@ -472,26 +438,13 @@ now exists (Float beta m emin).
 now apply relative_error_FLT.
 Qed.
 
-Theorem relative_error_FLT_F2R_emin_ex' :
+Theorem relative_error_FLT_F2R_emin_ex :
   forall m, let x := F2R (Float beta m emin) in
   exists eps,
   (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
 Proof with auto with typeclass_instances.
 intros m x.
-apply relative_error_lt_conversion'...
-apply bpow_gt_0.
-now apply relative_error_FLT_F2R_emin'.
-Qed.
-
-(* TODO: remove *)
-Theorem relative_error_FLT_F2R_emin_ex :
-  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
-  (x <> 0)%R ->
-  exists eps,
-  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
-Proof with auto with typeclass_instances.
-intros m x _.
-apply relative_error_lt_conversion'...
+apply relative_error_lt_conversion...
 apply bpow_gt_0.
 now apply relative_error_FLT_F2R_emin.
 Qed.
@@ -506,7 +459,7 @@ Proof with auto with typeclass_instances.
 intros x Hx.
 apply relative_error_lt_conversion...
 apply bpow_gt_0.
-now apply relative_error_FLT.
+intros _; now apply relative_error_FLT.
 Qed.
 
 Variable choice : Z -> bool.
@@ -548,7 +501,7 @@ apply relative_error_N_round with (emin + prec - 1)%Z...
 apply relative_error_FLT_aux.
 Qed.
 
-Theorem relative_error_N_FLT_F2R_emin' :
+Theorem relative_error_N_FLT_F2R_emin :
   forall m, let x := F2R (Float beta m emin) in
   (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
 Proof with auto with typeclass_instances.
@@ -573,17 +526,7 @@ now exists (Float beta m emin).
 now apply relative_error_N_FLT.
 Qed.
 
-(* TODO: remove *)
-Theorem relative_error_N_FLT_F2R_emin :
-  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
-  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
-Proof with auto with typeclass_instances.
-intros m x.
-apply relative_error_N_F2R_emin...
-apply relative_error_FLT_aux.
-Qed.
-
-Theorem relative_error_N_FLT_F2R_emin_ex' :
+Theorem relative_error_N_FLT_F2R_emin_ex :
   forall m, let x := F2R (Float beta m emin) in
   exists eps,
   (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
@@ -594,26 +537,11 @@ apply Rmult_le_pos.
 apply Rlt_le.
 apply (RinvN_pos 1).
 apply bpow_ge_0.
-now apply relative_error_N_FLT_F2R_emin'.
-Qed.
-
-(* TODO: remove *)
-Theorem relative_error_N_FLT_F2R_emin_ex :
-  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
-  exists eps,
-  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
-Proof with auto with typeclass_instances.
-intros m x.
-apply relative_error_le_conversion...
-apply Rlt_le.
-apply Rmult_lt_0_compat.
-apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
-apply bpow_gt_0.
 now apply relative_error_N_FLT_F2R_emin.
 Qed.
 
-Theorem relative_error_N_FLT_round_F2R_emin' :
+
+Theorem relative_error_N_FLT_round_F2R_emin :
   forall m, let x := F2R (Float beta m emin) in
   (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
 Proof with auto with typeclass_instances.
@@ -639,16 +567,6 @@ apply relative_error_N_round with (emin := (emin + prec - 1)%Z)...
 apply relative_error_FLT_aux.
 Qed.
 
-(* TODO: remove *)
-Theorem relative_error_N_FLT_round_F2R_emin :
-  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
-  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
-Proof with auto with typeclass_instances.
-intros m x.
-apply relative_error_N_round_F2R_emin...
-apply relative_error_FLT_aux.
-Qed.
-
 Lemma error_N_FLT_aux :
   forall x,
   (0 < x)%R ->
@@ -682,10 +600,11 @@ auto with real.
 apply bpow_ge_0.
 split.
 apply Rle_trans with (/2*ulp beta (FLT_exp emin prec) x)%R.
-apply ulp_half_error.
+apply error_le_half_ulp.
 now apply FLT_exp_valid.
 apply Rmult_le_compat_l; auto with real.
-unfold ulp.
+rewrite ulp_neq_0.
+2: now apply Rgt_not_eq.
 apply bpow_le.
 unfold FLT_exp, canonic_exp.
 rewrite Zmax_right.
@@ -770,28 +689,17 @@ apply He.
 Qed.
 
 (** 1+#&epsilon;# property in any rounding in FLX *)
-Theorem relative_error_FLX_ex' :
+Theorem relative_error_FLX_ex :
   forall x,
   exists eps,
   (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R.
 Proof with auto with typeclass_instances.
 intros x.
-apply relative_error_lt_conversion'...
+apply relative_error_lt_conversion...
 apply bpow_gt_0.
 now apply relative_error_FLX.
 Qed.
 
-(* TODO: remove *)
-Theorem relative_error_FLX_ex :
-  forall x,
-  (x <> 0)%R ->
-  exists eps,
-  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R.
-Proof with auto with typeclass_instances.
-intros x _.
-apply relative_error_FLX_ex'.
-Qed.
-
 Theorem relative_error_FLX_round :
   forall x,
   (x <> 0)%R ->
diff --git a/ia32/AsmToJSON.ml b/ia32/AsmToJSON.ml
index de39cb9d..3214491f 100644
--- a/ia32/AsmToJSON.ml
+++ b/ia32/AsmToJSON.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (* *********************************************************************)
 
-(* Simple functions to serialize powerpc Asm to JSON *)
+(* Simple functions to serialize ia32 Asm to JSON *)
 
 (* Dummy function *)
 let p_program oc prog =
diff --git a/ia32/Asmexpand.ml b/ia32/Asmexpand.ml
index baf0523e..4f02e633 100644
--- a/ia32/Asmexpand.ml
+++ b/ia32/Asmexpand.ml
@@ -387,36 +387,46 @@ let expand_instruction instr =
      end
   | _ -> emit instr
        
-let expand_function fn =
-  try
-    set_current_function fn;
-    List.iter expand_instruction fn.fn_code;
-    Errors.OK (get_current_function ())
-  with Error s ->
-    Errors.Error (Errors.msg (coqstring_of_camlstring s))
+let int_reg_to_dwarf = function
+  | EAX -> 0
+  | EBX -> 3
+  | ECX -> 1
+  | EDX -> 2
+  | ESI -> 6
+  | EDI -> 7
+  | EBP -> 5
+  | ESP -> 4
 
-let expand_fundef = function
-  | Internal f ->
-      begin match expand_function f with
-      | Errors.OK tf -> Errors.OK (Internal tf)
-      | Errors.Error msg -> Errors.Error msg
-      end
-  | External ef ->
-      Errors.OK (External ef)
+let float_reg_to_dwarf = function
+  | XMM0 -> 21
+  | XMM1 -> 22
+  | XMM2 -> 23
+  | XMM3 -> 24
+  | XMM4 -> 25
+  | XMM5 -> 26
+  | XMM6 -> 27
+  | XMM7 -> 28
 
-let expand_program (p: Asm.program) : Asm.program Errors.res =
-  AST.transform_partial_program expand_fundef p
-let expand_function fn =
+let preg_to_dwarf = function
+   | IR r -> int_reg_to_dwarf r
+   | FR r -> float_reg_to_dwarf r
+   | _ -> assert false
+
+
+let expand_function id fn =
   try
     set_current_function fn;
-    List.iter expand_instruction fn.fn_code;
+    if !Clflags.option_g then
+      expand_debug id 4 preg_to_dwarf expand_instruction fn.fn_code
+    else
+      List.iter expand_instruction fn.fn_code;
     Errors.OK (get_current_function ())
   with Error s ->
     Errors.Error (Errors.msg (coqstring_of_camlstring s))
 
-let expand_fundef = function
+let expand_fundef id = function
   | Internal f ->
-      begin match expand_function f with
+      begin match expand_function id f with
       | Errors.OK tf -> Errors.OK (Internal tf)
       | Errors.Error msg -> Errors.Error msg
       end
@@ -424,4 +434,4 @@ let expand_fundef = function
       Errors.OK (External ef)
 
 let expand_program (p: Asm.program) : Asm.program Errors.res =
-  AST.transform_partial_program expand_fundef p
+  AST.transform_partial_ident_program expand_fundef p
diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml
index 439dd2b0..95de40ca 100644
--- a/ia32/TargetPrinter.ml
+++ b/ia32/TargetPrinter.ml
@@ -20,6 +20,7 @@ open AST
 open Memdata
 open Asm
 open PrintAsmaux
+open Fileinfo
 
 module StringSet = Set.Make(String)
 
@@ -101,8 +102,10 @@ module Cygwin_System : SYSTEM =
       | Section_user(s, wr, ex) ->
           sprintf ".section	\"%s\", \"%s\"\n"
             s (if ex then "xr" else if wr then "d" else "dr")
-      | Section_debug_info
-      | Section_debug_abbrev -> "" (* Dummy value *)
+      | Section_debug_info _ -> ".section	.debug_info,\"dr\""
+      | Section_debug_loc ->  ".section	.debug_loc,\"dr\""
+      | Section_debug_line _ -> ".section	.debug_line,\"dr\""
+      | Section_debug_abbrev -> ".section	.debug_abbrev,\"dr\"" (* Dummy value *)
 
     let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *)
 
@@ -150,8 +153,10 @@ module ELF_System : SYSTEM =
       | Section_user(s, wr, ex) ->
           sprintf ".section	\"%s\",\"a%s%s\",@progbits"
             s (if wr then "w" else "") (if ex then "x" else "")
-      | Section_debug_info
-      | Section_debug_abbrev -> "" (* Dummy value *)
+      | Section_debug_info _ -> ".section	.debug_info,\"\",@progbits"
+      | Section_debug_loc -> ".section	.debug_loc,\"\",@progbits"
+      | Section_debug_line _ -> ".section	.debug_line,\"\",@progbits"
+      | Section_debug_abbrev -> ".section	.debug_abbrev,\"\",@progbits"
             
     let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *)
                     
@@ -202,8 +207,11 @@ module MacOS_System : SYSTEM =
           sprintf ".section	\"%s\", %s, %s"
             (if wr then "__DATA" else "__TEXT") s
             (if ex then "regular, pure_instructions" else "regular")
-      | Section_debug_info
-      | Section_debug_abbrev -> "" (* Dummy value *)
+      | Section_debug_info _ ->	".section	__DWARF,__debug_info,regular,debug"
+      | Section_debug_loc  -> ".section	__DWARF,__debug_loc,regular,debug"
+      | Section_debug_line _ -> ".section	__DWARF,__debug_line,regular,debug"
+      | Section_debug_abbrev -> ".section	__DWARF,__debug_abbrev,regular,debug" (* Dummy value *)
+    
     
     let stack_alignment =  16 (* mandatory *)
          
@@ -741,9 +749,16 @@ module Target(System: SYSTEM):TARGET =
         
     let print_var_info = print_var_info
 
-    let print_prologue _ = 
-      need_masks := false
-    
+    let print_prologue oc = 
+      need_masks := false;
+      if !Clflags.option_g then begin
+        section oc Section_text;
+        let low_pc = new_label () in
+        Debug.add_compilation_section_start ".text" low_pc;
+        fprintf oc "%a:\n" elf_label low_pc;
+        fprintf oc "	.cfi_sections	.debug_frame\n"
+      end
+
     let print_epilogue oc = 
       if !need_masks then begin
         section oc (Section_const true);
@@ -758,25 +773,22 @@ module Target(System: SYSTEM):TARGET =
         fprintf oc "%a:	.long   0x7FFFFFFF, 0xFFFFFFFF, 0xFFFFFFFF, 0xFFFFFFFF\n"
           raw_symbol "__abss_mask"
       end;
-      System.print_epilogue oc
+      System.print_epilogue oc;
+      if !Clflags.option_g then begin
+        let high_pc = new_label () in
+        Debug.add_compilation_section_end ".text" high_pc;
+        Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f));
+        section oc Section_text;
+        fprintf oc "%a:\n" elf_label high_pc
+      end
       
     let comment = comment
 
     let default_falignment = 16
 
-    let get_start_addr () = -1 (* Dummy constant *)
-        
-    let get_end_addr () = -1 (* Dummy constant *)
-
-    let get_stmt_list_addr () = -1 (* Dummy constant *)
-
-    module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs (* Dummy Abbrev types *)
-
     let label = label
        
     let new_label = new_label
-        
-    let print_file_loc _ _ = () (* Dummy function *)
 
 end
 
diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml
index 68c095f0..c50b3230 100644
--- a/lib/Camlcoq.ml
+++ b/lib/Camlcoq.ml
@@ -295,8 +295,7 @@ let intern_string s =
     next_atom := Pos.succ !next_atom;
     Hashtbl.add atom_of_string s a;
     Hashtbl.add string_of_atom a s;
-    a
-
+    a 
 let extern_atom a =
   try
     Hashtbl.find string_of_atom a
diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml
index d82b9730..9d480ed5 100644
--- a/powerpc/AsmToJSON.ml
+++ b/powerpc/AsmToJSON.ml
@@ -337,9 +337,11 @@ let p_section oc = function
   | Section_string -> fprintf oc "{\"Section Name\":\"String\"}"
   | Section_literal -> fprintf oc "{\"Section Name\":\"Literal\"}"
   | Section_jumptable -> fprintf oc "{\"Section Name\":\"Jumptable\"}"
-  | Section_user (s,w,e) -> fprintf oc "{\"Section Name\":%s,\"Writable\":%B,\"Executable\":%B}" s w e
-  | Section_debug_info 
-  | Section_debug_abbrev -> () (* There should be no info in the debug sections *)
+  | Section_user (s,w,e) -> fprintf oc "{\"Section Name\":\"%s\",\"Writable\":%B,\"Executable\":%B}" s w e
+  | Section_debug_info _
+  | Section_debug_abbrev 
+  | Section_debug_line _
+  | Section_debug_loc -> () (* There should be no info in the debug sections *)
 
 let p_int_opt oc = function
   | None -> fprintf oc "0"
diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml
index 49f796ca..9e22e4e0 100644
--- a/powerpc/Asmexpand.ml
+++ b/powerpc/Asmexpand.ml
@@ -48,7 +48,7 @@ let emit_addimm rd rs n =
   List.iter emit (Asmgen.addimm rd rs n [])
 
 
-			    
+
 (* Handling of annotations *)
 
 let expand_annot_val txt targ args res =
@@ -71,7 +71,7 @@ let expand_annot_val txt targ args res =
    Note that lfd and stfd cannot trap on ill-formed floats. *)
 
 let offset_in_range ofs =
-  Int.eq (Asmgen.high_s ofs) Int.zero
+  Int.eq (Asmgen.high_s ofs) _0
 
 let memcpy_small_arg sz arg tmp =
   match arg with
@@ -86,7 +86,7 @@ let memcpy_small_arg sz arg tmp =
       assert false
 
 let expand_builtin_memcpy_small sz al src dst =
-  let (tsrc, tdst) = 
+  let (tsrc, tdst) =
     if dst <> BA (IR GPR11) then (GPR11, GPR12) else (GPR12, GPR11) in
   let (rsrc, osrc) = memcpy_small_arg sz src tsrc in
   let (rdst, odst) = memcpy_small_arg sz dst tdst in
@@ -124,7 +124,7 @@ let expand_builtin_memcpy_big sz al src dst =
   assert (sz >= 4);
   emit_loadimm GPR0 (Z.of_uint (sz / 4));
   emit (Pmtctr GPR0);
-  let (s, d) = 
+  let (s, d) =
     if dst <> BA (IR GPR11) then (GPR11, GPR12) else (GPR12, GPR11) in
   memcpy_big_arg src s;
   memcpy_big_arg dst d;
@@ -192,7 +192,7 @@ let rec expand_builtin_vload_common chunk base offset res =
             emit (Plwz(lo, offset', base));
             emit (Plwz(hi, offset, base))
           end
-      | None ->      
+      | None ->
           emit (Paddi(GPR11, base, offset));
           expand_builtin_vload_common chunk GPR11 (Cint _0) res
       end
@@ -246,7 +246,7 @@ let expand_builtin_vstore_common chunk base offset src =
       | Some offset' ->
           emit (Pstw(hi, offset, base));
           emit (Pstw(lo, offset', base))
-      | None ->      
+      | None ->
           let tmp = temp_for_vstore src in
           emit (Paddi(tmp, base, offset));
           emit (Pstw(hi, Cint _0, tmp));
@@ -283,9 +283,9 @@ let expand_builtin_vstore chunk args =
       assert false
 
 (* Handling of varargs *)
-let linkregister_offset = ref  Int.zero
+let linkregister_offset = ref  _0
 
-let retaddr_offset = ref Int.zero
+let retaddr_offset = ref _0
 
 let current_function_stacksize = ref 0l
 
@@ -448,8 +448,8 @@ let expand_builtin_inline name args res =
       emit (Picbi(GPR0,a1))
   | "__builtin_dcbtls", [BA (IR a1); BA_int loc],_ ->
       if not ((Int.eq loc _0) || (Int.eq loc _2)) then
-        raise (Error "the second argument of __builtin_dcbtls must be a constant between 0 and 2");
-      emit (Pdcbtls (loc,GPR0,a1))    
+        raise (Error "the second argument of __builtin_dcbtls must be 0 or 2");
+      emit (Pdcbtls (loc,GPR0,a1))
   | "__builtin_dcbtls",_,_ ->
       raise (Error "the second argument of __builtin_dcbtls must be a constant")
   | "__builtin_icbtls", [BA (IR a1); BA_int loc],_ ->
@@ -482,7 +482,7 @@ let expand_builtin_inline name args res =
       raise (Error "the first argument of __builtin_set_spr must be a constant")
   (* Frame and return address *)
   | "__builtin_call_frame", _,BR (IR res) ->
-      let sz = !current_function_stacksize 
+      let sz = !current_function_stacksize
       and ofs = !linkregister_offset in
       if sz < 0x8000l then
         emit (Paddi(res, GPR1, Cint(coqint_of_camlint sz)))
@@ -510,6 +510,57 @@ let expand_builtin_inline name args res =
         end;
         emit (Por (res, res, GPR0))
       end
+  (* atomic operations *)
+  | "__builtin_atomic_exchange", [BA (IR a1); BA (IR a2); BA (IR a3)],_ ->
+      emit (Plwz (GPR10,Cint _0,a2));
+      emit (Psync);
+      let lbl = new_label() in
+      emit (Plabel lbl);
+      emit (Plwarx (GPR0,GPR0,a1));
+      emit (Pstwcx_ (GPR10,GPR0,a1));
+      emit (Pbf (CRbit_2,lbl));
+      emit (Pisync);
+      emit (Pstw (GPR0,Cint _0,a3))
+  | "__builtin_atomic_load", [BA (IR a1); BA (IR a2)],_ ->
+      let lbl = new_label () in
+      emit (Psync);
+      emit (Plwz (GPR0,Cint _0,a1));
+      emit (Pcmpw (GPR0,GPR0));
+      emit (Pbf (CRbit_2,lbl));
+      emit (Plabel lbl);
+      emit (Pisync);
+      emit (Pstw (GPR0,Cint _0, a2))
+  | "__builtin_sync_fetch_and_add", [BA (IR a1); BA(IR a2)], BR (IR res) ->
+      let lbl = new_label() in
+      emit (Psync);
+      emit (Plabel lbl);
+      emit (Plwarx (res,GPR0,a1));
+      emit (Padd (GPR0,res,a2));
+      emit (Pstwcx_ (GPR0,GPR0,a1));
+      emit (Pbf (CRbit_2, lbl));
+      emit (Pisync);
+  | "__builtin_atomic_compare_exchange", [BA (IR dst); BA(IR exp); BA (IR des)],  BR (IR res) ->
+      let lbls = new_label ()
+      and lblneq = new_label ()
+      and lblsucc = new_label () in
+      emit (Plwz (GPR10,Cint _0,exp));
+      emit (Plwz (GPR11,Cint _0,des));
+      emit (Psync);
+      emit (Plabel lbls);
+      emit (Plwarx (GPR0,GPR0,dst));
+      emit (Pcmpw (GPR0,GPR10));
+      emit (Pbf (CRbit_2,lblneq));
+      emit (Pstwcx_ (GPR11,GPR0,dst));
+      emit (Pbf (CRbit_2,lbls));
+      emit (Plabel lblneq);
+      (* Here, CR2 is true if the exchange succeeded, false if it failed *)
+      emit (Pisync);
+      emit (Pmfcr GPR10);
+      emit (Prlwinm (res,GPR10,(Z.of_uint 3),_1));
+      (* Update exp with the current value of dst if the exchange failed *)
+      emit (Pbt (CRbit_2,lblsucc));
+      emit (Pstw (GPR0,Cint _0,exp));
+      emit (Plabel lblsucc)
   (* Catch-all *)
   | _ ->
       raise (Error ("unrecognized builtin " ^ name))
@@ -540,7 +591,7 @@ let expand_instruction instr =
   | Pallocframe(sz, ofs,retofs) ->
       let variadic = (!current_function).fn_sig.sig_cc.cc_vararg in
       let sz = camlint_of_coqint sz in
-      assert (ofs = Int.zero);
+      assert (ofs = _0);
       let sz = if variadic then Int32.add sz 96l else sz in
       let adj = Int32.neg sz in
       if adj >= -0x8000l then
@@ -635,17 +686,49 @@ let expand_instruction instr =
   | _ ->
       emit instr
 
-let expand_function fn =
+(* Translate to the integer identifier of the register as
+   the EABI specifies *)
+
+let int_reg_to_dwarf = function
+   | GPR0 -> 0  | GPR1 -> 1  | GPR2 -> 2  | GPR3 -> 3
+   | GPR4 -> 4  | GPR5 -> 5  | GPR6 -> 6  | GPR7 -> 7
+   | GPR8 -> 8  | GPR9 -> 9  | GPR10 -> 10 | GPR11 -> 11
+   | GPR12 -> 12 | GPR13 -> 13 | GPR14 -> 14 | GPR15 -> 15
+   | GPR16 -> 16 | GPR17 -> 17 | GPR18 -> 18 | GPR19 -> 19
+   | GPR20 -> 20 | GPR21 -> 21 | GPR22 -> 22 | GPR23 -> 23
+   | GPR24 -> 24 | GPR25 -> 25 | GPR26 -> 26 | GPR27 -> 27
+   | GPR28 -> 28 | GPR29 -> 29 | GPR30 -> 30 | GPR31 -> 31
+
+let float_reg_to_dwarf = function
+   | FPR0 -> 32  | FPR1 -> 33  | FPR2 -> 34  | FPR3 -> 35
+   | FPR4 -> 36  | FPR5 -> 37  | FPR6 -> 38  | FPR7 -> 39
+   | FPR8 -> 40  | FPR9 -> 41  | FPR10 -> 42 | FPR11 -> 43
+   | FPR12 -> 44 | FPR13 -> 45 | FPR14 -> 46 | FPR15 -> 47
+   | FPR16 -> 48 | FPR17 -> 49 | FPR18 -> 50 | FPR19 -> 51
+   | FPR20 -> 52 | FPR21 -> 53 | FPR22 -> 54| FPR23 -> 55
+   | FPR24 -> 56 | FPR25 -> 57 | FPR26 -> 58 | FPR27 -> 59
+   | FPR28 -> 60 | FPR29 -> 61 | FPR30 -> 62 | FPR31 -> 63
+
+let preg_to_dwarf = function
+   | IR r -> int_reg_to_dwarf r
+   | FR r -> float_reg_to_dwarf r
+   | _ -> assert false
+
+
+let expand_function id fn =
   try
     set_current_function fn;
-    List.iter expand_instruction fn.fn_code;
+    if !Clflags.option_g then
+      expand_debug id 2 preg_to_dwarf expand_instruction fn.fn_code
+    else
+      List.iter expand_instruction fn.fn_code;
     Errors.OK (get_current_function ())
   with Error s ->
     Errors.Error (Errors.msg (coqstring_of_camlstring s))
 
-let expand_fundef = function
+let expand_fundef id = function
   | Internal f ->
-      begin match expand_function f with
+      begin match expand_function id f with
       | Errors.OK tf -> Errors.OK (Internal tf)
       | Errors.Error msg -> Errors.Error msg
       end
@@ -653,4 +736,4 @@ let expand_fundef = function
       Errors.OK (External ef)
 
 let expand_program (p: Asm.program) : Asm.program Errors.res =
-  AST.transform_partial_program expand_fundef p
+  AST.transform_partial_ident_program expand_fundef p
diff --git a/powerpc/CBuiltins.ml b/powerpc/CBuiltins.ml
index 1bb8c6f7..a9e4f5e3 100644
--- a/powerpc/CBuiltins.ml
+++ b/powerpc/CBuiltins.ml
@@ -118,7 +118,16 @@ let builtins = {
       (TPtr (TVoid [],[]),[],false);
     (* isel *)
     "__builtin_isel",
-      (TInt (IInt, []),[TInt(IBool, []);TInt(IInt, []);TInt(IInt, [])],false)
+      (TInt (IInt, []),[TInt(IBool, []);TInt(IInt, []);TInt(IInt, [])],false);
+    (* atomic operations *)
+    "__builtin_atomic_exchange",
+      (TVoid [], [TPtr (TInt(IInt, []),[]);TPtr (TInt(IInt, []),[]);TPtr (TInt(IInt, []),[])],false);
+    "__builtin_atomic_load",
+      (TVoid [], [TPtr (TInt(IInt, []),[]);TPtr (TInt(IInt, []),[])],false);
+    "__builtin_atomic_compare_exchange",
+      (TInt (IBool, []), [TPtr (TInt(IInt, []),[]);TPtr (TInt(IInt, []),[]);TPtr (TInt(IInt, []),[])],false);
+    "__builtin_sync_fetch_and_add",
+      (TInt (IInt, []),  [TPtr (TInt(IInt, []),[]);TInt(IInt, [])],false);
   ]
 }
 
diff --git a/powerpc/Machregs.v b/powerpc/Machregs.v
index e4006523..20bec532 100644
--- a/powerpc/Machregs.v
+++ b/powerpc/Machregs.v
@@ -160,9 +160,16 @@ Fixpoint destroyed_by_clobber (cl: list string): list mreg :=
       end
   end.
 
+Definition builtin_atomic_exchange := ident_of_string "__builtin_atomic_exchange".
+Definition builtin_sync_and_fetch := ident_of_string "__builtin_sync_fetch_and_add".
+Definition builtin_atomic_compare_exchange := ident_of_string "__builtin_atomic_compare_exchange".
+
 Definition destroyed_by_builtin (ef: external_function): list mreg :=
   match ef with
-  | EF_builtin _ _ => F13 :: nil
+  | EF_builtin id sg =>
+    if ident_eq id builtin_atomic_exchange then R10::nil
+    else if ident_eq id builtin_atomic_compare_exchange then R10::R11::nil
+    else F13 :: nil
   | EF_vload _ => R11 :: nil
   | EF_vstore Mint64 => R10 :: R11 :: R12 :: nil
   | EF_vstore _ => R11 :: R12 :: nil
@@ -183,8 +190,16 @@ Definition temp_for_parent_frame: mreg :=
 Definition mregs_for_operation (op: operation): list (option mreg) * option mreg :=
   (nil, None).
 
+
 Definition mregs_for_builtin (ef: external_function): list (option mreg) * list (option mreg) :=
-  (nil, nil).
+  match ef with
+    | EF_builtin id sg =>
+      if ident_eq id builtin_atomic_exchange then ((Some R3)::(Some R4)::(Some R5)::nil,nil)
+      else if ident_eq id builtin_sync_and_fetch then ((Some R4)::(Some R5)::nil,(Some R3)::nil)
+      else if ident_eq id builtin_atomic_compare_exchange then ((Some R4)::(Some R5)::(Some R6)::nil, (Some R3):: nil)
+      else (nil, nil)
+    | _ => (nil, nil)
+  end.
 
 Global Opaque
     destroyed_by_op destroyed_by_load destroyed_by_store
diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml
index bc990de5..250686be 100644
--- a/powerpc/TargetPrinter.ml
+++ b/powerpc/TargetPrinter.ml
@@ -13,6 +13,7 @@
 (* Printing PPC assembly code in asm syntax *)
 
 open Printf
+open Fileinfo
 open Datatypes
 open Maps
 open Camlcoq
@@ -39,7 +40,6 @@ module type SYSTEM =
       val cfi_rel_offset: out_channel -> string -> int32 -> unit
       val print_prologue: out_channel -> unit
       val print_epilogue: out_channel -> unit
-      val print_file_loc: out_channel -> DwarfTypes.file_loc -> unit
       val section: out_channel -> section_name -> unit
       val debug_section: out_channel -> section_name -> unit
     end
@@ -72,12 +72,6 @@ let float_reg_name = function
   | FPR24 -> "24" | FPR25 -> "25" | FPR26 -> "26" | FPR27 -> "27"
   | FPR28 -> "28" | FPR29 -> "29" | FPR30 -> "30" | FPR31 -> "31"
 
-let start_addr = ref (-1)
-
-let end_addr = ref (-1)
-
-let stmt_list_addr = ref (-1)
-
 let label = elf_label
 
 module Linux_System : SYSTEM =
@@ -129,9 +123,12 @@ module Linux_System : SYSTEM =
       | Section_user(s, wr, ex) ->
           sprintf ".section	\"%s\",\"a%s%s\",@progbits"
             s (if wr then "w" else "") (if ex then "x" else "")
-      | Section_debug_info -> ".debug_info,\"\",@progbits"
-      | Section_debug_abbrev -> ".debug_abbrev,\"\",@progbits"
-    
+      | Section_debug_info _ -> ".section	.debug_info,\"\",@progbits"
+      | Section_debug_abbrev -> ".section	.debug_abbrev,\"\",@progbits"
+      | Section_debug_loc -> ".section	.debug_loc,\"\",@progbits"
+      | Section_debug_line _ ->  ".section	.debug_line,\"\",@progbits\n"
+
+
     let section oc sec =
       let name = name_of_section sec in
       assert (name <> "COMM");
@@ -150,12 +147,25 @@ module Linux_System : SYSTEM =
               
     let cfi_rel_offset = cfi_rel_offset
 
-    let print_prologue oc = ()
+    let print_prologue oc = 
+      if !Clflags.option_g then  begin
+          section oc Section_text;
+          let low_pc = new_label () in
+          Debug.add_compilation_section_start ".text" low_pc;
+          fprintf oc "%a:\n" label low_pc;
+          fprintf oc "	.cfi_sections	.debug_frame\n"
+        end
 
-    let print_epilogue oc = ()
+    let print_epilogue oc =
+      if !Clflags.option_g then
+        begin
+          let high_pc = new_label () in
+          Debug.add_compilation_section_end ".text" high_pc;
+          Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f));
+          section oc Section_text;
+          fprintf oc "%a:\n" label high_pc
+        end
 
-    let print_file_loc _ _ = ()
-        
     let debug_section _ _ = ()
   end
     
@@ -207,14 +217,21 @@ module Diab_System : SYSTEM =
             | true, false -> 'd'                (* data *)
             | false, true -> 'c'                (* text *)
             | false, false -> 'r')              (* const *)
-      | Section_debug_info -> ".debug_info,,n"
-      | Section_debug_abbrev -> ".debug_abbrev,,n"
+      | Section_debug_info s -> sprintf ".section	.debug_info%s,,n" (if s <> ".text" then s else "")
+      | Section_debug_abbrev -> ".section	.debug_abbrev,,n"
+      | Section_debug_loc -> ".section	.debug_loc,,n"
+      | Section_debug_line s -> sprintf ".section	.debug_line.%s,,n\n" s
 
     let section oc sec =
       let name = name_of_section sec in
       assert (name <> "COMM");
-      fprintf oc "	%s\n" name
-
+      match sec with
+      | Section_debug_info s ->
+          fprintf oc "	%s\n" name;
+          if s <> ".text" then
+            fprintf oc "	.sectionlink	.debug_info\n"
+      | _ ->
+          fprintf oc "	%s\n" name
 
     let print_file_line oc file line =
       print_file_line_d2 oc comment file line
@@ -227,68 +244,51 @@ module Diab_System : SYSTEM =
     let cfi_adjust oc delta = ()
 
     let cfi_rel_offset oc reg ofs = ()
+
+    let debug_section oc sec =
+      match sec with
+      | Section_debug_abbrev 
+      | Section_debug_info _
+      | Section_debug_loc -> ()
+      | sec ->
+          let name = match sec with
+          | Section_user (name,_,_) -> name
+          | _ -> name_of_section sec in
+          if not (Debug.exists_section name) then 
+            let line_start = new_label ()
+            and low_pc = new_label ()
+            and debug_info = new_label () in
+            Debug.add_diab_info name (line_start,debug_info,name_of_section sec);
+            Debug.add_compilation_section_start name low_pc;
+            let line_name = ".debug_line" ^(if name <> ".text" then name else "") in 
+            fprintf oc "	.section	%s,,n\n" line_name;
+            if name <> ".text" then
+              fprintf oc "	.sectionlink	.debug_line\n";
+            fprintf oc "%a:\n" label line_start;
+            section oc sec;
+            fprintf oc "%a:\n" label low_pc;
+            fprintf oc "	.0byte	%a\n" label debug_info;
+            fprintf oc "	.d2_line_start	%s\n" line_name
+          else
+            ()
         
     let print_prologue oc =
       fprintf oc "	.xopt	align-fill-text=0x60000000\n";
-      if !Clflags.option_g then
-        begin
-          fprintf oc "	.text\n";
-          fprintf oc "	.section	.debug_line,,n\n";
-          let label_line_start = new_label () in
-          stmt_list_addr := label_line_start;
-          fprintf oc "%a:\n" label label_line_start;
-          fprintf oc "	.text\n";
-          let label_start = new_label () in
-          start_addr := label_start;
-          fprintf oc "%a:\n" label label_start;
-          fprintf oc "	.d2_line_start	.debug_line\n";
-        end
-
-    let filenum : (string,int) Hashtbl.t = Hashtbl.create 7
-
-    let additional_debug_sections: StringSet.t ref = ref StringSet.empty
-
+      debug_section oc Section_text
 
     let print_epilogue oc =
-      if !Clflags.option_g then
-        begin
-          fprintf oc "\n";
-          let label_end = new_label () in
-          end_addr := label_end;
-          fprintf oc "%a:\n" label label_end;
-          fprintf oc "	.text\n";
-          StringSet.iter (fun file ->
-            let label = new_label () in
-            Hashtbl.add filenum file label;
-            fprintf oc ".L%d:	.d2filenum \"%s\"\n" label file) !all_files;
-          fprintf oc "	.d2_line_end\n";
-          StringSet.iter (fun s ->
-            fprintf oc "	%s\n" s;
-            fprintf oc "	.d2_line_end\n") !additional_debug_sections
-        end
-
-    let print_file_loc oc (file,col) =
-      fprintf oc "	.4byte		%a\n" label (Hashtbl.find filenum file);
-      fprintf oc "	.uleb128	%d\n" col
-
-    let debug_section oc sec =
-      if !Clflags.option_g && Configuration.advanced_debug then
-        match sec with
-        | Section_user (name,_,_)  ->
-            let sec_name = name_of_section sec in
-            if not (StringSet.mem sec_name !additional_debug_sections) then
-              begin
-                let name = ".debug_line"^name in
-                additional_debug_sections := StringSet.add sec_name !additional_debug_sections;
-                fprintf oc "	.section	%s,,n\n" name;
-                fprintf oc "	.sectionlink	.debug_line\n";
-                section oc sec;
-                fprintf oc "	.d2_line_start	%s\n" name
-              end
-        | _ -> () (* Only the case of a user section is interresting *)
-      else
-        ()
-            
+      let end_label sec = 
+        fprintf oc "\n";
+        fprintf oc "	%s\n" sec;
+        let label_end = new_label () in
+        fprintf oc "%a:\n" label label_end;
+        label_end 
+      and entry_label f =
+        let label = new_label () in
+        fprintf oc ".L%d:	.d2filenum \"%s\"\n" label f;
+        label
+      and end_line () =   fprintf oc "	.d2_line_end\n" in
+      Debug.compute_diab_file_enum end_label entry_label end_line
 
   end
 
@@ -865,21 +865,12 @@ module Target (System : SYSTEM):TARGET =
       end
 
     let default_falignment = 4
-        
-    let get_start_addr () = !start_addr
-
-    let get_end_addr () = !end_addr
-
-    let get_stmt_list_addr () = !stmt_list_addr
-
-    module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs
 
     let new_label = new_label            
 
     let section oc sec =
       section oc sec;
       debug_section oc sec
-
   end
 
 let sel_target () =
diff --git a/test/c/aes.c b/test/c/aes.c
index abdaf6c3..88b3de4a 100644
--- a/test/c/aes.c
+++ b/test/c/aes.c
@@ -1423,7 +1423,7 @@ static void do_test(int keybits, u8 * key,
 static void do_bench(int nblocks)
 {
   u32 ckey[4 * (MAXNR + 1)];
-  u8 temp[16];
+  u8 temp[16] = "Plaintext";
   int nr;
 
   nr = rijndaelKeySetupEnc(ckey, (u8 *)"\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F", 128);
diff --git a/test/regression/Makefile b/test/regression/Makefile
index 2f70c63a..6ef44b78 100644
--- a/test/regression/Makefile
+++ b/test/regression/Makefile
@@ -17,7 +17,8 @@ TESTS=int32 int64 floats floats-basics \
   volatile1 volatile2 volatile3 \
   funct3 expr5 struct7 struct8 struct11 struct12 casts1 casts2 char1 \
   sizeof1 sizeof2 binops bool for1 switch switch2 compound \
-  decl1 interop1 bitfields9 ptrs3
+  decl1 interop1 bitfields9 ptrs3 \
+  parsing
 
 # Can run, but only in compiled mode, and have reference output in Results
 
diff --git a/test/regression/Results/parsing b/test/regression/Results/parsing
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/test/regression/Results/parsing
diff --git a/test/regression/alias.c b/test/regression/alias.c
index a38e6dfd..9887ae2b 100644
--- a/test/regression/alias.c
+++ b/test/regression/alias.c
@@ -1,8 +1,8 @@
 /* Testing the alias analysis on ill-defined codes 
    where it should remain conservative. */
 
-typedef unsigned int uintptr_t;
-typedef signed int ptrdiff_t;
+#include <stddef.h>
+#include <stdint.h>
 
 /* For testing with GCC */
 #define NOINLINE __attribute__((noinline))
diff --git a/test/regression/builtins-arm.c b/test/regression/builtins-arm.c
index 91a8e890..643c8f1a 100644
--- a/test/regression/builtins-arm.c
+++ b/test/regression/builtins-arm.c
@@ -23,7 +23,10 @@ int main(int argc, char ** argv)
   y = 0;
   __builtin_write32_reversed(&y, 0x12345678);
   printf ("CSE write_32_rev: %s\n", y == 0x78563412 ? "ok" : "ERROR");
-
+  /* Make sure that ignoring the result of a builtin
+     doesn't cause an internal error */
+  (void) __builtin_bswap(x);
+  (void) __builtin_fsqrt(a);
   return 0;
 }
 
diff --git a/test/regression/builtins-ia32.c b/test/regression/builtins-ia32.c
index 10426209..558c3153 100644
--- a/test/regression/builtins-ia32.c
+++ b/test/regression/builtins-ia32.c
@@ -36,7 +36,10 @@ int main(int argc, char ** argv)
   y = 0;
   __builtin_write32_reversed(&y, 0x12345678);
   printf ("CSE write_32_rev: %s\n", y == 0x78563412 ? "ok" : "ERROR");
-
+  /* Make sure that ignoring the result of a builtin
+     doesn't cause an internal error */
+  (void) __builtin_bswap(x);
+  (void) __builtin_fsqrt(a);
   return 0;
 }
 
diff --git a/test/regression/builtins-powerpc.c b/test/regression/builtins-powerpc.c
index acffa435..90030737 100644
--- a/test/regression/builtins-powerpc.c
+++ b/test/regression/builtins-powerpc.c
@@ -50,7 +50,10 @@ int main(int argc, char ** argv)
   y = 0;
   __builtin_write32_reversed(&y, 0x12345678);
   printf ("CSE write_32_rev: %s\n", y == 0x78563412 ? "ok" : "ERROR");
-
+  /* Make sure that ignoring the result of a builtin
+     doesn't cause an internal error */
+  (void) __builtin_bswap(x);
+  (void) __builtin_fsqrt(a);
   return 0;
 }
 
diff --git a/test/regression/parsing.c b/test/regression/parsing.c
new file mode 100644
index 00000000..24b954c1
--- /dev/null
+++ b/test/regression/parsing.c
@@ -0,0 +1,104 @@
+#include<stdio.h>
+
+typedef signed int T;
+
+T f(T(T));
+T f(T a(T)) {
+  T b;
+  return 1;
+}
+int g(int x) {
+ T:;
+  T y;
+  T T;
+  T=1;
+
+  return 1;
+}
+
+void h() {
+  for(int T; ;)
+    if(1)
+      ;
+  T *x;
+  x = 0;
+}
+
+void h2() {
+  for(int T; ;)
+    if(1)
+      ;
+    else T;
+}
+
+struct S {
+  const T:3;
+  unsigned T:3;
+  const T:3;
+};
+
+void i() {
+  struct S s;
+  s.T = -1;
+  if(s.T < 0) printf("ERROR i\n");
+}
+
+/* These ones are parsed correctly, but rejected by the elaborator. */
+/* void j() { */
+/*   typedef int I; */
+/*   {sizeof(enum{I=2}); return I;} */
+/*   {do sizeof(enum{I=2}); while((I)1);} */
+/*   {if(1) return sizeof(enum{I=2}); */
+/*    else  return (I)1;} */
+/*   {if(sizeof(enum{I=2})) return I; */
+/*    else return I;} */
+/*   {sizeof(enum{I=2})+I;} */
+/*   {for(int i = sizeof(enum{I=2}); I; I) I; (I)1;} */
+/* } */
+/* int f2(enum{I=2} x) { */
+/*   return I; */
+/* } */
+/* void k(A, B) */
+/*      int B; */
+/*      int A[B]; */
+/* { } */
+/* int l(A) */
+/*      enum {T=1} A; */
+/* { return T * A; } */
+
+void m() {
+  if(0)
+    if(1);
+    else printf("ERROR m\n");
+  if(0)
+    for(int i; ; )
+      if(1);
+      else printf("ERROR m\n");
+  if(0)
+    for(1; ; )
+      if(1);
+      else printf("ERROR m\n");
+  if(0)
+    while(1)
+      if(1);
+      else printf("ERROR m\n");
+  if(0)
+  L: if(1);
+     else printf("ERROR m\n");
+
+  if(0)
+  LL:for(1;;)
+      for(int i;;)
+        while(1)
+          switch(1)
+          case 1:
+            if(1);
+            else printf("ERROR m\n");
+}
+
+int main () {
+  f(g);
+  i();
+  m();
+  return 0;
+}