Merge branch 'trunk' into pr379

359 files changed, 4445 insertions, 4011 deletions

diff --git a/.gitignore b/.gitignore
index 7434f6212..64c49b008 100644
--- a/.gitignore
+++ b/.gitignore
@@ -43,6 +43,7 @@ TAGS
 .DS_Store
 .pc
 bin/
+_build_ci
 _build
 myocamlbuild_config.ml
 config/Makefile
@@ -122,10 +123,10 @@ g_*.ml
 ide/project_file.ml
 parsing/compat.ml
 parsing/cLexer.ml
-ltac/coretactics.ml
-ltac/extratactics.ml
-ltac/extraargs.ml
-ltac/profile_ltac_tactics.ml
+plugins/ltac/coretactics.ml
+plugins/ltac/extratactics.ml
+plugins/ltac/extraargs.ml
+plugins/ltac/profile_ltac_tactics.ml
 ide/coqide_main.ml
 plugins/ssrmatching/ssrmatching.ml
 
diff --git a/.merlin b/.merlin
index 7410e601b..394db528d 100644
--- a/.merlin
+++ b/.merlin
@@ -1,4 +1,4 @@
-FLG -rectypes -thread
+FLG -rectypes -thread -safe-string
 
 S ltac
 B ltac
@@ -34,6 +34,8 @@ S stm
 B stm
 S toplevel
 B toplevel
+S vernac
+B vernac
 
 S tools
 B tools
diff --git a/.travis.yml b/.travis.yml
index 188e44600..81f50af0a 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -1,4 +1,7 @@
 dist: trusty
+# Travis builds are slower using sudo: false (the container-based
+# infrastructure) as of March 2017; see
+# https://github.com/coq/coq/pull/467 for some discussion.
 sudo: required
 # Until Ocaml becomes a language, we set a known one.
 language: c
@@ -27,23 +30,27 @@ env:
   - TEST_TARGET="ci-color"
   - TEST_TARGET="ci-compcert"
   - TEST_TARGET="ci-coquelicot"
-  - TEST_TARGET="ci-cpdt"
   - TEST_TARGET="ci-geocoq"
   - TEST_TARGET="ci-fiat-crypto"
+  - TEST_TARGET="ci-fiat-parsers"
   - TEST_TARGET="ci-flocq"
   - TEST_TARGET="ci-hott"
   - TEST_TARGET="ci-iris-coq"
   - TEST_TARGET="ci-math-classes"
   - TEST_TARGET="ci-math-comp"
   - TEST_TARGET="ci-sf"
+  - TEST_TARGET="ci-unimath"
+  - TEST_TARGET="ci-vst"
   # Not ready yet for 8.7
+  # - TEST_TARGET="ci-cpdt"
   # - TEST_TARGET="ci-metacoq"
   # - TEST_TARGET="ci-tlc"
 
 matrix:
 
   allow_failures:
-  - env: TEST_TARGET="ci-cpdt"
+  - env: TEST_TARGET="ci-geocoq"
+  - env: TEST_TARGET="ci-vst"
 
   # Full Coq test-suite with two compilers
   # [TODO: use yaml refs and avoid duplication for packages list]
diff --git a/CHANGES b/CHANGES
index 4a7cb8c45..0acc2bb95 100644
--- a/CHANGES
+++ b/CHANGES
@@ -7,6 +7,21 @@ Tactics
   functional extensionality in H supposed to be a quantified equality
   until giving a bare equality.
 
+Standard Library
+
+- New file PropExtensionality.v to explicitly work in the axiomatic
+  context of propositional extensionality.
+- New file SetoidChoice.v axiomatically providing choice over setoids,
+  and, consequently, choice of representatives in equivalence classes.
+  Various proof-theoretic characterizations of choice over setoids in
+  file ChoiceFacts.v.
+
+- IZR (Reals) has been changed to produce a compact representation of
+  integers. As a consequence, IZR is no longer convertible to INR and
+  lemmas such as INR_IZR_INZ should be used instead.
+- Real constants are now represented using IZR rather than R0 and R1;
+  this might cause rewriting rules to fail to apply to constants.
+
 Changes from V8.6beta1 to V8.6
 ==============================
 
diff --git a/META.coq b/META.coq
index 5be69d5fd..074c2e457 100644
--- a/META.coq
+++ b/META.coq
@@ -1,5 +1,15 @@
+# TODO: Move to META.in once coq_makefile2 is merged.
+# We need to reuse:
+# - The variable substitution mechanism.
+# - Sourcing of "coq_install_path" and "coq_version" variables.
+#
+# With this rules, we would have:
+#  version = ${coq_version}
+# and
+#  linkopts(byte)   = "-dllpath ${coq_install_path}/kernel/byterun/ -dllib -lcoqrun"
+
 description = "The Coq Proof Assistant Plugin API"
-version = "8.6"
+version = "8.7"
 
 directory = ""
 requires = "camlp5"
@@ -7,7 +17,7 @@ requires = "camlp5"
 package "config" (
 
   description = "Coq Configuration Variables"
-  version     = "8.6"
+  version     = "8.7"
 
   directory   = "config"
 
@@ -16,7 +26,7 @@ package "config" (
 package "lib" (
 
   description = "Base Coq Library"
-  version     = "8.6"
+  version     = "8.7"
 
   directory   = "lib"
 
@@ -33,22 +43,16 @@ package "lib" (
 package "vm" (
 
   description = "Coq VM"
+  version     = "8.7"
 
-  version     = "8.6"
-
-# EJGA FIXME: Unfortunately dllpath is dependent on the type of Coq
-# install. In a local one we'll want kernel/byterun, in a non-local
-# one we want to set it to coqlib. We should thus generate this file
-# at configure time, but let's hear for some more feedback from
-# experts.
+  directory        = "kernel/byterun"
 
-# Enable for local native & byte builds
-#  directory        = "kernel/byterun"
+# We should generate this file at configure time for local byte builds
+# to work properly.
 
-# Enable for local byte builds and set up properly
-#  linkopts(byte)   = "-dllpath /path/to/coq/kernel/byterun/ -dllib -lcoqrun"
+# Enable this setting for local byte builds, disabling the one below.
+#  linkopts(byte)   = "-dllpath path_to_coq/kernel/byterun/ -dllib -lcoqrun"
 
-# Disable for local byte builds
   linkopts(byte)   = "-dllib -lcoqrun"
   linkopts(native) = "-cclib -lcoqrun"
 
@@ -56,8 +60,8 @@ package "vm" (
 
 package "kernel" (
 
-  description = "The Coq's Kernel"
-  version     = "8.6"
+  description = "Coq's Kernel"
+  version     = "8.7"
 
   directory   = "kernel"
 
@@ -71,7 +75,7 @@ package "kernel" (
 package "library" (
 
   description = "Coq Libraries (vo) support"
-  version     = "8.6"
+  version     = "8.7"
 
   requires    = "coq.kernel"
 
@@ -85,7 +89,7 @@ package "library" (
 package "intf" (
 
   description = "Coq Public Data Types"
-  version     = "8.6"
+  version     = "8.7"
 
   requires    = "coq.library"
 
@@ -95,8 +99,8 @@ package "intf" (
 
 package "engine" (
 
-  description = "Coq Libraries (vo) support"
-  version     = "8.6"
+  description = "Coq Tactic Engine"
+  version     = "8.7"
 
   requires    = "coq.library"
   directory   = "engine"
@@ -109,7 +113,7 @@ package "engine" (
 package "pretyping" (
 
   description = "Coq Pretyper"
-  version     = "8.6"
+  version     = "8.7"
 
   requires    = "coq.engine"
   directory   = "pretyping"
@@ -122,7 +126,7 @@ package "pretyping" (
 package "interp" (
 
   description = "Coq Term Interpretation"
-  version     = "8.6"
+  version     = "8.7"
 
   requires    = "coq.pretyping"
   directory   = "interp"
@@ -135,7 +139,7 @@ package "interp" (
 package "grammar" (
 
   description = "Coq Base Grammar"
-  version     = "8.6"
+  version     = "8.7"
 
   requires    = "coq.interp"
   directory   = "grammar"
@@ -147,7 +151,7 @@ package "grammar" (
 package "proofs" (
 
   description = "Coq Proof Engine"
-  version     = "8.6"
+  version     = "8.7"
 
   requires    = "coq.interp"
   directory   = "proofs"
@@ -160,7 +164,7 @@ package "proofs" (
 package "parsing" (
 
   description = "Coq Parsing Engine"
-  version     = "8.6"
+  version     = "8.7"
 
   requires    = "coq.proofs"
   directory   = "parsing"
@@ -172,8 +176,8 @@ package "parsing" (
 
 package "printing" (
 
-  description = "Coq Printing Libraries"
-  version     = "8.6"
+  description = "Coq Printing Engine"
+  version     = "8.7"
 
   requires    = "coq.parsing"
   directory   = "printing"
@@ -185,8 +189,8 @@ package "printing" (
 
 package "tactics" (
 
-  description = "Coq Tactics"
-  version     = "8.6"
+  description = "Coq Basic Tactics"
+  version     = "8.7"
 
   requires    = "coq.printing"
   directory   = "tactics"
@@ -196,12 +200,25 @@ package "tactics" (
 
 )
 
+package "vernac" (
+
+  description = "Coq Vernacular Interpreter"
+  version     = "8.7"
+
+  requires    = "coq.tactics"
+  directory   = "vernac"
+
+  archive(byte)    = "vernac.cma"
+  archive(native)  = "vernac.cmxa"
+
+)
+
 package "stm" (
 
   description = "Coq State Transactional Machine"
-  version     = "8.6"
+  version     = "8.7"
 
-  requires    = "coq.tactics"
+  requires    = "coq.vernac"
   directory   = "stm"
 
   archive(byte)    = "stm.cma"
@@ -212,7 +229,7 @@ package "stm" (
 package "toplevel" (
 
   description = "Coq Toplevel"
-  version     = "8.6"
+  version     = "8.7"
 
   requires    = "coq.stm"
   directory   = "toplevel"
@@ -225,7 +242,7 @@ package "toplevel" (
 package "highparsing" (
 
   description = "Coq Extra Parsing"
-  version     = "8.6"
+  version     = "8.7"
 
   requires    = "coq.toplevel"
   directory   = "parsing"
@@ -235,15 +252,42 @@ package "highparsing" (
 
 )
 
+package "idetop" (
+
+  description = "Coq IDE Libraries"
+  version     = "8.7"
+
+  requires    = "coq.toplevel"
+  directory   = "ide"
+
+  archive(byte)    = "coqidetop.cma"
+  archive(native)  = "coqidetop.cmxa"
+
+)
+
+package "ide" (
+
+  description = "Coq IDE Libraries"
+  version     = "8.7"
+
+# XXX Add GTK
+  requires    = "coq.toplevel"
+  directory   = "ide"
+
+  archive(byte)    = "ide.cma"
+  archive(native)  = "ide.cmxa"
+
+)
+
 package "ltac" (
 
   description = "Coq LTAC Plugin"
-  version     = "8.6"
+  version     = "8.7"
 
   requires    = "coq.highparsing"
-  directory   = "ltac"
+  directory   = "plugins/ltac"
 
-  archive(byte)    = "ltac.cma"
-  archive(native)  = "ltac.cmxa"
+  archive(byte)    = "ltac_plugin.cmo"
+  archive(native)  = "ltac_plugin.cmx"
 
 )
diff --git a/Makefile.build b/Makefile.build
index 9d76638e1..01cc4d878 100644
--- a/Makefile.build
+++ b/Makefile.build
@@ -440,9 +440,9 @@ $(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkm
 # fake_ide : for debugging or test-suite purpose, a fake ide simulating
 # a connection to coqtop -ideslave
 
-FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo ide/document.cmo \
+FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo	ide/document.cmo \
  ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo ide/xml_printer.cmo \
- ide/xmlprotocol.cmo tools/fake_ide.cmo
+ ide/richpp.cmo ide/xmlprotocol.cmo tools/fake_ide.cmo
 
 $(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPLOOPCMA:.cma=$(BESTDYN))
 	$(SHOW)'OCAMLBEST -o $@'
diff --git a/Makefile.ci b/Makefile.ci
index 040144e6e..b055ada8e 100644
--- a/Makefile.ci
+++ b/Makefile.ci
@@ -1,6 +1,7 @@
-CI_TARGETS=ci-all ci-hott ci-math-comp ci-compcert ci-sf ci-cpdt	\
-           ci-color ci-math-classes ci-tlc ci-fiat-crypto		\
-           ci-coquelicot ci-flocq ci-iris-coq ci-metacoq ci-geocoq
+CI_TARGETS=ci-all ci-hott ci-math-comp ci-compcert ci-sf ci-cpdt \
+           ci-color ci-math-classes ci-tlc ci-fiat-crypto ci-fiat-parsers \
+           ci-coquelicot ci-flocq ci-iris-coq ci-metacoq ci-geocoq \
+           ci-unimath ci-vst
 
 .PHONY: $(CI_TARGETS)
 
diff --git a/Makefile.common b/Makefile.common
index 49fe1fd93..1e71bcf7d 100644
--- a/Makefile.common
+++ b/Makefile.common
@@ -53,16 +53,16 @@ INSTALLSH:=./install.sh
 MKDIR:=install -d
 
 CORESRCDIRS:=\
-  config 	lib		kernel		kernel/byterun	library \
-  proofs 	tactics 	pretyping	interp		stm \
-  toplevel	parsing 	printing	intf	engine	ltac
+  config 	lib		kernel	intf	kernel/byterun	library \
+  engine 	pretyping	interp	proofs	parsing 	printing \
+  tactics 	vernac		stm		toplevel
 
 PLUGINDIRS:=\
   omega		romega 		micromega 	quote \
   setoid_ring 	extraction 	fourier \
   cc 		funind 		firstorder 	derive \
   rtauto 	nsatz           syntax          decl_mode	btauto \
-  ssrmatching
+  ssrmatching	ltac
 
 SRCDIRS:=\
   $(CORESRCDIRS)  \
@@ -77,14 +77,13 @@ BYTERUN:=$(addprefix kernel/byterun/, \
   coq_fix_code.o coq_memory.o coq_values.o coq_interp.o )
 
 # LINK ORDER:
-# Beware that highparsing.cma should appear before ltac.cma
 # respecting this order is useful for developers that want to load or link
 # the libraries directly
 
 CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma library/library.cma \
         engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \
-        parsing/parsing.cma printing/printing.cma tactics/tactics.cma \
-	stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma ltac/ltac.cma
+        parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \
+	stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma
 
 TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma
 
@@ -120,9 +119,10 @@ OTHERSYNTAXCMO:=$(addprefix plugins/syntax/, \
         string_syntax_plugin.cmo )
 DECLMODECMO:=plugins/decl_mode/decl_mode_plugin.cmo
 DERIVECMO:=plugins/derive/derive_plugin.cmo
+LTACCMO:=plugins/ltac/ltac_plugin.cmo
 SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo
 
-PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \
+PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \
         $(QUOTECMO) $(RINGCMO) \
         $(FOURIERCMO) $(EXTRACTIONCMO) \
         $(CCCMO)  $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \
diff --git a/Makefile.dev b/Makefile.dev
index 8c1812da1..ea6b8b919 100644
--- a/Makefile.dev
+++ b/Makefile.dev
@@ -121,10 +121,9 @@ pretyping: pretyping/pretyping.cma
 highparsing: parsing/highparsing.cma
 stm: stm/stm.cma
 toplevel: toplevel/toplevel.cma
-ltac: ltac/ltac.cma
 
 .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping
-.PHONY: engine highparsing stm toplevel ltac
+.PHONY: engine highparsing stm toplevel
 
 ######################
 ### 3) theories files
@@ -183,6 +182,7 @@ RTAUTOVO:=$(filter plugins/rtauto/%, $(PLUGINSVO))
 EXTRACTIONVO:=$(filter plugins/extraction/%, $(PLUGINSVO))
 CCVO:=
 DERIVEVO:=$(filter plugins/derive/%, $(PLUGINSVO))
+LTACVO:=$(filter plugins/ltac/%, $(PLUGINSVO))
 
 omega: $(OMEGAVO) $(OMEGACMO) $(ROMEGAVO) $(ROMEGACMO)
 micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT)
@@ -194,9 +194,10 @@ funind: $(FUNINDCMO) $(FUNINDVO)
 cc: $(CCVO) $(CCCMO)
 rtauto: $(RTAUTOVO) $(RTAUTOCMO)
 btauto: $(BTAUTOVO) $(BTAUTOCMO)
+ltac: $(LTACVO) $(LTACCMO)
 
 .PHONY: omega micromega setoid_ring nsatz extraction
-.PHONY: fourier funind cc rtauto btauto
+.PHONY: fourier funind cc rtauto btauto ltac
 
 #################################
 ### Misc other development rules
diff --git a/Makefile.install b/Makefile.install
index 4800ea0b9..bde035551 100644
--- a/Makefile.install
+++ b/Makefile.install
@@ -104,11 +104,12 @@ install-library:
 	$(MKDIR) $(FULLCOQLIB)
 	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS)
 	$(MKDIR) $(FULLCOQLIB)/user-contrib
+	$(MKDIR) $(FULLCOQLIB)/kernel/byterun
 ifndef CUSTOM
-	$(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)
+	$(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)/kernel/byterun
 endif
 ifeq ($(BEST),opt)
-	$(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)
+	$(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)/kernel/byterun
 	$(INSTALLSH) $(FULLCOQLIB) $(PLUGINSOPT)
 endif
 # csdpcert is not meant to be directly called by the user; we install
diff --git a/checker/reduction.ml b/checker/reduction.ml
index ec16aa261..28c0126b4 100644
--- a/checker/reduction.ml
+++ b/checker/reduction.ml
@@ -176,9 +176,9 @@ let sort_cmp env univ pb s0 s1 =
         then begin
           if !Flags.debug then begin
             let op = match pb with CONV -> "=" | CUMUL -> "<=" in
-            Printf.eprintf "sort_cmp: %s\n%!" Pp.(string_of_ppcmds
-              (str"Error: " ++ Univ.pr_uni u1 ++ str op ++ Univ.pr_uni u2 ++ str ":" ++ cut()
-               ++ Univ.pr_universes univ))
+            Format.eprintf "sort_cmp: @[%a@]\n%!" Pp.pp_with Pp.(
+               str"Error: " ++ Univ.pr_uni u1 ++ str op ++ Univ.pr_uni u2 ++ str ":" ++ cut()
+               ++ Univ.pr_universes univ)
           end;
           raise NotConvertible
         end
diff --git a/configure.ml b/configure.ml
index 48e167c99..dfc6724a2 100644
--- a/configure.ml
+++ b/configure.ml
@@ -261,9 +261,13 @@ module Prefs = struct
   let withdoc = ref false
   let geoproof = ref false
   let byteonly = ref false
-  let debug = ref false
+  let debug = ref true
   let profile = ref false
   let annotate = ref false
+  (* Note, disabling this should be OK, but be careful with the
+     sharing invariants.
+  *)
+  let safe_string = ref true
   let nativecompiler = ref (not (os_type_win32 || os_type_cygwin))
   let coqwebsite = ref "http://coq.inria.fr/"
   let force_caml_version = ref false
@@ -336,7 +340,9 @@ let args_options = Arg.align [
   "-byteonly", Arg.Set Prefs.byteonly,
     " Compiles only bytecode version of Coq";
   "-debug", Arg.Set Prefs.debug,
-    " Add debugging information in the Coq executables";
+    " Deprecated";
+  "-nodebug", Arg.Clear Prefs.debug,
+    " Do not add debugging information in the Coq executables";
   "-profile", Arg.Set Prefs.profile,
     " Add profiling information in the Coq executables";
   "-annotate", Arg.Set Prefs.annotate,
@@ -384,6 +390,9 @@ let coq_annotate_flag =
   then if program_in_path "ocamlmerlin" then "-bin-annot" else "-annot"
   else ""
 
+let coq_safe_string =
+  if !Prefs.safe_string then "-safe-string" else ""
+
 let cflags = "-Wall -Wno-unused -g -O2"
 
 (** * Architecture *)
@@ -924,7 +933,7 @@ let config_runtime () =
   | _ ->
     let ld="CAML_LD_LIBRARY_PATH" in
     build_loadpath := sprintf "export %s:='%s/kernel/byterun':$(%s)" ld coqtop ld;
-    ["-dllib";"-lcoqrun";"-dllpath";libdir]
+    ["-dllib";"-lcoqrun";"-dllpath";libdir/"kernel/byterun"]
 
 let vmbyteflags = config_runtime ()
 
@@ -1116,7 +1125,7 @@ let write_makefile f =
   pr "CAMLHLIB=%S\n\n" camllib;
   pr "# Caml link command and Caml make top command\n";
   pr "# Caml flags\n";
-  pr "CAMLFLAGS=-rectypes %s\n" coq_annotate_flag;
+  pr "CAMLFLAGS=-rectypes %s %s\n" coq_annotate_flag coq_safe_string;
   pr "# User compilation flag\n";
   pr "USERFLAGS=\n\n";
   pr "# Flags for GCC\n";
diff --git a/dev/Makefile.oug b/dev/Makefile.oug
deleted file mode 100644
index ee69ea80d..000000000
--- a/dev/Makefile.oug
+++ /dev/null
@@ -1,74 +0,0 @@
-#######################################################################
-#  v      #   The Coq Proof Assistant  /  The Coq Development Team    #
-# <O___,, #        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              #
-#   \VV/  #############################################################
-#    //   #      This file is distributed under the terms of the      #
-#         #       GNU Lesser General Public License Version 2.1       #
-#######################################################################
-
-
-#### Source Code Analysis via Oug ####
-#### Cf http://home.gna.org/oug ####
-
-
-# To be used from top dir : make -f dev/Makefile.oug ...
-
-include Makefile.build
-
-# Oug location: in the path by default, native version
-
-OUG:=oug.x
-
-# NB: coq should have been compiled with the same ocaml version as oug
-
-# NOTA: it seems we obtain more useless elements reported when _not_
-# providing the .mli files, and also when giving a precise start point.
-# TO BE INVESTIGATED
-
-ml_of_cma = $(patsubst %.cmo,%.ml,$(filter %.cmo,$(shell cat $(1:.cma=.mllib.d))))
-local_ml_of_cma = $(filter $(dir $(1))%,$(call ml_of_cma,$(1)))
-mli_of_ml = $(foreach ml,$(1),$(wildcard $(ml)i))
-
-# Analysis of coqtop, without plugins
-
-COREML:=config/coq_config.ml $(call ml_of_cma, $(CORECMA))
-COREMLI:=$(call mli_of_ml,$(COREML))
-
-core.oug:
-	$(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(COREML)
-
-core.useless: core.oug
-	$(OUG) --load-data $< --no-reduce --print-loc --roots "<Coqtop.start>" --useless-elements $@
-
-core_intf.oug:
-	$(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(COREML) $(COREMLI)
-
-core_intf.useless: core_intf.oug
-	$(OUG) --load-data $< --no-reduce --print-loc --roots "<Coqtop.start>" --useless-elements $@
-
-# Analysis of coqchk, considering only files in the checker/ subdir
-
-CHECKERML:=$(call local_ml_of_cma,checker/check.cma)
-CHECKERMLI:=$(call mli_of_ml,$(CHECKERML))
-
-## BUG: in oug, include dirs have reversed priority compared with ocaml, cannot use CHKLIBS
-MYCHKINCL:=$(MLINCLUDES) -I checker
-
-checker.oug:
-	$(OUG) --dump-data $@ -rectypes $(MYCHKINCL) $(CHECKERML) #$(CHECKERMLI)
-
-checker.useless: checker.oug
-	$(OUG) --load-data $< --no-reduce --print-loc --roots "<Checker.start>" --useless-elements $@
-
-# Analysis of extraction
-
-EXTRACTIONML:=$(call local_ml_of_cma,$(EXTRACTIONCMA))
-EXTRACTIONMLI:=$(call mli_of_ml,$(EXTRACTIONMLI))
-
-extraction.oug:
-	$(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(EXTRACTIONML) #$(EXTRACTIONMLI)
-
-extraction.useless: extraction.oug
-	$(OUG) --load-data $< --no-reduce --print-loc --useless-elements $@
-
-# More to come ...
\ No newline at end of file
diff --git a/dev/base_include b/dev/base_include
index 0abcefc38..242405ae2 100644
--- a/dev/base_include
+++ b/dev/base_include
@@ -17,7 +17,7 @@
 #directory "grammar";;
 #directory "intf";;
 #directory "stm";;
-#directory "ltac";;
+#directory "vernac";;
 
 #directory "+camlp4";; (* lazy solution: add both of camlp4/5 so that *)
 #directory "+camlp5";; (* Gramext is found in top_printers.ml *)
@@ -195,7 +195,7 @@ let qid = Libnames.qualid_of_string;;
 (* parsing of terms *)
 
 let parse_constr = Pcoq.parse_string Pcoq.Constr.constr;;
-let parse_tac    = Pcoq.parse_string Pltac.tactic;;
+let parse_tac    = Pcoq.parse_string Ltac_plugin.Pltac.tactic;;
 let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac;;
 
 (* build a term of type glob_constr without type-checking or resolution of 
diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh
new file mode 100644
index 000000000..336ce9d8f
--- /dev/null
+++ b/dev/ci/ci-basic-overlay.sh
@@ -0,0 +1,112 @@
+#!/usr/bin/env bash
+
+# This is the basic overlay set for repositories in the CI.
+
+# Maybe we should just use Ruby to have real objects...
+
+########################################################################
+# MathComp
+########################################################################
+: ${mathcomp_CI_BRANCH:=master}
+: ${mathcomp_CI_GITURL:=https://github.com/math-comp/math-comp.git}
+
+########################################################################
+# UniMath
+########################################################################
+: ${UniMath_CI_BRANCH:=master}
+: ${UniMath_CI_GITURL:=https://github.com/UniMath/UniMath.git}
+
+########################################################################
+# Unicoq + Metacoq
+########################################################################
+: ${unicoq_CI_BRANCH:=master}
+: ${unicoq_CI_GITURL:=https://github.com/unicoq/unicoq.git}
+
+: ${metacoq_CI_BRANCH:=master}
+: ${metacoq_CI_GITURL:=https://github.com/MetaCoq/MetaCoq.git}
+
+########################################################################
+# Mathclasses + Corn
+########################################################################
+: ${math_classes_CI_BRANCH:=v8.6}
+: ${math_classes_CI_GITURL:=https://github.com/math-classes/math-classes.git}
+
+: ${Corn_CI_BRANCH:=v8.6}
+: ${Corn_CI_GITURL:=https://github.com/c-corn/corn.git}
+
+########################################################################
+# Iris
+########################################################################
+: ${stdpp_CI_BRANCH:=master}
+: ${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git}
+
+: ${Iris_CI_BRANCH:=master}
+: ${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/FP/iris-coq.git}
+
+########################################################################
+# HoTT
+########################################################################
+# Temporal overlay
+: ${HoTT_CI_BRANCH:=mz-8.7}
+: ${HoTT_CI_GITURL:=https://github.com/ejgallego/HoTT.git}
+# : ${HoTT_CI_BRANCH:=master}
+# : ${HoTT_CI_GITURL:=https://github.com/HoTT/HoTT.git}
+
+########################################################################
+# GeoCoq
+########################################################################
+: ${GeoCoq_CI_BRANCH:=master}
+: ${GeoCoq_CI_GITURL:=https://github.com/GeoCoq/GeoCoq.git}
+
+########################################################################
+# Flocq
+########################################################################
+: ${Flocq_CI_BRANCH:=master}
+: ${Flocq_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git}
+
+########################################################################
+# Coquelicot
+########################################################################
+: ${Coquelicot_CI_BRANCH:=master}
+: ${Coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git}
+
+########################################################################
+# CompCert
+########################################################################
+: ${CompCert_CI_BRANCH:=master}
+: ${CompCert_CI_GITURL:=https://github.com/AbsInt/CompCert.git}
+
+########################################################################
+# VST
+########################################################################
+: ${VST_CI_BRANCH:=master}
+: ${VST_CI_GITURL:=https://github.com/PrincetonUniversity/VST.git}
+
+########################################################################
+# fiat_parsers
+########################################################################
+: ${fiat_parsers_CI_BRANCH:=master}
+: ${fiat_parsers_CI_GITURL:=https://github.com/mit-plv/fiat.git}
+
+########################################################################
+# fiat_crypto
+########################################################################
+: ${fiat_crypto_CI_BRANCH:=master}
+: ${fiat_crypto_CI_GITURL:=https://github.com/mit-plv/fiat-crypto.git}
+
+########################################################################
+# CoLoR
+########################################################################
+: ${Color_CI_SVNURL:=https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color}
+
+########################################################################
+# SF
+########################################################################
+: ${sf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/current/sf.tgz}
+
+########################################################################
+# TLC
+########################################################################
+: ${tlc_CI_BRANCH:=master}
+: ${tlc_CI_GITURL:=https://gforge.inria.fr/git/tlc/tlc.git}
+
diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh
index 78ae7f02f..3f0716511 100755
--- a/dev/ci/ci-color.sh
+++ b/dev/ci/ci-color.sh
@@ -1,8 +1,10 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-svn checkout https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color color
+Color_CI_DIR=${CI_BUILD_DIR}/color
 
-( cd color && make -j ${NJOBS} )
+svn checkout ${Color_CI_SVNURL} ${Color_CI_DIR}
+
+( cd ${Color_CI_DIR} && make -j ${NJOBS} )
diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh
index 2a6601e04..2711b7eca 100644
--- a/dev/ci/ci-common.sh
+++ b/dev/ci/ci-common.sh
@@ -1,6 +1,66 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
 set -xe
 
+# Coq's tools need an ending slash :S, we should fix them.
+export COQBIN=`pwd`/bin/
 export PATH=`pwd`/bin:$PATH
+
 ls `pwd`/bin
+
+# Where we clone and build external developments
+CI_BUILD_DIR=`pwd`/_build_ci
+
+source ${ci_dir}/ci-user-overlay.sh
+source ${ci_dir}/ci-basic-overlay.sh
+
+mathcomp_CI_DIR=${CI_BUILD_DIR}/math-comp
+
+# git_checkout branch url dest will create a git repository
+# in <dest> (if it does not exist already) and checkout the
+# remote branch <branch> from <url>
+git_checkout()
+{
+  local _BRANCH=${1}
+  local _URL=${2}
+  local _DEST=${3}
+
+  # Allow an optional 4th argument for the commit
+  local _COMMIT=${4:-FETCH_HEAD}
+  local _DEPTH=$(if [ -z "${4}" ]; then echo "--depth 1"; fi)
+
+  mkdir -p ${_DEST}
+  ( cd ${_DEST}                                                && \
+    if [ ! -d .git ] ; then git clone ${_DEPTH} ${_URL} . ; fi && \
+    echo "Checking out ${_DEST}"                               && \
+    git fetch ${_URL} ${_BRANCH}                               && \
+    git checkout ${_COMMIT}                                    && \
+    echo "${_DEST}: `git log -1 --format='%s | %H | %cd | %aN'`" )
+}
+
+checkout_mathcomp()
+{
+  git_checkout ${mathcomp_CI_BRANCH} ${mathcomp_CI_GITURL} ${1}
+}
+
+# this installs just the ssreflect library of math-comp
+install_ssreflect()
+{
+  echo 'Installing ssreflect' && echo -en 'travis_fold:start:ssr.install\\r'
+
+  checkout_mathcomp ${mathcomp_CI_DIR}
+  ( cd ${mathcomp_CI_DIR}/mathcomp   && \
+    sed -i.bak '/ssrtest/d'     Make && \
+    sed -i.bak '/odd_order/d'   Make && \
+    sed -i.bak '/all\/all.v/d'  Make && \
+    sed -i.bak '/character/d'   Make && \
+    sed -i.bak '/real_closed/d' Make && \
+    sed -i.bak '/solvable/d'    Make && \
+    sed -i.bak '/field/d'       Make && \
+    sed -i.bak '/fingroup/d'    Make && \
+    sed -i.bak '/algebra/d'     Make && \
+    make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all && make install )
+
+  echo -en 'travis_fold:end:ssr.install\\r'
+
+}
diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh
index d4023c916..c78ffdc2c 100755
--- a/dev/ci/ci-compcert.sh
+++ b/dev/ci/ci-compcert.sh
@@ -1,10 +1,12 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
+CompCert_CI_DIR=${CI_BUILD_DIR}/CompCert
+
 opam install -j ${NJOBS} -y menhir
-git clone --depth 3 -b coq-8.6 https://github.com/maximedenes/CompCert.git
+git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} ${CompCert_CI_DIR}
 
 # Patch to avoid the upper version limit
-( cd CompCert && sed -i.bak 's/8.6)/8.6|trunk)/' configure && ./configure x86_32-linux && make -j ${NJOBS} )
+( cd ${CompCert_CI_DIR} && sed -i.bak 's/8.6)/8.6|trunk)/' configure && ./configure x86_32-linux && make -j ${NJOBS} )
diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh
index 4a23e51be..40eff03b7 100755
--- a/dev/ci/ci-coquelicot.sh
+++ b/dev/ci/ci-coquelicot.sh
@@ -1,29 +1,12 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
-# $0 is not the safest way, but...
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-git clone --depth 3 https://github.com/math-comp/math-comp.git
+Coquelicot_CI_DIR=${CI_BUILD_DIR}/coquelicot
 
-# coquelicot just needs mathcomp
-( cd math-comp/mathcomp && \
-  sed -i.bak '/ssrtest/d'   Make && \
-  sed -i.bak '/odd_order/d'   Make && \
-  sed -i.bak '/all\/all.v/d'  Make && \
-  sed -i.bak '/character/d'   Make && \
-  sed -i.bak '/real_closed/d' Make && \
-  sed -i.bak '/solvable/d'    Make && \
-  sed -i.bak '/field/d'       Make && \
-  sed -i.bak '/fingroup/d'    Make && \
-  sed -i.bak '/algebra/d'     Make && \
-  make -j ${NJOBS} && make install )
+install_ssreflect
 
-# Setup ssr
-# echo "Add ML Path \"`pwd`/math-comp/mathcomp/\"." > ${HOME}/.coqrc
-# echo "Add LoadPath \"`pwd`/math-comp/mathcomp/\" as mathcomp." >> ${HOME}/.coqrc
+git_checkout ${Coquelicot_CI_BRANCH} ${Coquelicot_CI_GITURL} ${Coquelicot_CI_DIR}
 
-# Setup coquelicot
-git clone --depth 3 https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git
-
-( cd coquelicot && ./autogen.sh && ./configure && ./remake -j${NJOBS} )
+( cd ${Coquelicot_CI_DIR} && ./autogen.sh && ./configure && ./remake -j${NJOBS} )
diff --git a/dev/ci/ci-cpdt.sh b/dev/ci/ci-cpdt.sh
index 18d756180..0e791ebbf 100755
--- a/dev/ci/ci-cpdt.sh
+++ b/dev/ci/ci-cpdt.sh
@@ -1,4 +1,4 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh
index c594f8360..93d39aab0 100755
--- a/dev/ci/ci-fiat-crypto.sh
+++ b/dev/ci/ci-fiat-crypto.sh
@@ -1,12 +1,10 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
-# $0 is not the safest way, but...
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-git clone --depth 3 https://github.com/mit-plv/fiat-crypto.git
+fiat_crypto_CI_DIR=${CI_BUILD_DIR}/fiat-crypto
 
-( cd fiat-crypto && make -j ${NJOBS} )
-
-# ( cd corn && make -j ${NJOBS} )
+git_checkout ${fiat_crypto_CI_BRANCH} ${fiat_crypto_CI_GITURL} ${fiat_crypto_CI_DIR}
 
+( cd ${fiat_crypto_CI_DIR} && make -j ${NJOBS} )
diff --git a/dev/ci/ci-fiat-parsers.sh b/dev/ci/ci-fiat-parsers.sh
new file mode 100755
index 000000000..c62aa1d85
--- /dev/null
+++ b/dev/ci/ci-fiat-parsers.sh
@@ -0,0 +1,10 @@
+#!/usr/bin/env bash
+
+ci_dir="$(dirname "$0")"
+source ${ci_dir}/ci-common.sh
+
+fiat_parsers_CI_DIR=${CI_BUILD_DIR}/fiat
+
+git_checkout ${fiat_parsers_CI_BRANCH} ${fiat_parsers_CI_GITURL} ${fiat_parsers_CI_DIR}
+
+( cd ${fiat_parsers_CI_DIR} && make -j ${NJOBS} parsers )
diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh
index b9cf649a1..ec19bd993 100755
--- a/dev/ci/ci-flocq.sh
+++ b/dev/ci/ci-flocq.sh
@@ -1,9 +1,10 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
-# $0 is not the safest way, but...
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-git clone --depth 3 https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git
+Flocq_CI_DIR=${CI_BUILD_DIR}/flocq
 
-( cd flocq && ./autogen.sh && ./configure && ./remake -j${NJOBS} )
+git_checkout ${Flocq_CI_BRANCH} ${Flocq_CI_GITURL} ${Flocq_CI_DIR}
+
+( cd ${Flocq_CI_DIR} && ./autogen.sh && ./configure && ./remake -j${NJOBS} )
diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh
index 589a826e0..4e5aa2687 100755
--- a/dev/ci/ci-geocoq.sh
+++ b/dev/ci/ci-geocoq.sh
@@ -1,16 +1,16 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-# XXX: replace by generic template
-GeoCoq_CI_BRANCH=master
-GeoCoq_CI_GITURL=https://github.com/GeoCoq/GeoCoq.git
+GeoCoq_CI_DIR=${CI_BUILD_DIR}/GeoCoq
 
-git clone --depth 1 -b ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL}
+git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} ${GeoCoq_CI_DIR}
 
-( cd GeoCoq                                               && \
+( cd ${GeoCoq_CI_DIR}                                     && \
   ./configure.sh                                          && \
   sed -i.bak '/Ch16_coordinates_with_functions\.v/d' Make && \
+  sed -i.bak '/Elements\/Book_1\.v/d'                Make && \
+  sed -i.bak '/Elements\/Book_3\.v/d'                Make && \
   coq_makefile -f Make -o Makefile                        && \
   make -j ${NJOBS} )
diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh
index 8f82ba9f2..1bf6e9a87 100755
--- a/dev/ci/ci-hott.sh
+++ b/dev/ci/ci-hott.sh
@@ -1,8 +1,10 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-git clone --depth 3 -b mz-8.6 https://github.com/ejgallego/HoTT.git
+HoTT_CI_DIR=${CI_BUILD_DIR}/HoTT
 
-( cd HoTT && ./autogen.sh && ./configure && make -j ${NJOBS} )
+git_checkout ${HoTT_CI_BRANCH} ${HoTT_CI_GITURL} ${HoTT_CI_DIR}
+
+( cd ${HoTT_CI_DIR} && ./autogen.sh && ./configure && make -j ${NJOBS} )
diff --git a/dev/ci/ci-iris-coq.sh b/dev/ci/ci-iris-coq.sh
index e97e2c19e..262dd6fa0 100755
--- a/dev/ci/ci-iris-coq.sh
+++ b/dev/ci/ci-iris-coq.sh
@@ -1,35 +1,26 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
-# $0 is not the safest way, but...
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-# XXX: Refactor into install-ssreflect
-git clone --depth 1 https://github.com/math-comp/math-comp.git
-
-# coquelicot just needs mathcomp
-( cd math-comp/mathcomp && \
-  sed -i.bak '/ssrtest/d'     Make && \
-  sed -i.bak '/odd_order/d'   Make && \
-  sed -i.bak '/all\/all.v/d'  Make && \
-  sed -i.bak '/character/d'   Make && \
-  sed -i.bak '/real_closed/d' Make && \
-  sed -i.bak '/solvable/d'    Make && \
-  sed -i.bak '/field/d'       Make && \
-  sed -i.bak '/fingroup/d'    Make && \
-  sed -i.bak '/algebra/d'     Make && \
-  make -j ${NJOBS} && make install )
-
-# Setup ssr = This doesn't work as coq_makefile will pass -q to coqc :S :S
-# echo "Add ML Path \"`pwd`/math-comp/mathcomp/\"." > ${HOME}/.coqrc
-# echo "Add LoadPath \"`pwd`/math-comp/mathcomp/\" as mathcomp." >> ${HOME}/.coqrc
+stdpp_CI_DIR=${CI_BUILD_DIR}/coq-stdpp
+
+Iris_CI_DIR=${CI_BUILD_DIR}/iris-coq
+
+install_ssreflect
+
+# Setup Iris first, as it is needed to compute the dependencies
+
+git_checkout ${Iris_CI_BRANCH} ${Iris_CI_GITURL} ${Iris_CI_DIR}
+read -a IRIS_DEP < ${Iris_CI_DIR}/opam.pins
 
 # Setup stdpp
-git clone --depth 1 https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git
+stdpp_CI_GITURL=${IRIS_DEP[1]}.git
+stdpp_CI_COMMIT=${IRIS_DEP[2]}
 
-( cd coq-stdpp && make -j ${NJOBS} && make install )
+git_checkout ${stdpp_CI_BRANCH} ${stdpp_CI_GITURL} ${stdpp_CI_DIR} ${stdpp_CI_COMMIT}
 
-# Setup Iris
-git clone --depth 1 https://gitlab.mpi-sws.org/FP/iris-coq.git
+( cd ${stdpp_CI_DIR} && make -j ${NJOBS} && make install )
 
-( cd iris-coq && make -j ${NJOBS} )
+# Build iris now
+( cd ${Iris_CI_DIR} && make -j ${NJOBS} )
diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh
index 9127c1895..beb75773b 100755
--- a/dev/ci/ci-math-classes.sh
+++ b/dev/ci/ci-math-classes.sh
@@ -1,12 +1,20 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
-# $0 is not the safest way, but...
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-git clone --depth 1 -b v8.6 https://github.com/math-classes/math-classes.git
-( cd math-classes && make -j ${NJOBS} && make install )
+math_classes_CI_DIR=${CI_BUILD_DIR}/math-classes
 
-git clone --depth 1 -b v8.6 https://github.com/c-corn/corn.git
-( cd corn         && make -j ${NJOBS} )
+Corn_CI_DIR=${CI_BUILD_DIR}/corn
 
+# Setup Math-Classes
+
+git_checkout ${math_classes_CI_BRANCH} ${math_classes_CI_GITURL} ${math_classes_CI_DIR}
+
+( cd ${math_classes_CI_DIR} && make -j ${NJOBS} && make install )
+
+# Setup Corn
+
+git_checkout ${Corn_CI_BRANCH} ${Corn_CI_GITURL} ${Corn_CI_DIR}
+
+( cd ${Corn_CI_DIR} && make -j ${NJOBS} )
diff --git a/dev/ci/ci-math-comp.sh b/dev/ci/ci-math-comp.sh
index b83379241..bb8188da4 100755
--- a/dev/ci/ci-math-comp.sh
+++ b/dev/ci/ci-math-comp.sh
@@ -1,13 +1,15 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
 # $0 is not the safest way, but...
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-git clone --depth 3 https://github.com/math-comp/math-comp.git
+mathcomp_CI_DIR=${CI_BUILD_DIR}/math-comp
+
+checkout_mathcomp ${mathcomp_CI_DIR}
 
 # odd_order takes too much time for travis.
-( cd math-comp/mathcomp                              && \
-     sed -i.bak '/PFsection/d'                  Make && \
-     sed -i.bak '/stripped_odd_order_theorem/d' Make && \
-     make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all )
+( cd ${mathcomp_CI_DIR}/mathcomp                  && \
+  sed -i.bak '/PFsection/d'                  Make && \
+  sed -i.bak '/stripped_odd_order_theorem/d' Make && \
+  make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all )
diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh
index 9a9bd3648..e31691179 100755
--- a/dev/ci/ci-metacoq.sh
+++ b/dev/ci/ci-metacoq.sh
@@ -1,16 +1,19 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
-# $0 is not the safest way, but...
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-# MetaCoq + UniCoq
+unicoq_CI_DIR=${CI_BUILD_DIR}/unicoq
+metacoq_CI_DIR=${CI_BUILD_DIR}/MetaCoq
 
-git clone --depth 1 https://github.com/unicoq/unicoq.git
+# Setup UniCoq
 
-( cd unicoq && coq_makefile -f Make -o Makefile && make -j ${NJOBS} && make install )
+git_checkout ${unicoq_CI_BRANCH} ${unicoq_CI_GITURL} ${unicoq_CI_DIR}
 
-git clone --depth 1 https://github.com/MetaCoq/MetaCoq.git
+( cd ${unicoq_CI_DIR} && coq_makefile -f Make -o Makefile && make -j ${NJOBS} && make install )
 
-( cd MetaCoq && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} )
+# Setup MetaCoq
 
+git_checkout ${metacoq_CI_BRANCH} ${metacoq_CI_GITURL} ${metacoq_CI_DIR}
+
+( cd ${metacoq_CI_DIR} && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} )
diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh
index 5e41211f1..7d23ccad9 100755
--- a/dev/ci/ci-sf.sh
+++ b/dev/ci/ci-sf.sh
@@ -1,9 +1,10 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-wget https://www.cis.upenn.edu/~bcpierce/sf/current/sf.tgz
+# XXX: Needs fixing to properly set the build directory.
+wget ${sf_CI_TARURL}
 tar xvfz sf.tgz
 
 ( cd sf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make -j ${NJOBS} )
diff --git a/dev/ci/ci-template.sh b/dev/ci/ci-template.sh
new file mode 100755
index 000000000..700105aed
--- /dev/null
+++ b/dev/ci/ci-template.sh
@@ -0,0 +1,12 @@
+#!/usr/bin/env bash
+
+ci_dir="$(dirname "$0")"
+source ${ci_dir}/ci-common.sh
+
+Template_CI_BRANCH=master
+Template_CI_GITURL=https://github.com/Template/Template
+Template_CI_DIR=${CI_BUILD_DIR}/Template
+
+git_checkout ${Template_CI_BRANCH} ${Template_CI_GITURL} ${Template_CI_DIR}
+
+( cd ${Template_CI_DIR} && make -j ${NJOBS} )
diff --git a/dev/ci/ci-tlc.sh b/dev/ci/ci-tlc.sh
index 2161a1146..ce2639937 100755
--- a/dev/ci/ci-tlc.sh
+++ b/dev/ci/ci-tlc.sh
@@ -1,8 +1,10 @@
-#!/bin/bash
+#!/usr/bin/env bash
 
 ci_dir="$(dirname "$0")"
 source ${ci_dir}/ci-common.sh
 
-git clone https://gforge.inria.fr/git/tlc/tlc.git
+tlc_CI_DIR=${CI_BUILD_DIR}/tlc
 
-( cd tlc && make -j ${NJOBS} )
+git_checkout ${tlc_CI_BRANCH} ${tlc_CI_GITURL} ${tlc_CI_DIR}
+
+( cd ${tlc_CI_DIR} && make -j ${NJOBS} )
diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh
new file mode 100755
index 000000000..175b82b5f
--- /dev/null
+++ b/dev/ci/ci-unimath.sh
@@ -0,0 +1,14 @@
+#!/usr/bin/env bash
+
+ci_dir="$(dirname "$0")"
+source ${ci_dir}/ci-common.sh
+
+UniMath_CI_DIR=${CI_BUILD_DIR}/UniMath
+
+git_checkout ${UniMath_CI_BRANCH} ${UniMath_CI_GITURL} ${UniMath_CI_DIR}
+
+( cd ${UniMath_CI_DIR}                        && \
+  sed -i.bak '/Folds/d'              Makefile && \
+  sed -i.bak '/HomologicalAlgebra/d' Makefile && \
+  make -j ${NJOBS} BUILD_COQ=no )
+
diff --git a/dev/ci/ci-user-overlay.sh b/dev/ci/ci-user-overlay.sh
new file mode 100644
index 000000000..028574743
--- /dev/null
+++ b/dev/ci/ci-user-overlay.sh
@@ -0,0 +1,22 @@
+#!/usr/bin/env bash
+
+# Add user overlays here. You can use some logic to detect if you are
+# in your travis branch and conditionally enable the overlay.
+
+# Some useful Travis variables:
+# (https://docs.travis-ci.com/user/environment-variables/#Default-Environment-Variables)
+#
+# - TRAVIS_BRANCH: For builds not triggered by a pull request this is
+#   the name of the branch currently being built; whereas for builds
+#   triggered by a pull request this is the name of the branch
+#   targeted by the pull request (in many cases this will be master).
+#
+# - TRAVIS_COMMIT: The commit that the current build is testing.
+#
+# - TRAVIS_PULL_REQUEST: The pull request number if the current job is
+#   a pull request, “false” if it’s not a pull request.
+#
+# - TRAVIS_PULL_REQUEST_BRANCH: If the current job is a pull request,
+#   the name of the branch from which the PR originated. "" if the
+#   current job is a push build.
+
diff --git a/dev/ci/ci-vst.sh b/dev/ci/ci-vst.sh
new file mode 100755
index 000000000..c11195185
--- /dev/null
+++ b/dev/ci/ci-vst.sh
@@ -0,0 +1,13 @@
+#!/usr/bin/env bash
+
+ci_dir="$(dirname "$0")"
+source ${ci_dir}/ci-common.sh
+
+VST_CI_DIR=${CI_BUILD_DIR}/VST
+
+# opam install -j ${NJOBS} -y menhir
+git_checkout ${VST_CI_BRANCH} ${VST_CI_GITURL} ${VST_CI_DIR}
+
+# Targets are: msl veric floyd
+# Patch to avoid the upper version limit
+( cd ${VST_CI_DIR} && sed -i.bak 's/8.6$/8.6 or-else trunk/' Makefile && make -j ${NJOBS} )
diff --git a/dev/core.dbg b/dev/core.dbg
index 38b9b2946..f04e5c07b 100644
--- a/dev/core.dbg
+++ b/dev/core.dbg
@@ -12,7 +12,8 @@ load_printer proofs.cma
 load_printer parsing.cma
 load_printer printing.cma
 load_printer tactics.cma
+load_printer vernac.cma
 load_printer stm.cma
 load_printer toplevel.cma
 load_printer highparsing.cma
-load_printer ltac.cma
+load_printer ltac_plugin.cmo
diff --git a/dev/doc/api.txt b/dev/doc/api.txt
new file mode 100644
index 000000000..5827257b5
--- /dev/null
+++ b/dev/doc/api.txt
@@ -0,0 +1,10 @@
+Recommendations in using the API:
+
+The type of terms: constr (see kernel/constr.ml and kernel/term.ml)
+
+- On type constr, the canonical equality on CIC (up to
+  alpha-conversion and cast removal) is Constr.equal
+- The type constr is abstract, use mkRel, mkSort, etc. to build
+  elements in constr; use "kind_of_term" to analyze the head of a
+  constr; use destRel, destSort, etc. when the head constructor is
+  known
diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt
index f54f3fcc8..03742fb8a 100644
--- a/dev/doc/changes.txt
+++ b/dev/doc/changes.txt
@@ -2,6 +2,12 @@
 = CHANGES BETWEEN COQ V8.6 AND COQ V8.7 =
 =========================================
 
+* Ocaml *
+
+Coq is compiled with -safe-string enabled and requires plugins to do
+the same. This means that code using `String` in an imperative way
+will fail to compile now. They should switch to `Bytes.t`
+
 * ML API *
 
 We renamed the following functions:
@@ -39,6 +45,26 @@ important things:
   instead
 - Some printing functions were moved from Pptactic to Pputils
 - A part of Tacexpr has been moved to Tactypes
+- The TacFun tactic expression constructor now takes a `Name.t list` for the 
+  variable list rather than an `Id.t option list`.
+
+The folder itself has been turned into a plugin. This does not change much,
+but because it is a packed plugin, it may wreak havoc for third-party plugins
+depending on any module defined in the ltac/ directory. Namely, even if
+everything looks OK at compile time, a plugin can fail to load at link time
+because it mistakenly looks for a module Foo instead of Ltac_plugin.Foo, with
+an error of the form:
+
+Error: while loading myplugin.cmxs, no implementation available for Foo.
+
+In particular, most EXTEND macros will trigger this problem even if they
+seemingly do not use any Ltac module, as their expansion do.
+
+The solution is simple, and consists in adding a statement "open Ltac_plugin"
+in each file using a Ltac module, before such a module is actually called. An
+alternative solution would be to fully qualify Ltac modules, e.g. turning any
+call to Tacinterp into Ltac_plugin.Tacinterp. Note that this solution does not
+work for EXTEND macros though.
 
 ** Error handling **
 
@@ -50,6 +76,58 @@ important things:
 
 - The header parameter to `user_err` has been made optional.
 
+** Pretty printing **
+
+Some functions have been removed, see pretty printing below for more
+details.
+
+* Pretty Printing and XML protocol *
+
+The type std_cmdpps has been reworked and made the canonical "Coq rich
+document type". This allows for a more uniform handling of printing
+(specially in IDEs). The main consequences are:
+
+ - Richpp has been confined to IDE use. Most of previous uses of the
+   `richpp` type should be replaced now by `Pp.std_cmdpps`. Main API
+   has been updated.
+
+ - The XML protocol will send a new message type of `pp`, which should
+   be rendered client-wise.
+
+ - `Set Printing Width` is deprecated, now width is controlled
+   client-side.
+
+ - `Pp_control` has removed. The new module `Topfmt` implements
+   console control for the toplevel.
+
+ - The impure tag system in Pp has been removed. This also does away
+   with the printer signatures and functors. Now printers tag
+   unconditionally.
+
+ - The following functions have been removed from `Pp`:
+
+   val stras : int * string -> std_ppcmds
+   val tbrk  : int * int -> std_ppcmds
+   val tab   : unit -> std_ppcmds
+   val pifb  : unit -> std_ppcmds
+   val comment  : int -> std_ppcmds
+   val comments : ((int * int) * string) list ref
+   val eval_ppcmds : std_ppcmds -> std_ppcmds
+   val is_empty : std_ppcmds -> bool
+   val t : std_ppcmds -> std_ppcmds
+   val hb : int -> std_ppcmds
+   val vb : int -> std_ppcmds
+   val hvb : int -> std_ppcmds
+   val hovb : int -> std_ppcmds
+   val tb : unit -> std_ppcmds
+   val close : unit -> std_ppcmds
+   val tclose : unit -> std_ppcmds
+   val open_tag : Tag.t -> std_ppcmds
+   val close_tag : unit -> std_ppcmds
+   val msg_with  : ...
+
+   module Tag
+
 =========================================
 = CHANGES BETWEEN COQ V8.5 AND COQ V8.6 =
 =========================================
diff --git a/dev/doc/style.txt b/dev/doc/style.txt
index 27695a09b..2ee3dadd7 100644
--- a/dev/doc/style.txt
+++ b/dev/doc/style.txt
@@ -1,75 +1,142 @@
-
-<< L'uniformité du style est plus importante que le style lui-même. >>
-(Kernigan & Pike, The Practice of Programming)
-
-Mode Emacs
-==========
-   Tuareg, que l'on trouve ici :  http://www.prism.uvsq.fr/~acohen/tuareg/
-
-   avec le réglage suivant :     (setq tuareg-in-indent 2)
-
-Types récursifs et filtrages
-============================
-   Une barre de séparation y compris sur le premier constructeur
-
-type t =
-  | A 
-  | B of machin
-
-match expr with
-  | A -> ...
-  | B x -> ...
-
-Remarque : à partir de la 8.2 environ, la tendance est à utiliser le
-format suivant qui permet de limiter l'escalade d'indentation tout en
-produisant un aspect visuel intéressant de bloc :
-
-type t =
-| A 
-| B of machin
-
-match expr with
-| A -> ...
-| B x -> ...
-
-let f expr = match expr with
-| A -> ...
-| B x -> ...
-
-let f expr = function
-| A -> ...
-| B x -> ...
-
-Le deuxième cas est obtenu sous tuareg avec les réglages
-
-  (setq tuareg-with-indent 0)
-  (setq tuareg-function-indent 0)
-  (setq tuareg-let-always-indent nil) /// notons que cette dernière est bien 
-                                      /// pour les let mais pas pour les let-in
-
-Conditionnelles
-===============
-  if condition then
-    premier-cas
-  else
-    deuxieme-cas
-
-  Si effets de bord dans les branches, utilisez begin ... end et non des
-  parenthèses i.e.
-
-  if condition then begin
-    instr1;
-    instr2
-  end else begin
-    instr3;
-    instr4
-  end
-    
-  Si la première branche lève une exception, évitez le else i.e.
-
-    if condition then                     if condition then error "machin";
-      error "machin"          ----->      suite
+<< Style uniformity is more important than style itself >>
+   (Kernigan & Pike, The Practice of Programming)
+
+OCaml Style:
+- Spacing and indentation
+  - indent your code (using tuareg default)
+  - no strong constraints in formatting "let in"; possible styles are:
+    "let x = ... in"
+    "let x =
+       ... in"
+    "let
+       x = ...
+     in"
+  - but: no extra indentation before a "in" coming on next line,
+    otherwise, it first shifts further and further on the right,
+    reducing the amount of space available; second, it is not robust to
+    insertion of a new "let"
+  - it is established usage to have space around "|" as in
+    "match c with
+     | [] | [a] -> ...
+     | a::b::l -> ..."
+  - in a one-line "match", it is preferred to have no "|" in front of
+    the first case (this saves spaces for the match to hold in the line)
+  - from about 8.2, the tendency is to use the following format which
+    limit excessive indentation while providing an interesting "block" aspect
+    type t =
+    | A 
+    | B of machin
+
+    let f expr = match expr with
+    | A -> ...
+    | B x -> ...
+
+    let f expr = function
+    | A -> ...
+    | B x -> ...
+  - add spaces around = and == (make the code "breaths")
+  - the common usage is to write "let x,y = ... in ..." rather than
+    "let (x,y) = ... in ..."
+  - parenthesizing with either "(" and ")" or with "begin" and "end" is
+    common practice
+  - preferred layout for conditionals:
+    if condition then
+      premier-cas
     else
-      suite
-
-  
+      deuxieme-cas
+  - in case of effects in branches, use "begin ... end" rather than
+    parentheses
+    if condition then begin
+      instr1;
+      instr2
+    end else begin
+      instr3;
+      instr4
+    end
+  - if the first branch raises an exception, avoid the "else", i.e.:
+    if condition then                     if condition then error "foo";
+      error "foo"          ----->         bar
+    else
+      bar
+  - it is the usage not to use ;; to end OCaml sentences (however,
+    inserting ";;" can be useful for debugging syntax errors crossing
+    the boundary of functions)
+  - relevant options in tuareg:
+    (setq tuareg-in-indent 2)
+    (setq tuareg-with-indent 0)
+    (setq tuareg-function-indent 0)
+    (setq tuareg-let-always-indent nil)
+
+- Coding methodology
+  - no "try ... with _ -> ..." which catches even Sys.Break (Ctrl-C),
+    Out_of_memory, Stack_overflow, etc.
+    at least, use "try with e when Errors.noncritical e -> ..."
+    (to be detailed, Pierre L. ?)
+  - do not abuse of fancy combinators: sometimes what a "let rec" loop
+    does is more readable and simpler to grasp than what a "fold" does
+  - do not break abstractions: if an internal property is hidden
+    behind an interface, do no rely on it in code which uses this
+    interface (e.g. do not use List.map thinking it is left-to-right,
+    use map_left)
+  - in particular, do not use "=" on abstract types: there is no
+    reason a priori that it is the intended equality on this type; use the
+    "equal" function normally provided with the abstract type
+  - avoid polymorphically typed "=" whose implementation is not
+    optimized in OCaml and which has moreover no reason to be the
+    intended implementation of the equality when it comes to be
+    instantiated on a particular type (e.g. use List.mem_f,
+    List.assoc_f, rather than List.mem, List.assoc, etc, unless it is
+    absolutely clear that "=" will implement the intended equality, and
+    with the right complexity)
+  - any new general-purpose enough combinator on list should be put in
+    cList.ml, on type option in cOpt.ml, etc.
+  - unless of a good reason not to so, follow the style of the
+    surrounding code in the same file as much as possible,
+    the general guidelines are otherwise "let spacing breaths" (we
+    have large screen nowadays), "make your code easy to read and
+    to understand"
+  - document what is tricky, but do not overdocument, sometimes the
+    choice of names and the structuration of the code is a better
+    documentation than a long discourse; use of unicode in comments is
+    welcome if it can make comments more readable (then
+    "toggle-enable-multibyte-characters" can help when using the
+    debugger in emacs)
+  - all of initial "open File", or of small-scope File.(...), or
+    per-ident File.foo are common practices
+
+- Choice of variable names
+  - be consistent when naming from one function to another
+  - be consistent with the naming adopted in the functions from the
+    same file, or with the naming used elsewhere by similar functions
+  - use variable names which express meaning
+  - keep "cst" for constants and avoid it for constructors which is
+    otherwise a source of confusion
+  - for constructors, use "cstr" in type constructor (resp. "cstru" in
+    constructor puniverse); avoid "constr" for "constructor" which
+    could be think as the name of an arbitrary Constr.t
+  - for inductive types, use "ind" in the type inductive (resp "indu"
+    in inductive puniverse)
+  - for env, use "env"
+  - for evar_map, use "sigma", with tolerance into "evm" and "evd"
+  - for named_context or rel_context, use "ctxt" or "ctx" (or "sign")
+  - for formal/actual indices of inductive types: "realdecls", "realargs"
+  - for formal/actual parameters of inductive types: "paramdecls", "paramargs"
+  - for terms, use e.g. c, b, a, ...
+  - if a term is known to be a function: f, ...
+  - if a term is known to be a type: t, u, typ, ...
+  - for a declaration, use d or "decl"
+  - for errors, exceptions, use e
+
+- Common OCaml pitfalls
+  - in "match ... with Case1 -> try ... with ... -> ... | Case2 -> ...", or in
+    "match ... with Case1 -> match ... with SubCase -> ... | Case2 -> ...", or in
+    parentheses are needed around the "try" and the inner "match"
+  - even if stream are lazy, the Pp.(++) combinator is strict and
+    forces the evaluation of its arguments (use a "lazy" or a "fun () ->")
+    to make it lazy explicitly
+  - in "if ... then ... else ... ++ ...", the default parenthesizing
+    is somehow counter-intuitive; use "(if ... then ... else ...) ++ ..."
+  - in "let myspecialfun = mygenericfun args", be sure that it does no
+    do side-effect; prefer otherwise "let mygenericfun arg =
+    mygenericfun args arg" to ensure that the function is evaluated at
+    runtime
diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run
index 46caca8d6..3850c05fd 100644
--- a/dev/ocamldebug-coq.run
+++ b/dev/ocamldebug-coq.run
@@ -20,7 +20,7 @@ exec $OCAMLDEBUG \
 	-I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar \
 	-I $COQTOP/lib -I $COQTOP/intf -I $COQTOP/kernel -I $COQTOP/kernel/byterun \
 	-I $COQTOP/library -I $COQTOP/engine \
-	-I $COQTOP/pretyping -I $COQTOP/parsing \
+	-I $COQTOP/pretyping -I $COQTOP/parsing -I $COQTOP/vernac \
         -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \
 	-I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \
         -I $COQTOP/plugins/cc         -I $COQTOP/plugins/dp \
@@ -32,6 +32,6 @@ exec $OCAMLDEBUG \
         -I $COQTOP/plugins/ring       -I $COQTOP/plugins/romega \
 	-I $COQTOP/plugins/rtauto     -I $COQTOP/plugins/setoid_ring \
         -I $COQTOP/plugins/subtac     -I $COQTOP/plugins/syntax \
-        -I $COQTOP/plugins/xml \
+        -I $COQTOP/plugins/xml        -I $COQTOP/plugins/ltac \
         -I $COQTOP/ide \
 	"$@"
diff --git a/dev/top_printers.ml b/dev/top_printers.ml
index ac73b54bd..474cc85c1 100644
--- a/dev/top_printers.ml
+++ b/dev/top_printers.ml
@@ -29,7 +29,7 @@ let _ = set_bool_option_value ["Printing";"Matching"] false
 let _ = Detyping.set_detype_anonymous (fun _ _ -> raise Not_found)
 
 (* std_ppcmds *)
-let pp   x = Pp.pp_with !Pp_control.std_ft x
+let pp   x = Pp.pp_with !Topfmt.std_ft x
 
 (** Future printer *)
 
@@ -235,7 +235,7 @@ let ppenvwithcst e = pp
    str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]" ++ spc() ++
    str "{" ++ Cmap_env.fold (fun a _ s -> pr_con a ++ spc () ++ s) (Obj.magic e).Pre_env.env_globals.Pre_env.env_constants (mt ()) ++ str "}")
 
-let pptac = (fun x -> pp(Pptactic.pr_glob_tactic (Global.env()) x))
+let pptac = (fun x -> pp(Ltac_plugin.Pptactic.pr_glob_tactic (Global.env()) x))
 
 let ppobj obj = Format.print_string (Libobject.object_tag obj)
 
diff --git a/doc/refman/Polynom.tex b/doc/refman/Polynom.tex
index 0664bf909..77d592834 100644
--- a/doc/refman/Polynom.tex
+++ b/doc/refman/Polynom.tex
@@ -342,16 +342,16 @@ describes their syntax and effects:
   By default the tactic does not recognize power expressions as ring
   expressions.
 \item[sign {\term}] allows {\tt ring\_simplify} to use a minus operation
-  when outputing its normal form, i.e writing $x - y$ instead of $x + (-y)$. 
+  when outputting its normal form, i.e writing $x - y$ instead of $x + (-y)$.
   The term {\term} is a proof that a given sign function indicates expressions
    that are signed ({\term} has to be a
-  proof of {\tt Ring\_theory.get\_sign}). See  {\tt plugins/setoid\_ring/IntialRing.v} for examples of sign function.
-\item[div {\term}] allows  {\tt ring} and {\tt ring\_simplify} to use moniomals
+  proof of {\tt Ring\_theory.get\_sign}). See  {\tt plugins/setoid\_ring/InitialRing.v} for examples of sign function.
+\item[div {\term}] allows  {\tt ring} and {\tt ring\_simplify} to use monomials
 with coefficient other than 1 in the rewriting. The term {\term} is a proof that a given division function  satisfies the specification of an euclidean
   division function  ({\term} has to be a
   proof of {\tt Ring\_theory.div\_theory}). For example, this function is
   called when trying to rewrite $7x$ by $2x = z$ to tell that $7 = 3 * 2 + 1$.
-   See  {\tt plugins/setoid\_ring/IntialRing.v} for examples of div function.
+   See  {\tt plugins/setoid\_ring/InitialRing.v} for examples of div function.
   
 \end{description}
 
diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex
index bef0a1686..45230fb6e 100644
--- a/doc/refman/RefMan-com.tex
+++ b/doc/refman/RefMan-com.tex
@@ -123,12 +123,6 @@ The following command-line options are recognized by the commands {\tt
   valid for {\tt coqc} as the toplevel module name is inferred from the
   name of the output file.
 
-\item[{\tt -notop}]\ %
-
-  Use the empty logical path for the toplevel module name instead of {\tt
-    Top}. Not valid for {\tt coqc} as the toplevel module name is
-  inferred from the name of the output file.
-
 \item[{\tt -exclude-dir} {\em directory}]\ %
 
   Exclude any subdirectory named {\em directory} while
diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex
index b475a5233..1d423f8b1 100644
--- a/doc/refman/RefMan-ext.tex
+++ b/doc/refman/RefMan-ext.tex
@@ -991,7 +991,7 @@ but library file names based on other roots can be obtained by using
 {\Coq} commands ({\tt coqc}, {\tt coqtop}, {\tt coqdep}, \dots) options
 {\tt -Q} or {\tt -R} (see Section~\ref{coqoptions}). Also, when an
 interactive {\Coq} session starts, a library of root {\tt Top} is
-started, unless option {\tt -top} or {\tt -notop} is set (see
+started, unless option {\tt -top} is set (see
 Section~\ref{coqoptions}).
 
 \subsection{Qualified names
diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex
index c37367de5..16c822b6a 100644
--- a/doc/refman/RefMan-pro.tex
+++ b/doc/refman/RefMan-pro.tex
@@ -477,15 +477,15 @@ names.
 \item{\tt Show Intro.}\comindex{Show Intro}\\
 If the current goal begins by at least one product, this command
 prints the name of the first product, as it would be generated by 
-an anonymous {\tt Intro}. The aim of this command is to ease the
+an anonymous {\tt intro}. The aim of this command is to ease the
 writing of more robust scripts. For example, with an appropriate 
 {\ProofGeneral} macro, it is possible to transform any anonymous {\tt
-  Intro} into a qualified one such as {\tt Intro y13}.
+  intro} into a qualified one such as {\tt intro y13}.
 In the case of a non-product goal, it prints nothing. 
 
 \item{\tt Show Intros.}\comindex{Show Intros}\\
 This command is similar to the previous one, it simulates the naming 
-process of an {\tt Intros}.
+process of an {\tt intros}.
 
 \item{\tt Show Existentials.\label{ShowExistentials}}\comindex{Show Existentials}
 \\ It displays
diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex
index 21c39de96..ecaf82806 100644
--- a/doc/refman/RefMan-syn.tex
+++ b/doc/refman/RefMan-syn.tex
@@ -59,6 +59,12 @@ and pretty-printer of {\Coq} already know how to deal with the
 syntactic expression (see \ref{ReservedNotation}), explicit precedences and
 associativity rules have to be given.
 
+\Rem The right-hand side of a notation is interpreted at the time the
+notation is given. In particular, implicit arguments (see
+Section~\ref{Implicit Arguments}), coercions (see
+Section~\ref{Coercions}), etc. are resolved at the time of the
+declaration of the notation.
+
 \subsection[Precedences and associativity]{Precedences and associativity\index{Precedences}
 \index{Associativity}}
 
@@ -114,7 +120,7 @@ Notation "A \/ B" := (or A B)  (at level 85, right associativity).
 
 By default, a notation is considered non associative, but the
 precedence level is mandatory (except for special cases whose level is
-canonical). The level is either a number or the mention {\tt next
+canonical). The level is either a number or the phrase {\tt next
 level} whose meaning is obvious. The list of levels already assigned
 is on Figure~\ref{init-notations}.
 
@@ -297,7 +303,7 @@ the possible following elements delimited by single quotes:
   of each newline
 \end{itemize}
 
-Thus, for the previous example, we get
+%Thus, for the previous example, we get
 %\footnote{The ``@'' is here to shunt
 %the notation "'IF' A 'then' B 'else' C" which is defined in {\Coq}
 %initial state}:
@@ -908,6 +914,28 @@ interpretation. See the next section.
 \SeeAlso The command to show the scopes bound to the arguments of a
 function is described in Section~\ref{About}.
 
+\Rem In notations, the subterms matching the identifiers of the
+notations are interpreted in the scope in which the identifiers
+occurred at the time of the declaration of the notation. Here is an
+example:
+
+\begin{coq_example}
+Parameter g : bool -> bool.
+Notation "@@" := true (only parsing) : bool_scope.
+Notation "@@" := false (only parsing): mybool_scope.
+
+(* Defining a notation while the argument of g is bound to bool_scope *)
+Bind Scope bool_scope with bool.
+Notation "# x #" := (g x) (at level 40).
+Check # @@ #.
+(* Rebinding the argument of g to mybool_scope has no effect on the notation *)
+Arguments g _%mybool_scope.
+Check # @@ #.
+(* But we can force the scope *)
+Delimit Scope mybool_scope with mybool.
+Check # @@%mybool #.
+\end{coq_example}
+
 \subsection[The {\tt type\_scope} interpretation scope]{The {\tt type\_scope} interpretation scope\index{type\_scope@\texttt{type\_scope}}}
 
 The scope {\tt type\_scope} has a special status. It is a primitive
diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template
index 9216c81fc..aeb0de48a 100644
--- a/doc/stdlib/index-list.html.template
+++ b/doc/stdlib/index-list.html.template
@@ -46,6 +46,7 @@ through the <tt>Require Import</tt> command.</p>
     theories/Logic/ClassicalDescription.v
     theories/Logic/ClassicalEpsilon.v
     theories/Logic/ClassicalUniqueChoice.v
+    theories/Logic/SetoidChoice.v
     theories/Logic/Berardi.v
     theories/Logic/Diaconescu.v
     theories/Logic/Hurkens.v
@@ -55,7 +56,10 @@ through the <tt>Require Import</tt> command.</p>
     theories/Logic/Description.v
     theories/Logic/Epsilon.v
     theories/Logic/IndefiniteDescription.v
+    theories/Logic/PropExtensionality.v
+    theories/Logic/PropExtensionalityFacts.v
     theories/Logic/FunctionalExtensionality.v
+    theories/Logic/ExtensionalFunctionRepresentative.v
     theories/Logic/ExtensionalityFacts.v
     theories/Logic/WeakFan.v
     theories/Logic/WKL.v
diff --git a/engine/universes.ml b/engine/universes.ml
index 51a113219..ad5ff827b 100644
--- a/engine/universes.ml
+++ b/engine/universes.ml
@@ -416,10 +416,9 @@ let constr_of_global gr =
 	(* Should be an error as we might forget constraints, allow for now
 	   to make firstorder work with "using" clauses *)
 	c
-      else raise (Invalid_argument 
-		    ("constr_of_global: globalization of polymorphic reference " ^ 
-			Pp.string_of_ppcmds (Nametab.pr_global_env Id.Set.empty gr) ^
-			" would forget universes."))
+      else CErrors.user_err ~hdr:"constr_of_global"
+          Pp.(str "globalization of polymorphic reference " ++ Nametab.pr_global_env Id.Set.empty gr ++
+	      str " would forget universes.")
     else c
 
 let constr_of_reference = constr_of_global
diff --git a/grammar/q_util.mli b/grammar/q_util.mli
index a5e36e47b..37ec1d56a 100644
--- a/grammar/q_util.mli
+++ b/grammar/q_util.mli
@@ -41,6 +41,8 @@ val mlexpr_of_string : string -> MLast.expr
 
 val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr
 
+val mlexpr_of_name : ('a -> MLast.expr) -> 'a option -> MLast.expr
+
 val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.expr
 
 val type_of_user_symbol : user_symbol -> argument_type
diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp
index 919ca3ad7..0dd096ef7 100644
--- a/grammar/q_util.mlp
+++ b/grammar/q_util.mlp
@@ -58,6 +58,10 @@ let mlexpr_of_option f = function
   | None -> <:expr< None >>
   | Some e -> <:expr< Some $f e$ >>
 
+let mlexpr_of_name f = function
+  | None -> <:expr< Anonymous >>
+  | Some e -> <:expr< Name $f e$ >>
+
 let symbol_of_string s = <:expr< Extend.Atoken (CLexer.terminal $str:s$) >>
 
 let rec mlexpr_of_prod_entry_key f = function
diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp
index fe864ed40..8c0614a7b 100644
--- a/grammar/tacextend.mlp
+++ b/grammar/tacextend.mlp
@@ -82,14 +82,14 @@ let make_var = function
   | ExtNonTerminal (_, p) -> Some p
   | _ -> assert false
 
-let declare_tactic loc s c cl = match cl with
+let declare_tactic loc tacname ~level classification clause = match clause with
 | [(ExtTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem ->
   (** The extension is only made of a name followed by constr entries: we do not
       add any grammar nor printing rule and add it as a true Ltac definition. *)
   let patt = make_patt rem in
   let vars = List.map make_var rem in
-  let vars = mlexpr_of_list (mlexpr_of_option mlexpr_of_ident) vars in
-  let entry = mlexpr_of_string s in
+  let vars = mlexpr_of_list (mlexpr_of_name mlexpr_of_ident) vars in
+  let entry = mlexpr_of_string tacname in
   let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in
   let ml = <:expr< { Tacexpr.mltac_name = $se$; Tacexpr.mltac_index = 0 } >> in
   let name = mlexpr_of_string name in
@@ -117,13 +117,14 @@ let declare_tactic loc s c cl = match cl with
 | _ ->
   (** Otherwise we add parsing and printing rules to generate a call to a
       TacML tactic. *)
-  let entry = mlexpr_of_string s in
+  let entry = mlexpr_of_string tacname in
   let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in
-  let gl = mlexpr_of_clause cl in
-  let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $gl$ >> in
+  let gl = mlexpr_of_clause clause in
+  let level = mlexpr_of_int level in
+  let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $level$ $gl$ >> in
   declare_str_items loc
     [ <:str_item< do {
-        Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc s cl$);
+        Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc tacname clause$);
         Mltop.declare_cache_obj $obj$ $plugin_name$; } >>
     ]
 
@@ -134,20 +135,17 @@ EXTEND
   GLOBAL: str_item;
   str_item:
     [ [ "TACTIC"; "EXTEND"; s = tac_name;
+        level = OPT [ "AT"; UIDENT "LEVEL"; level = INT -> level ];
         c = OPT [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >> ];
         OPT "|"; l = LIST1 tacrule SEP "|";
         "END" ->
-         declare_tactic loc s c l ] ]
+        let level = match level with Some i -> int_of_string i | None -> 0 in
+         declare_tactic loc s ~level c l ] ]
   ;
   tacrule:
     [ [ "["; l = LIST1 tacargs; "]";
         c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> c ];
-        "->"; "["; e = Pcaml.expr; "]" ->
-	(match l with
-	  | ExtNonTerminal _ :: _ ->
-	    (* En attendant la syntaxe de tacticielles *)
-	    failwith "Tactic syntax must start with an identifier"
-	  | _ -> (l,c,e))
+        "->"; "["; e = Pcaml.expr; "]" -> (l,c,e)
     ] ]
   ;
   tacargs:
diff --git a/ide/coq.ml b/ide/coq.ml
index 6d44ca59e..3a1d87787 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -205,7 +205,7 @@ type handle = {
   proc : CoqTop.process;
   xml_oc : Xml_printer.t;
   mutable alive : bool;
-  mutable waiting_for : (ccb * logger) option; (* last call + callback + log *)
+  mutable waiting_for : ccb option; (* last call + callback *)
 }
 
 (** Coqtop process status :
@@ -290,18 +290,6 @@ let rec check_errors = function
 | `NVAL :: _ -> raise (TubeError "NVAL")
 | `OUT :: _ -> raise (TubeError "OUT")
 
-let handle_intermediate_message handle level content =
-  let logger  = match handle.waiting_for with
-    | Some (_, l) -> l
-    | None -> function
-        | Feedback.Error   -> fun s -> Minilib.log ~level:`ERROR   (xml_to_string s)
-        | Feedback.Info    -> fun s -> Minilib.log ~level:`INFO    (xml_to_string s)
-        | Feedback.Notice  -> fun s -> Minilib.log ~level:`NOTICE  (xml_to_string s)
-        | Feedback.Warning -> fun s -> Minilib.log ~level:`WARNING (xml_to_string s)
-        | Feedback.Debug   -> fun s -> Minilib.log ~level:`DEBUG   (xml_to_string s)
-  in
-  logger level content
-
 let handle_feedback feedback_processor xml =
   let feedback = Xmlprotocol.to_feedback xml in
   feedback_processor feedback
@@ -310,7 +298,7 @@ let handle_final_answer handle xml =
   let () = Minilib.log "Handling coqtop answer" in
   let ccb = match handle.waiting_for with
     | None -> raise (AnswerWithoutRequest (Xml_printer.to_string_fmt xml))
-    | Some (c, _) -> c in
+    | Some c -> c in
   let () = handle.waiting_for <- None in
   with_ccb ccb { bind_ccb = fun (c, f) -> f (Xmlprotocol.to_answer c xml) }
 
@@ -332,18 +320,13 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all =
     let l_end = Lexing.lexeme_end lex in
     state.fragment <- String.sub s l_end (String.length s - l_end);
     state.lexerror <- None;
-    match Xmlprotocol.is_message xml with
-    | Some (lvl, _loc, msg) ->
-      handle_intermediate_message handle lvl msg;
+    if Xmlprotocol.is_feedback xml then begin
+      handle_feedback feedback_processor xml;
       loop ()
-    | None ->
-      if Xmlprotocol.is_feedback xml then begin
-        handle_feedback feedback_processor xml;
-        loop ()
-      end else
-        begin
-          ignore (handle_final_answer handle xml)
-        end
+    end else
+      begin
+        ignore (handle_final_answer handle xml)
+      end
   in
   try loop ()
   with Xml_parser.Error _ as e ->
@@ -383,7 +366,7 @@ let bind_self_as f =
 (** This launches a fresh handle from its command line arguments. *)
 let spawn_handle args respawner feedback_processor =
   let prog = coqtop_path () in
-  let args = Array.of_list ("-async-proofs" :: "on" :: "-ideslave" :: args) in
+  let args = Array.of_list ("--xml_format=Ppcmds" :: "-async-proofs" :: "on" :: "-ideslave" :: args) in
   let env =
     match !Flags.ideslave_coqtop_flags with
     | None -> None
@@ -493,20 +476,20 @@ let init_coqtop coqtop task =
 
 type 'a query = 'a Interface.value task
 
-let eval_call ?(logger=default_logger) call handle k =
+let eval_call call handle k =
   (** Send messages to coqtop and prepare the decoding of the answer *)
   Minilib.log ("Start eval_call " ^ Xmlprotocol.pr_call call);
   assert (handle.alive && handle.waiting_for = None);
-  handle.waiting_for <- Some (mk_ccb (call,k), logger);
+  handle.waiting_for <- Some (mk_ccb (call,k));
   Xml_printer.print handle.xml_oc (Xmlprotocol.of_call call);
   Minilib.log "End eval_call";
   Void
 
-let add ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.add x)
+let add x = eval_call (Xmlprotocol.add x)
 let edit_at i = eval_call (Xmlprotocol.edit_at i)
-let query ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.query x)
+let query x = eval_call (Xmlprotocol.query x)
 let mkcases s = eval_call (Xmlprotocol.mkcases s)
-let status ?logger force = eval_call ?logger (Xmlprotocol.status force)
+let status force = eval_call (Xmlprotocol.status force)
 let hints x = eval_call (Xmlprotocol.hints x)
 let search flags = eval_call (Xmlprotocol.search flags)
 let init x = eval_call (Xmlprotocol.init x)
@@ -566,18 +549,11 @@ struct
 
   let _ = reset ()
 
-  (** Integer option *)
-
-  let width = ["Printing"; "Width"]
-  let width_state = ref None
-  let set_printing_width w = width_state := Some w
-
   (** Transmitting options to coqtop *)
 
   let enforce h k =
     let mkopt o v acc = (o, Interface.BoolValue v) :: acc in
     let opts = Hashtbl.fold mkopt current_state [] in
-    let opts = (width, Interface.IntValue !width_state) :: opts in
     eval_call (Xmlprotocol.set_options opts) h
       (function
 	| Interface.Good () -> k ()
@@ -585,8 +561,8 @@ struct
 
 end
 
-let goals ?logger x h k =
-  PrintOpt.enforce h (fun () -> eval_call ?logger (Xmlprotocol.goals x) h k)
+let goals x h k =
+  PrintOpt.enforce h (fun () -> eval_call (Xmlprotocol.goals x) h k)
 
 let evars x h k =
   PrintOpt.enforce h (fun () -> eval_call (Xmlprotocol.evars x) h k)
diff --git a/ide/coq.mli b/ide/coq.mli
index 8a1fa3ed1..ab8c12a6f 100644
--- a/ide/coq.mli
+++ b/ide/coq.mli
@@ -115,15 +115,11 @@ val try_grab : coqtop -> unit task -> (unit -> unit) -> unit
 type 'a query = 'a Interface.value task
 (** A type abbreviation for coqtop specific answers *)
 
-val add        : ?logger:Ideutils.logger ->
-                 Interface.add_sty        -> Interface.add_rty query
+val add        : Interface.add_sty        -> Interface.add_rty query
 val edit_at    : Interface.edit_at_sty    -> Interface.edit_at_rty query
-val query      : ?logger:Ideutils.logger ->
-                 Interface.query_sty      -> Interface.query_rty query
-val status     : ?logger:Ideutils.logger ->
-                 Interface.status_sty     -> Interface.status_rty query
-val goals      : ?logger:Ideutils.logger ->
-                 Interface.goals_sty      -> Interface.goals_rty query
+val query      : Interface.query_sty      -> Interface.query_rty query
+val status     : Interface.status_sty     -> Interface.status_rty query
+val goals      : Interface.goals_sty      -> Interface.goals_rty query
 val evars      : Interface.evars_sty      -> Interface.evars_rty query
 val hints      : Interface.hints_sty      -> Interface.hints_rty query
 val mkcases    : Interface.mkcases_sty    -> Interface.mkcases_rty query
@@ -143,7 +139,6 @@ sig
   val bool_items : bool_descr list
 
   val set : t -> bool -> unit
-  val set_printing_width : int -> unit
 
   (** [enforce] transmits to coq the current option values.
       It is also called by [goals] and [evars] above. *)
diff --git a/ide/coqOps.ml b/ide/coqOps.ml
index 1563c7ffb..4a1d688f5 100644
--- a/ide/coqOps.ml
+++ b/ide/coqOps.ml
@@ -128,6 +128,9 @@ end = struct
 end
 open SentenceId
 
+let log_pp msg : unit task =
+  Coq.lift (fun () -> Minilib.log_pp msg)
+
 let log msg : unit task =
   Coq.lift (fun () -> Minilib.log msg)
 
@@ -162,13 +165,16 @@ let flags_to_color f =
   else if List.mem `INCOMPLETE f then `NAME "gray"
   else `NAME Preferences.processed_color#get
 
-let validate s =
-  let open Xml_datatype in
-  let rec validate = function
-  | PCData s -> Glib.Utf8.validate s
-  | Element (_, _, children) -> List.for_all validate children
-  in
-  validate (Richpp.repr s)
+(* Move to utils? *)
+let rec validate (s : Pp.std_ppcmds) = match Pp.repr s with
+  | Pp.Ppcmd_empty
+  | Pp.Ppcmd_print_break _
+  | Pp.Ppcmd_force_newline  -> true
+  | Pp.Ppcmd_glue l    -> List.for_all validate l
+  | Pp.Ppcmd_string s  -> Glib.Utf8.validate s
+  | Pp.Ppcmd_box (_,s)
+  | Pp.Ppcmd_tag (_,s) -> validate s
+  | Pp.Ppcmd_comment s -> List.for_all Glib.Utf8.validate s
 
 module Doc = Document
 
@@ -305,7 +311,7 @@ object(self)
 
   method private print_stack =
     Minilib.log "document:";
-    Minilib.log (Pp.string_of_ppcmds (Doc.print document (dbg_to_string buffer)))
+    Minilib.log_pp (Doc.print document (dbg_to_string buffer))
 
   method private enter_focus start stop =
     let at id id' _ = Stateid.equal id' id in
@@ -337,7 +343,6 @@ object(self)
     buffer#get_iter_at_mark `INSERT
 
   method private show_goals_aux ?(move_insert=false) () =
-    Coq.PrintOpt.set_printing_width proof#width;
     if move_insert then begin
       let dest = self#get_start_of_input in
       if (buffer#get_iter_at_mark `INSERT)#compare dest <= 0 then begin
@@ -345,7 +350,7 @@ object(self)
         script#recenter_insert
       end
     end;
-    Coq.bind (Coq.goals ~logger:messages#push ()) (function
+    Coq.bind (Coq.goals ()) (function
     | Fail x -> self#handle_failure_aux ~move_insert x
     | Good goals ->
       Coq.bind (Coq.evars ()) (function
@@ -368,7 +373,7 @@ object(self)
       else messages#add s;
     in
     let query =
-      Coq.query ~logger:messages#push (phrase,Stateid.dummy) in
+      Coq.query (phrase,Stateid.dummy) in
     let next = function
     | Fail (_, _, err) -> display_error err; Coq.return ()
     | Good msg ->
@@ -377,8 +382,7 @@ object(self)
     Coq.bind (Coq.seq action query) next
 
   method private mark_as_needed sentence =
-    Minilib.log("Marking " ^
-      Pp.string_of_ppcmds (dbg_to_string buffer false None sentence));
+    Minilib.log_pp Pp.(str "Marking " ++ dbg_to_string buffer false None sentence);
     let start = buffer#get_iter_at_mark sentence.start in
     let stop = buffer#get_iter_at_mark sentence.stop in
     let to_process = Tags.Script.to_process in
@@ -418,9 +422,10 @@ object(self)
     | _ -> false
 
   method private enqueue_feedback msg =
+    (* Minilib.log ("Feedback received: " ^ Xml_printer.to_string_fmt (Xmlprotocol.of_feedback msg)); *)
     let id = msg.id in
     if self#is_dummy_id id then () else Queue.add msg feedbacks
-    
+
   method private process_feedback () =
     let rec eat_feedback n =
       if n = 0 then true else
@@ -434,9 +439,11 @@ object(self)
           | _ -> None in
         try Some (Doc.find_map document finder)
         with Not_found -> None in
-      let log s state_id =
-        Minilib.log ("Feedback " ^ s ^ " on " ^ Stateid.to_string
-          (Option.default Stateid.dummy state_id)) in
+      let log_pp s state_id =
+        Minilib.log_pp Pp.(seq
+                [str "Feedback "; s; str " on ";
+                 str (Stateid.to_string (Option.default Stateid.dummy state_id))]) in
+      let log s state_id = log_pp (Pp.str s) state_id in
       begin match msg.contents, sentence with
       | AddedAxiom, Some (id,sentence) ->
           log "AddedAxiom" id;
@@ -466,22 +473,24 @@ object(self)
             (Printf.sprintf "%s %s %s" filepath ident ty)
       | Message(Error, loc, msg), Some (id,sentence) ->
           let loc = Option.default Loc.ghost loc in
-          let msg = Richpp.raw_print msg         in
-          log "ErrorMsg" id;
+          log_pp Pp.(str "ErrorMsg" ++ msg) id;
           remove_flag sentence `PROCESSING;
-          add_flag sentence (`ERROR (loc, msg));
+          let rmsg = Pp.string_of_ppcmds msg     in
+          add_flag sentence (`ERROR (loc, rmsg));
           self#mark_as_needed sentence;
-          self#attach_tooltip sentence loc msg;
+          self#attach_tooltip sentence loc rmsg;
           if not (Loc.is_ghost loc) then
             self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc))
       | Message(Warning, loc, msg), Some (id,sentence) ->
           let loc = Option.default Loc.ghost loc in
-          let msg = Richpp.raw_print msg         in
-          log "WarningMsg" id;
-          add_flag sentence (`WARNING (loc, msg));
-          self#attach_tooltip sentence loc msg;
-          self#position_warning_tag_at_sentence sentence loc
-      | Message((Info|Notice|Debug as lvl), _, msg), _ ->
+          log_pp Pp.(str "WarningMsg" ++ msg) id;
+          let rmsg = Pp.string_of_ppcmds msg     in
+          add_flag sentence (`WARNING (loc, rmsg));
+          self#attach_tooltip sentence loc rmsg;
+          self#position_warning_tag_at_sentence sentence loc;
+          messages#push Warning msg
+      | Message(lvl, loc, msg), Some (id,sentence) ->
+          log_pp Pp.(str "Msg" ++ msg) id;
           messages#push lvl msg
       | InProgress n, _ ->
           if n < 0 then processed <- processed + abs n
@@ -628,10 +637,9 @@ object(self)
         if Queue.is_empty queue then conclude topstack else
         match Queue.pop queue, topstack with
         | `Skip(start,stop), [] ->
-
-            logger Feedback.Error (Richpp.richpp_of_string "You must close the proof with Qed or Admitted");
+            logger Feedback.Error (Pp.str "You must close the proof with Qed or Admitted");
             self#discard_command_queue queue;
-            conclude [] 
+            conclude []
         | `Skip(start,stop), (_,s) :: topstack ->
             assert(start#equal (buffer#get_iter_at_mark s.start));
             assert(stop#equal (buffer#get_iter_at_mark s.stop));
@@ -641,11 +649,11 @@ object(self)
             add_flag sentence `PROCESSING;
             Doc.push document sentence;
             let _, _, phrase = self#get_sentence sentence in
-            let coq_query = Coq.add ~logger ((phrase,edit_id),(tip,verbose)) in
+            let coq_query = Coq.add ((phrase,edit_id),(tip,verbose)) in
             let handle_answer = function
               | Good (id, (Util.Inl (* NewTip *) (), msg)) ->
                   Doc.assign_tip_id document id;
-                  logger Feedback.Notice (Richpp.richpp_of_string msg);
+                  logger Feedback.Notice (Pp.str msg);
                   self#commit_queue_transaction sentence;
                   loop id []
               | Good (id, (Util.Inr (* Unfocus *) tip, msg)) ->
@@ -653,7 +661,7 @@ object(self)
                   let topstack, _ = Doc.context document in
                   self#exit_focus;
                   self#cleanup (Doc.cut_at document tip);
-                  logger Feedback.Notice (Richpp.richpp_of_string msg);
+                  logger Feedback.Notice (Pp.str msg);
                   self#mark_as_needed sentence;
                   if Queue.is_empty queue then loop tip []
                   else loop tip (List.rev topstack)
@@ -672,10 +680,10 @@ object(self)
    let next = function
      | Good _ ->
          messages#clear;
-         messages#push Feedback.Info (Richpp.richpp_of_string "All proof terms checked by the kernel");
+         messages#push Feedback.Info (Pp.str "All proof terms checked by the kernel");
          Coq.return ()
      | Fail x -> self#handle_failure x in
-   Coq.bind (Coq.status ~logger:messages#push true) next
+   Coq.bind (Coq.status true) next
 
   method stop_worker n =
     Coq.bind (Coq.stop_worker n) (fun _ -> Coq.return ())
@@ -859,7 +867,7 @@ object(self)
       let next = function
       | Fail (_, l, str) -> (* FIXME: check *)
         display_error (l, str);
-        messages#add (Richpp.richpp_of_string ("Unsuccessfully tried: "^phrase));
+        messages#add (Pp.str ("Unsuccessfully tried: "^phrase));
         more
       | Good msg ->
         messages#add_string msg;
@@ -905,7 +913,7 @@ object(self)
     let get_initial_state =
       let next = function
       | Fail (_, _, message) ->
-        let message = "Couldn't initialize coqtop\n\n" ^ (Richpp.raw_print message) in
+        let message = "Couldn't initialize coqtop\n\n" ^ (Pp.string_of_ppcmds message) in
         let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok ~message_type:`ERROR ~message () in
         ignore (popup#run ()); exit 1
       | Good id -> initial_state <- id; Coq.return () in
diff --git a/ide/coqide.ml b/ide/coqide.ml
index 450bfcdfb..25858acce 100644
--- a/ide/coqide.ml
+++ b/ide/coqide.ml
@@ -318,7 +318,7 @@ let export kind sn =
         local_cd f ^ cmd_coqdoc#get ^ " --" ^ kind ^ " -o " ^
         (Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1"
       in
-      sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd));
+      sn.messages#set (Pp.str ("Running: "^cmd));
       let finally st = flash_info (cmd ^ pr_exit_status st)
       in
       run_command (fun msg -> sn.messages#add_string msg) finally cmd
@@ -431,7 +431,7 @@ let compile sn =
 	^ " " ^ (Filename.quote f) ^ " 2>&1"
       in
       let buf = Buffer.create 1024 in
-      sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd));
+      sn.messages#set (Pp.str ("Running: "^cmd));
       let display s =
         sn.messages#add_string s;
         Buffer.add_string buf s
@@ -441,8 +441,8 @@ let compile sn =
           flash_info (f ^ " successfully compiled")
         else begin
           flash_info (f ^ " failed to compile");
-          sn.messages#set (Richpp.richpp_of_string "Compilation output:\n");
-          sn.messages#add (Richpp.richpp_of_string (Buffer.contents buf));
+          sn.messages#set (Pp.str "Compilation output:\n");
+          sn.messages#add (Pp.str (Buffer.contents buf));
         end
       in
       run_command display finally cmd
@@ -464,7 +464,7 @@ let make sn =
     |Some f ->
       File.saveall ();
       let cmd = local_cd f ^ cmd_make#get ^ " 2>&1" in
-      sn.messages#set (Richpp.richpp_of_string "Compilation output:\n");
+      sn.messages#set (Pp.str "Compilation output:\n");
       Buffer.reset last_make_buf;
       last_make := "";
       last_make_index := 0;
@@ -508,11 +508,11 @@ let next_error sn =
     let stopi = b#get_iter_at_byte ~line:(line-1) stop in
     b#apply_tag Tags.Script.error ~start:starti ~stop:stopi;
     b#place_cursor ~where:starti;
-    sn.messages#set (Richpp.richpp_of_string error_msg);
+    sn.messages#set (Pp.str error_msg);
     sn.script#misc#grab_focus ()
   with Not_found ->
     last_make_index := 0;
-    sn.messages#set (Richpp.richpp_of_string "No more errors.\n")
+    sn.messages#set (Pp.str "No more errors.\n")
 
 let next_error = cb_on_current_term next_error
 
@@ -536,7 +536,7 @@ let update_status sn =
     display ("Ready"^ (if nanoPG#get then ", [μPG]" else "") ^ path ^ name);
     Coq.return ()
   in
-  Coq.bind (Coq.status ~logger:sn.messages#push false) next
+  Coq.bind (Coq.status false) next
 
 let find_next_occurrence ~backward sn =
   (** go to the next occurrence of the current word, forward or backward *)
@@ -789,7 +789,7 @@ let coqtop_arguments sn =
         let args = String.concat " " args in
         let msg = Printf.sprintf "Invalid arguments: %s" args in
         let () = sn.messages#clear in
-        sn.messages#push Feedback.Error (Richpp.richpp_of_string msg)
+        sn.messages#push Feedback.Error (Pp.str msg)
     else dialog#destroy ()
   in
   let _ = entry#connect#activate ok_cb in
@@ -887,8 +887,8 @@ let alpha_items menu_name item_name l =
     | [] -> ()
     | [s] -> mk_item s
     | s::_ as ll ->
-      let name = item_name^" "^(String.make 1 s.[0]) in
-      let label = "_@..." in label.[1] <- s.[0];
+      let name = Printf.sprintf "%s %c" item_name s.[0] in
+      let label = Printf.sprintf "_%c..." s.[0] in
       item name ~label menu_name;
       List.iter mk_item ll
   in
diff --git a/ide/coqidetop.mllib b/ide/coqidetop.mllib
index ed1fa465d..043ad6008 100644
--- a/ide/coqidetop.mllib
+++ b/ide/coqidetop.mllib
@@ -2,7 +2,7 @@ Xml_lexer
 Xml_parser
 Xml_printer
 Serialize
-Richprinter
+Richpp
 Xmlprotocol
 Texmacspp
 Document
diff --git a/ide/ide.mllib b/ide/ide.mllib
index 72a14134b..78b4c01e8 100644
--- a/ide/ide.mllib
+++ b/ide/ide.mllib
@@ -9,11 +9,12 @@ Config_lexer
 Utf8_convert
 Preferences
 Project_file
-Serialize
-Richprinter
 Xml_lexer
 Xml_parser
 Xml_printer
+Serialize
+Richpp
+Topfmt
 Xmlprotocol
 Ideutils
 Coq
diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml
index 4967ddb75..0dfa03cca 100644
--- a/ide/ide_slave.ml
+++ b/ide/ide_slave.ml
@@ -32,24 +32,6 @@ let init_signal_handler () =
   let f _ = if !catch_break then raise Sys.Break else Control.interrupt := true in
   Sys.set_signal Sys.sigint (Sys.Signal_handle f)
 
-
-(** Redirection of standard output to a printable buffer *)
-
-let init_stdout, read_stdout =
-  let out_buff = Buffer.create 100 in
-  let out_ft = Format.formatter_of_buffer out_buff in
-  let deep_out_ft = Format.formatter_of_buffer out_buff in
-  let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in
-  (fun () ->
-     flush_all ();
-     Pp_control.std_ft := out_ft;
-     Pp_control.err_ft := out_ft;
-     Pp_control.deep_ft := deep_out_ft;
-  ),
-  (fun () -> Format.pp_print_flush out_ft ();
-             let r = Buffer.contents out_buff in
-             Buffer.clear out_buff; r)
-
 let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s
 
 let pr_error s = pr_with_pid s
@@ -97,42 +79,58 @@ let is_undo cmd = match cmd with
   | VernacUndo _ | VernacUndoTo _ -> true
   | _ -> false
 
-(** Check whether a command is forbidden by CoqIDE *)
+(** Check whether a command is forbidden in the IDE *)
 
-let coqide_cmd_checks (loc,ast) =
+let ide_cmd_checks (loc,ast) =
   let user_error s = CErrors.user_err ~loc ~hdr:"CoqIde" (str s) in
   if is_debug ast then
-    user_error "Debug mode not available within CoqIDE";
+    user_error "Debug mode not available in the IDE";
   if is_known_option ast then
-    Feedback.msg_warning (strbrk"This will not work. Use CoqIDE view menu instead");
+    Feedback.msg_warning (strbrk "Set this option from the IDE menu instead");
   if Vernac.is_navigation_vernac ast || is_undo ast then
-    Feedback.msg_warning (strbrk "Rather use CoqIDE navigation instead");
+    Feedback.msg_warning (strbrk "Use IDE navigation instead");
   if is_query ast then
     Feedback.msg_warning (strbrk "Query commands should not be inserted in scripts")
 
 (** Interpretation (cf. [Ide_intf.interp]) *)
 
 let add ((s,eid),(sid,verbose)) =
-  let newid, rc = Stm.add ~ontop:sid verbose ~check:coqide_cmd_checks eid s in
+  let newid, rc = Stm.add ~ontop:sid verbose ~check:ide_cmd_checks eid s in
   let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in
-  newid, (rc, read_stdout ())
+  (* TODO: the "" parameter is a leftover of the times the protocol
+   * used to include stderr/stdout output.
+   *
+   * Currently, we force all the output meant for the to go via the
+   * feedback mechanism, and we don't manipulate stderr/stdout, which
+   * are left to the client's discrection. The parameter is still there
+   * as not to break the core protocol for this minor change, but it should
+   * be removed in the next version of the protocol.
+   *)
+  newid, (rc, "")
 
 let edit_at id =
   match Stm.edit_at id with
   | `NewTip -> CSig.Inl ()
   | `Focus { Stm.start; stop; tip} -> CSig.Inr (start, (stop, tip))
 
-let query (s,id) = Stm.query ~at:id s; read_stdout ()
+(* TODO: the "" parameter is a leftover of the times the protocol
+ * used to include stderr/stdout output.
+ *
+ * Currently, we force all the output meant for the to go via the
+ * feedback mechanism, and we don't manipulate stderr/stdout, which
+ * are left to the client's discrection. The parameter is still there
+ * as not to break the core protocol for this minor change, but it should
+ * be removed in the next version of the protocol.
+ *)
+let query (s,id) = Stm.query ~at:id s; ""
 
 let annotate phrase =
   let (loc, ast) =
     let pa = Pcoq.Gram.parsable (Stream.of_string phrase) in
     Vernac.parse_sentence (pa,None)
   in
-  let (_, xml) =
-    Richprinter.richpp_vernac ast
-  in
-  xml
+  (* XXX: Width should be a parameter of annotate... *)
+  Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast)
 
 (** Goal display *)
 
@@ -192,13 +190,13 @@ let process_goal sigma g =
   let id = Goal.uid g in
   let ccl =
     let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in
-    Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr)
+    pr_goal_concl_style_env env sigma norm_constr
   in
   let process_hyp d (env,l) =
     let d = CompactedDecl.map_constr (fun c -> EConstr.Unsafe.to_constr (Reductionops.nf_evar sigma (EConstr.of_constr c))) d in
     let d' = CompactedDecl.to_named_context d in
       (List.fold_right Environ.push_named d' env,
-       (Richpp.richpp_of_pp (pr_compacted_decl env sigma d)) :: l) in
+       (pr_compacted_decl env sigma d) :: l) in
   let (_env, hyps) =
     Context.Compacted.fold process_hyp
       (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in
@@ -214,8 +212,6 @@ let export_pre_goals pgs =
 
 let goals () =
   Stm.finish ();
-  let s = read_stdout () in
-  if not (String.is_empty s) then Feedback.msg_info (str s);
   try
     let pfts = Proof_global.give_me_the_proof () in
     Some (export_pre_goals (Proof.map_structured_proof pfts process_goal))
@@ -224,8 +220,6 @@ let goals () =
 let evars () =
   try
     Stm.finish ();
-    let s = read_stdout () in
-    if not (String.is_empty s) then Feedback.msg_info (str s);
     let pfts = Proof_global.give_me_the_proof () in
     let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
     let exl = Evar.Map.bindings (Evarutil.non_instantiated sigma) in
@@ -257,8 +251,6 @@ let status force =
       and display the other parts (opened sections and modules) *)
   Stm.finish ();
   if force then Stm.join ();
-  let s = read_stdout () in
-  if not (String.is_empty s) then Feedback.msg_info (str s);
   let path =
     let l = Names.DirPath.repr (Lib.cwd ()) in
     List.rev_map Names.Id.to_string l
@@ -281,7 +273,7 @@ let status force =
 let export_coq_object t = {
   Interface.coq_object_prefix = t.Search.coq_object_prefix;
   Interface.coq_object_qualid = t.Search.coq_object_qualid;
-  Interface.coq_object_object = t.Search.coq_object_object
+  Interface.coq_object_object = Pp.string_of_ppcmds (pr_lconstr_env (Global.env ()) Evd.empty t.Search.coq_object_object)
 }
 
 let pattern_of_string ?env s =
@@ -364,14 +356,10 @@ let handle_exn (e, info) =
   let loc_of e = match Loc.get_loc e with
     | Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc)
     | _ -> None in
-  let mk_msg () =
-    let msg = read_stdout () in
-    let msg = str msg ++ fnl () ++ CErrors.print ~info e in
-    Richpp.richpp_of_pp msg
-  in
+  let mk_msg () = CErrors.print ~info e in
   match e with
-  | CErrors.Drop -> dummy, None, Richpp.richpp_of_string "Drop is not allowed by coqide!"
-  | CErrors.Quit -> dummy, None, Richpp.richpp_of_string "Quit is not allowed by coqide!"
+  | CErrors.Drop -> dummy, None, Pp.str "Drop is not allowed by coqide!"
+  | CErrors.Quit -> dummy, None, Pp.str "Quit is not allowed by coqide!"
   | e ->
       match Stateid.get info with
       | Some (valid, _) -> valid, loc_of info, mk_msg ()
@@ -409,7 +397,16 @@ let interp ((_raw, verbose), s) =
       | Some ast -> ast)
     () in
   Stm.interp verbose (vernac_parse s);
-  Stm.get_current_state (), CSig.Inl (read_stdout ())
+  (* TODO: the "" parameter is a leftover of the times the protocol
+   * used to include stderr/stdout output.
+   *
+   * Currently, we force all the output meant for the to go via the
+   * feedback mechanism, and we don't manipulate stderr/stdout, which
+   * are left to the client's discrection. The parameter is still there
+   * as not to break the core protocol for this minor change, but it should
+   * be removed in the next version of the protocol.
+   *)
+  Stm.get_current_state (), CSig.Inl ""
 
 (** When receiving the Quit call, we don't directly do an [exit 0],
     but rather set this reference, in order to send a final answer
@@ -428,14 +425,12 @@ let print_ast id =
 
 (** Grouping all call handlers together + error handling *)
 
-let eval_call xml_oc log c =
+let eval_call c =
   let interruptible f x =
     catch_break := true;
     Control.check_for_interrupt ();
     let r = f x in
     catch_break := false;
-    let out = read_stdout () in
-    if not (String.is_empty out) then log (str out);
     r
   in
   let handler = {
@@ -473,16 +468,8 @@ let print_xml =
     try Xml_printer.print oc xml; Mutex.unlock m
     with e -> let e = CErrors.push e in Mutex.unlock m; iraise e
 
-
-let slave_logger xml_oc ?loc level message =
-  (* convert the message into XML *)
-  let msg = hov 0 message in
-  let () = pr_debug (Printf.sprintf "-> %S" (string_of_ppcmds msg))         in
-  let xml = Xmlprotocol.of_message level loc (Richpp.richpp_of_pp message) in
-  print_xml xml_oc xml
-
-let slave_feeder xml_oc msg =
-  let xml = Xmlprotocol.of_feedback msg in
+let slave_feeder fmt xml_oc msg =
+  let xml = Xmlprotocol.(of_feedback fmt msg) in
   print_xml xml_oc xml
 
 (** The main loop *)
@@ -491,17 +478,22 @@ let slave_feeder xml_oc msg =
     messages by [handle_exn] above. Otherwise, we die badly, without
     trying to answer malformed requests. *)
 
+let msg_format = ref (fun () ->
+    let margin = Option.default 72 (Topfmt.get_margin ()) in
+    Xmlprotocol.Richpp margin
+)
+
 let loop () =
   init_signal_handler ();
   catch_break := false;
-  let in_ch, out_ch = Spawned.get_channels () in
-  let xml_oc = Xml_printer.make (Xml_printer.TChannel out_ch) in
-  let in_lb = Lexing.from_function (fun s len ->
-    CThread.thread_friendly_read in_ch s ~off:0 ~len) in
-  let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in
+  let in_ch, out_ch = Spawned.get_channels ()                        in
+  let xml_oc        = Xml_printer.make (Xml_printer.TChannel out_ch) in
+  let in_lb         = Lexing.from_function (fun s len ->
+                      CThread.thread_friendly_read in_ch s ~off:0 ~len) in
+  (* SEXP parser make *)
+  let xml_ic        = Xml_parser.make (Xml_parser.SLexbuf in_lb) in
   let () = Xml_parser.check_eof xml_ic false in
-  Feedback.set_logger (slave_logger xml_oc);
-  Feedback.add_feeder (slave_feeder xml_oc);
+  ignore (Feedback.add_feeder (slave_feeder (!msg_format ()) xml_oc));
   (* We'll handle goal fetching and display in our own way *)
   Vernacentries.enable_goal_printing := false;
   Vernacentries.qed_display_script := false;
@@ -511,10 +503,10 @@ let loop () =
 (*       pr_with_pid (Xml_printer.to_string_fmt xml_query); *)
       let Xmlprotocol.Unknown q = Xmlprotocol.to_call xml_query in
       let () = pr_debug_call q in
-      let r = eval_call xml_oc (slave_logger xml_oc Feedback.Notice) q in
+      let r  = eval_call q in
       let () = pr_debug_answer q r in
 (*       pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *)
-      print_xml xml_oc (Xmlprotocol.of_answer q r);
+      print_xml xml_oc Xmlprotocol.(of_answer (!msg_format ()) q r);
       flush out_ch
     with
       | Xml_parser.Error (Xml_parser.Empty, _) ->
@@ -536,16 +528,19 @@ let loop () =
 let rec parse = function
   | "--help-XML-protocol" :: rest ->
         Xmlprotocol.document Xml_printer.to_string_fmt; exit 0
+  | "--xml_format=Ppcmds" :: rest ->
+        msg_format := (fun () -> Xmlprotocol.Ppcmds); parse rest
   | x :: rest -> x :: parse rest
   | [] -> []
 
 let () = Coqtop.toploop_init := (fun args ->
         let args = parse args in
         Flags.make_silent true;
-        init_stdout ();
         CoqworkmgrApi.(init Flags.High);
         args)
 
 let () = Coqtop.toploop_run := loop
 
-let () = Usage.add_to_usage "coqidetop" "  --help-XML-protocol    print the documentation of the XML protocol used by CoqIDE\n"
+let () = Usage.add_to_usage "coqidetop"
+"  --xml_format=Ppcmds    serialize pretty printing messages using the std_ppcmds format
+  --help-XML-protocol    print the documentation of the XML protocol used by CoqIDE\n"
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index 06a132732..da867e689 100644
--- a/ide/ideutils.ml
+++ b/ide/ideutils.ml
@@ -43,7 +43,7 @@ let xml_to_string xml =
   | Element (_, _, children) ->
     List.iter iter children
   in
-  let () = iter (Richpp.repr xml) in
+  let () = iter xml in
   Buffer.contents buf
 
 let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text =
@@ -75,7 +75,7 @@ let insert_xml ?(mark = `INSERT) ?(tags = []) (buf : #GText.buffer_skel) msg =
     let tags = try tag t :: tags with Not_found -> tags in
     List.iter (fun xml -> insert tags xml) children
   in
-  let () = try insert tags (Richpp.repr msg) with _ -> () in
+  let () = try insert tags msg with _ -> () in
   buf#delete_mark rmark
 
 let set_location = ref  (function s -> failwith "not ready")
@@ -294,18 +294,20 @@ let coqtop_path () =
       match cmd_coqtop#get with
 	| Some s -> s
 	| None ->
-	  let prog = String.copy Sys.executable_name in
 	  try
-	    let pos = String.length prog - 6 in
-	    let i = Str.search_backward (Str.regexp_string "coqide") prog pos
+            let old_prog = Sys.executable_name in
+            let pos = String.length old_prog - 6 in
+            let i = Str.search_backward (Str.regexp_string "coqide") old_prog pos
             in
-	    String.blit "coqtop" 0 prog i 6;
-	    if Sys.file_exists prog then prog
+            let new_prog = Bytes.of_string old_prog in
+            Bytes.blit_string "coqtop" 0 new_prog i 6;
+            let new_prog = Bytes.to_string new_prog in
+            if Sys.file_exists new_prog then new_prog
 	    else
 	      let in_macos_bundle =
 		Filename.concat
-		  (Filename.dirname prog)
-		  (Filename.concat "../Resources/bin" (Filename.basename prog))
+		  (Filename.dirname new_prog)
+		  (Filename.concat "../Resources/bin" (Filename.basename new_prog))
 	      in if Sys.file_exists in_macos_bundle then in_macos_bundle
 		 else "coqtop"
 	  with Not_found -> "coqtop"
@@ -325,7 +327,7 @@ let textview_width (view : #GText.view_skel) =
   let char_width = GPango.to_pixels metrics#approx_char_width in
   pixel_width / char_width
 
-type logger = Feedback.level -> Richpp.richpp -> unit
+type logger = Feedback.level -> Pp.std_ppcmds -> unit
 
 let default_logger level message =
   let level = match level with
@@ -335,7 +337,7 @@ let default_logger level message =
   | Feedback.Warning -> `WARNING
   | Feedback.Error -> `ERROR
   in
-  Minilib.log ~level (xml_to_string message)
+  Minilib.log_pp ~level message
 
 
 (** {6 File operations} *)
@@ -357,7 +359,7 @@ let stat f =
 
 let maxread = 4096
 
-let read_string = String.create maxread
+let read_string = Bytes.create maxread
 let read_buffer = Buffer.create maxread
 
 (** Read the content of file [f] and add it to buffer [b].
@@ -368,7 +370,7 @@ let read_file name buf =
   let len = ref 0 in
   try
     while len := input ic read_string 0 maxread; !len > 0 do
-      Buffer.add_substring buf read_string 0 !len
+      Buffer.add_subbytes buf read_string 0 !len
     done;
     close_in ic
   with e -> close_in ic; raise e
@@ -381,8 +383,9 @@ let read_file name buf =
 let io_read_all chan =
   Buffer.clear read_buffer;
   let read_once () =
-    let len = Glib.Io.read_chars ~buf:read_string ~pos:0 ~len:maxread chan in
-    Buffer.add_substring read_buffer read_string 0 len
+    (* XXX: Glib.Io must be converted to bytes / -safe-string upstream *)
+    let len = Glib.Io.read_chars ~buf:(Bytes.unsafe_to_string read_string) ~pos:0 ~len:maxread chan in
+    Buffer.add_subbytes read_buffer read_string 0 len
   in
   begin
     try while true do read_once () done
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
index e32a4d9e3..4b4ba72b0 100644
--- a/ide/ideutils.mli
+++ b/ide/ideutils.mli
@@ -52,8 +52,6 @@ val pop_info : unit -> unit
 val clear_info : unit -> unit
 val flash_info : ?delay:int -> string -> unit
 
-val xml_to_string : Richpp.richpp -> string
-
 val insert_xml : ?mark:GText.mark -> ?tags:GText.tag list ->
   #GText.buffer_skel -> Richpp.richpp -> unit
 
@@ -69,7 +67,7 @@ val requote : string -> string
 val textview_width : #GText.view_skel -> int
 (** Returns an approximate value of the character width of a textview *)
 
-type logger = Feedback.level -> Richpp.richpp -> unit
+type logger = Feedback.level -> Pp.std_ppcmds -> unit
 
 val default_logger : logger
 (** Default logger. It logs messages that the casual user should not see. *)
diff --git a/ide/interface.mli b/ide/interface.mli
index 123cac6c2..9ed606258 100644
--- a/ide/interface.mli
+++ b/ide/interface.mli
@@ -12,15 +12,14 @@
 
 type raw = bool
 type verbose = bool
-type richpp = Richpp.richpp
 
 (** The type of coqtop goals *)
 type goal = {
   goal_id : string;
   (** Unique goal identifier *)
-  goal_hyp : richpp list;
+  goal_hyp : Pp.std_ppcmds list;
   (** List of hypotheses *)
-  goal_ccl : richpp;
+  goal_ccl : Pp.std_ppcmds;
   (** Goal conclusion *)
 }
 
@@ -119,7 +118,7 @@ type edit_id = Feedback.edit_id
    should probably retract to that point *)
 type 'a value =
   | Good of 'a
-  | Fail of (state_id * location * richpp)
+  | Fail of (state_id * location * Pp.std_ppcmds)
 
 type ('a, 'b) union = ('a, 'b) Util.union
 
@@ -128,9 +127,13 @@ type ('a, 'b) union = ('a, 'b) Util.union
 (**  [add ((s,eid),(sid,v))] adds the phrase [s] with edit id [eid]
      on top of the current edit position (that is asserted to be [sid])
      verbosely if [v] is true.  The response [(id,(rc,s)] is the new state
-     [id] assigned to the phrase, some output [s].  [rc] is [Inl] if the new
+     [id] assigned to the phrase. [rc] is [Inl] if the new
      state id is the tip of the edit point, or [Inr tip] if the new phrase
-     closes a focus and [tip] is the new edit tip *)
+     closes a focus and [tip] is the new edit tip
+
+     [s] used to contain Coq's console output and has been deprecated
+     in favor of sending feedback, it will be removed in a future
+     version of the protocol.  *)
 type add_sty = (string * edit_id) * (state_id * verbose)
 type add_rty = state_id * ((unit, state_id) union * string)
 
@@ -143,8 +146,12 @@ type add_rty = state_id * ((unit, state_id) union * string)
 type edit_at_sty = state_id
 type edit_at_rty = (unit, state_id * (state_id * state_id)) union
 
-(** [query s id] executes [s] at state [id] and does not record any state
-    change but for the printings that are sent in response *)
+(** [query s id] executes [s] at state [id].
+
+    query used to reply with the contents of Coq's console output, and
+    has been deprecated in favor of sending the query answers as
+    feedback. It will be removed in a future version of the protocol.
+*)
 type query_sty = string * state_id
 type query_rty = string
 
@@ -203,7 +210,7 @@ type about_sty = unit
 type about_rty = coq_info
 
 type handle_exn_sty = Exninfo.iexn
-type handle_exn_rty = state_id * location * richpp
+type handle_exn_rty = state_id * location * Pp.std_ppcmds
 
 (* Retrocompatibility stuff *)
 type interp_sty = (raw * verbose) * string
diff --git a/ide/minilib.ml b/ide/minilib.ml
index d11e8c56b..2c24e46f8 100644
--- a/ide/minilib.ml
+++ b/ide/minilib.ml
@@ -30,7 +30,7 @@ let debug = ref false
    print in the response buffer.
 *)
 
-let log ?(level = `DEBUG) msg =
+let log_pp ?(level = `DEBUG) msg =
   let prefix = match level with
   | `DEBUG -> "DEBUG"
   | `INFO -> "INFO"
@@ -40,10 +40,12 @@ let log ?(level = `DEBUG) msg =
   | `FATAL -> "FATAL"
   in
   if !debug then begin
-    try Printf.eprintf "[%s] %s\n%!" prefix msg
+    try Format.eprintf "[%s] @[%a@]\n%!" prefix Pp.pp_with msg
     with _ -> ()
   end
 
+let log ?level str = log_pp ?level (Pp.str str)
+
 let coqify d = Filename.concat d "coq"
 
 let coqide_config_home () =
diff --git a/ide/minilib.mli b/ide/minilib.mli
index b7672c900..4517a2374 100644
--- a/ide/minilib.mli
+++ b/ide/minilib.mli
@@ -22,7 +22,8 @@ type level = [
 (** debug printing *)
 val debug : bool ref
 
-val log : ?level:level -> string -> unit
+val log_pp : ?level:level -> Pp.std_ppcmds -> unit
+val log    : ?level:level -> string        -> unit
 
 val coqide_config_home : unit -> string
 val coqide_config_dirs : unit -> string list
diff --git a/lib/richpp.ml b/ide/richpp.ml
index d1c6d158e..522a3e0b3 100644
--- a/lib/richpp.ml
+++ b/ide/richpp.ml
@@ -24,10 +24,6 @@ type 'a context = {
   (** Pending opened nodes *)
   mutable offset : int;
   (** Quantity of characters printed so far *)
-  mutable annotations : 'a option Int.Map.t;
-  (** Map associating annotations to indexes *)
-  mutable index : int;
-  (** Current index of annotations *)
 }
 
 (** We use Format to introduce tags inside the pretty-printed document.
@@ -38,23 +34,13 @@ type 'a context = {
     marking functions. As those functions are called when actually writing to
     the device, the resulting tree is correct.
 *)
-let rich_pp annotate ppcmds =
+let rich_pp width ppcmds =
 
   let context = {
     stack = Leaf;
     offset = 0;
-    annotations = Int.Map.empty;
-    index = (-1);
   } in
 
-  let pp_tag obj =
-    let index = context.index + 1 in
-    let () = context.index <- index in
-    let obj = annotate obj in
-    let () = context.annotations <- Int.Map.add index obj context.annotations in
-    string_of_int index
-  in
-
   let pp_buffer = Buffer.create 180 in
 
   let push_pcdata () =
@@ -81,12 +67,8 @@ let rich_pp annotate ppcmds =
     | Leaf -> assert false
     | Node (node, child, pos, ctx) ->
       let () = assert (String.equal tag node) in
-      let annotation =
-        try Int.Map.find (int_of_string node) context.annotations
-        with _ -> None
-      in
       let annotation = {
-        annotation = annotation;
+        annotation = Some tag;
         startpos = pos;
         endpos = context.offset;
       } in
@@ -113,18 +95,20 @@ let rich_pp annotate ppcmds =
   pp_set_formatter_tag_functions ft tag_functions;
   pp_set_mark_tags ft true;
 
-  (* Set formatter width. This is currently a hack and duplicate code
-     with Pp_control. Hopefully it will be fixed better in Coq 8.7 *)
-  let w = pp_get_margin str_formatter () in
-  let m = max (64 * w / 100) (w-30) in
-  pp_set_margin ft w;
+  (* Setting the formatter *)
+  pp_set_margin ft width;
+  let m = max (64 * width / 100) (width-30) in
   pp_set_max_indent ft m;
+  pp_set_max_boxes ft 50 ;
+  pp_set_ellipsis_text ft "...";
 
   (** The whole output must be a valid document. To that
       end, we nest the document inside <pp> tags. *)
+  pp_open_box ft 0;
   pp_open_tag ft "pp";
-  Pp.(pp_with ~pp_tag ft ppcmds);
+  Pp.(pp_with ft ppcmds);
   pp_close_tag ft ();
+  pp_close_box ft ();
 
   (** Get the resulting XML tree. *)
   let () = pp_print_flush ft () in
@@ -172,32 +156,14 @@ let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml =
 
 type richpp = xml
 
-let repr xml = xml
-let richpp_of_xml xml = xml
-let richpp_of_string s = PCData s
-
-let richpp_of_pp pp =
-  let annotate t = match Pp.Tag.prj t Ppstyle.tag with
-  | None -> None
-  | Some key -> Some (Ppstyle.repr key)
-  in
+let richpp_of_pp width pp =
   let rec drop = function
   | PCData s -> [PCData s]
   | Element (_, annotation, cs) ->
     let cs = List.concat (List.map drop cs) in
     match annotation.annotation with
     | None -> cs
-    | Some s -> [Element (String.concat "." s, [], cs)]
+    | Some s -> [Element (s, [], cs)]
   in
-  let xml = rich_pp annotate pp in
+  let xml = rich_pp width pp in
   Element ("_", [], drop xml)
-
-let raw_print xml =
-  let buf = Buffer.create 1024 in
-  let rec print = function
-  | PCData s -> Buffer.add_string buf s
-  | Element (_, _, cs) -> List.iter print cs
-  in
-  let () = print xml in
-  Buffer.contents buf
-
diff --git a/lib/richpp.mli b/ide/richpp.mli
index 287d265a8..ea4b189ba 100644
--- a/lib/richpp.mli
+++ b/ide/richpp.mli
@@ -16,14 +16,15 @@ type 'annotation located = {
   endpos     : int
 }
 
-(** [rich_pp get_annotations ppcmds] returns the interpretation
+(* XXX: The width parameter should be moved to a `formatter_property`
+   record shared with Topfmt *)
+
+(** [rich_pp width ppcmds] returns the interpretation
     of [ppcmds] as a semi-structured document
     that represents (located) annotations of this string.
     The [get_annotations] function is used to convert tags into the desired
-    annotation. *)
-val rich_pp :
-  (Pp.Tag.t -> 'annotation option) -> Pp.std_ppcmds ->
-  'annotation located Xml_datatype.gxml
+    annotation. [width] sets the printing witdh of the formatter. *)
+val rich_pp : int -> Pp.std_ppcmds -> Pp.pp_tag located Xml_datatype.gxml
 
 (** [annotations_positions ssdoc] returns a list associating each
     annotations with its position in the string from which [ssdoc] is
@@ -42,23 +43,9 @@ val xml_of_rich_pp :
 
 (** {5 Enriched text} *)
 
-type richpp
+type richpp = Xml_datatype.xml
+
 (** Type of text with style annotations *)
 
-val richpp_of_pp : Pp.std_ppcmds -> richpp
+val richpp_of_pp : int -> Pp.std_ppcmds -> richpp
 (** Extract style information from formatted text *)
-
-val richpp_of_xml : Xml_datatype.xml -> richpp
-(** Do not use outside of dedicated areas *)
-
-val richpp_of_string : string -> richpp
-(** Make a styled text out of a normal string *)
-
-val repr : richpp -> Xml_datatype.xml
-(** Observe the styled text as XML *)
-
-(** {5 Debug/Compat} *)
-
-(** Represent the semi-structured document as a string, dropping any additional
-    information. *)
-val raw_print : richpp -> string
diff --git a/ide/richprinter.ml b/ide/richprinter.ml
deleted file mode 100644
index 995cef1ac..000000000
--- a/ide/richprinter.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-open Richpp
-
-module RichppConstr = Ppconstr.Richpp
-module RichppVernac = Ppvernac.Richpp
-
-type rich_pp =
-    Ppannotation.t Richpp.located Xml_datatype.gxml
-    * Xml_datatype.xml
-
-let get_annotations obj = Pp.Tag.prj obj Ppannotation.tag
-
-let make_richpp pr ast =
-  let rich_pp =
-    rich_pp get_annotations (pr ast)
-  in
-  let xml = Ppannotation.(
-    xml_of_rich_pp tag_of_annotation attributes_of_annotation rich_pp
-  )
-  in
-  (rich_pp, xml)
-
-let richpp_vernac = make_richpp RichppVernac.pr_vernac
-let richpp_constr = make_richpp RichppConstr.pr_constr_expr
diff --git a/ide/richprinter.mli b/ide/richprinter.mli
deleted file mode 100644
index c9e84e3eb..000000000
--- a/ide/richprinter.mli
+++ /dev/null
@@ -1,36 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** This module provides an entry point to "rich" pretty-printers that
-    produce pretty-printing as done by {!Printer} but with additional
-    annotations represented as a semi-structured document.
-
-    To understand what are these annotations and how they are represented
-    as standard XML attributes, please refer to {!Ppannotation}.
-
-    In addition to these annotations, each node of the semi-structured
-    document contains a [startpos] and an [endpos] attribute that
-    relate this node to the raw pretty-printing.
-    Please refer to {!Richpp} for more details. *)
-
-(** A rich pretty-print is composed of: *)
-type rich_pp =
-
-    (** - a generalized semi-structured document whose attributes are
-        annotations ; *)
-    Ppannotation.t Richpp.located Xml_datatype.gxml
-
-    (** - an XML document, representing annotations as usual textual
-        XML attributes. *)
-    * Xml_datatype.xml
-
-(** [richpp_vernac phrase] produces a rich pretty-printing of [phrase]. *)
-val richpp_vernac : Vernacexpr.vernac_expr -> rich_pp
-
-(** [richpp_constr constr] produces a rich pretty-printing of [constr]. *)
-val richpp_constr : Constrexpr.constr_expr -> rich_pp
diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml
index 946aaf010..47dad8f19 100644
--- a/ide/wg_Command.ml
+++ b/ide/wg_Command.ml
@@ -100,18 +100,15 @@ object(self)
         if Str.string_match (Str.regexp "\\. *$") com 0 then com
         else com ^ " " ^ arg ^" . "
       in
-      let log level message =
-        Ideutils.insert_xml result#buffer message;
-        result#buffer#insert "\n";
-      in
       let process =
-	Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function
+	Coq.bind (Coq.query (phrase,Stateid.dummy)) (function
           | Interface.Fail (_,l,str) ->
-            Ideutils.insert_xml result#buffer str;
+            let width = Ideutils.textview_width result in
+            Ideutils.insert_xml result#buffer (Richpp.richpp_of_pp width str);
             notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce;
 	    Coq.return ()
           | Interface.Good res ->
-            result#buffer#insert res; 
+            result#buffer#insert res;
             notebook#set_page ~tab_label:(new_tab_lbl arg) frame#coerce;
 	    Coq.return ())
       in
diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml
index 0330b8eff..3d0cd46cd 100644
--- a/ide/wg_MessageView.ml
+++ b/ide/wg_MessageView.ml
@@ -28,9 +28,10 @@ class type message_view =
     inherit GObj.widget
     method connect : message_view_signals
     method clear : unit
-    method add : Richpp.richpp -> unit
+    method add : Pp.std_ppcmds -> unit
     method add_string : string -> unit
-    method set : Richpp.richpp -> unit
+    method set : Pp.std_ppcmds -> unit
+    method refresh : bool -> unit
     method push : Ideutils.logger
       (** same as [add], but with an explicit level instead of [Notice] *)
     method buffer : GText.buffer
@@ -57,46 +58,71 @@ let message_view () : message_view =
   let () = view#set_left_margin 2 in
   view#misc#show ();
   let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in
-  let _ = background_color#connect#changed cb in
-  let _ = view#misc#connect#realize (fun () -> cb background_color#get) in
+  let _ = background_color#connect#changed ~callback:cb in
+  let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in
   let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in
   stick text_font view cb;
-  object (self)
+
+  (* Inserts at point, advances the mark *)
+  let insert_msg (level, msg) =
+    let tags = match level with
+      | Feedback.Error   -> [Tags.Message.error]
+      | Feedback.Warning -> [Tags.Message.warning]
+      | _ -> []
+    in
+    let mark = `MARK mark in
+    let width = Ideutils.textview_width view in
+    Ideutils.insert_xml ~mark buffer ~tags (Richpp.richpp_of_pp width msg);
+    buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n"
+  in
+
+  let mv = object (self)
     inherit GObj.widget box#as_widget
 
+    (* List of displayed messages *)
+    val mutable last_width = -1
+    val mutable msgs = []
+
     val push = new GUtil.signal ()
 
     method connect =
       new message_view_signals_impl box#as_widget push
 
+    method refresh force =
+      (* We need to block updates here due to the following race:
+         insertion of messages may create a vertical scrollbar, this
+         will trigger a width change, calling refresh again and
+         going into an infinite loop. *)
+      let width = Ideutils.textview_width view  in
+      (* Could still this method race if the scrollbar changes the
+         textview_width ?? *)
+      let needed = force || last_width <> width in
+      if needed then begin
+        last_width <- width;
+        buffer#set_text "";
+        buffer#move_mark (`MARK mark) ~where:buffer#start_iter;
+        List.(iter insert_msg (rev msgs))
+      end
+
     method clear =
-      buffer#set_text "";
-      buffer#move_mark (`MARK mark) ~where:buffer#start_iter
+      msgs <- []; self#refresh true
 
     method push level msg =
-      let tags = match level with
-      | Feedback.Error -> [Tags.Message.error]
-      | Feedback.Warning -> [Tags.Message.warning]
-      | _ -> []
-      in
-      let rec non_empty = function
-      | Xml_datatype.PCData "" -> false
-      | Xml_datatype.PCData _ -> true
-      | Xml_datatype.Element (_, _, children) -> List.exists non_empty children
-      in
-      if non_empty (Richpp.repr msg) then begin
-        let mark = `MARK mark in
-        Ideutils.insert_xml ~mark buffer ~tags msg;
-        buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n";
-        push#call (level, msg)
-      end
+      msgs <- (level, msg) :: msgs;
+      insert_msg (level, msg);
+      push#call (level, msg)
 
     method add msg = self#push Feedback.Notice msg
 
-    method add_string s = self#add (Richpp.richpp_of_string s)
+    method add_string s = self#add (Pp.str s)
 
     method set msg = self#clear; self#add msg
 
     method buffer = text_buffer
 
   end
+  in
+  (* Is there a better way to connect the signal ? *)
+  let w_cb (_ : Gtk.rectangle) = mv#refresh false in
+  ignore (view#misc#connect#size_allocate ~callback:w_cb);
+  mv
diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli
index 2d34533de..d065fcbc8 100644
--- a/ide/wg_MessageView.mli
+++ b/ide/wg_MessageView.mli
@@ -18,9 +18,10 @@ class type message_view =
     inherit GObj.widget
     method connect : message_view_signals
     method clear : unit
-    method add : Richpp.richpp -> unit
+    method add : Pp.std_ppcmds -> unit
     method add_string : string -> unit
-    method set : Richpp.richpp -> unit
+    method set : Pp.std_ppcmds -> unit
+    method refresh : bool -> unit
     method push : Ideutils.logger
       (** same as [add], but with an explicit level instead of [Notice] *)
     method buffer : GText.buffer
diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml
index 47c86045a..b5405570c 100644
--- a/ide/wg_ProofView.ml
+++ b/ide/wg_ProofView.ml
@@ -18,7 +18,6 @@ class type proof_view =
     method clear : unit -> unit
     method set_goals : Interface.goals option -> unit
     method set_evars : Interface.evar list option -> unit
-    method width : int
   end
 
 (* tag is the tag to be hooked, item is the item covered by this tag, make_menu
@@ -74,6 +73,7 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with
       | None -> [], []
       | Some (hl, h) -> (hl, h)
       in
+      let width = Ideutils.textview_width proof in
       let rec insert_hyp hints hs = match hs with
       | [] -> ()
       | hyp :: hs ->
@@ -84,7 +84,7 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with
           let () = hook_tag_cb tag hint sel_cb on_hover in
           [tag], hints
         in
-        let () = insert_xml ~tags proof#buffer hyp in
+        let () = insert_xml ~tags proof#buffer (Richpp.richpp_of_pp width hyp) in
         proof#buffer#insert "\n";
         insert_hyp rem_hints hs
       in
@@ -98,13 +98,13 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with
           else []
         in
         proof#buffer#insert (goal_str 1 goals_cnt);
-        insert_xml proof#buffer cur_goal;
+        insert_xml proof#buffer (Richpp.richpp_of_pp width cur_goal);
         proof#buffer#insert "\n"
       in
       (* Insert remaining goals (no hypotheses) *)
       let fold_goal i _ { Interface.goal_ccl = g } =
         proof#buffer#insert (goal_str i goals_cnt);
-        insert_xml proof#buffer g;
+        insert_xml proof#buffer (Richpp.richpp_of_pp width g);
         proof#buffer#insert "\n"
       in
       let () = Util.List.fold_left_i fold_goal 2 () rem_goals in
@@ -122,6 +122,7 @@ let rec flatten = function
 
 let display mode (view : #GText.view_skel) goals hints evars =
   let () = view#buffer#set_text "" in
+  let width = Ideutils.textview_width view in
   match goals with
   | None -> ()
     (* No proof in progress *)
@@ -144,7 +145,7 @@ let display mode (view : #GText.view_skel) goals hints evars =
       (* The proof is finished, with the exception of given up goals. *)
       view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n";
       let iter goal =
-        insert_xml view#buffer goal.Interface.goal_ccl;
+        insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl);
         view#buffer#insert "\n"
       in
       List.iter iter given_up_goals;
@@ -153,7 +154,7 @@ let display mode (view : #GText.view_skel) goals hints evars =
       (* All the goals have been resolved but those on the shelf. *)
       view#buffer#insert "All the remaining goals are on the shelf:\n\n";
       let iter goal =
-        insert_xml view#buffer goal.Interface.goal_ccl;
+        insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl);
         view#buffer#insert "\n"
       in
       List.iter iter shelved_goals
@@ -166,7 +167,7 @@ let display mode (view : #GText.view_skel) goals hints evars =
       view#buffer#insert "This subproof is complete, but there are some unfocused goals:\n\n";
       let iter i goal =
         let () = view#buffer#insert (goal_str (succ i)) in
-        insert_xml view#buffer goal.Interface.goal_ccl;
+        insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl);
         view#buffer#insert "\n"
       in
       List.iteri iter bg
@@ -192,7 +193,7 @@ let proof_view () =
   let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in
   stick text_font view cb;
 
-  object
+  let pf = object
     inherit GObj.widget view#as_widget
     val mutable goals = None
     val mutable evars = None
@@ -207,9 +208,11 @@ let proof_view () =
 
     method refresh () =
       let dummy _ () = () in
-      display (mode_tactic dummy) (view :> GText.view_skel) goals None evars
-
-    method width = Ideutils.textview_width (view :> GText.view_skel)
+      display (mode_tactic dummy) view goals None evars
   end
-
-(*     ignore (proof_buffer#add_selection_clipboard cb); *)
+  in
+  (* Is there a better way to connect the signal ? *)
+  (* Can this be done in the object constructor? *)
+  let w_cb _ = pf#refresh () in
+  ignore (view#misc#connect#size_allocate w_cb);
+  pf
diff --git a/ide/wg_ProofView.mli b/ide/wg_ProofView.mli
index b6eae48b3..aa01d955d 100644
--- a/ide/wg_ProofView.mli
+++ b/ide/wg_ProofView.mli
@@ -14,7 +14,6 @@ class type proof_view =
     method clear : unit -> unit
     method set_goals : Interface.goals option -> unit
     method set_evars : Interface.evar list option -> unit
-    method width : int
   end
 
 val proof_view : unit -> proof_view
diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml
index 5f82a8898..5f80d6897 100644
--- a/ide/xmlprotocol.ml
+++ b/ide/xmlprotocol.ml
@@ -12,6 +12,9 @@
 
 let protocol_version = "20150913"
 
+type msg_format = Richpp of int | Ppcmds
+let msg_format = ref (Richpp 72)
+
 (** * Interface of calls to Coq by CoqIde *)
 
 open Util
@@ -92,10 +95,57 @@ let to_stateid = function
 
 let of_stateid i = Element ("state_id",["val",string_of_int (Stateid.to_int i)],[])
 
-let of_richpp x = Element ("richpp", [], [Richpp.repr x])
-let to_richpp xml = match xml with
-  | Element ("richpp", [], [x]) -> Richpp.richpp_of_xml x
-  | x -> raise Serialize.(Marshal_error("richpp",x))
+let of_box (ppb : Pp.block_type) = let open Pp in match ppb with
+  | Pp_hbox   i -> constructor "ppbox" "hbox"   [of_int i]
+  | Pp_vbox   i -> constructor "ppbox" "vbox"   [of_int i]
+  | Pp_hvbox  i -> constructor "ppbox" "hvbox"  [of_int i]
+  | Pp_hovbox i -> constructor "ppbox" "hovbox" [of_int i]
+
+let to_box = let open Pp in
+  do_match "ppbox" (fun s args -> match s with
+      | "hbox"   -> Pp_hbox   (to_int (singleton args))
+      | "vbox"   -> Pp_vbox   (to_int (singleton args))
+      | "hvbox"  -> Pp_hvbox  (to_int (singleton args))
+      | "hovbox" -> Pp_hovbox (to_int (singleton args))
+      | x        -> raise (Marshal_error("*ppbox",PCData x))
+    )
+
+let rec of_pp (pp : Pp.std_ppcmds) = let open Pp in match Pp.repr pp with
+    | Ppcmd_empty         -> constructor "ppdoc" "emtpy"  []
+    | Ppcmd_string s      -> constructor "ppdoc" "string" [of_string s]
+    | Ppcmd_glue sl       -> constructor "ppdoc" "glue"   [of_list of_pp sl]
+    | Ppcmd_box (bt,s)    -> constructor "ppdoc" "box"    [of_pair of_box of_pp (bt,s)]
+    | Ppcmd_tag (t,s)     -> constructor "ppdoc" "tag"    [of_pair of_string of_pp (t,s)]
+    | Ppcmd_print_break (i,j)
+                          -> constructor "ppdoc" "break"     [of_pair of_int of_int (i,j)]
+    | Ppcmd_force_newline -> constructor "ppdoc" "newline"   []
+    | Ppcmd_comment cmd   -> constructor "ppdoc" "comment" [of_list of_string cmd]
+
+
+let rec to_pp xpp = let open Pp in
+  Pp.unrepr @@
+  do_match "ppdoc" (fun s args -> match s with
+    | "empty"     -> Ppcmd_empty
+    | "string"    -> Ppcmd_string (to_string (singleton args))
+    | "glue"      -> Ppcmd_glue (to_list to_pp (singleton args))
+    | "box"       -> let (bt,s) = to_pair to_box to_pp (singleton args) in
+                     Ppcmd_box(bt,s)
+    | "tag"       -> let (tg,s) = to_pair to_string to_pp (singleton args) in
+                     Ppcmd_tag(tg,s)
+    | "break"     -> let (i,j)   = to_pair to_int to_int (singleton args) in
+                     Ppcmd_print_break(i, j)
+    | "newline"   -> Ppcmd_force_newline
+    | "comment"   -> Ppcmd_comment (to_list to_string (singleton args))
+    | x           -> raise (Marshal_error("*ppdoc",PCData x))
+  ) xpp
+
+let of_richpp x = Element ("richpp", [], [x])
+
+(* Run-time Selectable *)
+let of_pp (pp : Pp.std_ppcmds) =
+  match !msg_format with
+  | Richpp margin -> of_richpp (Richpp.richpp_of_pp margin pp)
+  | Ppcmds        -> of_pp pp
 
 let of_value f = function
 | Good x -> Element ("value", ["val", "good"], [f x])
@@ -104,7 +154,7 @@ let of_value f = function
   | None -> []
   | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in
   let id = of_stateid id in
-  Element ("value", ["val", "fail"] @ loc, [id; of_richpp msg])
+  Element ("value", ["val", "fail"] @ loc, [id; of_pp msg])
 
 let to_value f = function
 | Element ("value", attrs, l) ->
@@ -120,7 +170,7 @@ let to_value f = function
     in
     let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise (Marshal_error("val",PCData "no id attribute")) in
     let id = to_stateid id in
-    let msg = to_richpp msg in
+    let msg = to_pp msg    in
     Fail (id, loc, msg)
   else raise (Marshal_error("good or fail",PCData ans))
 | x -> raise (Marshal_error("value",x))
@@ -147,15 +197,15 @@ let to_evar = function
   | x -> raise (Marshal_error("evar",x))
 
 let of_goal g =
-  let hyp = of_list of_richpp g.goal_hyp in
-  let ccl = of_richpp g.goal_ccl in
+  let hyp = of_list of_pp g.goal_hyp in
+  let ccl = of_pp g.goal_ccl in
   let id = of_string g.goal_id in
   Element ("goal", [], [id; hyp; ccl])
 let to_goal = function
   | Element ("goal", [], [id; hyp; ccl]) ->
-    let hyp = to_list to_richpp hyp in
-    let ccl = to_richpp ccl in
-    let id = to_string id in
+    let hyp = to_list to_pp hyp in
+    let ccl = to_pp ccl         in
+    let id  = to_string id      in
     { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; }
   | x -> raise (Marshal_error("goal",x))
 
@@ -344,8 +394,8 @@ end = struct
         Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals
     else
       let pr_goal { goal_hyp = hyps; goal_ccl = goal } =
-        "[" ^ String.concat "; " (List.map Richpp.raw_print hyps) ^ " |- " ^
-            Richpp.raw_print goal ^ "]" in
+        "[" ^ String.concat "; " (List.map Pp.string_of_ppcmds hyps) ^ " |- " ^
+            Pp.string_of_ppcmds goal ^ "]" in
       String.concat " " (List.map pr_goal g.fg_goals)
   let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]"
   let pr_status (s : status) =
@@ -631,6 +681,9 @@ let of_answer : type a. a call -> a value -> xml = function
   | PrintAst _   -> of_value (of_value_type print_ast_rty_t  )
   | Annotate _   -> of_value (of_value_type annotate_rty_t   )
 
+let of_answer msg_fmt =
+  msg_format := msg_fmt; of_answer
+
 let to_answer : type a. a call -> xml -> a value = function
   | Add _        -> to_value (to_value_type add_rty_t        )
   | Edit_at _    -> to_value (to_value_type edit_at_rty_t    )
@@ -701,10 +754,10 @@ let to_call : xml -> unknown_call =
 
 let pr_value_gen pr = function
   | Good v -> "GOOD " ^ pr v
-  | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^Richpp.raw_print str^"]"
+  | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^ Pp.string_of_ppcmds str ^ "]"
   | Fail (id,Some(i,j),str) ->
       "FAIL "^Stateid.to_string id^
-        " ("^string_of_int i^","^string_of_int j^")["^Richpp.raw_print str^"]"
+        " ("^string_of_int i^","^string_of_int j^")["^Pp.string_of_ppcmds str^"]"
 let pr_value v = pr_value_gen (fun _ -> "FIXME") v
 let pr_full_value : type a. a call -> a value -> string = fun call value -> match call with
   | Add _        -> pr_value_gen (print add_rty_t        ) value
@@ -760,7 +813,7 @@ let document to_string_fmt =
     (to_string_fmt (of_value (fun _ -> PCData "b") (Good ())));
   Printf.printf "or:\n\n%s\n\nwhere the attributes loc_s and loc_c are optional.\n"
     (to_string_fmt (of_value (fun _ -> PCData "b")
-      (Fail (Stateid.initial,Some (15,34),Richpp.richpp_of_string "error message"))));
+      (Fail (Stateid.initial,Some (15,34), Pp.str "error message"))));
   document_type_encoding to_string_fmt
 
 (* Moved from feedback.mli : This is IDE specific and we don't want to
@@ -787,20 +840,14 @@ let to_message_level =
 let of_message lvl loc msg =
   let lvl     = of_message_level lvl in
   let xloc    = of_option of_loc loc in
-  let content = of_richpp msg        in
+  let content = of_pp msg            in
   Xml_datatype.Element ("message", [], [lvl; xloc; content])
 
 let to_message xml = match xml with
   | Xml_datatype.Element ("message", [], [lvl; xloc; content]) ->
-      Message(to_message_level lvl, to_option to_loc xloc, to_richpp content)
+      Message(to_message_level lvl, to_option to_loc xloc, to_pp content)
   | x -> raise (Marshal_error("message",x))
 
-let is_message xml =
-  try begin match to_message xml with
-    | Message(l,c,m) -> Some (l,c,m)
-    | _              -> None
-  end with | Marshal_error _ -> None
-
 let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with
   | "addedaxiom", _ -> AddedAxiom
   | "processed", _ -> Processed
@@ -870,6 +917,9 @@ let of_feedback msg =
   let route = string_of_int msg.route in
   Element ("feedback", obj @ ["route",route], [id;content])
 
+let of_feedback msg_fmt =
+  msg_format := msg_fmt; of_feedback
+
 let to_feedback xml = match xml with
   | Element ("feedback", ["object","edit";"route",route], [id;content]) -> {
       id = Edit(to_edit_id id);
diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli
index 1bb998970..9cefab517 100644
--- a/ide/xmlprotocol.mli
+++ b/ide/xmlprotocol.mli
@@ -40,12 +40,17 @@ val abstract_eval_call : handler -> 'a call -> 'a value
 
 val protocol_version : string
 
+(** By default, we still output messages in Richpp so we are
+    compatible with 8.6, however, 8.7 aware clients will want to
+    set this to Ppcmds *)
+type msg_format = Richpp of int | Ppcmds
+
 (** * XML data marshalling *)
 
 val of_call : 'a call -> xml
 val to_call : xml -> unknown_call
 
-val of_answer : 'a call -> 'a value -> xml
+val of_answer : msg_format -> 'a call -> 'a value -> xml
 val to_answer : 'a call -> xml -> 'a value
 
 (* Prints the documentation of this module *)
@@ -57,16 +62,8 @@ val pr_call : 'a call -> string
 val pr_value : 'a value -> string
 val pr_full_value : 'a call -> 'a value -> string
 
-(** * Serialization of rich documents *)
-val of_richpp : Richpp.richpp -> Xml_datatype.xml
-val to_richpp : Xml_datatype.xml -> Richpp.richpp
-
 (** * Serializaiton of feedback  *)
-val of_feedback : Feedback.feedback -> xml
+val of_feedback : msg_format -> Feedback.feedback -> xml
 val to_feedback : xml -> Feedback.feedback
-val is_feedback : xml -> bool
-
-val is_message : xml -> (Feedback.level * Loc.t option * Richpp.richpp) option
-val of_message : Feedback.level -> Loc.t option -> Richpp.richpp -> xml
-(* val to_message : xml -> Feedback.message *)
 
+val is_feedback : xml -> bool
diff --git a/interp/constrintern.ml b/interp/constrintern.ml
index 7eeb81050..8fee191af 100644
--- a/interp/constrintern.ml
+++ b/interp/constrintern.ml
@@ -1591,7 +1591,8 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c =
         let idl_tmp = Array.map
           (fun ((loc,id),bl,ty,_) ->
             let (env',rbl) = List.fold_left intern_local_binder (env,[]) bl in
-            let rbl = List.map (function BDRawDef a -> a | BDPattern _ -> assert false) rbl in
+            let rbl = List.map (function BDRawDef a -> a | BDPattern _ -> 
+                      Loc.raise ~loc (Stream.Error "pattern with quote not allowed after cofix")) rbl in
             (List.rev rbl,
              intern_type env' ty,env')) dl in
 	let idl = Array.map2 (fun (_,_,_,bd) (b,c,env') ->
diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml
index b020f8945..9f549b0c0 100644
--- a/interp/dumpglob.ml
+++ b/interp/dumpglob.ml
@@ -173,32 +173,33 @@ let cook_notation df sc =
   (* - all single quotes in terminal tokens are doubled                       *)
   (* - characters < 32 are represented by '^A, '^B, '^C, etc                  *)
   (* The output is decoded in function Index.prepare_entry of coqdoc          *)
-  let ntn = String.make (String.length df * 5) '_' in
+  let ntn = Bytes.make (String.length df * 5) '_' in
   let j = ref 0 in
   let l = String.length df - 1 in
   let i = ref 0 in
+  let open Bytes in             (* Bytes.set *)
   while !i <= l do
     assert (df.[!i] != ' ');
     if df.[!i] == '_' && (Int.equal !i l || df.[!i+1] == ' ') then
       (* Next token is a non-terminal *)
-      (ntn.[!j] <- 'x'; incr j; incr i)
+      (set ntn !j 'x'; incr j; incr i)
     else begin
       (* Next token is a terminal *)
-      ntn.[!j] <- '\''; incr j;
+      set ntn !j '\''; incr j;
       while !i <= l && df.[!i] != ' ' do
 	if df.[!i] < ' ' then
 	  let c = char_of_int (int_of_char 'A' + int_of_char df.[!i] - 1) in
 	  (String.blit ("'^" ^ String.make 1 c) 0 ntn !j 3; j := !j+3; incr i)
 	else begin
-	  if df.[!i] == '\'' then (ntn.[!j] <- '\''; incr j);
-	  ntn.[!j] <- df.[!i]; incr j; incr i
+	  if df.[!i] == '\'' then (set ntn !j '\''; incr j);
+	  set ntn !j df.[!i]; incr j; incr i
 	end
       done;
-      ntn.[!j] <- '\''; incr j
+      set ntn !j '\''; incr j
     end;
-    if !i <= l then (ntn.[!j] <- '_'; incr j; incr i)
+    if !i <= l then (set ntn !j '_'; incr j; incr i)
   done;
-  let df = String.sub ntn 0 !j in
+  let df = Bytes.sub_string ntn 0 !j in
   match sc with Some sc -> ":" ^ sc ^ ":" ^ df | _ -> "::" ^ df
 
 let dump_notation_location posl df (((path,secpath),_),sc) =
diff --git a/interp/notation.ml b/interp/notation.ml
index 29e5a3bfd..90ac7f729 100644
--- a/interp/notation.ml
+++ b/interp/notation.ml
@@ -927,19 +927,19 @@ let locate_notation prglob ntn scope =
   match ntns with
   | [] -> str "Unknown notation"
   | _ ->
-    t (str "Notation            " ++
-    tab () ++ str "Scope     " ++ tab () ++ fnl () ++
+    str "Notation" ++ fnl () ++
     prlist (fun (ntn,l) ->
       let scope = find_default ntn scopes in
       prlist
 	(fun (sc,r,(_,df)) ->
 	  hov 0 (
-	    pr_notation_info prglob df r ++ tbrk (1,2) ++
-	    (if String.equal sc default_scope then mt () else (str ": " ++ str sc)) ++
-	    tbrk (1,2) ++
-	    (if Option.equal String.equal (Some sc) scope then str "(default interpretation)" else mt ())
+	    pr_notation_info prglob df r ++
+	    (if String.equal sc default_scope then mt ()
+             else (spc () ++ str ": " ++ str sc)) ++
+	    (if Option.equal String.equal (Some sc) scope
+             then spc () ++ str "(default interpretation)" else mt ())
 	    ++ fnl ()))
-	l) ntns)
+	l) ntns
 
 let collect_notation_in_scope scope sc known =
   assert (not (String.equal scope default_scope));
diff --git a/interp/ppextend.ml b/interp/ppextend.ml
index 37bbe0ce8..87ca25325 100644
--- a/interp/ppextend.ml
+++ b/interp/ppextend.ml
@@ -23,12 +23,9 @@ type ppbox =
   | PpHOVB of int
   | PpHVB of int
   | PpVB of int
-  | PpTB
 
 type ppcut =
   | PpBrk of int * int
-  | PpTbrk of int * int
-  | PpTab
   | PpFnl
 
 let ppcmd_of_box = function
@@ -36,13 +33,10 @@ let ppcmd_of_box = function
   | PpHOVB n -> hov n
   | PpHVB n -> hv n
   | PpVB n -> v n
-  | PpTB   -> t
 
 let ppcmd_of_cut = function
-  | PpTab -> tab ()
   | PpFnl -> fnl ()
   | PpBrk(n1,n2) -> brk(n1,n2)
-  | PpTbrk(n1,n2) -> tbrk(n1,n2)
 
 type unparsing =
   | UnpMetaVar of int * parenRelation
diff --git a/interp/ppextend.mli b/interp/ppextend.mli
index de7a42eee..09dc36943 100644
--- a/interp/ppextend.mli
+++ b/interp/ppextend.mli
@@ -23,12 +23,9 @@ type ppbox =
   | PpHOVB of int
   | PpHVB of int
   | PpVB of int
-  | PpTB
 
 type ppcut =
   | PpBrk of int * int
-  | PpTbrk of int * int
-  | PpTab
   | PpFnl
 
 val ppcmd_of_box : ppbox -> std_ppcmds -> std_ppcmds
diff --git a/interp/topconstr.ml b/interp/topconstr.ml
index 407cec084..fd57b70ca 100644
--- a/interp/topconstr.ml
+++ b/interp/topconstr.ml
@@ -60,6 +60,9 @@ let rec cases_pattern_fold_names f a = function
   | CPatPrim _ | CPatAtom _ -> a
   | CPatCast _ -> assert false
 
+let ids_of_pattern =
+  cases_pattern_fold_names Id.Set.add Id.Set.empty
+
 let ids_of_pattern_list =
   List.fold_left
     (Loc.located_fold_left
@@ -173,7 +176,8 @@ let split_at_annot bl na =
               (List.rev ans, LocalRawAssum (r, k, t) :: rest)
             end
 	| LocalRawDef _ as x :: rest -> aux (x :: acc) rest
-        | LocalPattern _ :: rest -> assert false
+        | LocalPattern (loc,_,_) :: rest ->
+            Loc.raise ~loc (Stream.Error "pattern with quote not allowed after fix")
 	| [] ->
             user_err ~loc 
 			 (str "No parameter named " ++ Nameops.pr_id id ++ str".")
@@ -196,8 +200,9 @@ let map_local_binders f g e bl =
         (map_binder g e nal, LocalRawAssum(nal,k,f e ty)::bl)
     | LocalRawDef((loc,na),ty) ->
         (name_fold g na e, LocalRawDef((loc,na),f e ty)::bl)
-    | LocalPattern _ ->
-        assert false in
+    | LocalPattern (loc,pat,t) ->
+        let ids = ids_of_pattern pat in
+        (Id.Set.fold g ids e, LocalPattern (loc,pat,Option.map (f e) t)::bl) in
   let (e,rbl) = List.fold_left h (e,[]) bl in
   (e, List.rev rbl)
 
diff --git a/intf/misctypes.mli b/intf/misctypes.mli
index e4f595ac4..33dc2a335 100644
--- a/intf/misctypes.mli
+++ b/intf/misctypes.mli
@@ -28,7 +28,7 @@ and 'constr intro_pattern_action_expr =
   | IntroWildcard
   | IntroOrAndPattern of 'constr or_and_intro_pattern_expr
   | IntroInjection of (Loc.t * 'constr intro_pattern_expr) list
-  | IntroApplyOn of 'constr * (Loc.t * 'constr intro_pattern_expr)
+  | IntroApplyOn of (Loc.t * 'constr) * (Loc.t * 'constr intro_pattern_expr)
   | IntroRewrite of bool
 and 'constr or_and_intro_pattern_expr =
   | IntroOrPattern of (Loc.t * 'constr intro_pattern_expr) list list
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index 810c34699..94ca4c72d 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -299,7 +299,7 @@ and pp_bytecodes c =
   | Ksequence (l1, l2) :: c ->
       pp_bytecodes l1 ++ pp_bytecodes l2 ++  pp_bytecodes c
   | i :: c ->
-      tab () ++ pp_instr i ++ fnl () ++ pp_bytecodes c
+      pp_instr i ++ fnl () ++ pp_bytecodes c
 
 (*spiwack: moved this type in this file  because I needed it for
   retroknowledge which can't depend from cbytegen *)
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index ad7a41a34..40c1e027d 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -24,33 +24,45 @@ type reloc_info =
 type patch = reloc_info * int
 
 let patch_char4 buff pos c1 c2 c3 c4 = 
-  String.unsafe_set buff pos       c1;
-  String.unsafe_set buff (pos + 1) c2;
-  String.unsafe_set buff (pos + 2) c3;
-  String.unsafe_set buff (pos + 3) c4 
+  Bytes.unsafe_set buff pos       c1;
+  Bytes.unsafe_set buff (pos + 1) c2;
+  Bytes.unsafe_set buff (pos + 2) c3;
+  Bytes.unsafe_set buff (pos + 3) c4 
   
 let patch buff (pos, n) =
   patch_char4 buff pos 
     (Char.unsafe_chr n) (Char.unsafe_chr (n asr 8))  (Char.unsafe_chr (n asr 16))
     (Char.unsafe_chr (n asr 24))
 
+(* val patch_int : emitcodes -> ((\*pos*\)int * int) list -> emitcodes *)
 let patch_int buff patches =
   (* copy code *before* patching because of nested evaluations:
      the code we are patching might be called (and thus "concurrently" patched)
      and results in wrong results. Side-effects... *)
-  let buff = String.copy buff in
+  let buff = Bytes.of_string buff in
   let () = List.iter (fun p -> patch buff p) patches in
-  buff
+  (* Note: we follow the apporach suggested by Gabriel Scherer in
+     PR#136 here, and use unsafe as we own buff.
+
+     The crux of the question that avoids defining emitcodes just as a
+     Byte.t is the call to hcons in to_memory below. Even if disabling
+     this optimization has no visible time impact, test data shows
+     that the optimization is indeed triggered quite often so we
+     choose ugliness over altering the semantics.
+
+     Handle with care.
+  *)
+  Bytes.unsafe_to_string buff
 
 (* Buffering of bytecode *)
 
-let out_buffer = ref(String.create 1024)
+let out_buffer = ref(Bytes.create 1024)
 and out_position = ref 0
 
 let out_word b1 b2 b3 b4 =
   let p = !out_position in
-  if p >= String.length !out_buffer then begin
-    let len = String.length !out_buffer in
+  if p >= Bytes.length !out_buffer then begin
+    let len = Bytes.length !out_buffer in
     let new_len =
       if len <= Sys.max_string_length / 2
       then 2 * len
@@ -58,8 +70,8 @@ let out_word b1 b2 b3 b4 =
 	if len = Sys.max_string_length
 	then invalid_arg "String.create"  (* Pas la bonne exception .... *)
 	else Sys.max_string_length in
-    let new_buffer = String.create new_len in
-    String.blit !out_buffer 0 new_buffer 0 len;
+    let new_buffer = Bytes.create new_len in
+    Bytes.blit !out_buffer 0 new_buffer 0 len;
     out_buffer := new_buffer
   end;
   patch_char4 !out_buffer p (Char.unsafe_chr b1)
@@ -94,10 +106,10 @@ let extend_label_table needed =
 
 let backpatch (pos, orig) =
   let displ = (!out_position - orig) asr 2 in
-  !out_buffer.[pos]   <- Char.unsafe_chr displ;
-  !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8);
-  !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16);
-  !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24)
+  Bytes.set !out_buffer  pos    @@ Char.unsafe_chr displ;
+  Bytes.set !out_buffer (pos+1) @@ Char.unsafe_chr (displ asr 8);
+  Bytes.set !out_buffer (pos+2) @@ Char.unsafe_chr (displ asr 16);
+  Bytes.set !out_buffer (pos+3) @@ Char.unsafe_chr (displ asr 24)
 
 let define_label lbl =
   if lbl >= Array.length !label_table then extend_label_table lbl;
@@ -262,41 +274,44 @@ let emit_instr = function
   | Kstop ->
       out opSTOP
 
-(* Emission of a list of instructions. Include some peephole optimization. *)
+(* Emission of a current list and remaining lists of instructions. Include some peephole optimization. *)
 
-let rec emit = function
-  | [] -> ()
+let rec emit insns remaining = match insns with
+  | [] -> 
+     (match remaining with 
+       [] -> () 
+     | (first::rest) -> emit first rest)
   (* Peephole optimizations *)
   | Kpush :: Kacc n :: c ->
       if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
-      emit c
+      emit c remaining
   | Kpush :: Kenvacc n :: c ->
       if n >= 1 && n <= 4
       then out(opPUSHENVACC1 + n - 1)
       else (out opPUSHENVACC; out_int n);
-      emit c
+      emit c remaining
   | Kpush :: Koffsetclosure ofs :: c ->
       if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2
       then out(opPUSHOFFSETCLOSURE0 + ofs / 2)
       else (out opPUSHOFFSETCLOSURE; out_int ofs);
-      emit c
+      emit c remaining
   | Kpush :: Kgetglobal id :: c ->
-      out opPUSHGETGLOBAL; slot_for_getglobal id; emit c
+      out opPUSHGETGLOBAL; slot_for_getglobal id; emit c remaining
   | Kpush :: Kconst (Const_b0 i) :: c ->
       if i >= 0 && i <= 3
       then out (opPUSHCONST0 + i)
       else (out opPUSHCONSTINT; out_int i);
-      emit c
+      emit c remaining
   | Kpush :: Kconst const :: c ->
       out opPUSHGETGLOBAL; slot_for_const const;
-      emit c
+      emit c remaining
   | Kpop n :: Kjump :: c ->
-      out opRETURN; out_int n; emit c
+      out opRETURN; out_int n; emit c remaining
   | Ksequence(c1,c2)::c ->
-      emit c1; emit c2;emit c
+      emit c1 (c2::c::remaining)
   (* Default case *)
   | instr :: c ->
-      emit_instr instr; emit c
+      emit_instr instr; emit c remaining
 
 (* Initialization *)
 
@@ -305,7 +320,7 @@ let init () =
   label_table := Array.make 16 (Label_undefined []);
   reloc_info := []
 
-type emitcodes = string
+type emitcodes = String.t
 
 let length = String.length
 
@@ -367,11 +382,10 @@ let repr_body_code = function
 
 let to_memory (init_code, fun_code, fv) =
   init();
-  emit init_code;
-  emit fun_code;
-  let code = String.create !out_position in
-  String.unsafe_blit !out_buffer 0 code 0 !out_position;
+  emit init_code [];
+  emit fun_code [];
   (** Later uses of this string are all purely functional *)
+  let code = Bytes.sub_string !out_buffer 0 !out_position in
   let code = CString.hcons code in
   let reloc = List.rev !reloc_info in
   Array.iter (fun lbl ->
diff --git a/kernel/entries.mli b/kernel/entries.mli
index 77081947e..1e07c9690 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.mli
@@ -113,5 +113,3 @@ type side_effect = {
   from_env : Declarations.structure_body CEphemeron.key;
   eff      : side_eff;
 }
-
-type side_effects = side_effect list
diff --git a/kernel/names.ml b/kernel/names.ml
index 1f138581c..ee8d838da 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -50,17 +50,20 @@ struct
   | None -> true
   | Some _ -> false
 
+  let of_bytes s =
+    let s = Bytes.to_string s in
+    check_soft s;
+    String.hcons s
+
   let of_string s =
     let () = check_soft s in
-    let s = String.copy s in
     String.hcons s
 
   let of_string_soft s =
     let () = check_soft ~warn:false s in
-    let s = String.copy s in
     String.hcons s
 
-  let to_string id = String.copy id
+  let to_string id = id
 
   let print id = str id
 
diff --git a/kernel/names.mli b/kernel/names.mli
index 6b0a80625..be9b9422b 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -43,6 +43,7 @@ sig
   (** Check that a string may be converted to an identifier.
   @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *)
 
+  val of_bytes : bytes -> t
   val of_string : string -> t
   (** Converts a string into an identifier.
       @raise UserError if the string is not valid, or echo a warning if it contains invalid identifier characters.
diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml
index 8093df304..965ed67b0 100644
--- a/kernel/nativevalues.ml
+++ b/kernel/nativevalues.ml
@@ -491,12 +491,12 @@ let str_encode expr =
 let str_decode s =
   let mshl_expr_len = String.length s / 2 in
   let mshl_expr = Buffer.create mshl_expr_len in
-  let buf = String.create 2 in
+  let buf = Bytes.create 2 in
   for i = 0 to mshl_expr_len - 1 do
-    String.blit s (2*i) buf 0 2;
-    Buffer.add_char mshl_expr (bin_of_hex buf)
+    Bytes.blit_string s (2*i) buf 0 2;
+    Buffer.add_char mshl_expr (bin_of_hex (Bytes.to_string buf))
   done;
-  Marshal.from_string (Buffer.contents mshl_expr) 0
+  Marshal.from_bytes (Buffer.to_bytes mshl_expr) 0
 
 (** Retroknowledge, to be removed when we switch to primitive integers *)
 
diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml
index 130f1eb03..f147ea343 100644
--- a/kernel/opaqueproof.ml
+++ b/kernel/opaqueproof.ml
@@ -136,7 +136,7 @@ let dump (otab,_) =
   let disch_table = Array.make n a_discharge in
   let f2t_map = ref FMap.empty in
   Int.Map.iter (fun n (d,cu) ->
-    let c, u = Future.split2 ~greedy:true cu in
+    let c, u = Future.split2 cu in
     Future.sink u;
     Future.sink c;
     opaque_table.(n) <- c;
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index e4b3fcbf1..caaaff1b8 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -71,7 +71,7 @@ module NamedDecl = Context.Named.Declaration
   - [env] : the underlying environment (cf Environ)
   - [modpath] : the current module name
   - [modvariant] :
-    * NONE before coqtop initialization (or when -notop is used)
+    * NONE before coqtop initialization
     * LIBRARY at toplevel of a compilation or a regular coqtop session
     * STRUCT (params,oldsenv) : inside a local module, with
       module parameters [params] and earlier environment [oldsenv]
@@ -208,19 +208,19 @@ let get_opaque_body env cbo =
          Opaqueproof.force_constraints (Environ.opaque_tables env) opaque)
 
 type private_constant = Entries.side_effect
-type private_constants = private_constant list
+type private_constants = Term_typing.side_effects
 
 type private_constant_role = Term_typing.side_effect_role =
   | Subproof
   | Schema of inductive * string
 
-let empty_private_constants = []
-let add_private x xs = if List.mem_f Term_typing.equal_eff x xs then xs else x :: xs
-let concat_private xs ys = List.fold_right add_private xs ys
+let empty_private_constants = Term_typing.empty_seff
+let add_private = Term_typing.add_seff
+let concat_private = Term_typing.concat_seff
 let mk_pure_proof = Term_typing.mk_pure_proof
 let inline_private_constants_in_constr = Term_typing.inline_side_effects
 let inline_private_constants_in_definition_entry = Term_typing.inline_entry_side_effects
-let side_effects_of_private_constants x = Term_typing.uniq_seff (List.rev x)
+let side_effects_of_private_constants = Term_typing.uniq_seff
 
 let private_con_of_con env c =
   let cbo = Environ.lookup_constant c env.env in
@@ -250,7 +250,7 @@ let universes_of_private eff =
      | Entries.SEsubproof (c, cb, e) ->
 	if cb.const_polymorphic then acc
 	else Univ.ContextSet.of_context cb.const_universes :: acc)
-   [] eff
+   [] (Term_typing.uniq_seff eff)
 
 let env_of_safe_env senv = senv.env
 let env_of_senv = env_of_safe_env
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 15ebc7d88..efeb98bd2 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -47,11 +47,18 @@ type private_constant_role =
   | Schema of inductive * string
 
 val side_effects_of_private_constants :
-  private_constants -> Entries.side_effects
+  private_constants -> Entries.side_effect list
+(** Return the list of individual side-effects in the order of their
+    creation. *)
 
 val empty_private_constants : private_constants
 val add_private : private_constant -> private_constants -> private_constants
+(** Add a constant to a list of private constants. The former must be more
+    recent than all constants appearing in the latter, i.e. one should not
+    create a dependency cycle. *)
 val concat_private : private_constants -> private_constants -> private_constants
+(** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in
+    [e1] must be more recent than those of [e2]. *)
 
 val private_con_of_con : safe_environment -> constant -> private_constant
 val private_con_of_scheme : kind:string -> safe_environment -> (inductive * constant) list -> private_constant
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index 3a0d1a2a5..2eb2c040e 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -24,28 +24,8 @@ open Typeops
 module RelDecl = Context.Rel.Declaration
 module NamedDecl = Context.Named.Declaration
 
-let constrain_type env j poly subst = function
-  | `None -> 
-    if not poly then (* Old-style polymorphism *)
-      make_polymorphic_if_constant_for_ind env j
-    else RegularArity (Vars.subst_univs_level_constr subst j.uj_type)
-  | `Some t ->
-      let tj = infer_type env t in
-      let _ = judge_of_cast env j DEFAULTcast tj in
-	assert (eq_constr t tj.utj_val);
-	RegularArity (Vars.subst_univs_level_constr subst t)
-  | `SomeWJ (t, tj) ->
-      let tj = infer_type env t in
-      let _ = judge_of_cast env j DEFAULTcast tj in
-	assert (eq_constr t tj.utj_val);
-	RegularArity (Vars.subst_univs_level_constr subst t)
-
-let map_option_typ = function None -> `None | Some x -> `Some x
-
 (* Insertion of constants and parameters in environment. *)
 
-let mk_pure_proof c = (c, Univ.ContextSet.empty), []
-
 let equal_eff e1 e2 =
   let open Entries in
   match e1, e2 with
@@ -57,13 +37,54 @@ let equal_eff e1 e2 =
           cl1 cl2
   | _ -> false
 
-let rec uniq_seff = function
-  | [] -> []
-  | x :: xs -> x :: uniq_seff (List.filter (fun y -> not (equal_eff x y)) xs)
-(* The list of side effects is in reverse order (most recent first).
- * To keep the "topological" order between effects we have to uniq-ize from
- * the tail *)
-let uniq_seff l = List.rev (uniq_seff (List.rev l))
+module SideEffects :
+sig
+  type t
+  val repr : t -> side_effect list
+  val empty : t
+  val add : side_effect -> t -> t
+  val concat : t -> t -> t
+end =
+struct
+
+let compare_seff e1 e2 = match e1, e2 with
+| SEsubproof (c1, _, _), SEsubproof (c2, _, _) -> Constant.CanOrd.compare c1 c2
+| SEscheme (cl1, _), SEscheme (cl2, _) ->
+  let cmp (_, c1, _, _) (_, c2, _, _) = Constant.CanOrd.compare c1 c2 in
+  CList.compare cmp cl1 cl2
+| SEsubproof _, SEscheme _ -> -1
+| SEscheme _, SEsubproof _ -> 1
+
+module SeffOrd = struct
+type t = side_effect
+let compare e1 e2 = compare_seff e1.eff e2.eff
+end
+
+module SeffSet = Set.Make(SeffOrd)
+
+type t = { seff : side_effect list; elts : SeffSet.t }
+(** Invariant: [seff] is a permutation of the elements of [elts] *)
+
+let repr eff = eff.seff
+let empty = { seff = []; elts = SeffSet.empty }
+let add x es =
+  if SeffSet.mem x es.elts then es
+  else { seff = x :: es.seff; elts = SeffSet.add x es.elts }
+let concat xes yes =
+  List.fold_right add xes.seff yes
+
+end
+
+type side_effects = SideEffects.t
+
+let uniq_seff_rev = SideEffects.repr
+let uniq_seff l = List.rev (SideEffects.repr l)
+
+let empty_seff = SideEffects.empty
+let add_seff = SideEffects.add
+let concat_seff = SideEffects.concat
+
+let mk_pure_proof c = (c, Univ.ContextSet.empty), empty_seff
 
 let inline_side_effects env body ctx side_eff =
   let handle_sideff (t,ctx,sl) { eff = se; from_env = mb } =
@@ -76,8 +97,7 @@ let inline_side_effects env body ctx side_eff =
     let cbl = List.filter not_exists cbl in
     let cname c = 
       let name = string_of_con c in
-      for i = 0 to String.length name - 1 do
-        if name.[i] == '.' || name.[i] == '#' then name.[i] <- '_' done;
+      let name = String.map (fun c -> if c == '.' || c == '#' then '_' else c) name in
       Name (id_of_string name) in
     let rec sub c i x = match kind_of_term x with
       | Const (c', _) when eq_constant c c' -> mkRel i
@@ -117,7 +137,7 @@ let inline_side_effects env body ctx side_eff =
     t, ctx, (mb,List.length cbl) :: sl
   in
   (* CAVEAT: we assure a proper order *)
-  List.fold_left handle_sideff (body,ctx,[]) (uniq_seff side_eff)
+  List.fold_left handle_sideff (body,ctx,[]) (uniq_seff_rev side_eff)
 
 (* Given the list of signatures of side effects, checks if they match.
  * I.e. if they are ordered descendants of the current revstruct *)
@@ -184,6 +204,10 @@ let infer_declaration ~trust env kn dcl =
       let t = hcons_constr (Vars.subst_univs_level_constr usubst c) in
 	Undef nl, RegularArity t, None, poly, univs, false, ctx
 
+  (** Definition [c] is opaque (Qed), non polymorphic and with a specified type,
+      so we delay the typing and hash consing of its body.
+      Remark: when the universe quantification is given explicitly, we could
+      delay even in the polymorphic case.  *)
   | DefinitionEntry ({ const_entry_type = Some typ;
                        const_entry_opaque = true;
 		       const_entry_polymorphic = false} as c) ->
@@ -191,19 +215,20 @@ let infer_declaration ~trust env kn dcl =
       let { const_entry_body = body; const_entry_feedback = feedback_id } = c in
       let tyj = infer_type env typ in
       let proofterm =
-        Future.chain ~greedy:true ~pure:true body (fun ((body,uctx),side_eff) ->
+        Future.chain ~pure:true body (fun ((body,uctx),side_eff) ->
           let body, uctx, signatures =
             inline_side_effects env body uctx side_eff in
           let valid_signatures = check_signatures trust signatures in
-	  let env' = push_context_set uctx env in
+	  let env = push_context_set uctx env in
           let j =
-            let body,env',ectx = skip_trusted_seff valid_signatures body env' in
-            let j = infer env' body in
+            let body,env,ectx = skip_trusted_seff valid_signatures body env in
+            let j = infer env body in
             unzip ectx j in
           let j = hcons_j j in
 	  let subst = Univ.LMap.empty in
-          let _typ = constrain_type env' j c.const_entry_polymorphic subst
-	    (`SomeWJ (typ,tyj)) in
+          let _ = judge_of_cast env j DEFAULTcast tyj in
+          assert (eq_constr typ tyj.utj_val);
+          let _typ = RegularArity (Vars.subst_univs_level_constr subst typ) in
           feedback_completion_typecheck feedback_id;
           j.uj_val, uctx) in
       let def = OpaqueDef (Opaqueproof.create proofterm) in
@@ -211,6 +236,7 @@ let infer_declaration ~trust env kn dcl =
 	c.const_entry_universes,
 	c.const_entry_inline_code, c.const_entry_secctx
 
+  (** Other definitions have to be processed immediately. *)
   | DefinitionEntry c ->
       let { const_entry_type = typ; const_entry_opaque = opaque } = c in
       let { const_entry_body = body; const_entry_feedback = feedback_id } = c in
@@ -223,7 +249,17 @@ let infer_declaration ~trust env kn dcl =
       let usubst, univs =
 	Univ.abstract_universes abstract (Univ.ContextSet.to_context ctx) in      
       let j = infer env body in
-      let typ = constrain_type env j c.const_entry_polymorphic usubst (map_option_typ typ) in
+      let typ = match typ with
+        | None ->
+           if not c.const_entry_polymorphic then (* Old-style polymorphism *)
+             make_polymorphic_if_constant_for_ind env j
+           else RegularArity (Vars.subst_univs_level_constr usubst j.uj_type)
+        | Some t ->
+           let tj = infer_type env t in
+           let _ = judge_of_cast env j DEFAULTcast tj in
+           assert (eq_constr t tj.utj_val);
+           RegularArity (Vars.subst_univs_level_constr usubst t)
+      in
       let def = hcons_constr (Vars.subst_univs_level_constr usubst j.uj_val) in
       let def = 
 	if opaque then OpaqueDef (Opaqueproof.create (Future.from_val (def, Univ.ContextSet.empty)))
@@ -383,7 +419,7 @@ let constant_entry_of_side_effect cb u =
     | Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty
     | _ -> assert false in
   DefinitionEntry {
-    const_entry_body = Future.from_val (pt, []);
+    const_entry_body = Future.from_val (pt, empty_seff);
     const_entry_secctx = None;
     const_entry_feedback = None;
     const_entry_type =
@@ -416,8 +452,8 @@ let export_side_effects mb env ce =
       let { const_entry_body = body } = c in
       let _, eff = Future.force body in
       let ce = DefinitionEntry { c with
-        const_entry_body = Future.chain ~greedy:true ~pure:true body
-          (fun (b_ctx, _) -> b_ctx, []) } in
+        const_entry_body = Future.chain ~pure:true body
+          (fun (b_ctx, _) -> b_ctx, empty_seff) } in
       let not_exists (c,_,_,_) =
         try ignore(Environ.lookup_constant c env); false
         with Not_found -> true in 
@@ -429,7 +465,7 @@ let export_side_effects mb env ce =
         let cbl = List.filter not_exists cbl in
         if cbl = [] then acc, sl
         else cbl :: acc, (mb,List.length cbl) :: sl in
-      let seff, signatures = List.fold_left aux ([],[]) (uniq_seff eff) in
+      let seff, signatures = List.fold_left aux ([],[]) (uniq_seff_rev eff) in
       let trusted = check_signatures mb signatures in
       let push_seff env = function
         | kn, cb, `Nothing, _ ->
@@ -498,10 +534,10 @@ let translate_local_def mb env id centry =
 let translate_mind env kn mie = Indtypes.check_inductive env kn mie
 
 let inline_entry_side_effects env ce = { ce with
-  const_entry_body = Future.chain ~greedy:true ~pure:true
+  const_entry_body = Future.chain ~pure:true
     ce.const_entry_body (fun ((body, ctx), side_eff) ->
       let body, ctx',_ = inline_side_effects env body ctx side_eff in
-      (body, ctx'), []);
+      (body, ctx'), empty_seff);
 }
 
 let inline_side_effects env body side_eff =
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index 89b5fc40e..075389ea5 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.mli
@@ -12,6 +12,8 @@ open Environ
 open Declarations
 open Entries
 
+type side_effects
+
 val translate_local_def : structure_body -> env -> Id.t -> side_effects definition_entry ->
   constant_def * types * constant_universes
 
@@ -29,7 +31,15 @@ val inline_entry_side_effects :
     {!Entries.const_entry_body} field. It is meant to get a term out of a not
     yet type checked proof. *)
 
-val uniq_seff : side_effects -> side_effects
+val empty_seff : side_effects
+val add_seff : side_effect -> side_effects -> side_effects
+val concat_seff : side_effects -> side_effects -> side_effects
+(** [concat_seff e1 e2] adds the side-effects of [e1] to [e2], i.e. effects in
+    [e1] must be more recent than those of [e2]. *)
+val uniq_seff : side_effects -> side_effect list
+(** Return the list of individual side-effects in the order of their
+    creation. *)
+
 val equal_eff : side_effect -> side_effect -> bool
 
 val translate_constant :
diff --git a/lib/cErrors.ml b/lib/cErrors.ml
index dbebe6a48..99b763602 100644
--- a/lib/cErrors.ml
+++ b/lib/cErrors.ml
@@ -16,16 +16,6 @@ let push = Backtrace.add_backtrace
 
 exception Anomaly of string option * std_ppcmds (* System errors *)
 
-(* XXX: To move to common tagging functions in Pp, blocked on tag
- * system cleanup as we cannot define generic error tags now.
- *
- * Anyways, tagging should not happen here, but in the specific
- * listener to the msg_* stuff.
- *)
-let tag_err_str s = tag Ppstyle.(Tag.inj error_tag tag) (str s) ++ spc ()
-let err_str       = tag_err_str "Error:"
-let ann_str       = tag_err_str "Anomaly:"
-
 let _ =
   let pr = function
   | Anomaly (s, pp) -> Some ("\"Anomaly: " ^ string_of_ppcmds pp ^ "\"")
@@ -102,7 +92,7 @@ let print_backtrace e = match Backtrace.get_backtrace e with
 
 let print_anomaly askreport e =
   if askreport then
-    hov 0 (ann_str ++ raw_anomaly e ++ spc () ++
+    hov 0 (raw_anomaly e ++ spc () ++
            strbrk "Please report at " ++ str Coq_config.wwwbugtracker ++
            str ".")
   else
@@ -124,7 +114,7 @@ let iprint_no_report (e, info) =
 
 let _ = register_handler begin function
   | UserError(s, pps) ->
-    hov 0 (err_str ++ where s ++ pps)
+    hov 0 (where s ++ pps)
   | _ -> raise Unhandled
 end
 
@@ -147,13 +137,3 @@ let handled e =
   let bottom _ = raise Bottom in
   try let _ = print_gen bottom !handle_stack e in true
   with Bottom -> false
-
-(** Prints info which is either an error or
-   an anomaly and then exits with the appropriate
-   error code *)
-
-let fatal_error info anomaly =
-  let msg = info ++ fnl () in
-  pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft msg;
-  Format.pp_print_flush !Pp_control.err_ft ();
-  exit (if anomaly then 129 else 1)
diff --git a/lib/cErrors.mli b/lib/cErrors.mli
index 5cffc725d..0665a8ce7 100644
--- a/lib/cErrors.mli
+++ b/lib/cErrors.mli
@@ -98,8 +98,3 @@ val noncritical : exn -> bool
 (** Check whether an exception is handled by some toplevel printer. The
     [Anomaly] exception is never handled. *)
 val handled : exn -> bool
-
-(** Prints info which is either an error or
-   an anomaly and then exits with the appropriate
-   error code *)
-val fatal_error : Pp.std_ppcmds -> bool -> 'a
diff --git a/lib/cThread.ml b/lib/cThread.ml
index 4f60a6974..9f642b3ce 100644
--- a/lib/cThread.ml
+++ b/lib/cThread.ml
@@ -36,7 +36,7 @@ let really_read_fd fd s off len =
 let really_read_fd_2_oc fd oc len =
   let i = ref 0 in
   let size = 4096 in
-  let s = String.create size in
+  let s = Bytes.create size in
   while !i < len do
     let len = len - !i in
     let r = thread_friendly_read_fd fd s ~off:0 ~len:(min len size) in
@@ -55,11 +55,13 @@ let thread_friendly_really_read_line ic =
   try
     let fd = Unix.descr_of_in_channel ic in
     let b = Buffer.create 1024 in
-    let s = String.make 1 '\000' in
-    while s <> "\n" do
+    let s = Bytes.make 1 '\000' in
+    let endl = Bytes.of_string "\n" in
+    (* Bytes.equal is in 4.03.0 *)
+    while Bytes.compare s endl <> 0 do
       let n = thread_friendly_read_fd fd s ~off:0 ~len:1 in
       if n = 0 then raise End_of_file;
-      if s <> "\n" then Buffer.add_string b s;
+      if Bytes.compare s endl <> 0 then Buffer.add_bytes b s;
     done;
     Buffer.contents b
   with Unix.Unix_error _ -> raise End_of_file
@@ -67,15 +69,15 @@ let thread_friendly_really_read_line ic =
 let thread_friendly_input_value ic =
   try
     let fd = Unix.descr_of_in_channel ic in
-    let header = String.create Marshal.header_size in
+    let header = Bytes.create Marshal.header_size in
     really_read_fd fd header 0 Marshal.header_size;
     let body_size = Marshal.data_size header 0 in
     let desired_size = body_size + Marshal.header_size in
     if desired_size <= Sys.max_string_length then begin
-      let msg = String.create desired_size in
-      String.blit header 0 msg 0 Marshal.header_size;
+      let msg = Bytes.create desired_size in
+      Bytes.blit header 0 msg 0 Marshal.header_size;
       really_read_fd fd msg Marshal.header_size body_size;
-      Marshal.from_string msg 0
+      Marshal.from_bytes msg 0
     end else begin
       (* Workaround for 32 bit systems and data > 16M *)
       let name, oc =
diff --git a/lib/cThread.mli b/lib/cThread.mli
index 7302dfb55..36477a116 100644
--- a/lib/cThread.mli
+++ b/lib/cThread.mli
@@ -19,8 +19,8 @@ val prepare_in_channel_for_thread_friendly_io : in_channel -> thread_ic
 
 val thread_friendly_input_value : thread_ic -> 'a
 val thread_friendly_read :
-  thread_ic -> string -> off:int -> len:int -> int
+  thread_ic -> Bytes.t -> off:int -> len:int -> int
 val thread_friendly_really_read :
-  thread_ic -> string -> off:int -> len:int -> unit
+  thread_ic -> Bytes.t -> off:int -> len:int -> unit
 val thread_friendly_really_read_line : thread_ic -> string
 
diff --git a/lib/cUnix.ml b/lib/cUnix.ml
index cb436511f..2542b9751 100644
--- a/lib/cUnix.ml
+++ b/lib/cUnix.ml
@@ -91,15 +91,15 @@ let rec waitpid_non_intr pid =
 let run_command ?(hook=(fun _ ->())) c =
   let result = Buffer.create 127 in
   let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
-  let buff = String.make 127 ' ' in
-  let buffe = String.make 127 ' ' in
+  let buff = Bytes.make 127 ' ' in
+  let buffe = Bytes.make 127 ' ' in
   let n = ref 0 in
   let ne = ref 0 in
   while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ;
     !n+ !ne <> 0
   do
-    let r = String.sub buff 0 !n in (hook r; Buffer.add_string result r);
-    let r = String.sub buffe 0 !ne in (hook r; Buffer.add_string result r);
+    let r = Bytes.sub buff 0 !n in (hook r; Buffer.add_bytes result r);
+    let r = Bytes.sub buffe 0 !ne in (hook r; Buffer.add_bytes result r);
   done;
   (Unix.close_process_full (cin,cout,cerr),  Buffer.contents result)
 
diff --git a/lib/cUnix.mli b/lib/cUnix.mli
index f03719c3d..c6bcf6347 100644
--- a/lib/cUnix.mli
+++ b/lib/cUnix.mli
@@ -46,7 +46,7 @@ val file_readable_p : string -> bool
     is called on each elements read on stdout or stderr. *)
 
 val run_command :
-  ?hook:(string->unit) -> string -> Unix.process_status * string
+  ?hook:(bytes->unit) -> string -> Unix.process_status * string
 
 (** [sys_command] launches program [prog] with arguments [args].
     It behaves like [Sys.command], except that we rely on
diff --git a/lib/clib.mllib b/lib/clib.mllib
index 1e33173ee..c73ae9b90 100644
--- a/lib/clib.mllib
+++ b/lib/clib.mllib
@@ -15,7 +15,6 @@ Store
 Exninfo
 Backtrace
 IStream
-Pp_control
 Flags
 Control
 Loc
@@ -28,8 +27,6 @@ CStack
 Util
 Stateid
 Pp
-Ppstyle
-Richpp
 Feedback
 CUnix
 Envars
diff --git a/lib/feedback.ml b/lib/feedback.ml
index 57c6f30a4..7d9d6bf7f 100644
--- a/lib/feedback.ml
+++ b/lib/feedback.ml
@@ -35,7 +35,7 @@ type feedback_content =
   (* Extra metadata *)
   | Custom of Loc.t * string * xml
   (* Generic messages *)
-  | Message of level * Loc.t option * Richpp.richpp
+  | Message of level * Loc.t option * Pp.std_ppcmds
 
 type feedback = {
   id : edit_or_state_id;
@@ -45,146 +45,16 @@ type feedback = {
 
 let default_route = 0
 
-(** Feedback and logging *)
-open Pp
-open Pp_control
-
-type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit
-
-let msgnl_with ?pp_tag fmt strm = msg_with ?pp_tag fmt (strm ++ fnl ())
-
-(* XXX: This is really painful! *)
-module Emacs = struct
-
-  (* Special chars for emacs, to detect warnings inside goal output *)
-  let emacs_quote_start = String.make 1 (Char.chr 254)
-  let emacs_quote_end   = String.make 1 (Char.chr 255)
-
-  let emacs_quote_err g =
-    hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end)
-
-  let emacs_quote_info_start = "<infomsg>"
-  let emacs_quote_info_end = "</infomsg>"
-
-  let emacs_quote_info g =
-    hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end)
-
-end
-
-open Emacs
-
-let  dbg_str = tag Ppstyle.(Tag.inj debug_tag   tag) (str "Debug:")   ++ spc ()
-let info_str = mt ()
-let warn_str = tag Ppstyle.(Tag.inj warning_tag tag) (str "Warning:") ++ spc ()
-let  err_str = tag Ppstyle.(Tag.inj error_tag   tag) (str "Error:"  ) ++ spc ()
-
-let make_body quoter info ?loc s =
-  let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in
-  quoter (hov 0 (loc ++ info ++ s))
-
-(* Generic logger *)
-let gen_logger dbg err ?pp_tag ?loc level msg = match level with
-  | Debug   -> msgnl_with ?pp_tag !std_ft (make_body dbg  dbg_str ?loc msg)
-  | Info    -> msgnl_with ?pp_tag !std_ft (make_body dbg info_str ?loc msg)
-  | Notice  -> msgnl_with ?pp_tag !std_ft msg
-  | Warning -> Flags.if_warn (fun () ->
-               msgnl_with ?pp_tag !err_ft (make_body err warn_str ?loc msg)) ()
-  | Error   -> msgnl_with ?pp_tag !err_ft (make_body err  err_str ?loc msg)
-
-(* We provide a generic clear_log_backend callback for backends
-   wanting to do clenaup after the print.
-*)
-let std_logger_tag     = ref None
-let std_logger_cleanup = ref (fun () -> ())
-
-let std_logger ?loc level msg =
-  gen_logger (fun x -> x) (fun x -> x) ?pp_tag:!std_logger_tag ?loc level msg;
-  !std_logger_cleanup ()
-
-(* Rules for emacs:
-   - Debug/info: emacs_quote_info
-   - Warning/Error: emacs_quote_err
-   - Notice: unquoted
-
-  Note the inconsistency.
- *)
-let emacs_logger = gen_logger emacs_quote_info emacs_quote_err ?pp_tag:None
-
-(** Color logging. Moved from pp_style, it may need some more refactoring  *)
-
-(** Not thread-safe. We should put a lock somewhere if we print from
-    different threads. Do we? *)
-let make_style_stack () =
-  (** Default tag is to reset everything *)
-  let empty = Terminal.make () in
-  let default_tag = Terminal.({
-      fg_color = Some `DEFAULT;
-      bg_color = Some `DEFAULT;
-      bold = Some false;
-      italic = Some false;
-      underline = Some false;
-      negative = Some false;
-    })
-  in
-  let style_stack = ref [] in
-  let peek () = match !style_stack with
-  | []      -> default_tag  (** Anomalous case, but for robustness *)
-  | st :: _ -> st
-  in
-  let push tag =
-    let style = match Ppstyle.get_style tag with
-      | None    -> empty
-      | Some st -> st
-    in
-    (** Use the merging of the latest tag and the one being currently pushed.
-    This may be useful if for instance the latest tag changes the background and
-    the current one the foreground, so that the two effects are additioned. *)
-    let style = Terminal.merge (peek ()) style in
-    style_stack := style :: !style_stack;
-    Terminal.eval style
-  in
-  let pop _ = match !style_stack with
-  | []       -> (** Something went wrong, we fallback *)
-                Terminal.eval default_tag
-  | _ :: rem -> style_stack := rem;
-                Terminal.eval (peek ())
-  in
-  let clear () = style_stack := [] in
-  push, pop, clear
-
-let init_color_output () =
-  let open Pp_control in
-  let push_tag, pop_tag, clear_tag = make_style_stack () in
-  std_logger_cleanup := clear_tag;
-  std_logger_tag     := Some Ppstyle.pp_tag;
-  let tag_handler = {
-    Format.mark_open_tag   = push_tag;
-    Format.mark_close_tag  = pop_tag;
-    Format.print_open_tag  = ignore;
-    Format.print_close_tag = ignore;
-  } in
-  Format.pp_set_mark_tags !std_ft true;
-  Format.pp_set_mark_tags !err_ft true;
-  Format.pp_set_formatter_tag_functions !std_ft tag_handler;
-  Format.pp_set_formatter_tag_functions !err_ft tag_handler
-
-let logger       = ref std_logger
-let set_logger l = logger := l
-
-let msg_info    ?loc x = !logger ?loc Info x
-let msg_notice  ?loc x = !logger ?loc Notice x
-let msg_warning ?loc x = !logger ?loc Warning x
-let msg_error   ?loc x = !logger ?loc Error x
-let msg_debug   ?loc x = !logger ?loc Debug x
-
 (** Feeders *)
-let feeders = ref []
-let add_feeder f = feeders := f :: !feeders
+let feeders : (int, feedback -> unit) Hashtbl.t = Hashtbl.create 7
 
-let debug_feeder = function
-  | { contents = Message (Debug, loc, pp) } ->
-       msg_debug ?loc (Pp.str (Richpp.raw_print pp))
-  | _ -> ()
+let add_feeder =
+  let f_id = ref 0 in fun f ->
+  incr f_id;
+  Hashtbl.add feeders !f_id f;
+  !f_id
+
+let del_feeder fid = Hashtbl.remove feeders fid
 
 let feedback_id    = ref (Edit 0)
 let feedback_route = ref default_route
@@ -198,34 +68,14 @@ let feedback ?id ?route what =
      route = Option.default !feedback_route route;
      id    = Option.default !feedback_id id;
   } in
-  List.iter (fun f -> f m) !feeders
+  Hashtbl.iter (fun _ f -> f m) feeders
 
+(* Logging messages *)
 let feedback_logger ?loc lvl msg =
-  feedback ~route:!feedback_route ~id:!feedback_id
-    (Message (lvl, loc, Richpp.richpp_of_pp msg))
-
-(* Output to file *)
-let ft_logger old_logger ft ?loc level mesg =
-  let id x = x in
-  match level with
-  | Debug   -> msgnl_with ft (make_body id  dbg_str mesg)
-  | Info    -> msgnl_with ft (make_body id info_str mesg)
-  | Notice  -> msgnl_with ft mesg
-  | Warning -> old_logger ?loc level mesg
-  | Error   -> old_logger ?loc level mesg
-
-let with_output_to_file fname func input =
-  let old_logger = !logger in
-  let channel = open_out (String.concat "." [fname; "out"]) in
-  logger := ft_logger old_logger (Format.formatter_of_out_channel channel);
-  try
-    let output = func input in
-    logger := old_logger;
-    close_out channel;
-    output
-  with reraise ->
-    let reraise = Backtrace.add_backtrace reraise in
-    logger := old_logger;
-    close_out channel;
-    Exninfo.iraise reraise
+  feedback ~route:!feedback_route ~id:!feedback_id (Message (lvl, loc, msg))
 
+let msg_info    ?loc x = feedback_logger ?loc Info x
+let msg_notice  ?loc x = feedback_logger ?loc Notice x
+let msg_warning ?loc x = feedback_logger ?loc Warning x
+let msg_error   ?loc x = feedback_logger ?loc Error x
+let msg_debug   ?loc x = feedback_logger ?loc Debug x
diff --git a/lib/feedback.mli b/lib/feedback.mli
index b4bed8793..4bbdfcb5b 100644
--- a/lib/feedback.mli
+++ b/lib/feedback.mli
@@ -8,7 +8,7 @@
 
 open Xml_datatype
 
-(* Old plain messages (used to be in Pp) *)
+(* Legacy-style logging messages (used to be in Pp) *)
 type level =
   | Debug
   | Info
@@ -16,7 +16,6 @@ type level =
   | Warning
   | Error
 
-
 (** Coq "semantic" infos obtained during parsing/execution *)
 type edit_id = int
 type state_id = Stateid.t
@@ -44,7 +43,7 @@ type feedback_content =
   (* Extra metadata *)
   | Custom of Loc.t * string * xml
   (* Generic messages *)
-  | Message of level * Loc.t option * Richpp.richpp
+  | Message of level * Loc.t option * Pp.std_ppcmds
 
 type feedback = {
   id       : edit_or_state_id;  (* The document part concerned *)
@@ -53,37 +52,17 @@ type feedback = {
 }
 
 (** {6 Feedback sent, even asynchronously, to the user interface} *)
-
-(** Moved here from pp.ml *)
-
 (* Morally the parser gets a string and an edit_id, and gives back an AST.
  * Feedbacks during the parsing phase are attached to this edit_id.
  * The interpreter assignes an exec_id to the ast, and feedbacks happening
  * during interpretation are attached to the exec_id.
  * Only one among state_id and edit_id can be provided. *)
 
-(** A [logger] takes a level plus a pretty printing doc and logs it *)
-type logger = ?loc:Loc.t -> level -> Pp.std_ppcmds -> unit
-
-(** [set_logger l] makes the [msg_*] to use [l] for logging *)
-val set_logger : logger -> unit
-
-(** [std_logger] standard logger to [stdout/stderr]  *)
-val std_logger : logger
-
-(** [init_color_output ()] Enable color in the std_logger *)
-val init_color_output : unit -> unit
-
-(** [feedback_logger] will produce feedback messages instead IO events *)
-val feedback_logger : logger
-val emacs_logger    : logger
+(** [add_feeder f] adds a feeder listiner [f], returning its id *)
+val add_feeder : (feedback -> unit) -> int
 
-
-(** [add_feeder] feeders observe the feedback *)
-val add_feeder : (feedback -> unit) -> unit
-
-(** Prints feedback messages of kind Message(Debug,_) using msg_debug *)
-val debug_feeder : feedback -> unit
+(** [del_feeder fid] removes the feeder with id [fid] *)
+val del_feeder : int -> unit
 
 (** [feedback ?id ?route fb] produces feedback fb, with [route] and
     [id] set appropiatedly, if absent, it will use the defaults set by
@@ -94,10 +73,6 @@ val feedback :
 (** [set_id_for_feedback route id] Set the defaults for feedback *)
 val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit
 
-(** [with_output_to_file file f x] executes [f x] with logging
-    redirected to a file [file] *)
-val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b
-
 (** {6 output functions}
 
 [msg_notice] do not put any decoration on output by default. If
@@ -125,7 +100,3 @@ val msg_error : ?loc:Loc.t -> Pp.std_ppcmds -> unit
 
 val msg_debug : ?loc:Loc.t -> Pp.std_ppcmds -> unit
 (** For debugging purposes *)
-
-
-
-
diff --git a/lib/future.ml b/lib/future.ml
index ea0382a63..1360b7ac4 100644
--- a/lib/future.ml
+++ b/lib/future.ml
@@ -151,8 +151,8 @@ let chain ~pure ck f =
   create ~uuid ~name fix_exn (match !c with
   | Closure _ | Delegated _ -> Closure (fun () -> f (force ~pure ck))
   | Exn _ as x -> x
-  | Val (v, None) when pure -> Closure (fun () -> f v)
-  | Val (v, Some _) when pure -> Closure (fun () -> f v)
+  | Val (v, None)   when pure -> Val (f v, None)
+  | Val (v, Some _) when pure -> Val (f v, None)
   | Val (v, Some state) -> Closure (fun () -> !unfreeze state; f v)
   | Val (v, None) ->
       match !ck with
@@ -191,9 +191,9 @@ let transactify f x =
 let purify_future f x = if is_over x then f x else purify f x
 let compute x = purify_future (compute ~pure:false) x
 let force ~pure x = purify_future (force ~pure) x
-let chain ?(greedy=true) ~pure x f =
+let chain ~pure x f =
   let y = chain ~pure x f in
-  if is_over x && greedy then ignore(force ~pure y);
+  if is_over x then ignore(force ~pure y);
   y
 let force x = force ~pure:false x
 
@@ -204,13 +204,13 @@ let join kx =
 
 let sink kx = if is_val kx then ignore(join kx)
 
-let split2 ?greedy x =
-  chain ?greedy ~pure:true x (fun x -> fst x),
-  chain ?greedy ~pure:true x (fun x -> snd x)
+let split2 x =
+  chain ~pure:true x (fun x -> fst x),
+  chain ~pure:true x (fun x -> snd x)
 
-let map2 ?greedy f x l =
+let map2 f x l =
   CList.map_i (fun i y ->
-    let xi = chain ?greedy ~pure:true x (fun x ->
+    let xi = chain ~pure:true x (fun x ->
         try List.nth x i
         with Failure _ | Invalid_argument _ ->
           CErrors.anomaly (Pp.str "Future.map2 length mismatch")) in
diff --git a/lib/future.mli b/lib/future.mli
index c780faf32..2a025ae84 100644
--- a/lib/future.mli
+++ b/lib/future.mli
@@ -113,8 +113,9 @@ val is_exn : 'a computation -> bool
 val peek_val : 'a computation -> 'a option
 val uuid : 'a computation -> UUID.t
 
-(* [chain greedy pure c f] chains computation [c] with [f].
- * The [greedy] and [pure] parameters are tricky:
+(* [chain pure c f] chains computation [c] with [f].
+ * [chain] forces immediately the new computation if the old one is_over (Exn or Val).
+ * The [pure] parameter is tricky:
  * [pure]:
  *   When pure is true, the returned computation will not keep a copy
  *   of the global state.
@@ -124,10 +125,8 @@ val uuid : 'a computation -> UUID.t
  *   one forces c' and then c''.
  *   [join c; chain ~pure:false c g] is invalid and fails at runtime.
  *   [force c; chain ~pure:false c g] is correct.
- * [greedy]:
- *   The [greedy] parameter forces immediately the new computation if
- *   the old one is_over (Exn or Val). Defaults to true. *)
-val chain : ?greedy:bool -> pure:bool ->
+ *)
+val chain : pure:bool ->
   'a computation -> ('a -> 'b) -> 'b computation
 
 (* Forcing a computation *)
@@ -143,9 +142,9 @@ val join : 'a computation -> 'a
 val sink : 'a computation -> unit
 
 (*** Utility functions ************************************************* ***)
-val split2 : ?greedy:bool ->
+val split2 :
   ('a * 'b) computation -> 'a computation * 'b computation
-val map2 : ?greedy:bool ->
+val map2 :
   ('a computation -> 'b -> 'c) ->
      'a list computation -> 'b list -> 'c list
 
diff --git a/lib/pp.ml b/lib/pp.ml
index f3bb47539..9f33756df 100644
--- a/lib/pp.ml
+++ b/lib/pp.ml
@@ -6,64 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-module Glue : sig
-
-  (** The [Glue] module implements a container data structure with
-      efficient concatenation. *)
-
-  type 'a t
-
-  val atom : 'a -> 'a t
-  val glue : 'a t -> 'a t -> 'a t
-  val empty : 'a t
-  val is_empty : 'a t -> bool
-  val iter : ('a -> unit) -> 'a t -> unit
-
-end = struct
-
-  type 'a t = GEmpty | GLeaf of 'a | GNode of 'a t * 'a t
-
-  let atom x = GLeaf x
-
-  let glue x y =
-    match x, y with
-    | GEmpty, _ -> y
-    | _, GEmpty -> x
-    | _, _ -> GNode (x,y)
-
-  let empty = GEmpty
-
-  let is_empty x = x = GEmpty
-
-  let rec iter f = function
-    | GEmpty -> ()
-    | GLeaf x -> f x
-    | GNode (x,y) -> iter f x; iter f y
-
-end
-
-module Tag :
-sig
-  type t 
-  type 'a key
-  val create : string -> 'a key
-  val inj : 'a -> 'a key -> t
-  val prj : t -> 'a key -> 'a option
-end =
-struct
-
-module Dyn = Dyn.Make(struct end)
-
-type t = Dyn.t
-type 'a key = 'a Dyn.tag
-let create = Dyn.create
-let inj = Dyn.Easy.inj
-let prj = Dyn.Easy.prj
-
-end
-
-open Pp_control
-
 (* The different kinds of blocks are:
    \begin{description}
    \item[hbox:] Horizontal block no line breaking;
@@ -72,54 +14,35 @@ open Pp_control
       this block is small enough to fit on a single line
    \item[hovbox:] Horizontal or Vertical block: breaks lead to new line
       only when necessary to print the content of the block
-   \item[tbox:] Tabulation block: go to tabulation marks and no line breaking
-      (except if no mark yet on the reste of the line)
    \end{description}
  *)
 
+type pp_tag = string
+
 type block_type =
-  | Pp_hbox of int
-  | Pp_vbox of int
-  | Pp_hvbox of int
+  | Pp_hbox   of int
+  | Pp_vbox   of int
+  | Pp_hvbox  of int
   | Pp_hovbox of int
-  | Pp_tbox
-
-type str_token =
-| Str_def of string
-| Str_len of string * int (** provided length *)
 
-type 'a ppcmd_token =
-  | Ppcmd_print of 'a
-  | Ppcmd_box of block_type * ('a ppcmd_token Glue.t)
+type doc_view =
+  | Ppcmd_empty
+  | Ppcmd_string of string
+  | Ppcmd_glue of doc_view list
+  | Ppcmd_box  of block_type * doc_view
+  | Ppcmd_tag of pp_tag * doc_view
+  (* Are those redundant? *)
   | Ppcmd_print_break of int * int
-  | Ppcmd_set_tab
-  | Ppcmd_print_tbreak of int * int
-  | Ppcmd_white_space of int
   | Ppcmd_force_newline
-  | Ppcmd_print_if_broken
-  | Ppcmd_open_box of block_type
-  | Ppcmd_close_box
-  | Ppcmd_close_tbox
   | Ppcmd_comment of string list
-  | Ppcmd_open_tag of Tag.t
-  | Ppcmd_close_tag
-
-type 'a ppdir_token =
-  | Ppdir_ppcmds of 'a ppcmd_token Glue.t
-  | Ppdir_print_newline
-  | Ppdir_print_flush
-
-type ppcmd = str_token ppcmd_token
 
-type std_ppcmds = ppcmd Glue.t
+(* Following discussion on #390, we play on the safe side and make the
+   internal representation opaque here. *)
+type t = doc_view
+type std_ppcmds = t
 
-type 'a ppdirs = 'a ppdir_token Glue.t
-
-let (++) = Glue.glue
-
-let app = Glue.glue
-
-let is_empty g = Glue.is_empty g
+let repr x = x
+let unrepr x = x
 
 (* Compute length of an UTF-8 encoded string
    Rem 1 : utf8_length <= String.length (equal if pure ascii)
@@ -157,25 +80,32 @@ let utf8_length s =
   done ;
   !cnt
 
+let app s1 s2 = match s1, s2 with
+  | Ppcmd_empty, s
+  | s, Ppcmd_empty -> s
+  | s1, s2         -> Ppcmd_glue [s1; s2]
+
+let seq s = Ppcmd_glue s
+
+let (++) = app
+
 (* formatting commands *)
-let str s = Glue.atom(Ppcmd_print (Str_def s))
-let stras (i, s) = Glue.atom(Ppcmd_print (Str_len (s, i)))
-let brk (a,b) = Glue.atom(Ppcmd_print_break (a,b))
-let tbrk (a,b) = Glue.atom(Ppcmd_print_tbreak (a,b))
-let tab () = Glue.atom(Ppcmd_set_tab)
-let fnl () = Glue.atom(Ppcmd_force_newline)
-let pifb () = Glue.atom(Ppcmd_print_if_broken)
-let ws n = Glue.atom(Ppcmd_white_space n)
-let comment l = Glue.atom(Ppcmd_comment l)
+let str s     = Ppcmd_string s
+let brk (a,b) = Ppcmd_print_break (a,b)
+let fnl  ()   = Ppcmd_force_newline
+let ws n      = Ppcmd_print_break (n,0)
+let comment l = Ppcmd_comment l
 
 (* derived commands *)
-let mt () = Glue.empty
-let spc () = Glue.atom(Ppcmd_print_break (1,0))
-let cut () = Glue.atom(Ppcmd_print_break (0,0))
-let align () = Glue.atom(Ppcmd_print_break (0,0))
-let int n = str (string_of_int n)
-let real r = str (string_of_float r)
-let bool b = str (string_of_bool b)
+let mt    () = Ppcmd_empty
+let spc   () = Ppcmd_print_break (1,0)
+let cut   () = Ppcmd_print_break (0,0)
+let align () = Ppcmd_print_break (0,0)
+let int   n  = str (string_of_int n)
+let real  r  = str (string_of_float r)
+let bool  b  = str (string_of_bool b)
+
+(* XXX: To Remove *)
 let strbrk s =
   let rec aux p n =
     if n < String.length s then
@@ -184,7 +114,7 @@ let strbrk s =
         else str (String.sub s p (n-p)) :: spc () :: aux (n+1) (n+1)
       else aux p (n + 1)
     else if p = n then [] else [str (String.sub s p (n-p))]
-  in List.fold_left (++) Glue.empty (aux 0 0)
+  in Ppcmd_glue (aux 0 0)
 
 let pr_loc_pos loc =
   if Loc.is_ghost loc then (str"<unknown>")
@@ -205,29 +135,16 @@ let pr_loc loc =
 	   int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++
 	   str":" ++ fnl())
 
-let ismt = is_empty
+let ismt = function | Ppcmd_empty -> true | _ -> false
 
 (* boxing commands *)
-let h n s = Glue.atom(Ppcmd_box(Pp_hbox n,s))
-let v n s = Glue.atom(Ppcmd_box(Pp_vbox n,s))
-let hv n s = Glue.atom(Ppcmd_box(Pp_hvbox n,s))
-let hov n s = Glue.atom(Ppcmd_box(Pp_hovbox n,s))
-let t s = Glue.atom(Ppcmd_box(Pp_tbox,s))
-
-(* Opening and closing of boxes *)
-let hb n = Glue.atom(Ppcmd_open_box(Pp_hbox n))
-let vb n = Glue.atom(Ppcmd_open_box(Pp_vbox n))
-let hvb n = Glue.atom(Ppcmd_open_box(Pp_hvbox n))
-let hovb n = Glue.atom(Ppcmd_open_box(Pp_hovbox n))
-let tb () = Glue.atom(Ppcmd_open_box Pp_tbox)
-let close () = Glue.atom(Ppcmd_close_box)
-let tclose () = Glue.atom(Ppcmd_close_tbox)
+let h   n s = Ppcmd_box(Pp_hbox n,s)
+let v   n s = Ppcmd_box(Pp_vbox n,s)
+let hv  n s = Ppcmd_box(Pp_hvbox n,s)
+let hov n s = Ppcmd_box(Pp_hovbox n,s)
 
 (* Opening and closed of tags *)
-let open_tag t = Glue.atom(Ppcmd_open_tag t)
-let close_tag () = Glue.atom(Ppcmd_close_tag)
-let tag t s = open_tag t ++ s ++ close_tag ()
-let eval_ppcmds l = l
+let tag t s = Ppcmd_tag(t,s)
 
 (* In new syntax only double quote char is escaped by repeating it *)
 let escape_string s =
@@ -254,71 +171,34 @@ let rec pr_com ft s =
       Some s2 -> Format.pp_force_newline ft (); pr_com ft s2
     | None -> ()
 
-type tag_handler = Tag.t -> Format.tag
-
 (* pretty printing functions *)
-let pp_dirs ?pp_tag ft =
-  let pp_open_box = function
+let pp_with ft =
+  let cpp_open_box = function
     | Pp_hbox n   -> Format.pp_open_hbox ft ()
     | Pp_vbox n   -> Format.pp_open_vbox ft n
     | Pp_hvbox n  -> Format.pp_open_hvbox ft n
     | Pp_hovbox n -> Format.pp_open_hovbox ft n
-    | Pp_tbox     -> Format.pp_open_tbox ft ()
   in
-  let rec pp_cmd = function
-    | Ppcmd_print tok         ->
-        begin match tok with
-        | Str_def s ->
-          let n = utf8_length s in
-          Format.pp_print_as ft n s
-        | Str_len (s, n) ->
-          Format.pp_print_as ft n s
-        end
-    | Ppcmd_box(bty,ss)       -> (* Prevent evaluation of the stream! *)
-        pp_open_box bty ;
-        if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss;
-        Format.pp_close_box ft ()
-    | Ppcmd_open_box bty      -> pp_open_box bty
-    | Ppcmd_close_box         -> Format.pp_close_box ft ()
-    | Ppcmd_close_tbox        -> Format.pp_close_tbox ft ()
-    | Ppcmd_white_space n     -> Format.pp_print_break ft n 0
-    | Ppcmd_print_break(m,n)  -> Format.pp_print_break ft m n
-    | Ppcmd_set_tab           -> Format.pp_set_tab ft ()
-    | Ppcmd_print_tbreak(m,n) -> Format.pp_print_tbreak ft m n
-    | Ppcmd_force_newline     -> Format.pp_force_newline ft ()
-    | Ppcmd_print_if_broken   -> Format.pp_print_if_newline ft ()
+  let rec pp_cmd = let open Format in function
+    | Ppcmd_empty             -> ()
+    | Ppcmd_glue sl           -> List.iter pp_cmd sl
+    | Ppcmd_string str        -> let n = utf8_length str in
+                                 pp_print_as ft n str
+    | Ppcmd_box(bty,ss)       -> cpp_open_box bty ;
+                                 if not (over_max_boxes ()) then pp_cmd ss;
+                                 pp_close_box ft ()
+    | Ppcmd_print_break(m,n)  -> pp_print_break ft m n
+    | Ppcmd_force_newline     -> pp_force_newline ft ()
     | Ppcmd_comment coms      -> List.iter (pr_com ft) coms
-    | Ppcmd_open_tag tag ->
-      begin match pp_tag with
-      | None -> ()
-      | Some f -> Format.pp_open_tag ft (f tag)
-      end
-    | Ppcmd_close_tag ->
-      begin match pp_tag with
-      | None -> ()
-      | Some _ -> Format.pp_close_tag ft ()
-      end
-  in
-  let pp_dir = function
-    | Ppdir_ppcmds cmdstream -> Glue.iter pp_cmd cmdstream
-    | Ppdir_print_newline    -> Format.pp_print_newline ft ()
-    | Ppdir_print_flush      -> Format.pp_print_flush ft ()
+    | Ppcmd_tag(tag, s)       -> pp_open_tag  ft tag;
+                                 pp_cmd s;
+                                 pp_close_tag ft ()
   in
-  fun (dirstream : _ ppdirs) ->
-    try
-      Glue.iter pp_dir dirstream
-    with reraise ->
-      let reraise = Backtrace.add_backtrace reraise in
-      let () = Format.pp_print_flush ft () in
-      Exninfo.iraise reraise
-
-(* pretty printing functions WITHOUT FLUSH *)
-let pp_with ?pp_tag ft strm =
-  pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm))
-
-(* pretty printing functions WITH FLUSH *)
-let msg_with ?pp_tag ft strm =
-  pp_dirs ?pp_tag ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush))
+  try pp_cmd
+  with reraise ->
+    let reraise = Backtrace.add_backtrace reraise in
+    let () = Format.pp_print_flush ft () in
+    Exninfo.iraise reraise
 
 (* If mixing some output and a goal display, please use msg_warning,
    so that interfaces (proofgeneral for example) can easily dispatch
@@ -326,7 +206,7 @@ let msg_with ?pp_tag ft strm =
 
 (** Output to a string formatter *)
 let string_of_ppcmds c =
-  Format.fprintf Format.str_formatter "@[%a@]" (msg_with ?pp_tag:None) c;
+  Format.fprintf Format.str_formatter "@[%a@]" pp_with c;
   Format.flush_str_formatter ()
 
 (* Copy paste from Util *)
@@ -353,7 +233,7 @@ let pr_nth n =
 
 (* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *)
 
-let prlist pr l = List.fold_left (fun x e -> x ++ pr e) Glue.empty l
+let prlist pr l = Ppcmd_glue (List.map pr l)
 
 (* unlike all other functions below, [prlist] works lazily.
    if a strict behavior is needed, use [prlist_strict] instead.
@@ -418,4 +298,3 @@ let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v
 let prvect elem v = prvect_with_sep mt elem v
 
 let surround p = hov 1 (str"(" ++ p ++ str")")
-
diff --git a/lib/pp.mli b/lib/pp.mli
index 8342a983d..802ffe8e7 100644
--- a/lib/pp.mli
+++ b/lib/pp.mli
@@ -6,19 +6,65 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** Pretty-printers. *)
+(** Coq document type. *)
+
+(** Pretty printing guidelines ******************************************)
+(*                                                                      *)
+(* `Pp.t` or `Pp.std_ppcmds` is the main pretty printing document type  *)
+(* in the Coq system. Documents are composed laying out boxes, and      *)
+(* users can add arbitrary tag metadata that backends are free          *)
+(*                                                                      *)
+(* The datatype has a public view to allow serialization or advanced    *)
+(* uses, however regular users are _strongly_ warned againt its use,    *)
+(* they should instead rely on the available functions below.           *)
+(*                                                                      *)
+(* Box order and number is indeed an important factor. Try to create    *)
+(* a proper amount of boxes. The `++` operator provides "efficient"     *)
+(* concatenation, but using the list constructors is usually preferred. *)
+(*                                                                      *)
+(* That is to say, this:                                                *)
+(*                                                                      *)
+(* `hov [str "Term"; hov (pr_term t); str "is defined"]`                *)
+(*                                                                      *)
+(* is preferred to:                                                     *)
+(*                                                                      *)
+(* `hov (str "Term" ++ hov (pr_term t) ++ str "is defined")`            *)
+(*                                                                      *)
+(************************************************************************)
 
-type std_ppcmds
+(* XXX: Improve and add attributes *)
+type pp_tag = string
+
+(* Following discussion on #390, we play on the safe side and make the
+   internal representation opaque here. *)
+type t
+type std_ppcmds = t
+
+type block_type =
+  | Pp_hbox   of int
+  | Pp_vbox   of int
+  | Pp_hvbox  of int
+  | Pp_hovbox of int
+
+type doc_view =
+  | Ppcmd_empty
+  | Ppcmd_string of string
+  | Ppcmd_glue of t list
+  | Ppcmd_box  of block_type * t
+  | Ppcmd_tag  of pp_tag * t
+  (* Are those redundant? *)
+  | Ppcmd_print_break of int * int
+  | Ppcmd_force_newline
+  | Ppcmd_comment of string list
+
+val repr   : std_ppcmds -> doc_view
+val unrepr : doc_view -> std_ppcmds
 
 (** {6 Formatting commands} *)
 
 val str   : string -> std_ppcmds
-val stras : int * string -> std_ppcmds
 val brk   : int * int -> std_ppcmds
-val tbrk  : int * int -> std_ppcmds
-val tab   : unit -> std_ppcmds
 val fnl   : unit -> std_ppcmds
-val pifb  : unit -> std_ppcmds
 val ws    : int -> std_ppcmds
 val mt    : unit -> std_ppcmds
 val ismt  : std_ppcmds -> bool
@@ -30,15 +76,12 @@ val comment  : string list -> std_ppcmds
 val app : std_ppcmds -> std_ppcmds -> std_ppcmds
 (** Concatenation. *)
 
+val seq : std_ppcmds list -> std_ppcmds
+(** Multi-Concatenation. *)
+
 val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds
 (** Infix alias for [app]. *)
 
-val eval_ppcmds : std_ppcmds -> std_ppcmds
-(** Force computation. *)
-
-val is_empty : std_ppcmds -> bool
-(** Test emptyness. *)
-
 (** {6 Derived commands} *)
 
 val spc : unit -> std_ppcmds
@@ -58,46 +101,10 @@ val h : int -> std_ppcmds -> std_ppcmds
 val v : int -> std_ppcmds -> std_ppcmds
 val hv : int -> std_ppcmds -> std_ppcmds
 val hov : int -> std_ppcmds -> std_ppcmds
-val t : std_ppcmds -> std_ppcmds
-
-(** {6 Opening and closing of boxes} *)
-
-val hb : int -> std_ppcmds
-val vb : int -> std_ppcmds
-val hvb : int -> std_ppcmds
-val hovb : int -> std_ppcmds
-val tb : unit -> std_ppcmds
-val close : unit -> std_ppcmds
-val tclose : unit -> std_ppcmds
-
-(** {6 Opening and closing of tags} *)
-
-module Tag :
-sig
-  type t
-  (** Type of tags. Tags are dynamic types comparable to {Dyn.t}. *)
-
-  type 'a key
-  (** Keys used to inject tags *)
 
-  val create : string -> 'a key
-  (** Create a key with the given name. Two keys cannot share the same name, if
-      ever this is the case this function raises an assertion failure. *)
+(** {6 Tagging} *)
 
-  val inj : 'a -> 'a key -> t
-  (** Inject an object into a tag. *)
-
-  val prj : t -> 'a key -> 'a option
-  (** Project an object from a tag. *)
-end
-
-val tag : Tag.t -> std_ppcmds -> std_ppcmds
-val open_tag : Tag.t -> std_ppcmds
-val close_tag : unit -> std_ppcmds
-
-(** {6 Utilities} *)
-
-val string_of_ppcmds : std_ppcmds -> string
+val tag : pp_tag -> std_ppcmds -> std_ppcmds
 
 (** {6 Printing combinators} *)
 
@@ -164,16 +171,11 @@ val surround : std_ppcmds -> std_ppcmds
 (** Surround with parenthesis. *)
 
 val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds
-
 val pr_loc : Loc.t -> std_ppcmds
 
-(** {6 Low-level pretty-printing functions with and without flush} *)
+(** {6 Main renderers, to formatter and to string } *)
 
-(** FIXME: These ignore the logging settings and call [Format] directly *)
-type tag_handler = Tag.t -> Format.tag
+(** [pp_with fmt pp] Print [pp] to [fmt] and don't flush [fmt]  *)
+val pp_with          : Format.formatter -> std_ppcmds -> unit
 
-(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and flush [fmt]  *)
-val msg_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit
-
-(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and don't flush [fmt]  *)
-val pp_with  : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit
+val string_of_ppcmds : std_ppcmds -> string
diff --git a/lib/pp_control.ml b/lib/pp_control.ml
deleted file mode 100644
index 890ffe0a1..000000000
--- a/lib/pp_control.ml
+++ /dev/null
@@ -1,93 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Parameters of pretty-printing *)
-
-type pp_global_params = {
-  margin : int;
-  max_indent : int;
-  max_depth : int;
-  ellipsis : string }
-
-(* Default parameters of pretty-printing *)
-
-let dflt_gp = {
-  margin     = 78;
-  max_indent = 50;
-  max_depth  = 50;
-  ellipsis   = "..." }
-
-(* A deeper pretty-printer to print proof scripts *)
-
-let deep_gp = {
-  margin     = 78;
-  max_indent = 50;
-  max_depth  = 10000;
-  ellipsis   = "..." }
-
-(* set_gp : Format.formatter -> pp_global_params -> unit
- * set the parameters of a formatter *)
-
-let set_gp ft gp =
-  Format.pp_set_margin ft gp.margin ;
-  Format.pp_set_max_indent ft gp.max_indent ;
-  Format.pp_set_max_boxes ft gp.max_depth ;
-  Format.pp_set_ellipsis_text ft gp.ellipsis
-
-let set_dflt_gp ft = set_gp ft dflt_gp
-
-let get_gp ft =
-  { margin = Format.pp_get_margin ft ();
-    max_indent = Format.pp_get_max_indent ft ();
-    max_depth = Format.pp_get_max_boxes ft ();
-    ellipsis = Format.pp_get_ellipsis_text ft () }
-
-(* with_fp : 'a pp_formatter_params -> Format.formatter
- * returns of formatter for given formatter functions *)
-
-let with_fp chan out_function flush_function =
-  let ft = Format.make_formatter out_function flush_function in
-  Format.pp_set_formatter_out_channel ft chan;
-  ft
-
-(* Output on a channel ch *)
-
-let with_output_to ch =
-  let ft = with_fp ch (output ch) (fun () -> flush ch) in
-  set_gp ft deep_gp;
-  ft
-
-let std_ft = ref Format.std_formatter
-let _ = set_dflt_gp !std_ft
-
-let err_ft = ref Format.err_formatter
-let _ = set_gp !err_ft deep_gp
-
-let deep_ft = ref (with_output_to stdout)
-let _ = set_gp !deep_ft deep_gp
-
-(* For parametrization through vernacular *)
-let default = Format.pp_get_max_boxes !std_ft ()
-let default_margin = Format.pp_get_margin !std_ft ()
-
-let get_depth_boxes () = Some (Format.pp_get_max_boxes !std_ft ())
-let set_depth_boxes v =
-  Format.pp_set_max_boxes !std_ft (match v with None -> default | Some v -> v)
-
-let get_margin () = Some (Format.pp_get_margin !std_ft ())
-let set_margin v =
-  let v = match v with None -> default_margin | Some v -> v in
-  Format.pp_set_margin Format.str_formatter v;
-  Format.pp_set_margin !std_ft v;
-  Format.pp_set_margin !deep_ft v;
-  (* Heuristic, based on usage: the column on the right of max_indent
-     column is 20% of width, capped to 30 characters *)
-  let m = max (64 * v / 100) (v-30) in
-  Format.pp_set_max_indent Format.str_formatter m;
-  Format.pp_set_max_indent !std_ft m;
-  Format.pp_set_max_indent !deep_ft m
diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml
deleted file mode 100644
index aa47c5167..000000000
--- a/lib/ppstyle.ml
+++ /dev/null
@@ -1,73 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-module String = CString
-
-type t = string
-(** We use the concatenated string, with dots separating each string. We
-    forbid the use of dots in the strings. *)
-
-let tags : Terminal.style option String.Map.t ref = ref String.Map.empty
-
-let make ?style tag =
-  let check s = if String.contains s '.' then invalid_arg "Ppstyle.make" in
-  let () = List.iter check tag in
-  let name = String.concat "." tag in
-  let () = assert (not (String.Map.mem name !tags)) in
-  let () = tags := String.Map.add name style !tags in
-  name
-
-let repr t = String.split '.' t
-
-let get_style tag =
-  try String.Map.find tag !tags with Not_found -> assert false
-
-let set_style tag st =
-  try tags := String.Map.update tag st !tags with Not_found -> assert false
-
-let clear_styles () =
-  tags := String.Map.map (fun _ -> None) !tags
-
-let dump () = String.Map.bindings !tags
-
-let parse_config s =
-  let styles = Terminal.parse s in
-  let set accu (name, st) =
-    try String.Map.update name (Some st) accu with Not_found -> accu
-  in
-  tags := List.fold_left set !tags styles
-
-let tag = Pp.Tag.create "ppstyle"
-
-(** Default tag is to reset everything *)
-let default = Terminal.({
-  fg_color = Some `DEFAULT;
-  bg_color = Some `DEFAULT;
-  bold = Some false;
-  italic = Some false;
-  underline = Some false;
-  negative = Some false;
-})
-
-let empty = Terminal.make ()
-
-let error_tag =
-  let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () in
-  make ~style ["message"; "error"]
-
-let warning_tag =
-  let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`YELLOW () in
-  make ~style ["message"; "warning"]
-
-let debug_tag =
-  let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () in
-  make ~style ["message"; "debug"]
-
-let pp_tag t = match Pp.Tag.prj t tag with
-| None -> ""
-| Some key -> key
diff --git a/lib/ppstyle.mli b/lib/ppstyle.mli
deleted file mode 100644
index d9fd75765..000000000
--- a/lib/ppstyle.mli
+++ /dev/null
@@ -1,63 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** Highlighting of printers. Used for pretty-printing terms that should be
-    displayed on a color-capable terminal. *)
-
-(** {5 Style tags} *)
-
-type t = string
-
-(** Style tags *)
-
-val make : ?style:Terminal.style -> string list -> t
-(** Create a new tag with the given name. Each name must be unique. The optional
-    style is taken as the default one. *)
-
-val repr : t -> string list
-(** Gives back the original name of the style tag where each string has been
-    concatenated and separated with a dot. *)
-
-val tag : t Pp.Tag.key
-(** An annotation for styles *)
-
-(** {5 Manipulating global styles} *)
-
-val get_style : t -> Terminal.style option
-(** Get the style associated to a tag. *)
-
-val set_style : t -> Terminal.style option -> unit
-(** Set a style associated to a tag. *)
-
-val clear_styles : unit -> unit
-(** Clear all styles. *)
-
-val parse_config : string -> unit
-(** Add all styles from the given string as parsed by {!Terminal.parse}.
-    Unregistered tags are ignored. *)
-
-val dump : unit -> (t * Terminal.style option) list
-(** Recover the list of known tags together with their current style. *)
-
-(** {5 Color output} *)
-
-val pp_tag : Pp.tag_handler
-(** Returns the name of a style tag that is understandable by the formatters
-    that have been inititialized through {!init_color_output}. To be used with
-    {!Pp.pp_with}. *)
-
-(** {5 Tags} *)
-
-val error_tag : t
-(** Tag used by the {!Pp.msg_error} function. *)
-
-val warning_tag : t
-(** Tag used by the {!Pp.msg_warning} function. *)
-
-val debug_tag : t
-(** Tag used by the {!Pp.msg_debug} function. *)
diff --git a/lib/unicode.ml b/lib/unicode.ml
index ced5e258c..959ccaf73 100644
--- a/lib/unicode.ml
+++ b/lib/unicode.ml
@@ -124,27 +124,11 @@ exception End_of_input
 let utf8_of_unicode n =
   if n < 128 then
     String.make 1 (Char.chr n)
-  else if n < 2048 then
-    let s = String.make 2 (Char.chr (128 + n mod 64)) in
-    begin
-      s.[0] <- Char.chr (192 + n / 64);
-      s
-    end
-  else if n < 65536 then
-    let s = String.make 3 (Char.chr (128 + n mod 64)) in
-    begin
-      s.[1] <- Char.chr (128 + (n / 64) mod 64);
-      s.[0] <- Char.chr (224 + n / 4096);
-      s
-    end
   else
-    let s = String.make 4 (Char.chr (128 + n mod 64)) in
-    begin
-      s.[2] <- Char.chr (128 + (n / 64) mod 64);
-      s.[1] <- Char.chr (128 + (n / 4096) mod 64);
-      s.[0] <- Char.chr (240 + n / 262144);
-      s
-    end
+    let (m,s) = if n < 2048 then (2,192) else if n < 65536 then (3,224) else (4,240) in
+    String.init m (fun i ->
+        let j = (n lsr ((m - 1 - i) * 6)) land 63 in
+        Char.chr (j + if i = 0 then s else 128))
 
 (* If [s] is some UTF-8 encoded string
    and [i] is a position of some UTF-8 character within [s]
diff --git a/lib/util.ml b/lib/util.ml
index 9fb0d48ee..0d2425f27 100644
--- a/lib/util.ml
+++ b/lib/util.ml
@@ -161,11 +161,11 @@ let iraise = Exninfo.iraise
 
 let open_utf8_file_in fname =
   let is_bom s =
-    Int.equal (Char.code s.[0]) 0xEF &&
-    Int.equal (Char.code s.[1]) 0xBB &&
-    Int.equal (Char.code s.[2]) 0xBF
+    Int.equal (Char.code (Bytes.get s 0)) 0xEF &&
+    Int.equal (Char.code (Bytes.get s 1)) 0xBB &&
+    Int.equal (Char.code (Bytes.get s 2)) 0xBF
   in
   let in_chan = open_in fname in
-  let s = "   " in
+  let s = Bytes.make 3 ' ' in
   if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0;
   in_chan
diff --git a/library/lib.ml b/library/lib.ml
index 4fd29a94d..ddd2ed6af 100644
--- a/library/lib.ml
+++ b/library/lib.ml
@@ -97,21 +97,30 @@ let segment_of_objects prefix =
 
 let initial_prefix = default_library,(Names.initial_path,Names.DirPath.empty)
 
-let lib_stk = ref ([] : library_segment)
+type lib_state = {
+  comp_name   : Names.DirPath.t option;
+  lib_stk     : library_segment;
+  path_prefix : Names.DirPath.t * (Names.module_path * Names.DirPath.t);
+}
 
-let comp_name = ref None
+let initial_lib_state = {
+  comp_name   = None;
+  lib_stk     = [];
+  path_prefix = initial_prefix;
+}
+
+let lib_state = ref initial_lib_state
 
 let library_dp () =
-  match !comp_name with Some m -> m | None -> default_library
+  match !lib_state.comp_name with Some m -> m | None -> default_library
 
 (* [path_prefix] is a pair of absolute dirpath and a pair of current
    module path and relative section path *)
-let path_prefix = ref initial_prefix
 
-let cwd () = fst !path_prefix
-let current_prefix () = snd !path_prefix
-let current_mp () = fst (snd !path_prefix)
-let current_sections () = snd (snd !path_prefix)
+let cwd () = fst !lib_state.path_prefix
+let current_prefix () = snd !lib_state.path_prefix
+let current_mp () = fst (snd !lib_state.path_prefix)
+let current_sections () = snd (snd !lib_state.path_prefix)
 
 let sections_depth () = List.length (Names.DirPath.repr (current_sections ()))
 let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ()))
@@ -132,7 +141,7 @@ let make_kn id =
   let mp,dir = current_prefix () in
   Names.make_kn mp dir (Names.Label.of_id id)
 
-let make_oname id = Libnames.make_oname !path_prefix id
+let make_oname id = Libnames.make_oname !lib_state.path_prefix id
 
 let recalc_path_prefix () =
   let rec recalc = function
@@ -142,18 +151,18 @@ let recalc_path_prefix () =
     | _::l -> recalc l
     | [] -> initial_prefix
   in
-  path_prefix := recalc !lib_stk
+  lib_state := { !lib_state with path_prefix = recalc !lib_state.lib_stk }
 
 let pop_path_prefix () =
-  let dir,(mp,sec) = !path_prefix in
-  path_prefix := pop_dirpath dir, (mp, pop_dirpath sec)
+  let dir,(mp,sec) = !lib_state.path_prefix in
+  lib_state := { !lib_state with path_prefix = pop_dirpath dir, (mp, pop_dirpath sec)}
 
 let find_entry_p p =
   let rec find = function
     | [] -> raise Not_found
     | ent::l -> if p ent then ent else find l
   in
-  find !lib_stk
+  find !lib_state.lib_stk
 
 let split_lib_gen test =
   let rec collect after equal = function
@@ -174,7 +183,7 @@ let split_lib_gen test =
 		| _ -> findeq (hd::after) before)
     | [] -> None
   in
-    match findeq [] !lib_stk with
+    match findeq [] !lib_state.lib_stk with
       | None -> error "no such entry"
       | Some r -> r
 
@@ -199,10 +208,10 @@ let split_lib_at_opening sp =
 (* Adding operations. *)
 
 let add_entry sp node =
-  lib_stk := (sp,node) :: !lib_stk
+  lib_state := { !lib_state with lib_stk = (sp,node) :: !lib_state.lib_stk }
 
 let pull_to_head oname =
-  lib_stk := (oname,List.assoc oname !lib_stk) :: List.remove_assoc oname !lib_stk
+  lib_state := { !lib_state with lib_stk = (oname,List.assoc oname !lib_state.lib_stk) :: List.remove_assoc oname !lib_state.lib_stk }
 
 let anonymous_id =
   let n = ref 0 in
@@ -277,7 +286,7 @@ let start_mod is_type export id mp fs =
   if exists then
     user_err ~hdr:"open_module" (pr_id id ++ str " already exists");
   add_entry (make_oname id) (OpenedModule (is_type,export,prefix,fs));
-  path_prefix := prefix;
+  lib_state := { !lib_state with path_prefix = prefix} ;
   prefix
 
 let start_module = start_mod false
@@ -299,16 +308,16 @@ let end_mod is_type =
     with Not_found -> error "No opened modules."
   in
   let (after,mark,before) = split_lib_at_opening oname in
-  lib_stk := before;
+  lib_state := { !lib_state with lib_stk = before };
   add_entry oname (ClosedModule (List.rev (mark::after)));
-  let prefix = !path_prefix in
+  let prefix = !lib_state.path_prefix in
   recalc_path_prefix ();
   (oname, prefix, fs, after)
 
 let end_module () = end_mod false
 let end_modtype () = end_mod true
 
-let contents () = !lib_stk
+let contents () = !lib_state.lib_stk
 
 let contents_after sp = let (after,_,_) = split_lib sp in after
 
@@ -316,14 +325,14 @@ let contents_after sp = let (after,_,_) = split_lib sp in after
 
 (* TODO: use check_for_module ? *)
 let start_compilation s mp =
-  if !comp_name != None then
+  if !lib_state.comp_name != None then
     error "compilation unit is already started";
   if not (Names.DirPath.is_empty (current_sections ())) then
     error "some sections are already opened";
   let prefix = s, (mp, Names.DirPath.empty) in
   let () = add_anonymous_entry (CompilingLibrary prefix) in
-  comp_name := Some s;
-  path_prefix := prefix
+  lib_state := { !lib_state with comp_name = Some s;
+                                 path_prefix = prefix }
 
 let end_compilation_checks dir =
   let _ =
@@ -344,7 +353,7 @@ let end_compilation_checks dir =
     with Not_found -> anomaly (Pp.str "No module declared")
   in
   let _ =
-    match !comp_name with
+    match !lib_state.comp_name with
       | None -> anomaly (Pp.str "There should be a module name...")
       | Some m ->
 	  if not (Names.DirPath.equal m dir) then anomaly
@@ -355,8 +364,8 @@ let end_compilation_checks dir =
 
 let end_compilation oname =
   let (after,mark,before) = split_lib_at_opening oname in
-  comp_name := None;
-  !path_prefix,after
+  lib_state := { !lib_state with comp_name = None };
+  !lib_state.path_prefix,after
 
 (* Returns true if we are inside an opened module or module type *)
 
@@ -514,7 +523,7 @@ let (f_xml_open_section, xml_open_section) = Hook.make ~default:ignore ()
 let (f_xml_close_section, xml_close_section) = Hook.make ~default:ignore ()
 
 let open_section id =
-  let olddir,(mp,oldsec) = !path_prefix in
+  let olddir,(mp,oldsec) = !lib_state.path_prefix in
   let dir = add_dirpath_suffix olddir id in
   let prefix = dir, (mp, add_dirpath_suffix oldsec id) in
   if Nametab.exists_section dir then
@@ -523,7 +532,7 @@ let open_section id =
   add_entry (make_oname id) (OpenedSection (prefix, fs));
   (*Pushed for the lifetime of the section: removed by unfrozing the summary*)
   Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix);
-  path_prefix := prefix;
+  lib_state := { !lib_state with path_prefix = prefix };
   if !Flags.xml_export then Hook.get f_xml_open_section id;
   add_section ()
 
@@ -549,8 +558,8 @@ let close_section () =
       error "No opened section."
   in
   let (secdecls,mark,before) = split_lib_at_opening oname in
-  lib_stk := before;
-  let full_olddir = fst !path_prefix in
+  lib_state := { !lib_state with lib_stk = before };
+  let full_olddir = fst !lib_state.path_prefix in
   pop_path_prefix ();
   add_entry oname (ClosedSection (List.rev (mark::secdecls)));
   if !Flags.xml_export then Hook.get f_xml_close_section (basename (fst oname));
@@ -561,7 +570,7 @@ let close_section () =
 
 (* State and initialization. *)
 
-type frozen = Names.DirPath.t option * library_segment
+type frozen = lib_state
 
 let freeze ~marshallable =
   match marshallable with
@@ -578,18 +587,15 @@ let freeze ~marshallable =
                Some(n,OpenedSection(op,Summary.empty_frozen))
         | n, ClosedSection _ -> Some (n,ClosedSection [])
         | _, FrozenState _ -> None)
-      !lib_stk in
-    !comp_name, lib_stk
+      !lib_state.lib_stk in
+    { !lib_state with lib_stk }
   | _ ->
-    !comp_name, !lib_stk
+    !lib_state
 
-let unfreeze (mn,stk) =
-  comp_name := mn;
-  lib_stk := stk;
-  recalc_path_prefix ()
+let unfreeze st = lib_state := st
 
 let init () =
-  unfreeze (None,[]);
+  unfreeze initial_lib_state;
   Summary.init_summaries ();
   add_frozen_state () (* Stores e.g. the keywords declared in g_*.ml4 *)
 
diff --git a/library/libobject.ml b/library/libobject.ml
index caa03c85b..8757ca08c 100644
--- a/library/libobject.ml
+++ b/library/libobject.ml
@@ -91,16 +91,8 @@ let declare_object_full odecl =
 			     dyn_rebuild_function = rebuild };
   (infun,outfun)
 
-(* The "try .. with .. " allows for correct printing when calling
-   declare_object a loading time.
-*)
-
-let declare_object odecl =
-  try fst (declare_object_full odecl)
-  with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e)
-let declare_object_full odecl =
-  try declare_object_full odecl
-  with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e)
+let declare_object odecl = fst (declare_object_full odecl)
+let declare_object_full odecl = declare_object_full odecl
 
 (* this function describes how the cache, load, open, and export functions
    are triggered. *)
diff --git a/library/nameops.ml b/library/nameops.ml
index 6020db33d..098f5112f 100644
--- a/library/nameops.ml
+++ b/library/nameops.ml
@@ -61,7 +61,7 @@ let make_ident sa = function
         if c < code_of_0 || c > code_of_9 then sa ^ (string_of_int n)
         else sa ^ "_" ^ (string_of_int n) in
       Id.of_string s
-  | None -> Id.of_string (String.copy sa)
+  | None -> Id.of_string sa
 
 let root_of_id id =
   let suffixstart = cut_ident true id in
@@ -92,20 +92,20 @@ let increment_subscript id =
 	add (carrypos-1)
       end
       else begin
-	let newid = String.copy id in
-	String.fill newid (carrypos+1) (len-1-carrypos) '0';
-	newid.[carrypos] <- Char.chr (Char.code c + 1);
+	let newid = Bytes.of_string id in
+	Bytes.fill newid (carrypos+1) (len-1-carrypos) '0';
+	Bytes.set newid carrypos (Char.chr (Char.code c + 1));
 	newid
       end
     else begin
-      let newid = id^"0" in
+      let newid = Bytes.of_string (id^"0") in
       if carrypos < len-1 then begin
-	String.fill newid (carrypos+1) (len-1-carrypos) '0';
-	newid.[carrypos+1] <- '1'
+	Bytes.fill newid (carrypos+1) (len-1-carrypos) '0';
+	Bytes.set newid (carrypos+1) '1'
       end;
       newid
     end
-  in Id.of_string (add (len-1))
+  in Id.of_bytes (add (len-1))
 
 let has_subscript id =
   let id = Id.to_string id in
@@ -113,9 +113,9 @@ let has_subscript id =
 
 let forget_subscript id =
   let numstart = cut_ident false id in
-  let newid = String.make (numstart+1) '0' in
+  let newid = Bytes.make (numstart+1) '0' in
   String.blit (Id.to_string id) 0 newid 0 numstart;
-  (Id.of_string newid)
+  (Id.of_bytes newid)
 
 let add_suffix id s = Id.of_string (Id.to_string id ^ s)
 let add_prefix s id = Id.of_string (s ^ Id.to_string id)
diff --git a/library/summary.ml b/library/summary.ml
index 6efa07f38..2ec4760d6 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -107,8 +107,10 @@ let unfreeze_summaries fs =
     try fold id decl state
     with e when CErrors.noncritical e ->
       let e = CErrors.push e in
-      Printf.eprintf "Error unfrezing summay %s\n%s\n%!"
-        (name_of_summary id) (Pp.string_of_ppcmds (CErrors.iprint e));
+      Feedback.msg_error
+        Pp.(seq [str "Error unfrezing summay %s\n%s\n%!";
+                 str (name_of_summary id);
+                 CErrors.iprint e]);
       iraise e
   in
   (** We rely on the order of the frozen list, and the order of folding *)
diff --git a/ltac/pptactic.mli b/ltac/pptactic.mli
deleted file mode 100644
index 5fff3062d..000000000
--- a/ltac/pptactic.mli
+++ /dev/null
@@ -1,67 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** This module implements pretty-printers for tactic_expr syntactic
-    objects and their subcomponents. *)
-
-open Pp
-open Genarg
-open Geninterp
-open Names
-open Constrexpr
-open Tacexpr
-open Ppextend
-
-type 'a grammar_tactic_prod_item_expr =
-| TacTerm of string
-| TacNonTerm of Loc.t * 'a * Names.Id.t
-
-type 'a raw_extra_genarg_printer =
-    (constr_expr -> std_ppcmds) ->
-    (constr_expr -> std_ppcmds) ->
-    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
-    'a -> std_ppcmds
-
-type 'a glob_extra_genarg_printer =
-    (glob_constr_and_expr -> std_ppcmds) ->
-    (glob_constr_and_expr -> std_ppcmds) ->
-    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
-    'a -> std_ppcmds
-
-type 'a extra_genarg_printer =
-    (EConstr.constr -> std_ppcmds) ->
-    (EConstr.constr -> std_ppcmds) ->
-    (tolerability -> Val.t -> std_ppcmds) ->
-    'a -> std_ppcmds
-
-val declare_extra_genarg_pprule :
-  ('a, 'b, 'c) genarg_type ->
-  'a raw_extra_genarg_printer ->
-  'b glob_extra_genarg_printer ->
-  'c extra_genarg_printer -> unit
-
-type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list
-
-type pp_tactic = {
-  pptac_level : int;
-  pptac_prods : grammar_terminals;
-}
-
-val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit
-
-(** The default pretty-printers produce {!Pp.std_ppcmds} that are
-    interpreted as raw strings. *)
-include Pptacticsig.Pp
-
-(** The rich pretty-printers produce {!Pp.std_ppcmds} that are
-    interpreted as annotated strings. The annotations can be
-    retrieved using {!RichPp.rich_pp}. Their definitions are
-    located in {!Ppannotation.t}. *)
-module Richpp : Pptacticsig.Pp
-
-val ltop : tolerability
diff --git a/ltac/pptacticsig.mli b/ltac/pptacticsig.mli
deleted file mode 100644
index dfbc3b3ed..000000000
--- a/ltac/pptacticsig.mli
+++ /dev/null
@@ -1,81 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Genarg
-open Geninterp
-open Tacexpr
-open Ppextend
-open Environ
-open Misctypes
-
-module type Pp = sig
-
-  val pr_with_occurrences :
-    ('a -> std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds
-  val pr_red_expr :
-    ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) ->
-    ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds
-  val pr_may_eval :
-    ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
-    ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds
-
-  val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds
-
-  val pr_in_clause :
-    ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds
-
-  val pr_clauses :  bool option ->
-    ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds
-
-  val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds
-
-  val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds
-
-  val pr_raw_extend: env -> int ->
-    ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds
-
-  val pr_glob_extend: env -> int ->
-    ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds
-
-  val pr_extend :
-    (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds
-
-  val pr_alias_key : Names.KerName.t -> std_ppcmds
-
-  val pr_alias : (Val.t -> std_ppcmds) ->
-    int -> Names.KerName.t -> Val.t list -> std_ppcmds
-
-  val pr_alias_key : Names.KerName.t -> std_ppcmds
-
-  val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds
-
-  val pr_raw_tactic : raw_tactic_expr -> std_ppcmds
-
-  val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds
-
-  val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds
-
-  val pr_atomic_tactic : env -> Evd.evar_map -> atomic_tactic_expr -> std_ppcmds
-
-  val pr_hintbases : string list option -> std_ppcmds
-
-  val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds
-
-  val pr_bindings :
-    ('constr -> std_ppcmds) ->
-    ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds
-
-  val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds
-
-  val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
-    ('b, 'a) match_rule -> std_ppcmds
-
-  val pr_value : tolerability -> Val.t -> std_ppcmds
-
-end
diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4
index 02a720d2d..3b84eaa81 100644
--- a/parsing/cLexer.ml4
+++ b/parsing/cLexer.ml4
@@ -105,7 +105,7 @@ module Error = struct
              Printf.sprintf "Unsupported Unicode character (0x%x)" x)
 
   (* Require to fix the Camlp4 signature *)
-  let print ppf x = Pp.pp_with ~pp_tag:Ppstyle.pp_tag ppf (Pp.str (to_string x))
+  let print ppf x = Pp.pp_with ppf (Pp.str (to_string x))
 
 end
 open Error
@@ -240,18 +240,19 @@ let unfreeze tt = (token_tree := tt)
 
 (* The string buffering machinery *)
 
-let buff = ref (String.create 80)
+let buff = ref (Bytes.create 80)
 
 let store len x =
-  if len >= String.length !buff then
-    buff := !buff ^ String.create (String.length !buff);
-  !buff.[len] <- x;
+  let open Bytes in
+  if len >= length !buff then
+    buff := cat !buff (create (length !buff));
+  set !buff len x;
   succ len
 
 let rec nstore n len cs =
   if n>0 then nstore (n-1) (store len (Stream.next cs)) cs else len
 
-let get_buff len = String.sub !buff 0 len
+let get_buff len = Bytes.sub_string !buff 0 len
 
 (* The classical lexer: idents, numbers, quoted strings, comments *)
 
@@ -382,6 +383,7 @@ let push_char c =
     real_push_char c
 
 let push_string s = Buffer.add_string current_comment s
+let push_bytes s = Buffer.add_bytes current_comment s
 
 let null_comment s =
   let rec null i =
@@ -716,13 +718,13 @@ let strip s =
   in
   if len == String.length s then s
   else
-    let s' = String.create len in
+    let s' = Bytes.create len in
     let rec loop i i' =
       if i == String.length s then s'
       else if s.[i] == ' ' then loop (i + 1) i'
-      else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end
+      else begin Bytes.set s' i' s.[i]; loop (i + 1) (i' + 1) end
     in
-    loop 0 0
+    Bytes.to_string (loop 0 0)
 
 let terminal s =
   let s = strip s in
diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4
index 820514b08..2db91b8f8 100644
--- a/parsing/g_prim.ml4
+++ b/parsing/g_prim.ml4
@@ -34,7 +34,7 @@ GEXTEND Gram
   GLOBAL:
     bigint natural integer identref name ident var preident
     fullyqualid qualid reference dirpath ne_lstring
-    ne_string string pattern_ident pattern_identref by_notation smart_global;
+    ne_string string lstring pattern_ident pattern_identref by_notation smart_global;
   preident:
     [ [ s = IDENT -> s ] ]
   ;
@@ -106,6 +106,9 @@ GEXTEND Gram
   string:
     [ [ s = STRING -> s ] ]
   ;
+  lstring:
+    [ [ s = string -> (!@loc, s) ] ]
+  ;
   integer:
     [ [ i = INT      -> my_int_of_string (!@loc) i
       | "-"; i = INT -> - my_int_of_string (!@loc) i ] ]
diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4
index d46880831..18807113c 100644
--- a/parsing/g_vernac.ml4
+++ b/parsing/g_vernac.ml4
@@ -1112,7 +1112,7 @@ GEXTEND Gram
 	 idl = LIST0 ident; ":="; c = constr; b = only_parsing ->
            VernacSyntacticDefinition
 	     (id,(idl,c),local,b)
-     | IDENT "Notation"; local = obsolete_locality; s = ne_lstring; ":=";
+     | IDENT "Notation"; local = obsolete_locality; s = lstring; ":=";
 	 c = constr;
          modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
 	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml
index c5823440a..b8405ca8c 100644
--- a/parsing/pcoq.ml
+++ b/parsing/pcoq.ml
@@ -267,6 +267,7 @@ module Prim =
     let integer = gec_gen "integer"
     let bigint = Gram.entry_create "Prim.bigint"
     let string = gec_gen "string"
+    let lstring = Gram.entry_create "Prim.lstring"
     let reference = make_gen_entry uprim "reference"
     let by_notation = Gram.entry_create "by_notation"
     let smart_global = Gram.entry_create "smart_global"
diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli
index d987bb455..cf5174af9 100644
--- a/parsing/pcoq.mli
+++ b/parsing/pcoq.mli
@@ -136,6 +136,7 @@ module Prim :
     val bigint : Bigint.bigint Gram.entry
     val integer : int Gram.entry
     val string : string Gram.entry
+    val lstring : string located Gram.entry
     val qualid : qualid located Gram.entry
     val fullyqualid : Id.t list located Gram.entry
     val reference : reference Gram.entry
diff --git a/plugins/btauto/g_btauto.ml4 b/plugins/btauto/g_btauto.ml4
index f3e2c99f4..298027448 100644
--- a/plugins/btauto/g_btauto.ml4
+++ b/plugins/btauto/g_btauto.ml4
@@ -8,6 +8,8 @@
 
 (*i camlp4deps: "grammar/grammar.cma"  i*)
 
+open Ltac_plugin
+
 DECLARE PLUGIN "btauto_plugin"
 
 TACTIC EXTEND btauto
diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
index 6f6811334..7e76854b1 100644
--- a/plugins/cc/g_congruence.ml4
+++ b/plugins/cc/g_congruence.ml4
@@ -8,6 +8,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open Cctac
 open Stdarg
 
diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml
index 828d634d0..3aa572529 100644
--- a/plugins/decl_mode/decl_interp.ml
+++ b/plugins/decl_mode/decl_interp.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open CErrors
 open Util
 open Names
diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml
index 4fe59d755..2ea4538c3 100644
--- a/plugins/decl_mode/decl_proof_instr.ml
+++ b/plugins/decl_mode/decl_proof_instr.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open CErrors
 open Util
 open Pp
diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4
index 18a35c6cf..a71d20f0d 100644
--- a/plugins/decl_mode/g_decl_mode.ml4
+++ b/plugins/decl_mode/g_decl_mode.ml4
@@ -10,6 +10,7 @@
 
 DECLARE PLUGIN "decl_mode_plugin"
 
+open Ltac_plugin
 open Compat
 open Pp
 open Decl_expr
diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml
index 93b98263e..92045e775 100644
--- a/plugins/decl_mode/ppdecl_proof.ml
+++ b/plugins/decl_mode/ppdecl_proof.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open CErrors
 open Pp
 open Decl_expr
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
index de97ba97c..fc8d5356c 100644
--- a/plugins/extraction/common.ml
+++ b/plugins/extraction/common.ml
@@ -67,7 +67,9 @@ let pp_boxed_tuple f = function
     blocks is less that a line length. To avoid this awkward situation,
     we attach a big virtual size to [fnl] newlines. *)
 
-let fnl () = stras (1000000,"") ++ fnl ()
+(* EG: This looks quite suspicious... but beware of bugs *)
+(* let fnl () = stras (1000000,"") ++ fnl () *)
+let fnl () = fnl ()
 
 let fnl2 () = fnl () ++ fnl ()
 
@@ -91,10 +93,7 @@ let begins_with_CoqXX s =
 
 let unquote s =
   if lang () != Scheme then s
-  else
-    let s = String.copy s in
-    for i=0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done;
-    s
+  else String.map (fun c -> if c == '\'' then '~' else c) s
 
 let rec qualify delim = function
   | [] -> assert false
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index e019bb3c2..2b12462ad 100644
--- a/plugins/extraction/extract_env.ml
+++ b/plugins/extraction/extract_env.ml
@@ -472,13 +472,14 @@ let formatter dry file =
     if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ())
     else
       match file with
-	| Some f -> Pp_control.with_output_to f
+	| Some f -> Topfmt.with_output_to f
 	| None -> Format.formatter_of_buffer buf
   in
+  (* XXX: Fixme, this shouldn't depend on Topfmt *)
   (* We never want to see ellipsis ... in extracted code *)
   Format.pp_set_max_boxes ft max_int;
   (* We reuse the width information given via "Set Printing Width" *)
-  (match Pp_control.get_margin () with
+  (match Topfmt.get_margin () with
     | None -> ()
     | Some i ->
       Format.pp_set_margin ft i;
@@ -518,8 +519,10 @@ let print_structure_to_file (fn,si,mo) dry struc =
     set_phase Impl;
     pp_with ft (d.preamble mo comment opened unsafe_needs);
     pp_with ft (d.pp_struct struc);
+    Format.pp_print_flush ft ();
     Option.iter close_out cout;
   with reraise ->
+    Format.pp_print_flush ft ();
     Option.iter close_out cout; raise reraise
   end;
   if not dry then Option.iter info_file fn;
@@ -532,8 +535,10 @@ let print_structure_to_file (fn,si,mo) dry struc =
 	 set_phase Intf;
 	 pp_with ft (d.sig_preamble mo comment opened unsafe_needs);
 	 pp_with ft (d.pp_sig (signature_of_structure struc));
+         Format.pp_print_flush ft ();
 	 close_out cout;
        with reraise ->
+         Format.pp_print_flush ft ();
 	 close_out cout; raise reraise
        end;
        info_file si)
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
index e1d6bb4a8..3ed959cf2 100644
--- a/plugins/extraction/g_extraction.ml4
+++ b/plugins/extraction/g_extraction.ml4
@@ -12,6 +12,7 @@ DECLARE PLUGIN "extraction_plugin"
 
 (* ML names *)
 
+open Ltac_plugin
 open Genarg
 open Stdarg
 open Pcoq.Prim
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index d89bf95ee..d8e382155 100644
--- a/plugins/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.ml
@@ -66,7 +66,7 @@ let pp_header_comment = function
   | None -> mt ()
   | Some com -> pp_comment com ++ fnl2 ()
 
-let then_nl pp = if Pp.is_empty pp then mt () else pp ++ fnl ()
+let then_nl pp = if Pp.ismt pp then mt () else pp ++ fnl ()
 
 let pp_tdummy usf =
   if usf.tdummy || usf.tunknown then str "type __ = Obj.t" ++ fnl () else mt ()
@@ -618,7 +618,7 @@ and pp_module_type params = function
       push_visible mp params;
       let try_pp_specif l x =
         let px = pp_specif x in
-        if Pp.is_empty px then l else px::l
+        if Pp.ismt px then l else px::l
       in
       (* We cannot use fold_right here due to side effects in pp_specif *)
       let l = List.fold_left try_pp_specif [] sign in
@@ -696,7 +696,7 @@ and pp_module_expr params = function
       push_visible mp params;
       let try_pp_structure_elem l x =
         let px = pp_structure_elem x in
-        if Pp.is_empty px then l else px::l
+        if Pp.ismt px then l else px::l
       in
       (* We cannot use fold_right here due to side effects in pp_structure_elem *)
       let l = List.fold_left try_pp_structure_elem [] sel in
@@ -714,7 +714,7 @@ let rec prlist_sep_nonempty sep f = function
   | h::t ->
      let e = f h in
      let r = prlist_sep_nonempty sep f t in
-     if Pp.is_empty e then r
+     if Pp.ismt e then r
      else e ++ sep () ++ r
 
 let do_struct f s =
diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
index a6309e61f..8d0cc4a0d 100644
--- a/plugins/extraction/scheme.ml
+++ b/plugins/extraction/scheme.ml
@@ -40,11 +40,7 @@ let preamble _ comment _ usf =
   (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ())
 
 let pr_id id =
-  let s = Id.to_string id in
-  for i = 0 to String.length s - 1 do
-    if s.[i] == '\'' then s.[i] <- '~'
-  done;
-  str s
+  str @@ String.map (fun c -> if c == '\'' then '~' else c) (Id.to_string id)
 
 let paren = pp_par true
 
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
index 5e7d810c9..d6a334c5f 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -773,9 +773,7 @@ let file_of_modfile mp =
     | MPfile f -> Id.to_string (List.hd (DirPath.repr f))
     | _ -> assert false
   in
-  let s = String.copy (string_of_modfile mp) in
-  if s.[0] != s0.[0] then s.[0] <- s0.[0];
-  s
+  String.mapi (fun i c -> if i = 0 then s0.[0] else c) (string_of_modfile mp)
 
 let add_blacklist_entries l =
   blacklist_table :=
diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
index 260e86ad6..e28d6aa62 100644
--- a/plugins/firstorder/g_ground.ml4
+++ b/plugins/firstorder/g_ground.ml4
@@ -8,6 +8,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma"  i*)
 
+open Ltac_plugin
 open Formula
 open Sequent
 open Ground
diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml
index 628af4e71..d6cd7e2a0 100644
--- a/plugins/firstorder/ground.ml
+++ b/plugins/firstorder/ground.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open Formula
 open Sequent
 open Rules
diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v
index 1d7ee93ea..a96254713 100644
--- a/plugins/fourier/Fourier.v
+++ b/plugins/fourier/Fourier.v
@@ -13,6 +13,6 @@ Require Export DiscrR.
 Require Export Fourier_util.
 Declare ML Module "fourier_plugin".
 
-Ltac fourier := abstract (fourierz; field; discrR).
+Ltac fourier := abstract (compute [IZR IPR IPR_2] in *; fourierz; field; discrR).
 
 Ltac fourier_eq := apply Rge_antisym; fourier.
diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4
index 7c665ae7b..1960fa835 100644
--- a/plugins/fourier/g_fourier.ml4
+++ b/plugins/fourier/g_fourier.ml4
@@ -8,6 +8,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open FourierR
 
 DECLARE PLUGIN "fourier_plugin"
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index bc64b079c..48c0f5f04 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1228,7 +1228,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
     let mk_fixes : tactic =
       let pre_info,infos = list_chop fun_num infos in
       match pre_info,infos with
-	| [],[] -> tclIDTAC
+	| _,[] -> tclIDTAC
 	| _, this_fix_info::others_infos ->
 	    let other_fix_infos =
 	      List.map
@@ -1244,7 +1244,6 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	    else
 	      Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1)
 		other_fix_infos 0)
-	| _ -> anomaly (Pp.str "Not a valid information")
     in
     let first_tac : tactic = (* every operations until fix creations *)
       tclTHENSEQ
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index 27a892ca7..253f3ba72 100644
--- a/plugins/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 (*i camlp4deps: "grammar/grammar.cma" i*)
+open Ltac_plugin
 open Compat
 open Util
 open Term
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
index 8f1420940..2c2cd919b 100644
--- a/plugins/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open Tacexpr
 open Declarations
 open CErrors
diff --git a/ltac/tauto.mli b/plugins/ltac/Ltac.v
index e69de29bb..e69de29bb 100644
--- a/ltac/tauto.mli
+++ b/plugins/ltac/Ltac.v
diff --git a/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4
index 28ff6df83..28ff6df83 100644
--- a/ltac/coretactics.ml4
+++ b/plugins/ltac/coretactics.ml4
diff --git a/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml
index 5d3f6df03..5d3f6df03 100644
--- a/ltac/evar_tactics.ml
+++ b/plugins/ltac/evar_tactics.ml
diff --git a/ltac/evar_tactics.mli b/plugins/ltac/evar_tactics.mli
index cfe747665..cfe747665 100644
--- a/ltac/evar_tactics.mli
+++ b/plugins/ltac/evar_tactics.mli
diff --git a/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4
index 53b726432..53b726432 100644
--- a/ltac/extraargs.ml4
+++ b/plugins/ltac/extraargs.ml4
diff --git a/ltac/extraargs.mli b/plugins/ltac/extraargs.mli
index 7d4bccfad..7d4bccfad 100644
--- a/ltac/extraargs.mli
+++ b/plugins/ltac/extraargs.mli
diff --git a/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4
index 55108631b..55108631b 100644
--- a/ltac/extratactics.ml4
+++ b/plugins/ltac/extratactics.ml4
diff --git a/ltac/extratactics.mli b/plugins/ltac/extratactics.mli
index 18334dafe..18334dafe 100644
--- a/ltac/extratactics.mli
+++ b/plugins/ltac/extratactics.mli
diff --git a/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4
index faa64f31d..e9a6e9e04 100644
--- a/ltac/g_auto.ml4
+++ b/plugins/ltac/g_auto.ml4
@@ -17,6 +17,7 @@ open Pltac
 open Hints
 open Tacexpr
 open Proofview.Notations
+open Names
 
 DECLARE PLUGIN "g_auto"
 
@@ -154,16 +155,6 @@ TACTIC EXTEND autounfold_one
     [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ]
       END
 
-TACTIC EXTEND autounfoldify
-| [ "autounfoldify" constr(x) ] -> [
-    Proofview.tclEVARMAP >>= fun sigma ->
-    let db = match EConstr.kind sigma x with
-      | Term.Const (c,_) -> Names.Label.to_string (Names.con_label c)
-      | _ -> assert false
-    in Eauto.autounfold ["core";db] Locusops.onConcl 
-  ]
-END
-
 TACTIC EXTEND unify
 | ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ]
 | ["unify" constr(x) constr(y) "with" preident(base)  ] -> [
diff --git a/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4
index 1ea347ccb..40f30c794 100644
--- a/ltac/g_class.ml4
+++ b/plugins/ltac/g_class.ml4
@@ -13,6 +13,7 @@ open Class_tactics
 open Pltac
 open Stdarg
 open Tacarg
+open Names
 
 DECLARE PLUGIN "g_class"
 
diff --git a/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4
index 905653281..679aa1127 100644
--- a/ltac/g_eqdecide.ml4
+++ b/plugins/ltac/g_eqdecide.ml4
@@ -15,6 +15,7 @@
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Eqdecide
+open Names
 
 DECLARE PLUGIN "g_eqdecide"
 
diff --git a/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4
index 54229bb2a..aab568746 100644
--- a/ltac/g_ltac.ml4
+++ b/plugins/ltac/g_ltac.ml4
@@ -17,6 +17,7 @@ open Misctypes
 open Genarg
 open Genredexpr
 open Tok (* necessary for camlp4 *)
+open Names
 
 open Pcoq
 open Pcoq.Constr
@@ -226,8 +227,8 @@ GEXTEND Gram
       | "multimatch" -> General ] ]
   ;
   input_fun:
-    [ [ "_" -> None
-      | l = ident -> Some l ] ]
+    [ [ "_" -> Anonymous
+      | l = ident -> Name l ] ]
   ;
   let_clause:
     [ [ id = identref; ":="; te = tactic_expr ->
@@ -499,8 +500,8 @@ let pr_tacdef_body tacdef_body =
       | Tacexpr.TacFun (idl,b) -> idl,b
       | _ -> [], body in
   id ++
-    prlist (function None -> str " _"
-      | Some id -> spc () ++ Nameops.pr_id id) idl
+    prlist (function Anonymous -> str " _"
+      | Name id -> spc () ++ Nameops.pr_id id) idl
   ++ (if redef then str" ::=" else str" :=") ++ brk(1,1)
   ++ Pptactic.pr_raw_tactic body
 
diff --git a/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4
index d286a5870..d286a5870 100644
--- a/ltac/g_obligations.ml4
+++ b/plugins/ltac/g_obligations.ml4
diff --git a/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4
index b1c4f58eb..b1c4f58eb 100644
--- a/ltac/g_rewrite.ml4
+++ b/plugins/ltac/g_rewrite.ml4
diff --git a/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4
index 685c07c9a..fa01baab7 100644
--- a/ltac/g_tactic.ml4
+++ b/plugins/ltac/g_tactic.ml4
@@ -325,8 +325,9 @@ GEXTEND Gram
         l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] ->
           let loc0,pat = pat in
           let f c pat =
-            let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in
-            IntroAction (IntroApplyOn (c,(loc,pat))) in
+            let loc1 = Constrexpr_ops.constr_loc c in
+            let loc = Loc.merge loc0 loc1 in
+            IntroAction (IntroApplyOn ((loc1,c),(loc,pat))) in
           !@loc, List.fold_right f l pat ] ]
   ;
   simple_intropattern_closed:
diff --git a/ltac/ltac.mllib b/plugins/ltac/ltac_plugin.mlpack
index af1c7149d..af1c7149d 100644
--- a/ltac/ltac.mllib
+++ b/plugins/ltac/ltac_plugin.mlpack
diff --git a/ltac/pltac.ml b/plugins/ltac/pltac.ml
index 1d21118ae..1d21118ae 100644
--- a/ltac/pltac.ml
+++ b/plugins/ltac/pltac.ml
diff --git a/ltac/pltac.mli b/plugins/ltac/pltac.mli
index 810e1ec39..810e1ec39 100644
--- a/ltac/pltac.mli
+++ b/plugins/ltac/pltac.mli
diff --git a/ltac/pptactic.ml b/plugins/ltac/pptactic.ml
index ed024289c..39ae1f41d 100644
--- a/ltac/pptactic.ml
+++ b/plugins/ltac/pptactic.ml
@@ -27,6 +27,26 @@ open Pputils
 open Ppconstr
 open Printer
 
+module Tag =
+struct
+
+  let keyword   = "tactic.keyword"
+  let primitive = "tactic.primitive"
+  let string    = "tactic.string"
+
+end
+
+let tag t s = Pp.tag t s
+let do_not_tag _ x = x
+let tag_keyword                 = tag Tag.keyword
+let tag_primitive               = tag Tag.primitive
+let tag_string                  = tag Tag.string
+let tag_glob_tactic_expr        = do_not_tag
+let tag_glob_atomic_tactic_expr = do_not_tag
+let tag_raw_tactic_expr         = do_not_tag
+let tag_raw_atomic_tactic_expr  = do_not_tag
+let tag_atomic_tactic_expr      = do_not_tag
+
 let pr_global x = Nametab.pr_global_env Id.Set.empty x
 
 type 'a grammar_tactic_prod_item_expr =
@@ -64,30 +84,6 @@ type 'a extra_genarg_printer =
     (tolerability -> Val.t -> std_ppcmds) ->
     'a -> std_ppcmds
 
-module Make
-  (Ppconstr : Ppconstrsig.Pp)
-  (Taggers : sig
-      val tag_keyword
-        : std_ppcmds -> std_ppcmds
-      val tag_primitive
-        : std_ppcmds -> std_ppcmds
-      val tag_string
-        : std_ppcmds -> std_ppcmds
-      val tag_glob_tactic_expr
-        : glob_tactic_expr -> std_ppcmds -> std_ppcmds
-      val tag_glob_atomic_tactic_expr
-        : glob_atomic_tactic_expr -> std_ppcmds -> std_ppcmds
-      val tag_raw_tactic_expr
-        : raw_tactic_expr -> std_ppcmds -> std_ppcmds
-      val tag_raw_atomic_tactic_expr
-        : raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds
-      val tag_atomic_tactic_expr
-        : atomic_tactic_expr -> std_ppcmds -> std_ppcmds
-  end)
-= struct
-
-  open Taggers
-
   let keyword x = tag_keyword (str x)
   let primitive x = tag_primitive (str x)
 
@@ -574,9 +570,7 @@ module Make
               str "=>" ++ brk (1,4) ++ pr t))
     | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t
 
-  let pr_funvar = function
-    | None -> spc () ++ str "_"
-    | Some id -> spc () ++ pr_id id
+  let pr_funvar n = spc () ++ pr_name n
 
   let pr_let_clause k pr (id,(bl,t)) =
     hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++
@@ -1209,46 +1203,14 @@ module Make
 
   let pr_atomic_tactic env sigma c = pr_atomic_tactic_level env sigma ltop c
 
-end
-
-module Tag =
-struct
-  let keyword =
-    let style = Terminal.make ~bold:true () in
-    Ppstyle.make ~style ["tactic"; "keyword"]
-
-  let primitive =
-    let style = Terminal.make ~fg_color:`LIGHT_GREEN () in
-    Ppstyle.make ~style ["tactic"; "primitive"]
-
-  let string =
-    let style = Terminal.make ~fg_color:`LIGHT_RED () in
-    Ppstyle.make ~style ["tactic"; "string"]
-
-end
-
-include Make (Ppconstr) (struct
-    let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s
-    let do_not_tag _ x = x
-    let tag_keyword                 = tag Tag.keyword
-    let tag_primitive               = tag Tag.primitive
-    let tag_string                  = tag Tag.string
-    let tag_glob_tactic_expr        = do_not_tag
-    let tag_glob_atomic_tactic_expr = do_not_tag
-    let tag_raw_tactic_expr         = do_not_tag
-    let tag_raw_atomic_tactic_expr  = do_not_tag
-    let tag_atomic_tactic_expr      = do_not_tag
-end)
-
 let declare_extra_genarg_pprule wit
   (f : 'a raw_extra_genarg_printer)
   (g : 'b glob_extra_genarg_printer)
   (h : 'c extra_genarg_printer) =
-  let s = match wit with
-    | ExtraArg s -> ArgT.repr s
-    | _ -> error
-      "Can declare a pretty-printing rule only for extra argument types."
-  in
+  begin match wit with
+    | ExtraArg s -> ()
+    | _          -> error "Can declare a pretty-printing rule only for extra argument types."
+  end;
   let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in
   let g x =
     let env = Global.env () in
@@ -1342,22 +1304,3 @@ let () =
   let pr_unit _ _ _ () = str "()" in
   let printer _ _ prtac = prtac (0, E) in
   declare_extra_genarg_pprule wit_ltac printer printer pr_unit
-
-module Richpp = struct
-
-  include Make (Ppconstr.Richpp) (struct
-    open Ppannotation
-    open Genarg
-    let do_not_tag _ x = x
-    let tag e s = Pp.tag (Pp.Tag.inj e tag) s
-    let tag_keyword                   = tag AKeyword
-    let tag_primitive                 = tag AKeyword
-    let tag_string                    = do_not_tag ()
-    let tag_glob_tactic_expr        e = tag (AGlbGenArg (in_gen (glbwit wit_ltac) e))
-    let tag_glob_atomic_tactic_expr   = do_not_tag
-    let tag_raw_tactic_expr         e = tag (ARawGenArg (in_gen (rawwit wit_ltac) e))
-    let tag_raw_atomic_tactic_expr    = do_not_tag
-    let tag_atomic_tactic_expr        = do_not_tag
-  end)
-
-end
diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli
new file mode 100644
index 000000000..729338fb9
--- /dev/null
+++ b/plugins/ltac/pptactic.mli
@@ -0,0 +1,121 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This module implements pretty-printers for tactic_expr syntactic
+    objects and their subcomponents. *)
+
+open Pp
+open Genarg
+open Geninterp
+open Names
+open Misctypes
+open Environ
+open Constrexpr
+open Tacexpr
+open Ppextend
+
+type 'a grammar_tactic_prod_item_expr =
+| TacTerm of string
+| TacNonTerm of Loc.t * 'a * Names.Id.t
+
+type 'a raw_extra_genarg_printer =
+    (constr_expr -> std_ppcmds) ->
+    (constr_expr -> std_ppcmds) ->
+    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+type 'a glob_extra_genarg_printer =
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+type 'a extra_genarg_printer =
+    (EConstr.t -> std_ppcmds) ->
+    (EConstr.t -> std_ppcmds) ->
+    (tolerability -> Val.t -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+val declare_extra_genarg_pprule :
+  ('a, 'b, 'c) genarg_type ->
+  'a raw_extra_genarg_printer ->
+  'b glob_extra_genarg_printer ->
+  'c extra_genarg_printer -> unit
+
+type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list
+
+type pp_tactic = {
+  pptac_level : int;
+  pptac_prods : grammar_terminals;
+}
+
+val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit
+
+val pr_with_occurrences :
+  ('a -> std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds
+val pr_red_expr :
+  ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) ->
+  ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds
+val pr_may_eval :
+  ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
+  ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds
+
+val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds
+val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds
+
+val pr_in_clause :
+  ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds
+
+val pr_clauses :  bool option ->
+  ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds
+
+val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds
+
+val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds
+
+val pr_raw_extend: env -> int ->
+  ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds
+
+val pr_glob_extend: env -> int ->
+  ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds
+
+val pr_extend :
+  (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds
+
+val pr_alias_key : Names.KerName.t -> std_ppcmds
+
+val pr_alias : (Val.t -> std_ppcmds) ->
+  int -> Names.KerName.t -> Val.t list -> std_ppcmds
+
+val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds
+
+val pr_raw_tactic : raw_tactic_expr -> std_ppcmds
+
+val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds
+
+val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds
+
+val pr_atomic_tactic : env -> Evd.evar_map -> atomic_tactic_expr -> std_ppcmds
+
+val pr_hintbases : string list option -> std_ppcmds
+
+val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds
+
+val pr_bindings :
+  ('constr -> std_ppcmds) ->
+  ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds
+
+val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds
+
+val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
+  ('b, 'a) match_rule -> std_ppcmds
+
+val pr_value : tolerability -> Val.t -> std_ppcmds
+
+
+val ltop : tolerability
diff --git a/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml
index 2514ededb..58123f63e 100644
--- a/ltac/profile_ltac.ml
+++ b/plugins/ltac/profile_ltac.ml
@@ -257,7 +257,7 @@ let string_of_call ck =
          (Pptactic.pr_glob_tactic (Global.env ())
             te)
     ) in
-  for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done;
+  let s = String.map (fun c -> if c = '\n' then ' ' else c) s in
   let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in
   CString.strip s
 
diff --git a/ltac/profile_ltac.mli b/plugins/ltac/profile_ltac.mli
index e5e2e4197..e5e2e4197 100644
--- a/ltac/profile_ltac.mli
+++ b/plugins/ltac/profile_ltac.mli
diff --git a/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.ml4
index 8cb76d81c..8cb76d81c 100644
--- a/ltac/profile_ltac_tactics.ml4
+++ b/plugins/ltac/profile_ltac_tactics.ml4
diff --git a/ltac/rewrite.ml b/plugins/ltac/rewrite.ml
index 55172cba6..55172cba6 100644
--- a/ltac/rewrite.ml
+++ b/plugins/ltac/rewrite.ml
diff --git a/ltac/rewrite.mli b/plugins/ltac/rewrite.mli
index 10fec2032..10fec2032 100644
--- a/ltac/rewrite.mli
+++ b/plugins/ltac/rewrite.mli
diff --git a/ltac/tacarg.ml b/plugins/ltac/tacarg.ml
index 42552c484..42552c484 100644
--- a/ltac/tacarg.ml
+++ b/plugins/ltac/tacarg.ml
diff --git a/ltac/tacarg.mli b/plugins/ltac/tacarg.mli
index bfa423db2..bfa423db2 100644
--- a/ltac/tacarg.mli
+++ b/plugins/ltac/tacarg.mli
diff --git a/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml
index 114b8dda0..114b8dda0 100644
--- a/ltac/taccoerce.ml
+++ b/plugins/ltac/taccoerce.ml
diff --git a/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli
index 9c4ac5265..9c4ac5265 100644
--- a/ltac/taccoerce.mli
+++ b/plugins/ltac/taccoerce.mli
diff --git a/ltac/tacentries.ml b/plugins/ltac/tacentries.ml
index 2e2b55be7..cd8c9e471 100644
--- a/ltac/tacentries.ml
+++ b/plugins/ltac/tacentries.ml
@@ -302,9 +302,9 @@ let cons_production_parameter = function
 | TacTerm _ -> None
 | TacNonTerm (_, _, id) -> Some id
 
-let add_glob_tactic_notation local n prods forml ids tac =
+let add_glob_tactic_notation local ~level prods forml ids tac =
   let parule = {
-    tacgram_level = n;
+    tacgram_level = level;
     tacgram_prods = prods;
   } in
   let tacobj = {
@@ -360,7 +360,7 @@ let extend_atomic_tactic name entries =
   in
   List.iteri add_atomic entries
 
-let add_ml_tactic_notation name prods =
+let add_ml_tactic_notation name ~level prods =
   let len = List.length prods in
   let iter i prods =
     let open Tacexpr in
@@ -372,10 +372,12 @@ let add_ml_tactic_notation name prods =
     let entry = { mltac_name = name; mltac_index = len - i - 1 } in
     let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in
     let tac = TacML (Loc.ghost, entry, List.map map ids) in
-    add_glob_tactic_notation false 0 prods true ids tac
+    add_glob_tactic_notation false ~level prods true ids tac
   in
   List.iteri iter (List.rev prods);
-  extend_atomic_tactic name prods
+  (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at
+  tactic_expr level 0) *)
+  if Int.equal level 0 then extend_atomic_tactic name prods
 
 (**********************************************************************)
 (** Ltac quotations                                                   *)
@@ -504,10 +506,7 @@ let print_ltacs () =
     | Tacexpr.TacFun (l, t) -> (l, t)
     | _ -> ([], body)
     in
-    let pr_ltac_fun_arg = function
-    | None -> spc () ++ str "_"
-    | Some id -> spc () ++ pr_id id
-    in
+    let pr_ltac_fun_arg n = spc () ++ pr_name n in
     hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l)
   in
   Feedback.msg_notice (prlist_with_sep fnl pr_entry entries)
diff --git a/ltac/tacentries.mli b/plugins/ltac/tacentries.mli
index 969c118fb..069504473 100644
--- a/ltac/tacentries.mli
+++ b/plugins/ltac/tacentries.mli
@@ -45,7 +45,7 @@ val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type -
     to finding an argument by name (as in {!Genarg}) if there is none
     matching. *)
 
-val add_ml_tactic_notation : ml_tactic_name ->
+val add_ml_tactic_notation : ml_tactic_name -> level:int ->
   argument grammar_tactic_prod_item_expr list list -> unit
 (** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND
     ML-side macro. *)
diff --git a/ltac/tacenv.ml b/plugins/ltac/tacenv.ml
index e3c2b4ad5..e3c2b4ad5 100644
--- a/ltac/tacenv.ml
+++ b/plugins/ltac/tacenv.ml
diff --git a/ltac/tacenv.mli b/plugins/ltac/tacenv.mli
index 94e14223a..94e14223a 100644
--- a/ltac/tacenv.mli
+++ b/plugins/ltac/tacenv.mli
diff --git a/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli
index b8d2d42b7..8aefe7605 100644
--- a/ltac/tacexpr.mli
+++ b/plugins/ltac/tacexpr.mli
@@ -282,7 +282,7 @@ constraint 'a = <
 >
 
 and 'a gen_tactic_fun_ast =
-    Id.t option list * 'a gen_tactic_expr
+    Name.t list * 'a gen_tactic_expr
 
 constraint 'a = <
     term:'t;
diff --git a/ltac/tacintern.ml b/plugins/ltac/tacintern.ml
index 763e0dc22..3f83f104e 100644
--- a/ltac/tacintern.ml
+++ b/plugins/ltac/tacintern.ml
@@ -248,8 +248,8 @@ and intern_intro_pattern_action lf ist = function
   | IntroInjection l ->
       IntroInjection (List.map (intern_intro_pattern lf ist) l)
   | IntroWildcard | IntroRewrite _ as x -> x
-  | IntroApplyOn (c,pat) ->
-      IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat)
+  | IntroApplyOn ((loc,c),pat) ->
+      IntroApplyOn ((loc,intern_constr ist c), intern_intro_pattern lf ist pat)
 
 and intern_or_and_intro_pattern lf ist = function
    | IntroAndPattern l ->
@@ -646,7 +646,7 @@ and intern_tactic_or_tacarg ist = intern_tactic false ist
 and intern_pure_tactic ist = intern_tactic true ist
 
 and intern_tactic_fun ist (var,body) =
-  let lfun = List.fold_left opt_cons ist.ltacvars var in
+  let lfun = List.fold_left name_cons ist.ltacvars var in
   (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body)
 
 and intern_tacarg strict onlytac ist = function
@@ -722,9 +722,7 @@ let split_ltac_fun = function
   | TacFun (l,t) -> (l,t)
   | t -> ([],t)
 
-let pr_ltac_fun_arg = function
-  | None -> spc () ++ str "_"
-  | Some id -> spc () ++ pr_id id
+let pr_ltac_fun_arg n = spc () ++ pr_name n
 
 let print_ltac id =
  try
@@ -782,6 +780,7 @@ let intern_ltac ist tac =
 let () =
   Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var);
   Genintern.register_intern0 wit_ref (lift intern_global_reference);
+  Genintern.register_intern0 wit_pre_ident (fun ist c -> (ist,c));
   Genintern.register_intern0 wit_ident intern_ident';
   Genintern.register_intern0 wit_var (lift intern_hyp);
   Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg);
diff --git a/ltac/tacintern.mli b/plugins/ltac/tacintern.mli
index 71ca354fa..71ca354fa 100644
--- a/ltac/tacintern.mli
+++ b/plugins/ltac/tacintern.mli
diff --git a/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml
index ecf67bfef..928646bcb 100644
--- a/ltac/tacinterp.ml
+++ b/plugins/ltac/tacinterp.ml
@@ -120,7 +120,7 @@ let combine_appl appl1 appl2 =
 (* Values for interpretation *)
 type tacvalue =
   | VFun of appl*ltac_trace * value Id.Map.t *
-      Id.t option list * glob_tactic_expr
+      Name.t list * glob_tactic_expr
   | VRec of value Id.Map.t ref * glob_tactic_expr
 
 let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) =
@@ -520,7 +520,7 @@ let rec intropattern_ids (loc,pat) = match pat with
       List.flatten (List.map intropattern_ids (List.flatten ll))
   | IntroAction (IntroInjection l) ->
       List.flatten (List.map intropattern_ids l)
-  | IntroAction (IntroApplyOn (c,pat)) -> intropattern_ids pat
+  | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids pat
   | IntroNaming (IntroAnonymous | IntroFresh _)
   | IntroAction (IntroWildcard | IntroRewrite _)
   | IntroForthcoming _ -> []
@@ -921,14 +921,14 @@ and interp_intro_pattern_action ist env sigma = function
   | IntroInjection l ->
       let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in
       sigma, IntroInjection l
-  | IntroApplyOn (c,ipat) ->
+  | IntroApplyOn ((loc,c),ipat) ->
       let c = { delayed = fun env sigma ->
         let sigma = Sigma.to_evar_map sigma in
         let (sigma, c) = interp_open_constr ist env sigma c in
         Sigma.Unsafe.of_pair (c, sigma)
       } in
       let sigma,ipat = interp_intro_pattern ist env sigma ipat in
-      sigma, IntroApplyOn (c,ipat)
+      sigma, IntroApplyOn ((loc,c),ipat)
   | IntroWildcard | IntroRewrite _ as x -> sigma, x
 
 and interp_or_and_intro_pattern ist env sigma = function
@@ -1089,8 +1089,8 @@ let head_with_value (lvar,lval) =
     | ([],[]) -> (lacc,[],[])
     | (vr::tvr,ve::tve) ->
       (match vr with
-      |	None -> head_with_value_rec lacc (tvr,tve)
-      | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve))
+      |	Anonymous -> head_with_value_rec lacc (tvr,tve)
+      | Name v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve))
     | (vr,[]) -> (lacc,vr,[])
     | ([],ve) -> (lacc,[],ve)
   in
@@ -1424,7 +1424,14 @@ and tactic_of_value ist vle =
         extra = TacStore.set ist.extra f_trace []; } in
       let tac = name_if_glob appl (eval_tactic ist t) in
       Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac)
-  | (VFun _|VRec _) -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.")
+  | VFun (_, _, _,vars,_) ->
+    let numargs = List.length vars in
+    Tacticals.New.tclZEROMSG
+      (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++
+       Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++
+       Pp.str (String.plural numargs "variable") ++ Pp.str " " ++
+       pr_enum pr_name vars ++ Pp.str ".")
+  | VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.")
   else if has_type vle (topwit wit_tactic) then
     let tac = out_gen (topwit wit_tactic) vle in
     tactic_of_value ist tac
@@ -2022,9 +2029,6 @@ let () =
 let () =
   declare_uniform wit_string
 
-let () =
-  declare_uniform wit_pre_ident
-
 let lift f = (); fun ist x -> Ftactic.enter { enter = begin fun gl ->
   let env = Proofview.Goal.env gl in
   let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
@@ -2052,9 +2056,13 @@ let interp_destruction_arg' ist c = Ftactic.enter { enter = begin fun gl ->
   Ftactic.return (interp_destruction_arg ist gl c)
 end }
 
+let interp_pre_ident ist env sigma s =
+  s |> Id.of_string |> interp_ident ist env sigma |> Id.to_string
+
 let () =
   register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n));
   register_interp0 wit_ref (lift interp_reference);
+  register_interp0 wit_pre_ident (lift interp_pre_ident);
   register_interp0 wit_ident (lift interp_ident);
   register_interp0 wit_var (lift interp_hyp);
   register_interp0 wit_intro_pattern (lifts interp_intro_pattern);
@@ -2119,8 +2127,8 @@ let lift_constr_tac_to_ml_tac vars tac =
     let env = Proofview.Goal.env gl in
     let sigma = project gl in
     let map = function
-    | None -> None
-    | Some id ->
+    | Anonymous -> None
+    | Name id ->
       let c = Id.Map.find id ist.lfun in
       try Some (coerce_to_closed_constr env c)
       with CannotCoerceTo ty ->
diff --git a/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli
index c657a11f1..1e5f6bd42 100644
--- a/ltac/tacinterp.mli
+++ b/plugins/ltac/tacinterp.mli
@@ -116,7 +116,7 @@ val error_ltac_variable : Loc.t -> Id.t ->
 
 (** Transforms a constr-expecting tactic into a tactic finding its arguments in
     the Ltac environment according to the given names. *)
-val lift_constr_tac_to_ml_tac : Id.t option list ->
+val lift_constr_tac_to_ml_tac : Name.t list ->
   (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic
 
 val default_ist : unit -> Geninterp.interp_sign
diff --git a/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml
index 55de58361..fe3a9f3b2 100644
--- a/ltac/tacsubst.ml
+++ b/plugins/ltac/tacsubst.ml
@@ -51,8 +51,8 @@ let rec subst_intro_pattern subst = function
   | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x
 
 and subst_intro_pattern_action subst = function
-  | IntroApplyOn (t,pat) ->
-      IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat)
+  | IntroApplyOn ((loc,t),pat) ->
+      IntroApplyOn ((loc,subst_glob_constr subst t),subst_intro_pattern subst pat)
   | IntroOrAndPattern l ->
       IntroOrAndPattern (subst_intro_or_and_pattern subst l)
   | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l)
@@ -291,6 +291,7 @@ and subst_genarg subst (GenArg (Glbwit wit, x)) =
 let () =
   Genintern.register_subst0 wit_int_or_var (fun _ v -> v);
   Genintern.register_subst0 wit_ref subst_global_reference;
+  Genintern.register_subst0 wit_pre_ident (fun _ v -> v);
   Genintern.register_subst0 wit_ident (fun _ v -> v);
   Genintern.register_subst0 wit_var (fun _ v -> v);
   Genintern.register_subst0 wit_intro_pattern (fun _ v -> v);
diff --git a/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli
index c1bf27257..c1bf27257 100644
--- a/ltac/tacsubst.mli
+++ b/plugins/ltac/tacsubst.mli
diff --git a/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml
index b2601ad32..b2601ad32 100644
--- a/ltac/tactic_debug.ml
+++ b/plugins/ltac/tactic_debug.ml
diff --git a/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli
index 7745d9b7b..7745d9b7b 100644
--- a/ltac/tactic_debug.mli
+++ b/plugins/ltac/tactic_debug.mli
diff --git a/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml
index 5b5cd06cc..5b5cd06cc 100644
--- a/ltac/tactic_matching.ml
+++ b/plugins/ltac/tactic_matching.ml
diff --git a/ltac/tactic_matching.mli b/plugins/ltac/tactic_matching.mli
index 300b546f1..300b546f1 100644
--- a/ltac/tactic_matching.mli
+++ b/plugins/ltac/tactic_matching.mli
diff --git a/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml
index a5ba3b837..a5ba3b837 100644
--- a/ltac/tactic_option.ml
+++ b/plugins/ltac/tactic_option.ml
diff --git a/ltac/tactic_option.mli b/plugins/ltac/tactic_option.mli
index ed759a76d..ed759a76d 100644
--- a/ltac/tactic_option.mli
+++ b/plugins/ltac/tactic_option.mli
diff --git a/ltac/tauto.ml b/plugins/ltac/tauto.ml
index 707154a30..dc7ee6a23 100644
--- a/ltac/tauto.ml
+++ b/plugins/ltac/tauto.ml
@@ -268,7 +268,7 @@ let with_flags flags _ ist =
 
 let register_tauto_tactic tac name0 args =
   let ids = List.map (fun id -> Id.of_string id) args in
-  let ids = List.map (fun id -> Some id) ids in
+  let ids = List.map (fun id -> Name id) ids in
   let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in
   let entry = { mltac_name = name; mltac_index = 0 } in
   let () = Tacenv.register_ml_tactic name [| tac |] in
diff --git a/plugins/ltac/tauto.mli b/plugins/ltac/tauto.mli
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/plugins/ltac/tauto.mli
diff --git a/plugins/ltac/vo.itarget b/plugins/ltac/vo.itarget
new file mode 100644
index 000000000..a28fb770b
--- /dev/null
+++ b/plugins/ltac/vo.itarget
@@ -0,0 +1 @@
+Ltac.vo
diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v
index 2352d78d6..30e475b71 100644
--- a/plugins/micromega/RMicromega.v
+++ b/plugins/micromega/RMicromega.v
@@ -18,7 +18,7 @@ Require Import Refl.
 Require Import Raxioms RIneq Rpow_def DiscrR.
 Require Import QArith.
 Require Import Qfield.
-
+Require Import Qreals.
 
 Require Setoid.
 (*Declare ML Module "micromega_plugin".*)
@@ -38,15 +38,8 @@ Proof.
   exact Rplus_opp_r.
 Qed.
 
-Add Ring Rring : Rsrt.
 Open Scope R_scope.
 
-Lemma Rmult_neutral : forall x:R , 0 * x = 0.
-Proof.
-  intro ; ring.
-Qed.
-
-
 Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R)  Rle Rlt.
 Proof.
   constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)).
@@ -59,142 +52,41 @@ Proof.
   apply (Rlt_irrefl m) ; auto.
   apply Rnot_le_lt. auto with real.
   destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto.
-  intros.
-  rewrite <- (Rmult_neutral m).
-  apply (Rmult_lt_compat_r) ; auto.
-Qed.
-
-Definition IQR := fun x : Q => (IZR (Qnum x) * / IZR (' Qden x))%R.
-
-
-Lemma Rinv_elim : forall x y z, 
-  y <> 0 -> (z * y = x <->   x * / y = z).
-Proof.
-  intros.
-  split ; intros.
-  subst.
-  rewrite Rmult_assoc.
-  rewrite Rinv_r; auto.
-  ring.
-  subst.
-  rewrite Rmult_assoc.
-  rewrite (Rmult_comm (/ y)).
-  rewrite Rinv_r ; auto.
-  ring.
-Qed.  
-
-Ltac INR_nat_of_P :=
-  match goal with
-    | H : context[INR (Pos.to_nat ?X)] |- _ =>
-      revert H ; 
-      let HH := fresh in
-        assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X))
-    | |- context[INR (Pos.to_nat ?X)] =>
-      let HH := fresh in
-        assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X))
-  end.
-
-Ltac add_eq expr val := set (temp := expr) ; 
-  generalize (eq_refl temp) ;
-    unfold temp at 1 ; generalize temp ; intro val ; clear temp.
-
-Ltac Rinv_elim :=
-  match goal with
-    | |- context[?x * / ?y] => 
-      let z := fresh "v" in 
-      add_eq (x * / y) z  ;
-      let H := fresh in intro H ; rewrite <- Rinv_elim in H
-  end.
-
-Lemma Rlt_neq : forall r , 0 < r -> r <> 0.
-Proof.
-  red. intros.
-  subst.
-  apply (Rlt_irrefl 0 H).  
+  now apply Rmult_lt_0_compat.
 Qed.
 
+Notation IQR := Q2R (only parsing).
 
 Lemma Rinv_1 : forall x, x * / 1 = x.
 Proof.
   intro.
-  Rinv_elim.
-  subst ; ring.
-  apply R1_neq_R0.
+  rewrite Rinv_1.
+  apply Rmult_1_r.
 Qed.
 
-Lemma Qeq_true : forall x y,  
-  Qeq_bool x y = true -> 
-   IQR x = IQR y.
+Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y.
 Proof.
-  unfold IQR.
-  simpl.
-  intros.
-  apply Qeq_bool_eq in H.
-  unfold Qeq in H.
-  assert (IZR (Qnum x * ' Qden y) = IZR (Qnum y * ' Qden x))%Z.
-     rewrite H. reflexivity.
-  repeat rewrite mult_IZR in H0.
-  simpl in H0.
-  revert H0.
-  repeat INR_nat_of_P.
   intros.
-  apply Rinv_elim in H2 ; [| apply Rlt_neq ; auto].
-  rewrite <- H2.
-  field.
-  split ; apply Rlt_neq ; auto.
+  now apply Qeq_eqR, Qeq_bool_eq.
 Qed.
 
 Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y.
 Proof.
   intros.
-  apply Qeq_bool_neq  in H.
-  intro. apply H.   clear H.
-  unfold Qeq,IQR in *.
-  simpl in *.
-  revert H0.
-  repeat Rinv_elim.
-  intros.
-  subst.
-  assert (IZR (Qnum x * ' Qden y)%Z = IZR (Qnum y * ' Qden x)%Z).
-  repeat rewrite mult_IZR.  
-  simpl.
-  rewrite <- H0. rewrite <- H.
-  ring.
-  apply eq_IZR ; auto.
-  INR_nat_of_P; intros; apply Rlt_neq ; auto. 
-  INR_nat_of_P; intros ; apply Rlt_neq ; auto. 
+  apply Qeq_bool_neq in H.
+  contradict H.
+  now apply eqR_Qeq.
 Qed.
 
-  
-
 Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y.
 Proof.
   intros.
-  apply Qle_bool_imp_le in H.
-  unfold Qle in H.
-  unfold IQR.
-  simpl in *.
-  apply IZR_le in H.
-  repeat rewrite mult_IZR in H.
-  simpl in H.
-  repeat INR_nat_of_P; intros.
-  assert (Hr := Rlt_neq r H).
-  assert (Hr0 := Rlt_neq r0 H0).
-  replace (IZR (Qnum x) * / r) with ((IZR (Qnum x) * r0) * (/r * /r0)).
-  replace (IZR (Qnum y) * / r0) with ((IZR (Qnum y) * r) * (/r * /r0)).
-  apply Rmult_le_compat_r ; auto.
-  apply Rmult_le_pos.
-  unfold Rle. left. apply Rinv_0_lt_compat ; auto.
-  unfold Rle. left. apply Rinv_0_lt_compat ; auto.
-  field ; intuition.
-  field ; intuition.
+  now apply Qle_Rle, Qle_bool_imp_le.
 Qed.
 
-
-
 Lemma IQR_0 : IQR 0 = 0.
 Proof.
-  compute. apply Rinv_1.
+  apply Rmult_0_l.
 Qed.
 
 Lemma IQR_1 : IQR 1 = 1.
@@ -202,160 +94,6 @@ Proof.
   compute. apply Rinv_1.
 Qed.
 
-Lemma IQR_plus : forall x y, IQR (x + y) = IQR x + IQR y.
-Proof.
-  intros.
-  unfold IQR.
-  simpl in *.
-  rewrite plus_IZR in *.
-  rewrite mult_IZR in *.
-  simpl.  
-  rewrite Pos2Nat.inj_mul.
-  rewrite mult_INR.
-  rewrite mult_IZR.
-  simpl.
-  repeat INR_nat_of_P.
-  intros. field. 
-  split ; apply Rlt_neq ; auto.
-Qed.
-
-Lemma IQR_opp : forall x, IQR (- x) = - IQR x.
-Proof.
-  intros.
-  unfold IQR.
-  simpl.
-  rewrite opp_IZR.
-  ring.  
-Qed.
-
-Lemma IQR_minus : forall x y, IQR (x - y) = IQR x - IQR y.
-Proof.
-  intros.
-  unfold Qminus.
-  rewrite IQR_plus.
-  rewrite IQR_opp.
-  ring.
-Qed.
-
-
-Lemma IQR_mult : forall x y, IQR (x * y) = IQR x * IQR y.
-Proof.
-  unfold IQR ; intros.
-  simpl.
-  repeat rewrite mult_IZR.
-  rewrite Pos2Nat.inj_mul.
-  rewrite mult_INR.
-  repeat INR_nat_of_P.
-  intros. field ; split ; apply Rlt_neq ; auto.
-Qed.
-
-Lemma IQR_inv_lt : forall x, (0 < x)%Q -> 
-  IQR (/ x) =  / IQR x.
-Proof.
-  unfold IQR ; simpl.
-  intros.
-  unfold Qlt in H.
-  revert H.
-  simpl.
-  intros.
-  unfold Qinv.
-  destruct x.
-  destruct Qnum ; simpl in *.
-  exfalso. auto with zarith.
-  clear H.
-  repeat INR_nat_of_P.
-  intros.
-  assert (HH := Rlt_neq _ H).
-  assert (HH0 := Rlt_neq _ H0).
-  rewrite Rinv_mult_distr ; auto.
-  rewrite Rinv_involutive ; auto.
-  ring.
-  apply Rinv_0_lt_compat in H0.
-  apply Rlt_neq ; auto.
-  simpl in H.
-  exfalso.
-  rewrite Pos.mul_comm  in H.
-  compute in H.
-  discriminate.
-Qed.
-
-Lemma Qinv_opp : forall x, (- (/ x) = / ( -x))%Q.
-Proof.
-  destruct x ; destruct Qnum ; reflexivity.
-Qed.
-
-Lemma Qopp_involutive_strong : forall x, (- - x = x)%Q.
-Proof.
-  intros.
-  destruct x.
-  unfold Qopp.
-  simpl.
-  rewrite Z.opp_involutive.
-  reflexivity.
-Qed.
-
-Lemma Ropp_0 : forall r , - r = 0 -> r = 0.
-Proof.
-  intros.
-  rewrite <- (Ropp_involutive r).
-  apply Ropp_eq_0_compat ; auto.
-Qed.
-
-Lemma IQR_x_0 : forall x, IQR x = 0 -> x == 0%Q.
-Proof.
-  destruct x ; simpl.
-  unfold IQR.
-  simpl.
-  INR_nat_of_P.
-  intros.
-  apply Rmult_integral in H0.  
-  destruct H0.
-  apply eq_IZR_R0 in H0.
-  subst.
-  reflexivity.
-  exfalso.
-  apply Rinv_0_lt_compat in H.
-  rewrite <- H0 in H.
-  apply Rlt_irrefl in H. auto.
-Qed.
-  
-
-Lemma IQR_inv_gt : forall x, (0 > x)%Q -> 
-  IQR (/ x) =  / IQR x.
-Proof.
-  intros.
-  rewrite <- (Qopp_involutive_strong x).
-  rewrite <- Qinv_opp.
-  rewrite IQR_opp.
-  rewrite IQR_inv_lt.
-  repeat rewrite IQR_opp.
-  rewrite Ropp_inv_permute.
-  auto.
-  intro.
-  apply Ropp_0 in H0.
-  apply IQR_x_0 in H0.
-  rewrite H0 in H.
-  compute in H. discriminate.
-  unfold Qlt in *.
-  destruct x ; simpl in *.
-  auto with zarith.
-Qed.
-
-Lemma IQR_inv : forall x, ~ x ==  0 -> 
-  IQR (/ x) =  / IQR x.
-Proof.
-  intros.
-  assert ( 0 > x \/ 0 < x)%Q.
-   destruct x ; unfold Qlt, Qeq in * ; simpl in *.
-   rewrite Z.mul_1_r in *.
-   destruct Qnum ; simpl in * ; intuition auto.
-   right. reflexivity.
-   left ; reflexivity.
-  destruct H0.
-  apply IQR_inv_gt ; auto.
-  apply IQR_inv_lt ; auto.
-Qed.
-
 Lemma IQR_inv_ext : forall x, 
   IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x).
 Proof.
@@ -366,18 +104,13 @@ Proof.
   destruct x ; simpl.
   unfold Qeq in H.
   simpl in H.
-  replace Qnum with 0%Z.
-  compute. rewrite Rinv_1.
-  reflexivity.
-  rewrite <- H. ring.
+  rewrite Zmult_1_r in H.
+  rewrite H.
+  apply Rmult_0_l.
   intros.
-  apply IQR_inv.
-  intro.
-  rewrite <- Qeq_bool_iff in H0.
-  congruence.
+  now apply Q2R_inv, Qeq_bool_neq.
 Qed.
 
-
 Notation to_nat := N.to_nat.
 
 Lemma QSORaddon :
@@ -391,10 +124,10 @@ Proof.
   constructor ; intros ; try reflexivity.
   apply IQR_0.
   apply IQR_1.
-  apply IQR_plus.
-  apply IQR_minus.
-  apply IQR_mult.
-  apply IQR_opp.
+  apply Q2R_plus.
+  apply Q2R_minus.
+  apply Q2R_mult.
+  apply Q2R_opp.
   apply Qeq_true ; auto.
   apply R_power_theory.
   apply Qeq_false.
@@ -453,13 +186,13 @@ Proof.
     apply IQR_1. 
     reflexivity.
     unfold IQR. simpl. rewrite Rinv_1. reflexivity.
-    apply IQR_plus.
-    apply IQR_minus.
-    apply IQR_mult.
+    apply Q2R_plus.
+    apply Q2R_minus.
+    apply Q2R_mult.
     rewrite <- IHc.
     apply IQR_inv_ext.
     rewrite <- IHc.
-    apply IQR_opp.
+    apply Q2R_opp.
   Qed.
 
 Require Import EnvRing.
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
index 5b56fb35b..4b87e6e2e 100644
--- a/plugins/micromega/coq_micromega.ml
+++ b/plugins/micromega/coq_micromega.ml
@@ -368,6 +368,7 @@ struct
     [["Coq";"Reals" ; "Rdefinitions"];
      ["Coq";"Reals" ; "Rpow_def"] ;
      ["Coq";"Reals" ; "Raxioms"] ;
+     ["Coq";"QArith"; "Qreals"] ;
     ]
 
   let z_modules = [["Coq";"ZArith";"BinInt"]]
@@ -388,7 +389,6 @@ struct
   let coq_and = lazy (init_constant "and")
   let coq_or = lazy (init_constant "or")
   let coq_not = lazy (init_constant "not")
-  let coq_not_gl_ref = (Nametab.locate (  Libnames.qualid_of_string "Coq.Init.Logic.not"))
 
   let coq_iff = lazy (init_constant "iff")
   let coq_True = lazy (init_constant "True")
@@ -485,7 +485,7 @@ struct
   let coq_Rinv = lazy (r_constant "Rinv")
   let coq_Rpower = lazy (r_constant "pow")
   let coq_IZR    = lazy (r_constant "IZR")
-  let coq_IQR    = lazy (constant "IQR")
+  let coq_IQR    = lazy (r_constant "Q2R")
 
 
   let coq_PEX = lazy (constant "PEX" )
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 79020ed03..ccb6daa11 100644
--- a/plugins/micromega/g_micromega.ml4
+++ b/plugins/micromega/g_micromega.ml4
@@ -16,6 +16,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open Stdarg
 open Tacarg
 
diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4
index a6749c347..759885253 100644
--- a/plugins/nsatz/g_nsatz.ml4
+++ b/plugins/nsatz/g_nsatz.ml4
@@ -1,5 +1,3 @@
-DECLARE PLUGIN "nsatz_plugin"
-
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
@@ -10,6 +8,9 @@ DECLARE PLUGIN "nsatz_plugin"
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
+open Names
+
 DECLARE PLUGIN "nsatz_plugin"
 
 TACTIC EXTEND nsatz_compute
diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4
index 27115abec..6b711a176 100644
--- a/plugins/omega/g_omega.ml4
+++ b/plugins/omega/g_omega.ml4
@@ -17,6 +17,7 @@
 
 DECLARE PLUGIN "omega_plugin"
 
+open Ltac_plugin
 open Names
 open Coq_omega
 open Stdarg
diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
index 40c1028e5..6c3e66112 100644
--- a/plugins/quote/g_quote.ml4
+++ b/plugins/quote/g_quote.ml4
@@ -8,6 +8,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open Names
 open Misctypes
 open Tacexpr
diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4
index 2f38688d1..9a54ad778 100644
--- a/plugins/romega/g_romega.ml4
+++ b/plugins/romega/g_romega.ml4
@@ -10,6 +10,7 @@
 
 DECLARE PLUGIN "romega_plugin"
 
+open Ltac_plugin
 open Names
 open Refl_omega
 open Stdarg
diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4
index d27b04834..7e58ef9a3 100644
--- a/plugins/rtauto/g_rtauto.ml4
+++ b/plugins/rtauto/g_rtauto.ml4
@@ -8,6 +8,8 @@
 
 (*i camlp4deps: "grammar/grammar.cma"  i*)
 
+open Ltac_plugin
+
 DECLARE PLUGIN "rtauto_plugin"
 
 TACTIC EXTEND rtauto
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
index 8b9261113..1ad4d622b 100644
--- a/plugins/rtauto/proof_search.ml
+++ b/plugins/rtauto/proof_search.ml
@@ -505,12 +505,12 @@ let pp_mapint map =
 		pp_form obj ++ str " => " ++
 				 pp_list (fun (i,f) -> pp_form f) l ++
 				 cut ()) ) map;
-    str "{ " ++ vb 0 ++  (!pp) ++ str " }" ++ close ()
+    str "{ " ++ hv 0 (!pp ++ str " }")
 
 let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2
 
 let pp_gl gl= cut () ++
-  str "{ " ++ vb 0 ++
+  str "{ " ++ hv 0 (
 	      begin
 		match gl.abs with
 		    None -> str ""
@@ -520,7 +520,7 @@ let pp_gl gl= cut () ++
   str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++
   str "arrows=" ++ pp_mapint gl.right ++ cut () ++
   str "cnx   =" ++ pp_list pp_connect gl.cnx ++ cut () ++
-  str "goal  =" ++ pp_form gl.gl ++ str " }" ++ close ()
+  str "goal  =" ++ pp_form gl.gl ++ str " }")
 
 let pp =
   function
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index adb11f4f8..f30f8a943 100644
--- a/plugins/rtauto/refl_tauto.ml
+++ b/plugins/rtauto/refl_tauto.ml
@@ -8,6 +8,7 @@
 
 module Search = Explore.Make(Proof_search)
 
+open Ltac_plugin
 open CErrors
 open Util
 open Term
diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v
index 293722125..facd2e062 100644
--- a/plugins/setoid_ring/RealField.v
+++ b/plugins/setoid_ring/RealField.v
@@ -59,11 +59,12 @@ Notation Rset := (Eqsth R).
 Notation Rext := (Eq_ext Rplus Rmult Ropp).
 
 Lemma Rlt_0_2 : 0 < 2.
+Proof.
 apply Rlt_trans with (0 + 1).
  apply Rlt_n_Sn.
  rewrite Rplus_comm.
    apply Rplus_lt_compat_l.
-    replace 1 with (0 + 1).
+    replace R1 with (0 + 1).
   apply Rlt_n_Sn.
   apply Rplus_0_l.
 Qed.
@@ -126,9 +127,17 @@ Ltac Rpow_tac t :=
   | _ => constr:(N.of_nat t)
   end.
 
-Add Field RField : Rfield
-   (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]).
-
-
-
+Ltac IZR_tac t :=
+  match t with
+  | R0 => constr:(0%Z)
+  | R1 => constr:(1%Z)
+  | IZR ?u =>
+    match isZcst u with
+    | true => u
+    | _ => constr:(InitialRing.NotConstant)
+    end
+  | _ => constr:(InitialRing.NotConstant)
+  end.
 
+Add Field RField : Rfield
+   (completeness Zeq_bool_complete, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]).
diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4
index b1882ae8a..05ab8ab32 100644
--- a/plugins/setoid_ring/g_newring.ml4
+++ b/plugins/setoid_ring/g_newring.ml4
@@ -8,6 +8,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open Pp
 open Util
 open Libnames
diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml
index f52557095..dd68eac24 100644
--- a/plugins/setoid_ring/newring.ml
+++ b/plugins/setoid_ring/newring.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open Pp
 open CErrors
 open Util
@@ -128,7 +129,7 @@ let closed_term_ast l =
     mltac_index = 0;
   } in
   let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in
-  TacFun([Some(Id.of_string"t")],
+  TacFun([Name(Id.of_string"t")],
   TacML(Loc.ghost,tacname,
   [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None));
    TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)]))
@@ -213,7 +214,7 @@ let exec_tactic env evd n f args =
   let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in
   let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in
   let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in
-  let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in
+  let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in
   (** Evaluate the whole result *)
   let gl = dummy_goal env evd in
   let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in
@@ -331,14 +332,16 @@ let _ = add_map "ring"
   (map_with_eq
     [coq_cons,(function -1->Eval|2->Rec|_->Prot);
     coq_nil, (function -1->Eval|_ -> Prot);
+    my_reference "IDphi", (function _->Eval);
+    my_reference "gen_phiZ", (function _->Eval);
     (* Pphi_dev: evaluate polynomial and coef operations, protect
        ring operations and make recursive call on the var map *)
     pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
     pol_cst "Pphi_pow",
-          (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
+          (function -1|8|9|10|13|15|17->Eval|11|16->Rec|_->Prot);
     (* PEeval: evaluate morphism and polynomial, protect ring
        operations and make recursive call on the var map *)
-    pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)])
+    pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot)])
 
 (****************************************************************************)
 (* Ring database *)
@@ -742,8 +745,8 @@ let ltac_ring_structure e =
   let pow_tac = tacarg e.ring_pow_tac in
   let lemma1 = carg e.ring_lemma1 in
   let lemma2 = carg e.ring_lemma2 in
-  let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in
-  let posttac = tacarg (TacFun([None],e.ring_post_tac)) in
+  let pretac = tacarg (TacFun([Anonymous],e.ring_pre_tac)) in
+  let posttac = tacarg (TacFun([Anonymous],e.ring_post_tac)) in
   [req;sth;ext;morph;th;cst_tac;pow_tac;
    lemma1;lemma2;pretac;posttac]
 
@@ -775,12 +778,14 @@ let _ = add_map "field"
   (map_with_eq
     [coq_cons,(function -1->Eval|2->Rec|_->Prot);
     coq_nil, (function -1->Eval|_ -> Prot);
+    my_reference "IDphi", (function _->Eval);
+    my_reference "gen_phiZ", (function _->Eval);
     (* display_linear: evaluate polynomials and coef operations, protect
        field operations and make recursive call on the var map *)
     my_reference "display_linear",
       (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot);
     my_reference "display_pow_linear",
-     (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot);
+     (function -1|9|10|11|14|16|18|19->Eval|12|17->Rec|_->Prot);
    (* Pphi_dev: evaluate polynomial and coef operations, protect
        ring operations and make recursive call on the var map *)
     pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
@@ -788,19 +793,20 @@ let _ = add_map "field"
           (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
     (* PEeval: evaluate morphism and polynomial, protect ring
        operations and make recursive call on the var map *)
-    pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot);
+    pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot);
     (* FEeval: evaluate morphism, protect field
        operations and make recursive call on the var map *)
-    my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
+    my_reference "FEeval", (function -1|10|12|15->Eval|14->Rec|_->Prot)]);;
 
 let _ = add_map "field_cond"
   (map_without_eq
     [coq_cons,(function -1->Eval|2->Rec|_->Prot);
      coq_nil, (function -1->Eval|_ -> Prot);
-    (* PCond: evaluate morphism and denum list, protect ring
+     my_reference "IDphi", (function _->Eval);
+     my_reference "gen_phiZ", (function _->Eval);
+    (* PCond: evaluate denum list, protect ring
        operations and make recursive call on the var map *)
-     my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);;
-(*                       (function -1|9|11->Eval|10->Rec|_->Prot)]);;*)
+     my_reference "PCond", (function -1|11|14->Eval|9|13->Rec|_->Prot)]);;
 
 
 let _ = Redexpr.declare_reduction "simpl_field_expr"
@@ -1025,8 +1031,8 @@ let ltac_field_structure e =
   let field_simpl_eq_ok = carg e.field_simpl_eq_ok in
   let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in
   let cond_ok = carg e.field_cond in
-  let pretac = tacarg (TacFun([None],e.field_pre_tac)) in
-  let posttac = tacarg (TacFun([None],e.field_post_tac)) in
+  let pretac = tacarg (TacFun([Anonymous],e.field_pre_tac)) in
+  let posttac = tacarg (TacFun([Anonymous],e.field_post_tac)) in
   [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
    field_simpl_eq_in_ok;cond_ok;pretac;posttac]
 
diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4
index 1094d50af..01e20d0f1 100644
--- a/plugins/ssrmatching/ssrmatching.ml4
+++ b/plugins/ssrmatching/ssrmatching.ml4
@@ -15,6 +15,7 @@ let frozen_lexer = CLexer.freeze () ;;
 (*i camlp4use: "pa_extend.cmo" i*)
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open Names
 open Pp
 open Pcoq
@@ -1427,7 +1428,7 @@ let () =
   let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in
   let () = Tacenv.register_ml_tactic name [|mltac|] in
   let tac =
-    TacFun ([Some (Id.of_string "pattern")],
+    TacFun ([Name (Id.of_string "pattern")],
       TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in
   let obj () =
     Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in
diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml
index 3ae2d45f3..8f065f528 100644
--- a/plugins/syntax/r_syntax.ml
+++ b/plugins/syntax/r_syntax.ml
@@ -9,6 +9,8 @@
 open Util
 open Names
 open Globnames
+open Glob_term
+open Bigint
 
 (* Poor's man DECLARE PLUGIN *)
 let __coq_plugin_name = "r_syntax_plugin"
@@ -17,95 +19,105 @@ let () = Mltop.add_known_module __coq_plugin_name
 exception Non_closed_number
 
 (**********************************************************************)
-(* Parsing R via scopes                                               *)
+(* Parsing positive via scopes                                        *)
 (**********************************************************************)
 
-open Glob_term
-open Bigint
+let binnums = ["Coq";"Numbers";"BinNums"]
 
 let make_dir l = DirPath.make (List.rev_map Id.of_string l)
-let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"]
-let make_path dir id = Libnames.make_path dir (Id.of_string id)
+let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id)
+
+let positive_path = make_path binnums "positive"
+
+(* TODO: temporary hack *)
+let make_kn dir id = Globnames.encode_mind dir id
+
+let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive")
+let glob_positive = IndRef (positive_kn,0)
+let path_of_xI = ((positive_kn,0),1)
+let path_of_xO = ((positive_kn,0),2)
+let path_of_xH = ((positive_kn,0),3)
+let glob_xI = ConstructRef path_of_xI
+let glob_xO = ConstructRef path_of_xO
+let glob_xH = ConstructRef path_of_xH
+
+let pos_of_bignat dloc x =
+  let ref_xI = GRef (dloc, glob_xI, None) in
+  let ref_xH = GRef (dloc, glob_xH, None) in
+  let ref_xO = GRef (dloc, glob_xO, None) in
+  let rec pos_of x =
+    match div2_with_rest x with
+      | (q,false) -> GApp (dloc, ref_xO,[pos_of q])
+      | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q])
+      | (q,true) -> ref_xH
+  in
+  pos_of x
+
+(**********************************************************************)
+(* Printing positive via scopes                                       *)
+(**********************************************************************)
+
+let rec bignat_of_pos = function
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a)
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a))
+  | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one
+  | _ -> raise Non_closed_number
+
+(**********************************************************************)
+(* Parsing Z via scopes                                               *)
+(**********************************************************************)
 
+let z_path = make_path binnums "Z"
+let z_kn = make_kn (make_dir binnums) (Id.of_string "Z")
+let glob_z = IndRef (z_kn,0)
+let path_of_ZERO = ((z_kn,0),1)
+let path_of_POS = ((z_kn,0),2)
+let path_of_NEG = ((z_kn,0),3)
+let glob_ZERO = ConstructRef path_of_ZERO
+let glob_POS = ConstructRef path_of_POS
+let glob_NEG = ConstructRef path_of_NEG
+
+let z_of_int dloc n =
+  if not (Bigint.equal n zero) then
+    let sgn, n =
+      if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in
+    GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n])
+  else
+    GRef (dloc, glob_ZERO, None)
+
+(**********************************************************************)
+(* Printing Z via scopes                                              *)
+(**********************************************************************)
+
+let bigint_of_z = function
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a)
+  | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero
+  | _ -> raise Non_closed_number
+
+(**********************************************************************)
+(* Parsing R via scopes                                               *)
+(**********************************************************************)
+
+let rdefinitions = ["Coq";"Reals";"Rdefinitions"]
 let r_path = make_path rdefinitions "R"
 
 (* TODO: temporary hack *)
 let make_path dir id = Globnames.encode_con dir (Id.of_string id)
 
-let r_kn = make_path rdefinitions "R"
-let glob_R = ConstRef r_kn
-let glob_R1 = ConstRef (make_path rdefinitions "R1")
-let glob_R0 = ConstRef (make_path rdefinitions "R0")
-let glob_Ropp = ConstRef (make_path rdefinitions "Ropp")
-let glob_Rplus = ConstRef (make_path rdefinitions "Rplus")
-let glob_Rmult = ConstRef (make_path rdefinitions "Rmult")
-
-let two = mult_2 one
-let three = add_1 two
-let four = mult_2 two
-
-(* Unary representation of strictly positive numbers *)
-let rec small_r dloc n =
-  if equal one n then GRef (dloc, glob_R1, None)
-  else GApp(dloc,GRef (dloc,glob_Rplus, None),
-            [GRef (dloc, glob_R1, None);small_r dloc (sub_1 n)])
-
-let r_of_posint dloc n =
-  let r1 = GRef (dloc, glob_R1, None) in
-  let r2 = small_r dloc two in
-  let rec r_of_pos n =
-    if less_than n four then small_r dloc n
-    else
-      let (q,r) = div2_with_rest n in
-      let b = GApp(dloc,GRef(dloc,glob_Rmult,None),[r2;r_of_pos q]) in
-      if r then GApp(dloc,GRef(dloc,glob_Rplus,None),[r1;b]) else b in
-  if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0,None)
+let glob_IZR = ConstRef (make_path (make_dir rdefinitions) "IZR")
 
 let r_of_int dloc z =
-  if is_strictly_neg z then
-    GApp (dloc, GRef(dloc,glob_Ropp,None), [r_of_posint dloc (neg z)])
-  else
-    r_of_posint dloc z
+  GApp (dloc, GRef(dloc,glob_IZR,None), [z_of_int dloc z])
 
 (**********************************************************************)
 (* Printing R via scopes                                              *)
 (**********************************************************************)
 
-let bignat_of_r =
-(* for numbers > 1 *)
-let rec bignat_of_pos = function
-  (* 1+1 *)
-  | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)])
-      when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two
-  (* 1+(1+1) *)
-  | GApp (_,GRef (_,p1,_), [GRef (_,o1,_);
-      GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])])
-      when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus &&
-           Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three
-  (* (1+1)*b *)
-  | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult ->
-      if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number;
-      mult_2 (bignat_of_pos b)
-  (* 1+(1+1)*b *)
-  | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])])
-      when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1  ->
-      if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number;
-        add_1 (mult_2 (bignat_of_pos b))
-  | _ -> raise Non_closed_number
-in
-let bignat_of_r = function
-  | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero
-  | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one
-  | r -> bignat_of_pos r
-in
-bignat_of_r
-
 let bigint_of_r = function
-  | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp ->
-      let n = bignat_of_r a in
-      if Bigint.equal n zero then raise Non_closed_number;
-      neg n
-  | a -> bignat_of_r a
+  | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_IZR ->
+      bigint_of_z a
+  | _ -> raise Non_closed_number
 
 let uninterp_r p =
   try
@@ -113,12 +125,9 @@ let uninterp_r p =
   with Non_closed_number ->
     None
 
-let mkGRef gr = GRef (Loc.ghost,gr,None)
-
 let _ = Notation.declare_numeral_interpreter "R_scope"
   (r_path,["Coq";"Reals";"Rdefinitions"])
   r_of_int
-  (List.map mkGRef 
-    [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1],
+  ([GRef (Loc.ghost,glob_IZR,None)],
     uninterp_r,
     false)
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 043616a51..85cc8762e 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -514,8 +514,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
   (* Evar must be undefined since we have flushed evars *)
   let () = if !debug_unification then
 	     let open Pp in
-	     Feedback.msg_notice (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ()) 
-		 ++ fnl ()) in
+	     Feedback.msg_notice (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ())) in
   match (flex_kind_of_term (fst ts) env evd term1 sk1, 
 	 flex_kind_of_term (fst ts) env evd term2 sk2) with
     | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) ->
@@ -1152,6 +1151,10 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
   let t2 = apprec_nohdbeta ts env evd (whd_head_evar evd t2) in
   let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in
   let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in
+  let () = if !debug_unification then
+	     let open Pp in
+	     Feedback.msg_notice (v 0 (str "Heuristic:" ++ spc () ++ print_constr t1
+                                       ++ cut () ++ print_constr t2 ++ cut ())) in
   let app_empty = Array.is_empty l1 && Array.is_empty l2 in
   match EConstr.kind evd term1, EConstr.kind evd term2 with
   | Evar (evk1,args1), (Rel _|Var _) when app_empty
diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index 823071e29..8c6b39b7e 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -402,7 +402,9 @@ let rec pat_of_raw metas vars = function
 
 and pats_of_glob_branches loc metas vars ind brs =
   let get_arg = function
-    | PatVar(_,na) -> na
+    | PatVar(_,na) ->
+      name_iter (fun n -> metas := n::!metas) na;
+      na
     | PatCstr(loc,_,_,_) -> err ~loc (Pp.str "Non supported pattern.")
   in
   let rec get_pat indexes = function
diff --git a/printing/miscprint.ml b/printing/miscprint.ml
index 7b2c5695f..360843711 100644
--- a/printing/miscprint.ml
+++ b/printing/miscprint.ml
@@ -28,7 +28,7 @@ and pr_intro_pattern_action prc = function
   | IntroInjection pl ->
       str "[=" ++ hv 0 (prlist_with_sep spc (pr_intro_pattern prc) pl) ++
       str "]"
-  | IntroApplyOn (c,pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c
+  | IntroApplyOn ((_,c),pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c
   | IntroRewrite true -> str "->"
   | IntroRewrite false -> str "<-"
 
diff --git a/printing/ppannotation.ml b/printing/ppannotation.ml
deleted file mode 100644
index 726c0ffcf..000000000
--- a/printing/ppannotation.ml
+++ /dev/null
@@ -1,33 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Ppextend
-open Constrexpr
-open Vernacexpr
-open Genarg
-
-type t =
-  | AKeyword
-  | AUnparsing            of unparsing
-  | AConstrExpr           of constr_expr
-  | AVernac               of vernac_expr
-  | AGlbGenArg            of glob_generic_argument
-  | ARawGenArg            of raw_generic_argument
-
-let tag_of_annotation = function
-  | AKeyword                -> "keyword"
-  | AUnparsing _            -> "unparsing"
-  | AConstrExpr _           -> "constr_expr"
-  | AVernac _               -> "vernac_expr"
-  | AGlbGenArg _            -> "glob_generic_argument"
-  | ARawGenArg _            -> "raw_generic_argument"
-
-let attributes_of_annotation a =
-  []
-
-let tag = Pp.Tag.create "ppannotation"
diff --git a/printing/ppannotation.mli b/printing/ppannotation.mli
deleted file mode 100644
index b0e0facef..000000000
--- a/printing/ppannotation.mli
+++ /dev/null
@@ -1,29 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** This module defines the annotations that are attached to
-    semi-structured pretty-printing of Coq syntactic objects. *)
-
-open Ppextend
-open Constrexpr
-open Vernacexpr
-open Genarg
-
-type t =
-  | AKeyword
-  | AUnparsing            of unparsing
-  | AConstrExpr           of constr_expr
-  | AVernac               of vernac_expr
-  | AGlbGenArg            of glob_generic_argument
-  | ARawGenArg            of raw_generic_argument
-
-val tag_of_annotation : t -> string
-
-val attributes_of_annotation : t -> (string * string) list
-
-val tag : t Pp.Tag.key
diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml
index 80ddd669f..d92d83275 100644
--- a/printing/ppconstr.ml
+++ b/printing/ppconstr.ml
@@ -21,18 +21,31 @@ open Decl_kinds
 open Misctypes
 (*i*)
 
-module Make (Taggers : sig
-  val tag_keyword     : std_ppcmds -> std_ppcmds
-  val tag_evar     : std_ppcmds -> std_ppcmds
-  val tag_type     : std_ppcmds -> std_ppcmds
-  val tag_path     : std_ppcmds -> std_ppcmds
-  val tag_ref     : std_ppcmds -> std_ppcmds
-  val tag_var     : std_ppcmds -> std_ppcmds
-  val tag_constr_expr : constr_expr -> std_ppcmds -> std_ppcmds
-  val tag_unparsing   : unparsing -> std_ppcmds -> std_ppcmds
-end) = struct
-
-  open Taggers
+module Tag =
+struct
+  let keyword   = "constr.keyword"
+  let evar      = "constr.evar"
+  let univ      = "constr.type"
+  let notation  = "constr.notation"
+  let variable  = "constr.variable"
+  let reference = "constr.reference"
+  let path      = "constr.path"
+
+end
+
+let do_not_tag _ x = x
+let tag t s = Pp.tag t s
+let tag_keyword     = tag Tag.keyword
+let tag_evar        = tag Tag.evar
+let tag_type        = tag Tag.univ
+let tag_unparsing   = function
+| UnpTerminal s -> tag Tag.notation
+| _ -> do_not_tag ()
+let tag_constr_expr = do_not_tag
+let tag_path = tag Tag.path
+let tag_ref = tag Tag.reference
+let tag_var = tag Tag.variable
+
 
   let keyword s = tag_keyword (str s)
   let sep_v = fun _ -> str"," ++ spc()
@@ -764,86 +777,3 @@ end) = struct
 
   let pr_binders = pr_undelimited_binders spc (pr ltop)
 
-end
-
-module Tag =
-struct
-  let keyword =
-    let style = Terminal.make ~bold:true () in
-    Ppstyle.make ~style ["constr"; "keyword"]
-
-  let evar =
-    let style = Terminal.make ~fg_color:`LIGHT_BLUE () in
-    Ppstyle.make ~style ["constr"; "evar"]
-
-  let univ =
-    let style = Terminal.make ~bold:true ~fg_color:`YELLOW () in
-    Ppstyle.make ~style ["constr"; "type"]
-
-  let notation =
-    let style = Terminal.make ~fg_color:`WHITE () in
-    Ppstyle.make ~style ["constr"; "notation"]
-
-  let variable =
-    Ppstyle.make ["constr"; "variable"]
-
-  let reference =
-    let style = Terminal.make ~fg_color:`LIGHT_GREEN () in
-    Ppstyle.make ~style ["constr"; "reference"]
-
-  let path =
-    let style = Terminal.make ~fg_color:`LIGHT_MAGENTA () in
-    Ppstyle.make ~style ["constr"; "path"]
-
-end
-
-let do_not_tag _ x = x
-
-let split_token tag s =
-  let len = String.length s in
-  let rec parse_string off i =
-    if Int.equal i len then
-      if Int.equal off i then mt () else tag (str (String.sub s off (i - off)))
-    else if s.[i] == ' ' then
-      if Int.equal off i then parse_space 1 (succ i)
-      else tag (str (String.sub s off (i - off))) ++ parse_space 1 (succ i)
-    else parse_string off (succ i)
-  and parse_space spc i =
-    if Int.equal i len then str (String.make spc ' ')
-    else if s.[i] == ' ' then parse_space (succ spc) (succ i)
-    else str (String.make spc ' ') ++ parse_string i (succ i)
-  in
-  parse_string 0 0
-
-(** Instantiating Make with tagging functions that only add style
-    information. *)
-include Make (struct
-    let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s
-    let tag_keyword     = tag Tag.keyword
-    let tag_evar        = tag Tag.evar
-    let tag_type        = tag Tag.univ
-    let tag_unparsing   = function
-    | UnpTerminal s -> fun _ -> split_token (fun pp -> tag Tag.notation pp) s
-    | _ -> do_not_tag ()
-    let tag_constr_expr = do_not_tag
-    let tag_path = tag Tag.path
-    let tag_ref = tag Tag.reference
-    let tag_var = tag Tag.variable
-end)
-
-module Richpp = struct
-
-  include Make (struct
-    open Ppannotation
-    let tag_keyword       = Pp.tag (Pp.Tag.inj AKeyword tag)
-    let tag_type          = Pp.tag (Pp.Tag.inj AKeyword tag)
-    let tag_evar          = do_not_tag ()
-    let tag_unparsing unp = Pp.tag (Pp.Tag.inj (AUnparsing unp) tag)
-    let tag_constr_expr e = Pp.tag (Pp.Tag.inj (AConstrExpr e) tag)
-    let tag_path = do_not_tag ()
-    let tag_ref = do_not_tag ()
-    let tag_var = do_not_tag ()
-  end)
-
-end
-
diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli
index 0241633c6..a0106837a 100644
--- a/printing/ppconstr.mli
+++ b/printing/ppconstr.mli
@@ -11,11 +11,85 @@
 
 (** The default pretty-printers produce {!Pp.std_ppcmds} that are
     interpreted as raw strings. *)
-include Ppconstrsig.Pp
+open Loc
+open Pp
+open Libnames
+open Constrexpr
+open Names
+open Misctypes
 
-(** The rich pretty-printers produce {!Pp.std_ppcmds} that are
-    interpreted as annotated strings. The annotations can be
-    retrieved using {!RichPp.rich_pp}. Their definitions are
-    located in {!Ppannotation.t}. *)
+val extract_lam_binders :
+  constr_expr -> local_binder list * constr_expr
+val extract_prod_binders :
+  constr_expr -> local_binder list * constr_expr
+val split_fix :
+  int -> constr_expr -> constr_expr ->
+  local_binder list *  constr_expr * constr_expr
 
-module Richpp : Ppconstrsig.Pp
+val prec_less : int -> int * Ppextend.parenRelation -> bool
+
+val pr_tight_coma : unit -> std_ppcmds
+
+val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
+
+val pr_lident : Id.t located -> std_ppcmds
+val pr_lname : Name.t located -> std_ppcmds
+
+val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds
+val pr_com_at : int -> std_ppcmds
+val pr_sep_com :
+  (unit -> std_ppcmds) ->
+  (constr_expr -> std_ppcmds) ->
+  constr_expr -> std_ppcmds
+
+val pr_id : Id.t -> std_ppcmds
+val pr_name : Name.t -> std_ppcmds
+val pr_qualid : qualid -> std_ppcmds
+val pr_patvar : patvar -> std_ppcmds
+
+val pr_glob_level : glob_level -> std_ppcmds
+val pr_glob_sort : glob_sort -> std_ppcmds
+val pr_guard_annot : (constr_expr -> std_ppcmds) ->
+  local_binder list ->
+  ('a * Names.Id.t) option * recursion_order_expr ->
+  std_ppcmds
+
+val pr_record_body : (reference * constr_expr) list -> std_ppcmds
+val pr_binders : local_binder list -> std_ppcmds
+val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds
+val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
+val pr_constr_expr : constr_expr -> std_ppcmds
+val pr_lconstr_expr : constr_expr -> std_ppcmds
+val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds
+
+type term_pr = {
+  pr_constr_expr   : constr_expr -> std_ppcmds;
+  pr_lconstr_expr  : constr_expr -> std_ppcmds;
+  pr_constr_pattern_expr  : constr_pattern_expr -> std_ppcmds;
+  pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
+}
+
+val set_term_pr : term_pr -> unit
+val default_term_pr : term_pr
+
+(* The modular constr printer.
+  [modular_constr_pr pr s p t] prints the head of the term [t] and calls
+  [pr] on its subterms.
+  [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers
+  and [ltop] for "lconstr" printers (spiwack: we might need more
+  specification here).
+  We can make a new modular constr printer by overriding certain branches,
+  for instance if we want to build a printer which prints "Prop" as "Omega"
+  instead we can proceed as follows:
+  let my_modular_constr_pr pr s p = function
+  | CSort (_,GProp Null) -> str "Omega"
+  | t -> modular_constr_pr pr s p t
+  Which has the same type. We can turn a modular printer into a printer by
+  taking its fixpoint. *)
+
+type precedence
+val lsimpleconstr : precedence
+val ltop : precedence
+val modular_constr_pr :
+  ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) ->
+  (unit->std_ppcmds) -> precedence  -> constr_expr -> std_ppcmds
diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli
deleted file mode 100644
index 3de0d805c..000000000
--- a/printing/ppconstrsig.mli
+++ /dev/null
@@ -1,95 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Loc
-open Pp
-open Libnames
-open Constrexpr
-open Names
-open Misctypes
-
-module type Pp = sig
-
-  val extract_lam_binders :
-    constr_expr -> local_binder list * constr_expr
-  val extract_prod_binders :
-    constr_expr -> local_binder list * constr_expr
-  val split_fix :
-    int -> constr_expr -> constr_expr ->
-    local_binder list *  constr_expr * constr_expr
-
-  val prec_less : int -> int * Ppextend.parenRelation -> bool
-
-  val pr_tight_coma : unit -> std_ppcmds
-
-  val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
-
-  val pr_lident : Id.t located -> std_ppcmds
-  val pr_lname : Name.t located -> std_ppcmds
-
-  val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds
-  val pr_com_at : int -> std_ppcmds
-  val pr_sep_com :
-    (unit -> std_ppcmds) ->
-    (constr_expr -> std_ppcmds) ->
-    constr_expr -> std_ppcmds
-
-  val pr_id : Id.t -> std_ppcmds
-  val pr_name : Name.t -> std_ppcmds
-  val pr_qualid : qualid -> std_ppcmds
-  val pr_patvar : patvar -> std_ppcmds
-
-  val pr_glob_level : glob_level -> std_ppcmds
-  val pr_glob_sort : glob_sort -> std_ppcmds
-  val pr_guard_annot : (constr_expr -> std_ppcmds) ->
-    local_binder list ->
-    ('a * Names.Id.t) option * recursion_order_expr ->
-    std_ppcmds
-
-  val pr_record_body : (reference * constr_expr) list -> std_ppcmds
-  val pr_binders : local_binder list -> std_ppcmds
-  val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds
-  val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
-  val pr_constr_expr : constr_expr -> std_ppcmds
-  val pr_lconstr_expr : constr_expr -> std_ppcmds
-  val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds
-
-  type term_pr = {
-    pr_constr_expr   : constr_expr -> std_ppcmds;
-    pr_lconstr_expr  : constr_expr -> std_ppcmds;
-    pr_constr_pattern_expr  : constr_pattern_expr -> std_ppcmds;
-    pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
-  }
-
-  val set_term_pr : term_pr -> unit
-  val default_term_pr : term_pr
-
-(** The modular constr printer.
-    [modular_constr_pr pr s p t] prints the head of the term [t] and calls
-    [pr] on its subterms.
-    [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers
-    and [ltop] for "lconstr" printers (spiwack: we might need more
-    specification here).
-    We can make a new modular constr printer by overriding certain branches,
-    for instance if we want to build a printer which prints "Prop" as "Omega"
-    instead we can proceed as follows:
-    let my_modular_constr_pr pr s p = function
-    | CSort (_,GProp Null) -> str "Omega"
-    | t -> modular_constr_pr pr s p t
-    Which has the same type. We can turn a modular printer into a printer by
-    taking its fixpoint. *)
-
-  type precedence
-  val lsimpleconstr : precedence
-  val ltop : precedence
-  val modular_constr_pr :
-    ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) ->
-    (unit->std_ppcmds) -> precedence  -> constr_expr -> std_ppcmds
-
-end
-
diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml
index ff72be90c..78ef4d4ba 100644
--- a/printing/ppvernac.ml
+++ b/printing/ppvernac.ml
@@ -19,17 +19,12 @@ open Constrexpr
 open Constrexpr_ops
 open Decl_kinds
 
-module Make
-  (Ppconstr : Ppconstrsig.Pp)
-  (Taggers  : sig
-    val tag_keyword : std_ppcmds -> std_ppcmds
-    val tag_vernac  : vernac_expr -> std_ppcmds -> std_ppcmds
-  end)
-= struct
-
-  open Taggers
   open Ppconstr
 
+  let do_not_tag _ x = x
+  let tag_keyword = do_not_tag ()
+  let tag_vernac  = do_not_tag
+
   let keyword s = tag_keyword (str s)
 
   let pr_constr = pr_constr_expr
@@ -526,7 +521,7 @@ module Make
   let pr_using e = str (Proof_using.to_string e)
 
   let rec pr_vernac_body v =
-    let return = Taggers.tag_vernac v in
+    let return = tag_vernac v in
     match v with
       | VernacPolymorphic (poly, v) ->
         let s = if poly then keyword "Polymorphic" else keyword "Monomorphic" in
@@ -1244,23 +1239,3 @@ module Make
   let pr_vernac v =
     try pr_vernac_body v ++ sep_end v
     with e -> CErrors.print e
-
-end
-
-include Make (Ppconstr) (struct
-  let do_not_tag _ x = x
-  let tag_keyword = do_not_tag ()
-  let tag_vernac  = do_not_tag
-end)
-
-module Richpp = struct
-
-  include Make
-    (Ppconstr.Richpp)
-    (struct
-      open Ppannotation
-      let tag_keyword s = Pp.tag (Pp.Tag.inj AKeyword tag) s
-      let tag_vernac v s = Pp.tag (Pp.Tag.inj (AVernac v) tag) s
-     end)
-
-end
diff --git a/printing/ppvernac.mli b/printing/ppvernac.mli
index d3d4a5ceb..836b05e0e 100644
--- a/printing/ppvernac.mli
+++ b/printing/ppvernac.mli
@@ -9,12 +9,11 @@
 (** This module implements pretty-printers for vernac_expr syntactic
     objects and their subcomponents. *)
 
-(** The default pretty-printers produce {!Pp.std_ppcmds} that are
-    interpreted as raw strings. *)
-include Ppvernacsig.Pp
+(** Prints a fixpoint body *)
+val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds
 
-(** The rich pretty-printers produce {!Pp.std_ppcmds} that are
-    interpreted as annotated strings. The annotations can be
-    retrieved using {!RichPp.rich_pp}. Their definitions are
-    located in {!Ppannotation.t}. *)
-module Richpp : Ppvernacsig.Pp
+(** Prints a vernac expression *)
+val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds
+
+(** Prints a vernac expression and closes it with a dot. *)
+val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds
diff --git a/printing/printer.ml b/printing/printer.ml
index f05968383..239e1d7eb 100644
--- a/printing/printer.ml
+++ b/printing/printer.ml
@@ -306,6 +306,9 @@ let pr_named_context_of env sigma =
   let psl = List.rev (fold_named_context make_decl_list env ~init:[]) in
   hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl)
 
+let pr_var_list_decl env sigma decl =
+  hov 0 (pr_compacted_decl env sigma decl)
+
 let pr_named_context env sigma ne_context =
   hv 0 (Context.Named.fold_outside
 	  (fun d pps -> pps ++ ws 2 ++ pr_named_decl env sigma d)
@@ -339,39 +342,43 @@ let pr_ne_context_of header env sigma =
     List.is_empty (Environ.named_context env)  then (mt ())
   else let penv = pr_context_unlimited env sigma in (header ++ penv ++ fnl ())
 
-let pr_context_limit n env sigma =
-  let named_context = Environ.named_context env in
-  let lgsign = List.length named_context in
-  if n >= lgsign then
-    pr_context_unlimited env sigma
-  else
-    let k = lgsign-n in
-    let _,sign_env =
-      Context.Compacted.fold
-        (fun d (i,pps) ->
-           if i < k then
-	     (i+1, (pps ++str "."))
-	   else
-             let pidt = pr_compacted_decl env sigma d in
-	     (i+1, (pps ++ fnl () ++
-		      str (emacs_str "") ++
-		      pidt)))
-        (Termops.compact_named_context (Environ.named_context env)) ~init:(0,(mt ()))
-    in
-    let db_env =
-      fold_rel_context
-        (fun env d pps ->
-           let pnat = pr_rel_decl env sigma d in
-	   (pps ++ fnl () ++
-	      str (emacs_str "") ++
-	      pnat))
-        env ~init:(mt ())
-    in
-    (sign_env ++ db_env)
+let rec bld_sign_env env sigma ctxt pps =
+  match ctxt with
+  | [] -> pps
+  | d:: ctxt' ->
+     let pidt = pr_var_list_decl env sigma d in
+     let pps' = pps ++ brk (0,0) ++ pidt in
+     bld_sign_env env sigma ctxt' pps'
+
+
+let pr_context_limit_compact ?n env sigma =
+  let ctxt = Termops.compact_named_context (named_context env) in
+  let lgth = List.length ctxt in
+  let n_capped =
+    match n with
+    | None -> lgth
+    | Some n when n > lgth -> lgth
+    | Some n -> n in
+  let ctxt_chopped,ctxt_hidden = Util.List.chop n_capped ctxt in
+  (* a dot line hinting the number of hiden hyps. *)
+  let hidden_dots = String.make (List.length ctxt_hidden) '.' in
+  let sign_env = v 0 (str hidden_dots ++ (mt ())
+                 ++ bld_sign_env env sigma (List.rev ctxt_chopped) (mt ())) in
+  let db_env =
+    fold_rel_context
+      (fun env d pps -> pps ++ fnl () ++ pr_rel_decl env sigma d)
+      env ~init:(mt ()) in
+  (sign_env ++ db_env)
+
+(* compact printing an env (variables and de Bruijn). Separator: three
+   spaces between simple hyps, and newline otherwise *)
+let pr_context_unlimited_compact env sigma =
+  pr_context_limit_compact env sigma
 
-let pr_context_of env sigma = match Flags.print_hyps_limit () with
-  | None -> hv 0 (pr_context_unlimited env sigma)
-  | Some n -> hv 0 (pr_context_limit n env sigma)
+let pr_context_of env sigma =
+  match Flags.print_hyps_limit () with
+  | None -> hv 0 (pr_context_limit_compact env sigma)
+  | Some n -> hv 0 (pr_context_limit_compact ~n env sigma)
 
 (* display goal parts (Proof mode) *)
 
@@ -725,7 +732,7 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () =
             let end_cmd =
               str "This subproof is complete, but there are some unfocused goals." ++
               (let s = Proof_global.Bullet.suggest p in
-               if Pp.is_empty s then s else fnl () ++ s) ++
+               if Pp.ismt s then s else fnl () ++ s) ++
               fnl ()
             in
 	    pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] bgoals
diff --git a/printing/printing.mllib b/printing/printing.mllib
index b0141b6d3..86b68d8fb 100644
--- a/printing/printing.mllib
+++ b/printing/printing.mllib
@@ -1,6 +1,5 @@
 Genprint
 Pputils
-Ppannotation
 Ppconstr
 Printer
 Printmod
diff --git a/printing/printmod.ml b/printing/printmod.ml
index e8ea0a99a..6f4b162d7 100644
--- a/printing/printmod.ml
+++ b/printing/printmod.ml
@@ -26,6 +26,18 @@ open Goptions
     the "short" mode or (Some env) in the "rich" one.
 *)
 
+module Tag =
+struct
+
+  let definition = "module.definition"
+  let keyword    = "module.keyword"
+
+end
+
+let tag t s = Pp.tag t s
+let tag_definition s = tag Tag.definition s
+let tag_keyword s = tag Tag.keyword s
+
 let short = ref false
 
 let _ =
@@ -44,14 +56,8 @@ let mk_fake_top =
   let r = ref 0 in
   fun () -> incr r; Id.of_string ("FAKETOP"^(string_of_int !r))
 
-module Make (Taggers : sig
-  val tag_definition : std_ppcmds -> std_ppcmds
-  val tag_keyword : std_ppcmds -> std_ppcmds
-end) =
-struct
-
-let def s = Taggers.tag_definition (str s)
-let keyword s = Taggers.tag_keyword (str s)
+let def s = tag_definition (str s)
+let keyword s = tag_keyword (str s)
 
 let get_new_id locals id =
   let rec get_id l id =
@@ -397,11 +403,11 @@ let rec printable_body dir =
 
 let print_expression' is_type env mp me =
   States.with_state_protection
-    (fun e -> eval_ppcmds (print_expression is_type env mp [] e)) me
+    (fun e -> print_expression is_type env mp [] e) me
 
 let print_signature' is_type env mp me =
   States.with_state_protection
-    (fun e -> eval_ppcmds (print_signature is_type env mp [] e)) me
+    (fun e -> print_signature is_type env mp [] e) me
 
 let unsafe_print_module env mp with_body mb =
   let name = print_modpath [] mp in
@@ -441,20 +447,4 @@ let print_modtype kn =
       with e when CErrors.noncritical e ->
 	print_signature' true None kn mtb.mod_type))
 
-end
-
-module Tag =
-struct
-  let definition =
-    let style = Terminal.make ~bold:true ~fg_color:`LIGHT_RED () in
-    Ppstyle.make ~style ["module"; "definition"]
-  let keyword =
-    let style = Terminal.make ~bold:true () in
-    Ppstyle.make ~style ["module"; "keyword"]
-end
 
-include Make(struct
-  let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s
-  let tag_definition s = tag Tag.definition s
-  let tag_keyword s = tag Tag.keyword s
-end)
diff --git a/printing/printmod.mli b/printing/printmod.mli
index 7f7d34392..f3079d5b6 100644
--- a/printing/printmod.mli
+++ b/printing/printmod.mli
@@ -6,9 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Pp
 open Names
 
 (** false iff the module is an element of an open module type *)
 val printable_body : DirPath.t -> bool
 
-include Printmodsig.Pp
+val pr_mutual_inductive_body : Environ.env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds
+val print_module : bool -> module_path -> std_ppcmds
+val print_modtype : module_path -> std_ppcmds
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index d9a68acb8..c1a95878f 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -143,12 +143,7 @@ let solve ?with_end_tac gi info_lvl tac pr =
     in
     (p,status)
   with
-    | Proof_global.NoCurrentProof  -> CErrors.error "No focused proof"
-    | CList.IndexOutOfRange ->
-        match gi with
-	| Vernacexpr.SelectNth i -> let msg = str "No such goal: " ++ int i ++ str "." in
-	                            CErrors.user_err  msg
-        | _ -> assert false
+    Proof_global.NoCurrentProof -> CErrors.error "No focused proof"
 
 let by tac = Proof_global.with_current_proof (fun _ -> solve (Vernacexpr.SelectNth 1) None tac)
 
diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml
index 0eff0e6b4..e4cba6f07 100644
--- a/proofs/proof_global.ml
+++ b/proofs/proof_global.ml
@@ -195,9 +195,9 @@ let check_no_pending_proof () =
   if not (there_are_pending_proofs ()) then
     ()
   else begin
-    CErrors.error (Pp.string_of_ppcmds
+    CErrors.user_err
       (str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++
-       str"Use \"Abort All\" first or complete proof(s)."))
+       str"Use \"Abort All\" first or complete proof(s).")
   end
 
 let discard_gen id =
@@ -317,7 +317,10 @@ let constrain_variables init uctx =
   let cstrs = UState.constrain_variables levels uctx in
   Univ.ContextSet.add_constraints cstrs (UState.context_set uctx)
 
-let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
+type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context
+
+let close_proof ~keep_body_ucst_separate ?feedback_id ~now
+                (fpl : closed_proof_output Future.computation) =
   let { pid; section_vars; strength; proof; terminator; universe_binders } =
     cur_pstate () in
   let poly = pi2 strength (* Polymorphic *) in
@@ -396,8 +399,6 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
     universes = (universes, binders) },
   fun pr_ending -> CEphemeron.get terminator pr_ending
 
-type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context
-
 let return_proof ?(allow_partial=false) () =
  let { pid; proof; strength = (_,poly,_) } = cur_pstate () in
  if allow_partial then begin
diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml
index a125fb10d..f51586c73 100644
--- a/proofs/proof_using.ml
+++ b/proofs/proof_using.ml
@@ -108,7 +108,7 @@ let remove_ids_and_lets env s ids =
 let suggest_Proof_using name env vars ids_typ context_ids =
   let module S = Id.Set in
   let open Pp in
-  let print x = prerr_endline (string_of_ppcmds x) in
+  let print x = Feedback.msg_error x in
   let pr_set parens s =
     let wrap ppcmds =
       if parens && S.cardinal s > 1 then str "(" ++ ppcmds ++ str ")"
diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml
index 8acc3c233..125491988 100644
--- a/stm/asyncTaskQueue.ml
+++ b/stm/asyncTaskQueue.ml
@@ -10,9 +10,9 @@ open CErrors
 open Pp
 open Util
 
-let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr
+let stm_pr_err pp = Format.eprintf "%s] @[%a@]%!\n" (System.process_id ()) Pp.pp_with pp
 
-let prerr_endline s = if !Flags.debug then begin pr_err s end else ()
+let stm_prerr_endline s = if !Flags.debug then begin stm_pr_err (str s) end else ()
 
 type 'a worker_status = [ `Fresh | `Old of 'a ]
 
@@ -147,23 +147,23 @@ module Make(T : Task) = struct
     let stop_waiting = ref false in
     let expiration_date = ref (ref false) in
     let pick_task () =
-      prerr_endline "waiting for a task";
+      stm_prerr_endline "waiting for a task";
       let pick age (t, c) = not !c && T.task_match age t in
       let task, task_expiration =
         TQueue.pop ~picky:(pick !worker_age) ~destroy:stop_waiting queue in
       expiration_date := task_expiration;
       last_task := Some task;
-      prerr_endline ("got task: "^T.name_of_task task);
+      stm_prerr_endline ("got task: " ^ T.name_of_task task);
       task in
     let add_tasks l =
       List.iter (fun t -> TQueue.push queue (t,!expiration_date)) l in
     let get_exec_token () =
       ignore(CoqworkmgrApi.get 1);
       got_token := true;
-      prerr_endline ("got execution token") in
+      stm_prerr_endline ("got execution token") in
     let kill proc =
       Worker.kill proc;
-      prerr_endline ("Worker exited: " ^
+      stm_prerr_endline ("Worker exited: " ^
         match Worker.wait proc with
         | Unix.WEXITED 0x400 -> "exit code unavailable"
         | Unix.WEXITED i -> Printf.sprintf "exit(%d)" i
@@ -196,7 +196,7 @@ module Make(T : Task) = struct
       report_status ~id "Idle";
       let task = pick_task () in
       match T.request_of_task !worker_age task with
-      | None -> prerr_endline ("Task expired: " ^ T.name_of_task task)
+      | None -> stm_prerr_endline ("Task expired: " ^ T.name_of_task task)
       | Some req ->
       try
         get_exec_token ();
@@ -222,8 +222,7 @@ module Make(T : Task) = struct
           raise e (* we pass the exception to the external handler *)
       | MarshalError s -> T.on_marshal_error s task; raise Die
       | e ->
-          pr_err ("Uncaught exception in worker manager: "^
-            string_of_ppcmds (print e));
+          stm_pr_err Pp.(seq [str "Uncaught exception in worker manager: "; print e]);
           flush_all (); raise Die
     done with
     | (Die | TQueue.BeingDestroyed) ->
@@ -261,7 +260,7 @@ module Make(T : Task) = struct
   let broadcast { queue } = TQueue.broadcast queue
 
   let enqueue_task { queue; active } (t, _ as item) =
-    prerr_endline ("Enqueue task "^T.name_of_task t);
+    stm_prerr_endline ("Enqueue task "^T.name_of_task t);
     TQueue.push queue item
 
   let cancel_worker { active } n = Pool.cancel n active
@@ -298,18 +297,11 @@ module Make(T : Task) = struct
   let slave_handshake () =
     Pool.worker_handshake (Option.get !slave_ic) (Option.get !slave_oc)
 
-  let pp_pid pp = 
-    (* Breaking all abstraction barriers... very nice *)
-    let get_xml pp = match Richpp.repr pp with
-      | Xml_datatype.Element("_", [], xml) -> xml
-      | _ -> assert false in
-    Richpp.richpp_of_xml (Xml_datatype.Element("_", [],
-      get_xml (Richpp.richpp_of_pp Pp.(str (System.process_id ()^ " "))) @
-      get_xml pp))
+  let pp_pid pp = Pp.(str (System.process_id () ^ " ") ++ pp)
 
   let debug_with_pid = Feedback.(function
     | { contents = Message(Debug, loc, pp) } as fb ->
-       { fb with contents = Message(Debug,loc,pp_pid pp) }
+       { fb with contents = Message(Debug,loc, pp_pid pp) }
     | x -> x)
 
   let main_loop () =
@@ -317,7 +309,6 @@ module Make(T : Task) = struct
     let slave_feeder oc fb =
       Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc in
     Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x);
-    Feedback.set_logger Feedback.feedback_logger;
     (* We ask master to allocate universe identifiers *)
     Universes.set_remote_new_univ_level (bufferize (fun () ->
       marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel;
@@ -337,11 +328,11 @@ module Make(T : Task) = struct
         CEphemeron.clear ()
       with
       | MarshalError s ->
-        pr_err ("Fatal marshal error: " ^ s); flush_all (); exit 2
+        stm_pr_err Pp.(prlist str ["Fatal marshal error: "; s]); flush_all (); exit 2
       | End_of_file ->
-        prerr_endline "connection lost"; flush_all (); exit 2
+        stm_prerr_endline "connection lost"; flush_all (); exit 2
       | e ->
-        pr_err ("Slave: critical exception: " ^ Pp.string_of_ppcmds (print e));
+        stm_pr_err Pp.(seq [str "Slave: critical exception: "; print e]);
         flush_all (); exit 1
     done
 
diff --git a/stm/proofworkertop.ml b/stm/proofworkertop.ml
index 23538a467..0d2f9cb74 100644
--- a/stm/proofworkertop.ml
+++ b/stm/proofworkertop.ml
@@ -8,11 +8,7 @@
 
 module W = AsyncTaskQueue.MakeWorker(Stm.ProofTask)
 
-let () = Coqtop.toploop_init := (fun args ->
-        Flags.make_silent true;
-        W.init_stdout ();
-        CoqworkmgrApi.init !Flags.async_proofs_worker_priority;
-        args)
+let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout
 
 let () = Coqtop.toploop_run := W.main_loop
 
diff --git a/stm/queryworkertop.ml b/stm/queryworkertop.ml
index fff6d5543..9d3047373 100644
--- a/stm/queryworkertop.ml
+++ b/stm/queryworkertop.ml
@@ -8,11 +8,7 @@
 
 module W = AsyncTaskQueue.MakeWorker(Stm.QueryTask)
 
-let () = Coqtop.toploop_init := (fun args ->
-        Flags.make_silent true;
-        W.init_stdout ();
-        CoqworkmgrApi.init !Flags.async_proofs_worker_priority;
-        args)
+let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout
 
 let () = Coqtop.toploop_run := W.main_loop
 
diff --git a/stm/stm.ml b/stm/stm.ml
index c1d1aa445..b8a406430 100644
--- a/stm/stm.ml
+++ b/stm/stm.ml
@@ -6,14 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr
+let stm_pr_err s  = Printf.eprintf "%s] %s\n"     (System.process_id ()) s; flush stderr
+let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n" (System.process_id ()) Pp.pp_with pp; flush stderr
 
-let prerr_endline s = if false then begin pr_err (s ()) end else ()
-let prerr_debug s = if !Flags.debug then begin pr_err (s ()) end else ()
+let stm_prerr_endline s = if false then begin stm_pr_err (s ()) end else ()
+let stm_prerr_debug s = if !Flags.debug then begin stm_pr_err (s ()) end else ()
 
-(* Opening ppvernac below aliases Richpp, see PR#185 *)
-let pp_to_richpp  = Richpp.richpp_of_pp
-let str_to_richpp = Richpp.richpp_of_string
+let stm_pperr_endline s = if false then begin stm_pp_err (s ()) end else ()
 
 open Vernacexpr
 open CErrors
@@ -24,11 +23,13 @@ open Ppvernac
 open Vernac_classifier
 open Feedback
 
+let execution_error state_id loc msg =
+    feedback ~id:(State state_id)
+      (Message (Error, Some loc, msg))
+
 module Hooks = struct
 
 let process_error, process_error_hook = Hook.make ()
-let interp, interp_hook = Hook.make ()
-let with_fail, with_fail_hook = Hook.make ()
 
 let state_computed, state_computed_hook = Hook.make
  ~default:(fun state_id ~in_cache ->
@@ -46,11 +47,7 @@ let forward_feedback, forward_feedback_hook =
 
 let parse_error, parse_error_hook = Hook.make
  ~default:(fun id loc msg ->
-        feedback ~id (Message(Error, Some loc, pp_to_richpp msg))) ()
-
-let execution_error, execution_error_hook = Hook.make
- ~default:(fun state_id loc msg ->
-    feedback ~id:(State state_id) (Message(Error, Some loc, pp_to_richpp msg))) ()
+        feedback ~id (Message(Error, Some loc, msg))) ()
 
 let unreachable_state, unreachable_state_hook = Hook.make
  ~default:(fun _ _ -> ()) ()
@@ -105,26 +102,6 @@ let may_pierce_opaque = function
   | { expr = VernacExtend (("ExtractionInductive",_), _) } -> true
   | _ -> false
 
-(* Wrapper for Vernacentries.interp to set the feedback id *)
-let vernac_interp ?proof id ?route { verbose; loc; expr } =
-  let rec internal_command = function
-    | VernacResetName _ | VernacResetInitial | VernacBack _
-    | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _
-    | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true
-    | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> internal_command e
-    | _ -> false in
-  if internal_command expr then begin
-    prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr))
-  end else begin
-    set_id_for_feedback ?route (State id);
-    Aux_file.record_in_aux_set_at loc;
-    prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr));
-    try Hooks.(call interp ?verbosely:(Some verbose) ?proof (loc, expr))
-    with e ->
-      let e = CErrors.push e in
-      iraise Hooks.(call_process_error_once e)
-  end
-
 (* Wrapper for Vernac.parse_sentence to set the feedback id *)
 let indentation_of_string s =
   let len = String.length s in
@@ -566,7 +543,7 @@ end = struct (* {{{ *)
         let branch, mode = match Vcs_aux.find_proof_at_depth !vcs pl with
           | h, { Vcs_.kind = `Proof (m, _) } -> h, m | _ -> assert false in
         checkout branch;
-        prerr_endline (fun () -> "mode:" ^ mode);
+        stm_prerr_endline (fun () -> "mode:" ^ mode);
         Proof_global.activate_proof_mode mode
       with Failure _ ->
         checkout Branch.master;
@@ -860,7 +837,7 @@ end = struct (* {{{ *)
     | None ->
         let loc = Option.default Loc.ghost (Loc.get_loc info) in
         let (e, info) = Hooks.(call_process_error_once (e, info)) in
-        Hooks.(call execution_error id loc (iprint (e, info)));
+        execution_error id loc (iprint (e, info));
         (e, Stateid.add info ~valid id)
 
   let same_env { system = s1 } { system = s2 } =
@@ -878,7 +855,7 @@ end = struct (* {{{ *)
     if is_cached id && not redefine then
       anomaly (str"defining state "++str str_id++str" twice");
     try
-      prerr_endline (fun () -> "defining "^str_id^" (cache="^
+      stm_prerr_endline (fun () -> "defining "^str_id^" (cache="^
         if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)");
       let good_id = match safe_id with None -> !cur_id | Some id -> id in
       fix_exn_ref := exn_on id ~valid:good_id;
@@ -886,7 +863,7 @@ end = struct (* {{{ *)
       fix_exn_ref := (fun x -> x);
       if cache = `Yes then freeze `No id
       else if cache = `Shallow then freeze `Shallow id;
-      prerr_endline (fun () -> "setting cur id to "^str_id);
+      stm_prerr_endline (fun () -> "setting cur id to "^str_id);
       cur_id := id;
       if feedback_processed then
         Hooks.(call state_computed id ~in_cache:false);
@@ -910,6 +887,126 @@ end = struct (* {{{ *)
 
 end (* }}} *)
 
+(* indentation code for Show Script, initially contributed
+ * by D. de Rauglaudre. Should be moved away.
+ *)
+
+module ShowScript = struct
+
+let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) =
+  (* ng1 : number of goals remaining at the current level (before cmd)
+     ngl1 : stack of previous levels with their remaining goals
+     ng : number of goals after the execution of cmd
+     beginend : special indentation stack for { } *)
+  let ngprev = List.fold_left (+) ng1 ngl1 in
+  let new_ngl =
+    if ng > ngprev then
+      (* We've branched *)
+      (ng - ngprev + 1, ng1 - 1 :: ngl1)
+    else if ng < ngprev then
+      (* A subgoal have been solved. Let's compute the new current level
+	 by discarding all levels with 0 remaining goals. *)
+      let rec loop = function
+	| (0, ng2::ngl2) -> loop (ng2,ngl2)
+	| p -> p
+      in loop (ng1-1, ngl1)
+    else
+      (* Standard case, same goal number as before *)
+      (ng1, ngl1)
+  in
+  (* When a subgoal have been solved, separate this block by an empty line *)
+  let new_nl = (ng < ngprev)
+  in
+  (* Indentation depth *)
+  let ind = List.length ngl1
+  in
+  (* Some special handling of bullets and { }, to get a nicer display *)
+  let pred n = max 0 (n-1) in
+  let ind, nl, new_beginend = match cmd with
+    | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend
+    | VernacEndSubproof -> List.hd beginend, false, List.tl beginend
+    | VernacBullet _ -> pred ind, nl, beginend
+    | _ -> ind, nl, beginend
+  in
+  let pp =
+    (if nl then fnl () else mt ()) ++
+    (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd))
+  in
+  (new_ngl, new_nl, new_beginend, pp :: ppl)
+
+let get_script prf =
+  let branch, test =
+    match prf with
+    | None -> VCS.Branch.master, fun _ -> true
+    | Some name -> VCS.current_branch (),fun nl -> nl=[] || List.mem name nl in
+  let rec find acc id =
+    if Stateid.equal id Stateid.initial ||
+       Stateid.equal id Stateid.dummy then acc else
+    let view = VCS.visit id in
+    match view.step with
+    | `Fork((_,_,_,ns), _) when test ns -> acc
+    | `Qed (qed, proof) -> find [qed.qast.expr, (VCS.get_info id).n_goals] proof
+    | `Sideff (`Ast (x,_)) ->
+         find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next
+    | `Sideff (`Id id)  -> find acc id
+    | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *)
+         find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next 
+    | `Cmd _ -> find acc view.next
+    | `Alias (id,_) -> find acc id
+    | `Fork _ -> find acc view.next
+    in
+  find [] (VCS.get_branch_pos branch)
+
+let show_script ?proof () =
+  try
+    let prf =
+      try match proof with
+      | None -> Some (Pfedit.get_current_proof_name ())
+      | Some (p,_) -> Some (p.Proof_global.id)
+      with Proof_global.NoCurrentProof -> None
+    in
+    let cmds = get_script prf in
+    let _,_,_,indented_cmds =
+      List.fold_left indent_script_item ((1,[]),false,[],[]) cmds
+    in
+    let indented_cmds = List.rev (indented_cmds) in
+    msg_notice (v 0 (prlist_with_sep fnl (fun x -> x) indented_cmds))
+  with Vcs_aux.Expired -> ()
+
+end
+
+(* Wrapper for Vernacentries.interp to set the feedback id *)
+(* It is currently called 19 times, this number should be certainly
+   reduced... *)
+let stm_vernac_interp ?proof id ?route { verbose; loc; expr } =
+  (* The Stm will gain the capability to interpret commmads affecting
+     the whole document state, such as backtrack, etc... so we start
+     to design the stm command interpreter now *)
+  set_id_for_feedback ?route (State id);
+  Aux_file.record_in_aux_set_at loc;
+  (* We need to check if a command should be filtered from
+   * vernac_entries, as it cannot handle it. This should go away in
+   * future refactorings.
+   *)
+  let rec is_filtered_command = function
+  | VernacResetName _ | VernacResetInitial | VernacBack _
+  | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _
+  | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true
+  | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> is_filtered_command e
+  | _ -> false
+  in
+  let aux_interp cmd =
+  if is_filtered_command cmd then
+    stm_pperr_endline Pp.(fun () -> str "ignoring " ++ pr_vernac expr)
+  else match cmd with
+  | VernacShow ShowScript -> ShowScript.show_script ()
+  | expr ->
+    stm_pperr_endline Pp.(fun () -> str "interpreting " ++ pr_vernac expr);
+    try Vernacentries.interp ?verbosely:(Some verbose) ?proof (loc, expr)
+    with e ->
+      let e = CErrors.push e in
+      iraise Hooks.(call_process_error_once e)
+  in aux_interp expr
 
 (****************************** CRUFT *****************************************)
 (******************************************************************************)
@@ -1287,7 +1384,7 @@ end = struct (* {{{ *)
         let info = Stateid.add ~valid:start Exninfo.null start in
         let e = (RemoteException (strbrk s), info) in
         t_assign (`Exn e);
-        Hooks.(call execution_error start Loc.ghost (strbrk s));
+        execution_error start Loc.ghost (strbrk s);
         feedback (InProgress ~-1)
 
   let build_proof_here ~drop_pt (id,valid) loc eop =
@@ -1321,7 +1418,7 @@ end = struct (* {{{ *)
             Proof_global.close_future_proof stop (Future.from_val ~fix_exn p) in
           let terminator = (* The one sent by master is an InvalidKey *)
             Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in
-          vernac_interp stop
+          stm_vernac_interp stop
             ~proof:(pobject, terminator)
             { verbose = false; loc; indentation = 0; strlen = 0;
               expr = (VernacEndProof (Proved (Opaque None,None))) }) in
@@ -1337,11 +1434,10 @@ end = struct (* {{{ *)
           | Some (safe, err) -> err, safe
           | None -> Stateid.dummy, Stateid.dummy in
         let e_msg = iprint (e, info) in
-        prerr_endline (fun () -> "failed with the following exception:");
-        prerr_endline (fun () -> string_of_ppcmds e_msg);
+        stm_pperr_endline Pp.(fun () -> str "failed with the following exception: " ++ fnl () ++ e_msg);
         let e_safe_states = List.filter State.is_cached_and_valid my_states in
         RespError { e_error_at; e_safe_id; e_msg; e_safe_states }
-  
+
   let perform_states query =
     if query = [] then [] else
     let is_tac e = match classify_vernac e with
@@ -1463,7 +1559,7 @@ end = struct (* {{{ *)
       (* We jump at the beginning since the kernel handles side effects by also
        * looking at the ones that happen to be present in the current env *)
       Reach.known_state ~cache:`No start;
-      vernac_interp stop ~proof
+      stm_vernac_interp stop ~proof
         { verbose = false; loc; indentation = 0; strlen = 0;
           expr = (VernacEndProof (Proved (Opaque None,None))) };
       `OK proof
@@ -1520,9 +1616,9 @@ end = struct (* {{{ *)
           Future.from_val (Option.get (Global.body_of_constant_body c)) in
         let uc =
           Future.chain
-            ~greedy:true ~pure:true uc Univ.hcons_universe_context_set in
-        let pr = Future.chain ~greedy:true ~pure:true pr discharge in
-        let pr = Future.chain ~greedy:true ~pure:true pr Constr.hcons in
+            ~pure:true uc Univ.hcons_universe_context_set in
+        let pr = Future.chain ~pure:true pr discharge in
+        let pr = Future.chain ~pure:true pr Constr.hcons in
         Future.sink pr;
         let extra = Future.join uc in
         u.(bucket) <- uc;
@@ -1603,7 +1699,7 @@ end = struct (* {{{ *)
              | Some (ReqBuildProof (r, b, _)) -> Some(r, b)
              | _ -> None)
         tasks in
-    prerr_endline (fun () -> Printf.sprintf "dumping %d tasks\n" (List.length reqs));
+    stm_prerr_endline (fun () -> Printf.sprintf "dumping %d tasks\n" (List.length reqs));
     reqs
 
   let reset_task_queue () = TaskQueue.clear (Option.get !queue)
@@ -1687,7 +1783,7 @@ end = struct (* {{{ *)
         `Stay ((),[])
                     
   let on_marshal_error err { t_name } =
-    pr_err ("Fatal marshal error: " ^ t_name );
+    stm_pr_err ("Fatal marshal error: " ^ t_name );
     flush_all (); exit 1
 
   let on_task_cancellation_or_expiration_or_slave_death = function
@@ -1715,7 +1811,7 @@ end = struct (* {{{ *)
        else begin
         let (i, ast) = r_ast in
         Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p);
-        vernac_interp r_state_fb ast;
+        stm_vernac_interp r_state_fb ast;
         let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in
         match Evd.(evar_body (find sigma r_goal)) with
         | Evd.Evar_empty -> RespNoProgress
@@ -1753,7 +1849,7 @@ end = struct (* {{{ *)
         | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> find true fail e
         | VernacFail e -> find time true e
         | _ -> e, time, fail in find false false e in
-    Hooks.call Hooks.with_fail fail (fun () ->
+    Vernacentries.with_fail fail (fun () ->
     (if time then System.with_time false else (fun x -> x)) (fun () ->
     ignore(TaskQueue.with_n_workers nworkers (fun queue ->
     Proof_global.with_current_proof (fun _ p ->
@@ -1789,10 +1885,10 @@ end = struct (* {{{ *)
           let open Notations in
           try
             let pt, uc = Future.join f in
-            prerr_endline (fun () -> string_of_ppcmds(hov 0 (
+            stm_pperr_endline (fun () -> hov 0 (
               str"g=" ++ int (Evar.repr gid) ++ spc () ++
               str"t=" ++ (Printer.pr_constr pt) ++ spc () ++
-              str"uc=" ++ Termops.pr_evar_universe_context uc)));
+              str"uc=" ++ Termops.pr_evar_universe_context uc));
             (if abstract then Tactics.tclABSTRACT None else (fun x -> x))
               (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*>
               Tactics.exact_no_check (EConstr.of_constr pt))
@@ -1834,7 +1930,7 @@ end = struct (* {{{ *)
   let use_response _ _ _ = `End
 
   let on_marshal_error _ _ =
-    pr_err ("Fatal marshal error in query");
+    stm_pr_err ("Fatal marshal error in query");
     flush_all (); exit 1
 
   let on_task_cancellation_or_expiration_or_slave_death _ = ()
@@ -1846,11 +1942,11 @@ end = struct (* {{{ *)
     VCS.print ();
     Reach.known_state ~cache:`No r_where;
     try
-      vernac_interp r_for { r_what with verbose = true };
+      stm_vernac_interp r_for { r_what with verbose = true };
       feedback ~id:(State r_for) Processed
     with e when CErrors.noncritical e ->
       let e = CErrors.push e in
-      let msg = pp_to_richpp (iprint e) in
+      let msg = iprint e     in
       feedback ~id:(State r_for) (Message (Error, None, msg))
     
   let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what)
@@ -1909,7 +2005,7 @@ let warn_deprecated_nested_proofs =
                     "stop working in a future Coq version"))
 
 let collect_proof keep cur hd brkind id =
- prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id);
+ stm_prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id);
  let no_name = "" in
  let name = function
    | [] -> no_name
@@ -2009,7 +2105,7 @@ let string_of_reason = function
   | `NoPU_NoHint_NoES -> "no 'Proof using..', no .aux file, inside a section"
   | `Unknown -> "unsupported case"
 
-let log_string s = prerr_debug (fun () -> "STM: " ^ s)
+let log_string s = stm_prerr_debug (fun () -> "STM: " ^ s)
 let log_processing_async id name = log_string Printf.(sprintf
   "%s: proof %s: asynch" (Stateid.to_string id) name
 )
@@ -2055,7 +2151,7 @@ let known_state ?(redefine_qed=false) ~cache id =
                Proof_global.with_current_proof (fun _ p ->
                  feedback ~id:(State id) Feedback.AddedAxiom;
                  fst (Pfedit.solve Vernacexpr.SelectAll None tac p), ());
-               Option.iter (fun expr -> vernac_interp id {
+               Option.iter (fun expr -> stm_vernac_interp id {
                   verbose = true; loc = Loc.ghost; expr; indentation = 0;
                   strlen = 0 })
                recovery_command
@@ -2096,16 +2192,16 @@ let known_state ?(redefine_qed=false) ~cache id =
     Summary.unfreeze_summary s; Lib.unfreeze l; update_global_env ()
   in
   let rec pure_cherry_pick_non_pstate safe_id id = Future.purify (fun id ->
-    prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id);
+    stm_prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id);
     reach ~safe_id id;
     cherry_pick_non_pstate ()) id
 
   (* traverses the dag backward from nodes being already calculated *)
   and reach ?safe_id ?(redefine_qed=false) ?(cache=cache) id =
-    prerr_endline (fun () -> "reaching: " ^ Stateid.to_string id);
+    stm_prerr_endline (fun () -> "reaching: " ^ Stateid.to_string id);
     if not redefine_qed && State.is_cached ~cache id then begin
       Hooks.(call state_computed id ~in_cache:true);
-      prerr_endline (fun () -> "reached (cache)");
+      stm_prerr_endline (fun () -> "reached (cache)");
       State.install_cached id
     end else
     let step, cache_step, feedback_processed =
@@ -2134,24 +2230,24 @@ let known_state ?(redefine_qed=false) ~cache id =
             resilient_tactic id cblock (fun () ->
               reach view.next;
               Hooks.(call tactic_being_run true); 
-              vernac_interp id x;
+              stm_vernac_interp id x;
               Hooks.(call tactic_being_run false)); 
 	    if eff then update_global_env ()
           ), (if eff then `Yes else cache), true
       | `Cmd { cast = x; ceff = eff } -> (fun () ->
             resilient_command reach view.next;
-            vernac_interp id x;
+            stm_vernac_interp id x;
 	    if eff then update_global_env ()
           ), (if eff then `Yes else cache), true
       | `Fork ((x,_,_,_), None) -> (fun () ->
             resilient_command reach view.next;
-            vernac_interp id x;
+            stm_vernac_interp id x;
             wall_clock_last_fork := Unix.gettimeofday ()
           ), `Yes, true
       | `Fork ((x,_,_,_), Some prev) -> (fun () -> (* nested proof *)
             reach ~cache:`Shallow prev;
             reach view.next;
-            (try vernac_interp id x;
+            (try stm_vernac_interp id x;
             with e when CErrors.noncritical e ->
               let (e, info) = CErrors.push e in
               let info = Stateid.add info ~valid:prev id in
@@ -2201,14 +2297,14 @@ let known_state ?(redefine_qed=false) ~cache id =
                       Proof_global.close_future_proof ~feedback_id:id fp in
                     if not delegate then ignore(Future.compute fp);
                     reach view.next;
-                    vernac_interp id ~proof x;
+                    stm_vernac_interp id ~proof x;
                     feedback ~id:(State id) Incomplete
                 | { VCS.kind = `Master }, _ -> assert false
                 end;
                 Proof_global.discard_all ()
               ), (if redefine_qed then `No else `Yes), true
           | `Sync (name, _, `Immediate) -> (fun () -> 
-                reach eop; vernac_interp id x; Proof_global.discard_all ()
+                reach eop; stm_vernac_interp id x; Proof_global.discard_all ()
               ), `Yes, true
           | `Sync (name, pua, reason) -> (fun () ->
                 log_processing_sync id name reason;
@@ -2229,7 +2325,7 @@ let known_state ?(redefine_qed=false) ~cache id =
                 if keep != VtKeepAsAxiom then
                   reach view.next;
                 let wall_clock2 = Unix.gettimeofday () in
-                vernac_interp id ?proof x;
+                stm_vernac_interp id ?proof x;
                 let wall_clock3 = Unix.gettimeofday () in
                 Aux_file.record_in_aux_at x.loc "proof_check_time"
                   (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2));
@@ -2245,7 +2341,7 @@ let known_state ?(redefine_qed=false) ~cache id =
           in
           aux (collect_proof keep (view.next, x) brname brinfo eop)
       | `Sideff (`Ast (x,_)) -> (fun () ->
-            reach view.next; vernac_interp id x; update_global_env ()
+            reach view.next; stm_vernac_interp id x; update_global_env ()
           ), cache, true
       | `Sideff (`Id origin) -> (fun () ->
             reach view.next;
@@ -2257,7 +2353,7 @@ let known_state ?(redefine_qed=false) ~cache id =
       else cache_step in
     State.define ?safe_id
       ~cache:cache_step ~redefine:redefine_qed ~feedback_processed step id;
-    prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in
+    stm_prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in
   reach ~redefine_qed id
 
 end (* }}} *)
@@ -2272,7 +2368,7 @@ let init () =
   Backtrack.record ();
   Slaves.init ();
   if Flags.async_proofs_is_master () then begin
-    prerr_endline (fun () -> "Initializing workers");
+    stm_prerr_endline (fun () -> "Initializing workers");
     Query.init ();
     let opts = match !Flags.async_proofs_private_flags with
       | None -> []
@@ -2324,9 +2420,9 @@ let rec join_admitted_proofs id =
 let join () =
   finish ();
   wait ();
-  prerr_endline (fun () -> "Joining the environment");
+  stm_prerr_endline (fun () -> "Joining the environment");
   Global.join_safe_environment ();
-  prerr_endline (fun () -> "Joining Admitted proofs");
+  stm_prerr_endline (fun () -> "Joining Admitted proofs");
   join_admitted_proofs (VCS.get_branch_pos (VCS.current_branch ()));
   VCS.print ();
   VCS.print ()
@@ -2400,7 +2496,7 @@ let handle_failure (e, info) vcs tty =
       anomaly(str"error with no safe_id attached:" ++ spc() ++
         CErrors.iprint_no_report (e, info))
   | Some (safe_id, id) ->
-      prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id);
+      stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id);
       VCS.restore vcs;
       if tty && interactive () = `Yes then begin
         (* We stay on a valid state *)
@@ -2423,17 +2519,17 @@ let reset_task_queue = Slaves.reset_task_queue
 (* Document building *)
 let process_transaction ?(newtip=Stateid.fresh ()) ~tty
   ({ verbose; loc; expr } as x) c =
-  prerr_endline (fun () -> "{{{ processing: "^ string_of_ppcmds (pr_ast x));
+  stm_pperr_endline (fun () -> str "{{{ processing: " ++ pr_ast x);
   let vcs = VCS.backup () in
   try
     let head = VCS.current_branch () in
     VCS.checkout head;
     let rc = begin
-      prerr_endline (fun () ->
+      stm_prerr_endline (fun () ->
         "  classified as: " ^ string_of_vernac_classification c);
       match c with
       (* PG stuff *)    
-      | VtStm(VtPG,false), VtNow -> vernac_interp Stateid.dummy x; `Ok
+      | VtStm(VtPG,false), VtNow -> stm_vernac_interp Stateid.dummy x; `Ok
       | VtStm(VtPG,_), _ -> anomaly(str "PG command in script or VtLater")
       (* Joining various parts of the document *)
       | VtStm (VtJoinDocument, b), VtNow -> join (); `Ok
@@ -2467,7 +2563,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty
           VCS.commit id (Alias (oid,x));
           Backtrack.record (); if w == VtNow then finish (); `Ok
       | VtStm (VtBack id, false), VtNow ->
-          prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id);
+          stm_prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id);
           Backtrack.backto id;
           VCS.checkout_shallowest_proof_branch ();
           Reach.known_state ~cache:(interactive ()) id; `Ok
@@ -2477,13 +2573,13 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty
       (* Query *)
       | VtQuery (false,(report_id,route)), VtNow when tty = true ->
           finish ();
-          (try Future.purify (vernac_interp report_id ~route)
+          (try Future.purify (stm_vernac_interp report_id ~route)
             {x with verbose = true }
            with e when CErrors.noncritical e ->
              let e = CErrors.push e in
              iraise (State.exn_on ~valid:Stateid.dummy report_id e)); `Ok
       | VtQuery (false,(report_id,route)), VtNow ->
-          (try vernac_interp report_id ~route x
+          (try stm_vernac_interp report_id ~route x
            with e ->
              let e = CErrors.push e in
              iraise (State.exn_on ~valid:Stateid.dummy report_id e)); `Ok
@@ -2556,7 +2652,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty
           
       (* Side effect on all branches *)
       | VtUnknown, _ when expr = VernacToplevelControl Drop ->
-          vernac_interp (VCS.get_branch_pos head) x; `Ok
+          stm_vernac_interp (VCS.get_branch_pos head) x; `Ok
 
       | VtSideff l, w ->
           let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in
@@ -2582,7 +2678,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty
             VCS.checkout VCS.Branch.master;
             let mid = VCS.get_branch_pos VCS.Branch.master in
             Reach.known_state ~cache:(interactive ()) mid;
-            vernac_interp id x;
+            stm_vernac_interp id x;
             (* Vernac x may or may not start a proof *)
             if not in_proof && Proof_global.there_are_pending_proofs () then
             begin
@@ -2612,12 +2708,12 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty
     begin match expr with 
       | VernacStm (PGLast _) ->
         if not (VCS.Branch.equal head VCS.Branch.master) then
-          vernac_interp Stateid.dummy
+          stm_vernac_interp Stateid.dummy
             { verbose = true; loc = Loc.ghost; indentation = 0; strlen = 0;
               expr = VernacShow (ShowGoal OpenSubgoals) }
       | _ -> ()
     end;
-    prerr_endline (fun () -> "processed }}}");
+    stm_prerr_endline (fun () -> "processed }}}");
     VCS.print ();
     rc
   with e ->
@@ -2803,7 +2899,7 @@ let edit_at id =
         anomaly (str ("edit_at "^Stateid.to_string id^": ") ++
           CErrors.print_no_report e)
     | Some (_, id) ->
-        prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id);
+        stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id);
         VCS.restore vcs;
         VCS.print ();
         iraise (e, info)
@@ -2859,102 +2955,13 @@ let proofname b = match VCS.get_branch b with
 let get_all_proof_names () =
   List.map unmangle (List.map_filter proofname (VCS.branches ()))
 
-let get_current_proof_name () =
-  Option.map unmangle (proofname (VCS.current_branch ()))
-
-let get_script prf =
-  let branch, test =
-    match prf with
-    | None -> VCS.Branch.master, fun _ -> true
-    | Some name -> VCS.current_branch (),fun nl -> nl=[] || List.mem name nl in
-  let rec find acc id =
-    if Stateid.equal id Stateid.initial ||
-       Stateid.equal id Stateid.dummy then acc else
-    let view = VCS.visit id in
-    match view.step with
-    | `Fork((_,_,_,ns), _) when test ns -> acc
-    | `Qed (qed, proof) -> find [qed.qast.expr, (VCS.get_info id).n_goals] proof
-    | `Sideff (`Ast (x,_)) ->
-         find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next
-    | `Sideff (`Id id)  -> find acc id
-    | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *)
-         find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next 
-    | `Cmd _ -> find acc view.next
-    | `Alias (id,_) -> find acc id
-    | `Fork _ -> find acc view.next
-    in
-  find [] (VCS.get_branch_pos branch)
-
-(* indentation code for Show Script, initially contributed
-   by D. de Rauglaudre *)
-
-let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) =
-  (* ng1 : number of goals remaining at the current level (before cmd)
-     ngl1 : stack of previous levels with their remaining goals
-     ng : number of goals after the execution of cmd
-     beginend : special indentation stack for { } *)
-  let ngprev = List.fold_left (+) ng1 ngl1 in
-  let new_ngl =
-    if ng > ngprev then
-      (* We've branched *)
-      (ng - ngprev + 1, ng1 - 1 :: ngl1)
-    else if ng < ngprev then
-      (* A subgoal have been solved. Let's compute the new current level
-	 by discarding all levels with 0 remaining goals. *)
-      let rec loop = function
-	| (0, ng2::ngl2) -> loop (ng2,ngl2)
-	| p -> p
-      in loop (ng1-1, ngl1)
-    else
-      (* Standard case, same goal number as before *)
-      (ng1, ngl1)
-  in
-  (* When a subgoal have been solved, separate this block by an empty line *)
-  let new_nl = (ng < ngprev)
-  in
-  (* Indentation depth *)
-  let ind = List.length ngl1
-  in
-  (* Some special handling of bullets and { }, to get a nicer display *)
-  let pred n = max 0 (n-1) in
-  let ind, nl, new_beginend = match cmd with
-    | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend
-    | VernacEndSubproof -> List.hd beginend, false, List.tl beginend
-    | VernacBullet _ -> pred ind, nl, beginend
-    | _ -> ind, nl, beginend
-  in
-  let pp =
-    (if nl then fnl () else mt ()) ++
-    (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd))
-  in
-  (new_ngl, new_nl, new_beginend, pp :: ppl)
-
-let show_script ?proof () =
-  try
-    let prf =
-      try match proof with
-      | None -> Some (Pfedit.get_current_proof_name ())
-      | Some (p,_) -> Some (p.Proof_global.id)
-      with Proof_global.NoCurrentProof -> None
-    in
-    let cmds = get_script prf in
-    let _,_,_,indented_cmds =
-      List.fold_left indent_script_item ((1,[]),false,[],[]) cmds
-    in
-    let indented_cmds = List.rev (indented_cmds) in
-    msg_notice (v 0 (prlist_with_sep fnl (fun x -> x) indented_cmds))
-  with Vcs_aux.Expired -> ()
-
 (* Export hooks *)
 let state_computed_hook = Hooks.state_computed_hook
 let state_ready_hook = Hooks.state_ready_hook
 let parse_error_hook = Hooks.parse_error_hook
-let execution_error_hook = Hooks.execution_error_hook
 let forward_feedback_hook = Hooks.forward_feedback_hook
 let process_error_hook = Hooks.process_error_hook
-let interp_hook = Hooks.interp_hook
-let with_fail_hook = Hooks.with_fail_hook
 let unreachable_state_hook = Hooks.unreachable_state_hook
-let get_fix_exn () = !State.fix_exn_ref
+let () = Hook.set Obligations.stm_get_fix_exn (fun () -> !State.fix_exn_ref)
 let tactic_being_run_hook = Hooks.tactic_being_run_hook
 (* vim:set foldmethod=marker: *)
diff --git a/stm/stm.mli b/stm/stm.mli
index b8a2a3859..0f0a3c4e1 100644
--- a/stm/stm.mli
+++ b/stm/stm.mli
@@ -184,7 +184,6 @@ val register_proof_block_delimiter :
 val state_computed_hook : (Stateid.t -> in_cache:bool -> unit) Hook.t
 val parse_error_hook :
   (Feedback.edit_or_state_id -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t
-val execution_error_hook : (Stateid.t -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t
 val unreachable_state_hook : (Stateid.t -> Exninfo.iexn -> unit) Hook.t
 (* ready means that master has it at hand *)
 val state_ready_hook : (Stateid.t -> unit) Hook.t
@@ -213,12 +212,6 @@ val interp : bool -> vernac_expr located -> unit
 (* Queries for backward compatibility *)
 val current_proof_depth : unit -> int
 val get_all_proof_names : unit -> Id.t list
-val get_current_proof_name : unit -> Id.t option
-val show_script : ?proof:Proof_global.closed_proof -> unit -> unit
 
 (* Hooks to be set by other Coq components in order to break file cycles *)
 val process_error_hook : Future.fix_exn Hook.t
-val interp_hook : (?verbosely:bool -> ?proof:Proof_global.closed_proof ->
-  Loc.t * Vernacexpr.vernac_expr -> unit) Hook.t
-val with_fail_hook : (bool -> (unit -> unit) -> unit) Hook.t
-val get_fix_exn : unit -> (Exninfo.iexn -> Exninfo.iexn)
diff --git a/stm/stm.mllib b/stm/stm.mllib
index 939ee187a..72b538016 100644
--- a/stm/stm.mllib
+++ b/stm/stm.mllib
@@ -4,8 +4,8 @@ Vcs
 TQueue
 WorkerPool
 Vernac_classifier
-Lemmas
 CoqworkmgrApi
+WorkerLoop
 AsyncTaskQueue
 Stm
 ProofBlockDelimiter
diff --git a/stm/tacworkertop.ml b/stm/tacworkertop.ml
index d5333d107..256532c6b 100644
--- a/stm/tacworkertop.ml
+++ b/stm/tacworkertop.ml
@@ -8,11 +8,7 @@
 
 module W = AsyncTaskQueue.MakeWorker(Stm.TacTask)
 
-let () = Coqtop.toploop_init := (fun args ->
-        Flags.make_silent true;
-        W.init_stdout ();
-        CoqworkmgrApi.init !Flags.async_proofs_worker_priority;
-        args)
+let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout
 
 let () = Coqtop.toploop_run := W.main_loop
 
diff --git a/stm/workerLoop.ml b/stm/workerLoop.ml
new file mode 100644
index 000000000..50b42512c
--- /dev/null
+++ b/stm/workerLoop.ml
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+let rec parse = function
+  | "--xml_format=Ppcmds" :: rest -> parse rest
+  | x :: rest -> x :: parse rest
+  | [] -> []
+
+let loop init args =
+  let args = parse args in
+  Flags.make_silent true;
+  init ();
+  CoqworkmgrApi.init !Flags.async_proofs_worker_priority;
+  args
diff --git a/printing/printmodsig.mli b/stm/workerLoop.mli
index f71fffdce..dcbf9c88d 100644
--- a/printing/printmodsig.mli
+++ b/stm/workerLoop.mli
@@ -6,12 +6,4 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Pp
-open Names
-
-module type Pp =
-sig
-  val pr_mutual_inductive_body : Environ.env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds
-  val print_module : bool -> module_path -> std_ppcmds
-  val print_modtype : module_path -> std_ppcmds
-end
+val loop : (unit -> unit) -> string list -> string list
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml
index 64d76360f..c53e47d92 100644
--- a/tactics/class_tactics.ml
+++ b/tactics/class_tactics.ml
@@ -1614,11 +1614,15 @@ let is_ground c gl =
   if Evarutil.is_ground_term (project gl) c then tclIDTAC gl
   else tclFAIL 0 (str"Not ground") gl
 
-let autoapply c i = Proofview.Goal.enter { enter = begin fun gl ->
+let autoapply c i =
+  let open Proofview.Notations in
+  Proofview.Goal.enter { enter = begin fun gl ->
   let flags = auto_unif_flags Evar.Set.empty
     (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in
   let cty = Tacmach.New.pf_unsafe_type_of gl c in
   let ce = mk_clenv_from gl (c,cty) in
-  (unify_e_resolve false flags).enter gl
-    ((c,cty,Univ.ContextSet.empty),0,ce)
-end }
+    (unify_e_resolve false flags).enter gl
+                                 ((c,cty,Univ.ContextSet.empty),0,ce) <*>
+      Proofview.tclEVARMAP >>= (fun sigma ->
+      let sigma = Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals sigma in
+      Proofview.Unsafe.tclEVARS sigma) end }
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index f8cbc2671..55d6df659 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -1830,24 +1830,37 @@ let find_matching_clause unifier clause =
     with NotExtensibleClause -> failwith "Cannot apply"
   in find clause
 
+exception UnableToApply
+
 let progress_with_clause flags innerclause clause =
   let ordered_metas = List.rev (clenv_independent clause) in
-  if List.is_empty ordered_metas then error "Statement without assumptions.";
+  if List.is_empty ordered_metas then raise UnableToApply;
   let f mv =
     try Some (find_matching_clause (clenv_fchain ~with_univs:false mv ~flags clause) innerclause)
     with Failure _ -> None
   in
   try List.find_map f ordered_metas
-  with Not_found -> error "Unable to unify."
+  with Not_found -> raise UnableToApply
+
+let explain_unable_to_apply_lemma loc env sigma thm innerclause =
+  user_err ~loc (hov 0
+    (Pp.str "Unable to apply lemma of type" ++ brk(1,1) ++
+     Pp.quote (Printer.pr_leconstr_env env sigma thm) ++ spc() ++
+     str "on hypothesis of type" ++ brk(1,1) ++
+     Pp.quote (Printer.pr_leconstr_env innerclause.env innerclause.evd (clenv_type innerclause)) ++
+     str "."))
 
-let apply_in_once_main flags innerclause env sigma (d,lbind) =
+let apply_in_once_main flags innerclause env sigma (loc,d,lbind) =
   let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in
   let rec aux clause =
     try progress_with_clause flags innerclause clause
     with e when CErrors.noncritical e ->
-    let e = CErrors.push e in
+    let e' = CErrors.push e in
     try aux (clenv_push_prod clause)
-    with NotExtensibleClause -> iraise e
+    with NotExtensibleClause ->
+      match e with
+      | UnableToApply -> explain_unable_to_apply_lemma loc env sigma thm innerclause
+      | _ -> iraise e'
   in
   aux (make_clenv_binding env sigma (d,thm) lbind)
 
@@ -1867,7 +1880,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming
     let env = Proofview.Goal.env gl in
     let sigma = Tacmach.New.project gl in
     try
-      let clause = apply_in_once_main flags innerclause env sigma (c,lbind) in
+      let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in
       clenv_refine_in ~sidecond_first with_evars targetid id sigma clause
         (fun id ->
           Tacticals.New.tclTHENLIST [
@@ -2487,7 +2500,7 @@ and intro_pattern_action loc with_evars b style pat thin destopt tac id =
       intro_decomp_eq loc l' thin tac id
   | IntroRewrite l2r ->
       rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None [])
-  | IntroApplyOn (f,(loc,pat)) ->
+  | IntroApplyOn ((loc',f),(loc,pat)) ->
       let naming,tac_ipat =
         prepare_intros_loc loc with_evars (IntroIdentifier id) destopt pat in
       let doclear =
@@ -2499,7 +2512,7 @@ and intro_pattern_action loc with_evars b style pat thin destopt tac id =
         let Sigma (c, sigma, p) = f.delayed env sigma in
         Sigma ((c, NoBindings), sigma, p)
       } in
-      apply_in_delayed_once false true true with_evars naming id (None,(loc,f))
+      apply_in_delayed_once false true true with_evars naming id (None,(loc',f))
         (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []])
 
 and prepare_intros_loc loc with_evars dft destopt = function
@@ -3044,7 +3057,7 @@ let warn_unused_intro_pattern =
 	 (fun c -> Printer.pr_econstr (fst (run_delayed (Global.env()) Evd.empty c)))) names)
 
 let check_unused_names names =
-  if not (List.is_empty names) && Flags.is_verbose () then
+  if not (List.is_empty names) then
     warn_unused_intro_pattern names
 
 let intropattern_of_name gl avoid = function
diff --git a/test-suite/bugs/closed/2417.v b/test-suite/bugs/closed/2417.v
new file mode 100644
index 000000000..b2f00ffc6
--- /dev/null
+++ b/test-suite/bugs/closed/2417.v
@@ -0,0 +1,15 @@
+Parameter x y : nat.
+Axiom H : x = y.
+Hint Rewrite H : mybase.
+
+Ltac bar base := autorewrite with base.
+
+Tactic Notation "foo" ident(base) := autorewrite with base.
+
+Goal x = 0.
+  bar mybase.
+  now_show (y = 0).
+  Undo 2.
+  foo mybase.
+  now_show (y = 0).
+Abort.
diff --git a/test-suite/bugs/closed/3612.v b/test-suite/bugs/closed/3612.v
index a54768507..4b4f81dbc 100644
--- a/test-suite/bugs/closed/3612.v
+++ b/test-suite/bugs/closed/3612.v
@@ -38,8 +38,11 @@ Axiom path_path_sigma : forall {A : Type} (P : A -> Type) (u v : sigT P)
            (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2),
 p = q.
 
+Declare ML Module "ltac_plugin".
 Declare ML Module "coretactics".
 
+Set Default Proof Mode "Classic".
+
 Goal forall (A : Type) (B : forall _ : A, Type) (x : @sigT A (fun x : A => B x))
             (xx : @paths (@sigT A (fun x0 : A => B x0)) x x),
        @paths (@paths (@sigT A (fun x0 : A => B x0)) x x) xx
diff --git a/test-suite/bugs/closed/3649.v b/test-suite/bugs/closed/3649.v
index fc4c171e2..8687eaab0 100644
--- a/test-suite/bugs/closed/3649.v
+++ b/test-suite/bugs/closed/3649.v
@@ -2,7 +2,9 @@
 (* File reduced by coq-bug-finder from original input, then from 9518 lines to 404 lines, then from 410 lines to 208 lines, then from 162 lines to 77 lines *)
 (* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0
    coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *)
+Declare ML Module "ltac_plugin".
 Declare ML Module "coretactics".
+Set Default Proof Mode "Classic".
 Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
 Reserved Notation "x = y" (at level 70, no associativity).
 Delimit Scope type_scope with type.
diff --git a/test-suite/bugs/closed/4121.v b/test-suite/bugs/closed/4121.v
index d34a2b8b1..816bc845f 100644
--- a/test-suite/bugs/closed/4121.v
+++ b/test-suite/bugs/closed/4121.v
@@ -4,6 +4,8 @@ Unset Strict Universe Declaration.
 (* coqc version 8.5beta1 (March 2015) compiled on Mar 11 2015 18:51:36 with OCaml 4.01.0
    coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (8dbfee5c5f897af8186cb1bdfb04fd4f88eca677) *)
 
+Declare ML Module "ltac_plugin".
+
 Set Universe Polymorphism.
 Class Contr_internal (A : Type) := BuildContr { center : A }.
 Arguments center A {_}.
@@ -13,4 +15,4 @@ Definition contr_paths_contr0 {A} `{Contr A} : Contr A := {| center := center A
 Instance contr_paths_contr1 {A} `{Contr A} : Contr A := {| center := center A |}.
 Check @contr_paths_contr0@{i}.
 Check @contr_paths_contr1@{i}. (* Error: Universe instance should have length 2 *)
-(** It should have length 1, just like contr_paths_contr0 *)
\ No newline at end of file
+(** It should have length 1, just like contr_paths_contr0 *)
diff --git a/test-suite/bugs/closed/4527.v b/test-suite/bugs/closed/4527.v
index 08628377f..c6fcc24b6 100644
--- a/test-suite/bugs/closed/4527.v
+++ b/test-suite/bugs/closed/4527.v
@@ -5,6 +5,7 @@ then from 269 lines to 255 lines *)
 (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 
 4.01.0
    coqtop version 8.5 (January 2016) *)
+Declare ML Module "ltac_plugin".
 Inductive False := .
 Axiom proof_admitted : False.
 Tactic Notation "admit" := case proof_admitted.
diff --git a/test-suite/bugs/closed/4533.v b/test-suite/bugs/closed/4533.v
index ae17fb145..64c7fd8eb 100644
--- a/test-suite/bugs/closed/4533.v
+++ b/test-suite/bugs/closed/4533.v
@@ -5,6 +5,7 @@ then from 285 lines to 271 lines *)
 (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 
 4.01.0
    coqtop version 8.5 (January 2016) *)
+Declare ML Module "ltac_plugin".
 Inductive False := .
 Axiom proof_admitted : False.
 Tactic Notation "admit" := case proof_admitted.
@@ -223,4 +224,4 @@ v = _) r,
     | [ |- p2 @ p0 @ p1 @ eissect (to O A) (g x) = r ] => idtac "good"
     | [ |- ?G ] => fail 1 "bad" G
     end.
-    Fail rewrite concat_p_pp.
\ No newline at end of file
+    Fail rewrite concat_p_pp.
diff --git a/test-suite/bugs/closed/4544.v b/test-suite/bugs/closed/4544.v
index da140c931..64dd8c304 100644
--- a/test-suite/bugs/closed/4544.v
+++ b/test-suite/bugs/closed/4544.v
@@ -2,6 +2,7 @@
 (* File reduced by coq-bug-finder from original input, then from 2553 lines to 1932 lines, then from 1946 lines to 1932 lines, then from 2467 lines to 1002 lines, then from 1016 lines to 1002 lines *)
 (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0
    coqtop version 8.5 (January 2016) *)
+Declare ML Module "ltac_plugin".
 Inductive False := .
 Axiom proof_admitted : False.
 Tactic Notation "admit" := case proof_admitted.
@@ -1004,4 +1005,4 @@ Proof.
   Fail Timeout 1 Time rewrite !loops_functor_group.
   (* 0.004 s in 8.5rc1, 8.677 s in 8.5 *)
   Timeout 1 do 3 rewrite loops_functor_group.
-Abort.
\ No newline at end of file
+Abort.
diff --git a/test-suite/bugs/closed/4969.v b/test-suite/bugs/closed/4969.v
new file mode 100644
index 000000000..4dee41e22
--- /dev/null
+++ b/test-suite/bugs/closed/4969.v
@@ -0,0 +1,11 @@
+Require Import Classes.Init.
+
+Class C A := c : A.
+Instance nat_C : C nat := 0.
+Instance bool_C : C bool := true.
+Lemma silly {A} `{C A} : 0 = 0 -> c = c -> True.
+Proof. auto. Qed.
+
+Goal True.
+  class_apply @silly; [reflexivity|].
+  reflexivity. Fail Qed.
diff --git a/test-suite/bugs/closed/5345.v b/test-suite/bugs/closed/5345.v
new file mode 100644
index 000000000..d8448f35d
--- /dev/null
+++ b/test-suite/bugs/closed/5345.v
@@ -0,0 +1,7 @@
+Ltac break_tuple :=
+  match goal with
+  | [ H: context[match ?a with | pair n m => _ end] |- _ ] =>
+    let n := fresh n in
+    let m := fresh m in
+    destruct a as [n m]
+  end.
diff --git a/test-suite/bugs/closed/5346.v b/test-suite/bugs/closed/5346.v
new file mode 100644
index 000000000..0118c1870
--- /dev/null
+++ b/test-suite/bugs/closed/5346.v
@@ -0,0 +1,29 @@
+Inductive comp : Type -> Type :=
+| Ret {T} : forall (v:T), comp T
+| Bind {T T'} : forall (p: comp T') (p': T' -> comp T), comp T.
+
+Notation "'do' x .. y <- p1 ; p2" :=
+  (Bind p1 (fun x => .. (fun y => p2) ..))
+    (at level 60, right associativity,
+     x binder, y binder).
+
+Definition Fst1 A B (p: comp (A*B)) : comp A :=
+  do '(a, b) <- p;
+    Ret a.
+
+Definition Fst2 A B (p: comp (A*B)) : comp A :=
+  match tt with
+  | _ => Bind p (fun '(a, b) => Ret a)
+  end.
+
+Definition Fst3 A B (p: comp (A*B)) : comp A :=
+  match tt with
+  | _ => do a <- p;
+          Ret (fst a)
+  end.
+
+Definition Fst A B (p: comp (A * B)) : comp A :=
+  match tt with
+  | _ => do '(a, b) <- p;
+          Ret a
+  end.
diff --git a/test-suite/bugs/closed/5372.v b/test-suite/bugs/closed/5372.v
new file mode 100644
index 000000000..2dc78d4c7
--- /dev/null
+++ b/test-suite/bugs/closed/5372.v
@@ -0,0 +1,7 @@
+(* coq bug 5372: https://coq.inria.fr/bugs/show_bug.cgi?id=5372 *)
+Function odd (n:nat) :=
+  match n with
+  | 0 => false
+  | S n => true
+  end
+with even (n:nat) := false.
diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out
index a2ee2d4c8..979396969 100644
--- a/test-suite/output/Arguments.out
+++ b/test-suite/output/Arguments.out
@@ -97,8 +97,8 @@ Expands to: Constant Top.f
 forall w : r, w 3 true = tt
      : Prop
 The command has indeed failed with message:
-Error: Unknown interpretation for notation "$".
+Unknown interpretation for notation "$".
 w 3 true = tt
      : Prop
 The command has indeed failed with message:
-Error: Extra arguments: _, _.
+Extra arguments: _, _.
diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out
index b084ad498..4df21ae35 100644
--- a/test-suite/output/Arguments_renaming.out
+++ b/test-suite/output/Arguments_renaming.out
@@ -1,5 +1,5 @@
 The command has indeed failed with message:
-Error: To rename arguments the "rename" flag must be specified.
+To rename arguments the "rename" flag must be specified.
 Argument A renamed to B.
 File "stdin", line 2, characters 0-25:
 Warning: This command is just asserting the names of arguments of identity.
@@ -103,15 +103,15 @@ Expands to: Constant Top.myplus
 @myplus
      : forall Z : Type, Z -> nat -> nat -> nat
 The command has indeed failed with message:
-Error: Argument lists should agree on the names they provide.
+Argument lists should agree on the names they provide.
 The command has indeed failed with message:
-Error: Sequences of implicit arguments must be of different lengths.
+Sequences of implicit arguments must be of different lengths.
 The command has indeed failed with message:
-Error: Some argument names are duplicated: F
+Some argument names are duplicated: F
 The command has indeed failed with message:
-Error: Argument z cannot be declared implicit.
+Argument z cannot be declared implicit.
 The command has indeed failed with message:
-Error: Extra arguments: y.
+Extra arguments: y.
 The command has indeed failed with message:
-Error: To rename arguments the "rename" flag must be specified.
+To rename arguments the "rename" flag must be specified.
 Argument A renamed to R.
diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out
index 06a6b2d15..38d055b28 100644
--- a/test-suite/output/Errors.out
+++ b/test-suite/output/Errors.out
@@ -7,4 +7,4 @@ In nested Ltac calls to "f" and "apply x", last call failed.
 Unable to unify "nat" with "True".
 The command has indeed failed with message:
 Ltac call to "instantiate ( (ident) := (lglob) )" failed.
-Error: Instance is not well-typed in the environment of ?x.
+Instance is not well-typed in the environment of ?x.
diff --git a/test-suite/output/FunExt.out b/test-suite/output/FunExt.out
index c6786c72f..8d2a125c1 100644
--- a/test-suite/output/FunExt.out
+++ b/test-suite/output/FunExt.out
@@ -16,4 +16,4 @@ Tactic failure: Already an intensional equality.
 The command has indeed failed with message:
 In nested Ltac calls to "extensionality in (var)" and
 "clearbody (ne_var_list)", last call failed.
-Error: Hypothesis e depends on the body of H'
+Hypothesis e depends on the body of H'
diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out
index 26eaca827..9d106d2da 100644
--- a/test-suite/output/Notations.out
+++ b/test-suite/output/Notations.out
@@ -41,29 +41,29 @@ fun x : nat => ifn x is succ n then n else 0
 -4
      : Z
 The command has indeed failed with message:
-Error: x should not be bound in a recursive pattern of the right-hand side.
+x should not be bound in a recursive pattern of the right-hand side.
 The command has indeed failed with message:
-Error: in the right-hand side, y and z should appear in
+in the right-hand side, y and z should appear in
 term position as part of a recursive pattern.
 The command has indeed failed with message:
 The reference w was not found in the current environment.
 The command has indeed failed with message:
-Error: in the right-hand side, y and z should appear in
+in the right-hand side, y and z should appear in
 term position as part of a recursive pattern.
 The command has indeed failed with message:
-Error: z is expected to occur in binding position in the right-hand side.
+z is expected to occur in binding position in the right-hand side.
 The command has indeed failed with message:
-Error: as y is a non-closed binder, no such "," is allowed to occur.
+as y is a non-closed binder, no such "," is allowed to occur.
 The command has indeed failed with message:
-Error: Cannot find where the recursive pattern starts.
+Cannot find where the recursive pattern starts.
 The command has indeed failed with message:
-Error: Cannot find where the recursive pattern starts.
+Cannot find where the recursive pattern starts.
 The command has indeed failed with message:
-Error: Cannot find where the recursive pattern starts.
+Cannot find where the recursive pattern starts.
 The command has indeed failed with message:
-Error: Cannot find where the recursive pattern starts.
+Cannot find where the recursive pattern starts.
 The command has indeed failed with message:
-Error: Both ends of the recursive pattern are the same.
+Both ends of the recursive pattern are the same.
 SUM (nat * nat) nat
      : Set
 FST (0; 1)
diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out
index 1ff09e3af..35c3057d8 100644
--- a/test-suite/output/ltac.out
+++ b/test-suite/output/ltac.out
@@ -1,5 +1,4 @@
 The command has indeed failed with message:
-Error:
 Ltac variable y depends on pattern variable name z which is not bound in current context.
 Ltac f x y z :=
   symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize
@@ -22,11 +21,11 @@ The term "I" has type "True" while it is expected to have type "False".
 The command has indeed failed with message:
 In nested Ltac calls to "h" and "injection (destruction_arg)", last call
 failed.
-Error: No primitive equality found.
+No primitive equality found.
 The command has indeed failed with message:
 In nested Ltac calls to "h" and "injection (destruction_arg)", last call
 failed.
-Error: No primitive equality found.
+No primitive equality found.
 Hx
 nat
 nat
diff --git a/test-suite/output/ltac_missing_args.out b/test-suite/output/ltac_missing_args.out
new file mode 100644
index 000000000..172612405
--- /dev/null
+++ b/test-suite/output/ltac_missing_args.out
@@ -0,0 +1,20 @@
+The command has indeed failed with message:
+A fully applied tactic is expected: missing argument for variable x.
+The command has indeed failed with message:
+A fully applied tactic is expected: missing argument for variable x.
+The command has indeed failed with message:
+A fully applied tactic is expected: missing arguments for variables y and _.
+The command has indeed failed with message:
+A fully applied tactic is expected: missing argument for variable x.
+The command has indeed failed with message:
+A fully applied tactic is expected: missing argument for variable x.
+The command has indeed failed with message:
+A fully applied tactic is expected: missing argument for variable _.
+The command has indeed failed with message:
+A fully applied tactic is expected: missing argument for variable _.
+The command has indeed failed with message:
+A fully applied tactic is expected: missing argument for variable _.
+The command has indeed failed with message:
+A fully applied tactic is expected: missing argument for variable x.
+The command has indeed failed with message:
+A fully applied tactic is expected: missing argument for variable x.
diff --git a/test-suite/output/ltac_missing_args.v b/test-suite/output/ltac_missing_args.v
new file mode 100644
index 000000000..8ecd97aa5
--- /dev/null
+++ b/test-suite/output/ltac_missing_args.v
@@ -0,0 +1,19 @@
+Ltac foo x := idtac x.
+Ltac bar x := fun y _ => idtac x y.
+Ltac baz := foo.
+Ltac qux := bar.
+Ltac mydo tac := tac ().
+Ltac rec x := rec.
+
+Goal True.
+  Fail foo.
+  Fail bar.
+  Fail bar True.
+  Fail baz.
+  Fail qux.
+  Fail mydo ltac:(fun _ _ => idtac).
+  Fail let tac := (fun _ => idtac) in tac.
+  Fail (fun _ => idtac).
+  Fail rec True.
+  Fail let rec tac x := tac in tac True.
+Abort.
\ No newline at end of file
diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v
index 07bbb60c4..52acad746 100644
--- a/test-suite/success/Notations.v
+++ b/test-suite/success/Notations.v
@@ -128,3 +128,10 @@ Notation " |- {{ a }} b" := (a=b) (no associativity, at level 10).
 Goal True.
 {{ exact I. }}
 Qed.
+
+(* Check that we can have notations without any symbol iff they are "only printing". *)
+Fail Notation "" := (@nil).
+Notation "" := (@nil) (only printing).
+
+(* Check that a notation cannot be neither parsing nor printing. *)
+Fail Notation "'foobarkeyword'" := (@nil) (only parsing, only printing).
diff --git a/test-suite/success/decl_mode.v b/test-suite/success/decl_mode.v
index 58f79d45e..e569bcb49 100644
--- a/test-suite/success/decl_mode.v
+++ b/test-suite/success/decl_mode.v
@@ -153,7 +153,7 @@ proof.
       thus ~= (IZR (Zneg z) * IZR (Zneg z)).
   end cases.
 end proof.
-Qed.
+Admitted.
 
 Definition irrational (x:R):Prop :=
   forall (p:Z) (q:nat),q<>0%nat -> x<> (IZR p/INR q).
diff --git a/test-suite/success/hintdb_in_ltac.v b/test-suite/success/hintdb_in_ltac.v
new file mode 100644
index 000000000..f12b4d1f4
--- /dev/null
+++ b/test-suite/success/hintdb_in_ltac.v
@@ -0,0 +1,14 @@
+Definition x := 0.
+
+Hint Unfold x : mybase.
+
+Ltac autounfoldify base := autounfold with base.
+
+Tactic Notation "autounfoldify_bis" ident(base) := autounfold with base.
+
+Goal x = 0.
+  progress autounfoldify mybase.
+  Undo.
+  progress autounfoldify_bis mybase.
+  trivial.
+Qed.
diff --git a/test-suite/success/hintdb_in_ltac_bis.v b/test-suite/success/hintdb_in_ltac_bis.v
new file mode 100644
index 000000000..f5c25540e
--- /dev/null
+++ b/test-suite/success/hintdb_in_ltac_bis.v
@@ -0,0 +1,15 @@
+Parameter Foo : Prop.
+Axiom H : Foo.
+
+Hint Resolve H : mybase.
+
+Ltac foo base := eauto with base.
+
+Tactic Notation "bar" ident(base) :=
+  typeclasses eauto with base.
+
+Goal Foo.
+  progress foo mybase.
+  Undo.
+  progress bar mybase.
+Qed.
\ No newline at end of file
diff --git a/test-suite/success/ltac_match_pattern_names.v b/test-suite/success/ltac_match_pattern_names.v
new file mode 100644
index 000000000..736329496
--- /dev/null
+++ b/test-suite/success/ltac_match_pattern_names.v
@@ -0,0 +1,28 @@
+(* example from bug 5345 *)
+Ltac break_tuple :=
+  match goal with
+  | [ H: context[let '(n, m) := ?a in _] |- _ ] =>
+    let n := fresh n in
+    let m := fresh m in
+    destruct a as [n m]
+  end.
+
+(* desugared version of break_tuple *)
+Ltac break_tuple' :=
+  match goal with
+  | [ H: context[match ?a with | pair n m => _ end] |- _ ] =>
+    let n := fresh n in
+    let m := fresh m in
+    idtac
+  end.
+
+Ltac multiple_branches :=
+  match goal with
+  | [ H: match _ with
+         | left P => _
+         | right Q => _
+         end |- _ ] =>
+    let P := fresh P in
+    let Q := fresh Q in
+    idtac
+  end.
\ No newline at end of file
diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v
index 58d3a2b38..5a3d5631d 100644
--- a/theories/Arith/Between.v
+++ b/theories/Arith/Between.v
@@ -24,7 +24,7 @@ Section Between.
 
   Lemma bet_eq : forall k l, l = k -> between k l.
   Proof.
-    induction 1; auto with arith.
+    intros * ->; auto with arith.
   Qed.
 
   Hint Resolve bet_eq: arith.
@@ -37,9 +37,7 @@ Section Between.
 
   Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l.
   Proof.
-    intros k l H; induction H as [|l H].
-    intros; absurd (S k <= k); auto with arith.
-    destruct H; auto with arith.
+    induction 1 as [|* [|]]; auto with arith.
   Qed.
   Hint Resolve between_Sk_l: arith.
 
@@ -74,32 +72,32 @@ Section Between.
 
   Lemma in_int_intro : forall p q r, p <= r -> r < q -> in_int p q r.
   Proof.
-    red; auto with arith.
+    split; assumption.
   Qed.
   Hint Resolve in_int_intro: arith.
 
   Lemma in_int_lt : forall p q r, in_int p q r -> p < q.
   Proof.
-    induction 1; intros.
-    apply le_lt_trans with r; auto with arith.
+    intros * [].
+    eapply le_lt_trans; eassumption.
   Qed.
 
   Lemma in_int_p_Sq :
-    forall p q r, in_int p (S q) r -> in_int p q r \/ r = q :>nat.
+    forall p q r, in_int p (S q) r -> in_int p q r \/ r = q.
   Proof.
-    induction 1; intros.
-    elim (le_lt_or_eq r q); auto with arith.
+    intros p q r [].
+    destruct (le_lt_or_eq r q); auto with arith.
   Qed.
 
   Lemma in_int_S : forall p q r, in_int p q r -> in_int p (S q) r.
   Proof.
-    induction 1; auto with arith.
+    intros * []; auto with arith.
   Qed.
   Hint Resolve in_int_S: arith.
 
   Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r.
   Proof.
-    induction 1; auto with arith.
+    intros * []; auto with arith.
   Qed.
   Hint Immediate in_int_Sp_q: arith.
 
@@ -107,10 +105,9 @@ Section Between.
     forall k l, between k l -> forall r, in_int k l r -> P r.
   Proof.
     induction 1; intros.
-    absurd (k < k); auto with arith.
-    apply in_int_lt with r; auto with arith.
-    elim (in_int_p_Sq k l r); intros; auto with arith.
-    rewrite H2; trivial with arith.
+    - absurd (k < k). { auto with arith. }
+      eapply in_int_lt; eassumption.
+    - destruct (in_int_p_Sq k l r) as [| ->]; auto with arith.
   Qed.
 
   Lemma in_int_between :
@@ -120,17 +117,17 @@ Section Between.
   Qed.
 
   Lemma exists_in_int :
-    forall k l, exists_between k l ->  exists2 m : nat, in_int k l m & Q m.
+    forall k l, exists_between k l -> exists2 m : nat, in_int k l m & Q m.
   Proof.
-    induction 1.
-    case IHexists_between; intros p inp Qp; exists p; auto with arith.
-    exists l; auto with arith.
+    induction 1 as [* ? (p, ?, ?)|].
+    - exists p; auto with arith.
+    - exists l; auto with arith.
   Qed.
 
   Lemma in_int_exists : forall k l r, in_int k l r -> Q r -> exists_between k l.
   Proof.
-    destruct 1; intros.
-    elim H0; auto with arith.
+    intros * (?, lt_r_l) ?.
+    induction lt_r_l; auto with arith.
   Qed.
 
   Lemma between_or_exists :
@@ -139,9 +136,11 @@ Section Between.
       (forall n:nat, in_int k l n -> P n \/ Q n) ->
       between k l \/ exists_between k l.
   Proof.
-    induction 1; intros; auto with arith.
-    elim IHle; intro; auto with arith.
-    elim (H0 m); auto with arith.
+    induction 1 as [|m ? IHle].
+    - auto with arith.
+    - intros P_or_Q.
+      destruct IHle; auto with arith.
+      destruct (P_or_Q m); auto with arith.
   Qed.
 
   Lemma between_not_exists :
@@ -150,14 +149,14 @@ Section Between.
       (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l.
   Proof.
     induction 1; red; intros.
-    absurd (k < k); auto with arith.
-    absurd (Q l); auto with arith.
-    elim (exists_in_int k (S l)); auto with arith; intros l' inl' Ql'.
-    replace l with l'; auto with arith.
-    elim inl'; intros.
-    elim (le_lt_or_eq l' l); auto with arith; intros.
-    absurd (exists_between k l); auto with arith.
-    apply in_int_exists with l'; auto with arith.
+    - absurd (k < k); auto with arith.
+    - absurd (Q l). { auto with arith. }
+      destruct (exists_in_int k (S l)) as (l',[],?).
+      + auto with arith.
+      + replace l with l'. { trivial. }
+        destruct (le_lt_or_eq l' l); auto with arith.
+        absurd (exists_between k l). { auto with arith. }
+        eapply in_int_exists; eauto with arith.
   Qed.
 
   Inductive P_nth (init:nat) : nat -> nat -> Prop :=
@@ -168,15 +167,16 @@ Section Between.
 
   Lemma nth_le : forall (init:nat) l (n:nat), P_nth init l n -> init <= l.
   Proof.
-    induction 1; intros; auto with arith.
-    apply le_trans with (S k); auto with arith.
+    induction 1.
+    - auto with arith.
+    - eapply le_trans; eauto with arith.
   Qed.
 
   Definition eventually (n:nat) :=  exists2 k : nat, k <= n & Q k.
 
   Lemma event_O : eventually 0 -> Q 0.
   Proof.
-    induction 1; intros.
+    intros (x, ?, ?).
     replace 0 with x; auto with arith.
   Qed.
 
diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v
index ddaf08bf7..11d80dbc3 100644
--- a/theories/Init/Datatypes.v
+++ b/theories/Init/Datatypes.v
@@ -262,6 +262,11 @@ Inductive comparison : Set :=
   | Lt : comparison
   | Gt : comparison.
 
+Lemma comparison_eq_stable : forall c c' : comparison, ~~ c = c' -> c = c'.
+Proof.
+  destruct c, c'; intro H; reflexivity || destruct H; discriminate.
+Qed.
+
 Definition CompOpp (r:comparison) :=
   match r with
     | Eq => Eq
@@ -326,7 +331,6 @@ Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c,
  CompSpec eq lt x y c -> CompSpecT eq lt x y c.
 Proof. intros. apply CompareSpec2Type; assumption. Defined.
 
-
 (******************************************************************)
 (** * Misc Other Datatypes *)
 
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
index 85123cc44..9b58c524e 100644
--- a/theories/Init/Logic.v
+++ b/theories/Init/Logic.v
@@ -125,6 +125,25 @@ Proof.
   [apply Hl | apply Hr]; assumption.
 Qed.
 
+Theorem imp_iff_compat_l : forall A B C : Prop,
+  (B <-> C) -> ((A -> B) <-> (A -> C)).
+Proof.
+  intros ? ? ? [Hl Hr]; split; intros H ?; [apply Hl | apply Hr]; apply H; assumption.
+Qed.
+
+Theorem imp_iff_compat_r : forall A B C : Prop,
+  (B <-> C) -> ((B -> A) <-> (C -> A)).
+Proof.
+  intros ? ? ? [Hl Hr]; split; intros H ?; [apply H, Hr | apply H, Hl]; assumption.
+Qed.
+
+Theorem not_iff_compat : forall A B : Prop,
+  (A <-> B) -> (~ A <-> ~B).
+Proof.
+  intros; apply imp_iff_compat_r; assumption.
+Qed.
+
+
 (** Some equivalences *)
 
 Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False).
@@ -553,7 +572,8 @@ Proof.
   intros A P (x & Hp & Huniq); split.
   - intro; exists x; auto.
   - intros (x0 & HPx0 & HQx0) x1 HPx1.
-    replace x1 with x0 by (transitivity x; [symmetry|]; auto).
+    assert (H : x0 = x1) by (transitivity x; [symmetry|]; auto).
+    destruct H.
     assumption.
 Qed.   
 
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index 48fbe0793..edcd53005 100644
--- a/theories/Init/Notations.v
+++ b/theories/Init/Notations.v
@@ -88,9 +88,12 @@ Open Scope type_scope.
 
 (** ML Tactic Notations *)
 
+Declare ML Module "ltac_plugin".
 Declare ML Module "coretactics".
 Declare ML Module "extratactics".
 Declare ML Module "g_auto".
 Declare ML Module "g_class".
 Declare ML Module "g_eqdecide".
 Declare ML Module "g_rewrite".
+
+Global Set Default Proof Mode "Classic".
diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v
index 9fc00e80c..2cc2ecbc2 100644
--- a/theories/Init/Specif.v
+++ b/theories/Init/Specif.v
@@ -103,7 +103,7 @@ Definition sig_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sig P
     of an [a] of type [A], a of a proof [h] that [a] satisfies [P],
     and a proof [h'] that [a] satisfies [Q].  Then
     [(proj1_sig (sig_of_sig2 y))] is the witness [a],
-    [(proj2_sig (sig_of_sig2 y))] is the proof of [(P a)], and 
+    [(proj2_sig (sig_of_sig2 y))] is the proof of [(P a)], and
     [(proj3_sig y)] is the proof of [(Q a)]. *)
 
 Section Subset_projections2.
@@ -190,6 +190,23 @@ Definition sig2_of_sigT2 (A : Type) (P Q : A -> Prop) (X : sigT2 P Q) : sig2 P Q
 Definition sigT2_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sigT2 P Q
   := existT2 P Q (proj1_sig (sig_of_sig2 X)) (proj2_sig (sig_of_sig2 X)) (proj3_sig X).
 
+(** η Principles *)
+Definition sigT_eta {A P} (p : { a : A & P a })
+  : p = existT _ (projT1 p) (projT2 p).
+Proof. destruct p; reflexivity. Defined.
+
+Definition sig_eta {A P} (p : { a : A | P a })
+  : p = exist _ (proj1_sig p) (proj2_sig p).
+Proof. destruct p; reflexivity. Defined.
+
+Definition sigT2_eta {A P Q} (p : { a : A & P a & Q a })
+  : p = existT2 _ _ (projT1 (sigT_of_sigT2 p)) (projT2 (sigT_of_sigT2 p)) (projT3 p).
+Proof. destruct p; reflexivity. Defined.
+
+Definition sig2_eta {A P Q} (p : { a : A | P a & Q a })
+  : p = exist2 _ _ (proj1_sig (sig_of_sig2 p)) (proj2_sig (sig_of_sig2 p)) (proj3_sig p).
+Proof. destruct p; reflexivity. Defined.
+
 (** [sumbool] is a boolean type equipped with the justification of
     their value *)
 
@@ -263,10 +280,10 @@ Section Dependent_choice_lemmas.
     (forall x:X, {y | R x y}) ->
     forall x0, {f : nat -> X | f O = x0 /\ forall n, R (f n) (f (S n))}.
   Proof.
-    intros H x0. 
+    intros H x0.
     set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end).
     exists f.
-    split. reflexivity. 
+    split. reflexivity.
     induction n; simpl; apply proj2_sig.
   Defined.
 
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index 30f1dec22..1aece3f60 100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -419,7 +419,7 @@ Section Elts.
   Proof.
     unfold lt; induction n as [| n hn]; simpl.
     - destruct l; simpl; [ inversion 2 | auto ].
-    - destruct l as [| a l hl]; simpl.
+    - destruct l; simpl.
       * inversion 2.
       * intros d ie; right; apply hn; auto with arith.
   Qed.
@@ -1280,7 +1280,7 @@ End Fold_Right_Recursor.
     partition l = ([], []) <-> l = [].
   Proof.
     split.
-    - destruct l as [|a l' _].
+    - destruct l as [|a l'].
       * intuition.
       * simpl. destruct (f a), (partition l'); now intros [= -> ->].
     - now intros ->.
diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v
index 1420a000b..07e8b6ef8 100644
--- a/theories/Logic/ChoiceFacts.v
+++ b/theories/Logic/ChoiceFacts.v
@@ -22,7 +22,16 @@ description principles
 - AC!     = functional relation reification
             (known as axiom of unique choice in topos theory,
              sometimes called principle of definite description in
-             the context of constructive type theory)
+             the context of constructive type theory, sometimes
+             called axiom of no choice)
+
+- AC_fun_repr          = functional choice of a representative in an equivalence class
+- AC_fun_setoid_gen    = functional form of the general form of the (so-called
+                          extensional) axiom of choice over setoids
+- AC_fun_setoid        = functional form of the (so-called extensional) axiom of
+                         choice from setoids
+- AC_fun_setoid_simple = functional form of the (so-called extensional) axiom of
+                         choice from setoids on locally compatible relations
 
 - GAC_rel = guarded relational form of the (non extensional) axiom of choice
 - GAC_fun = guarded functional form of the (non extensional) axiom of choice
@@ -45,6 +54,11 @@ description principles
              independence of premises)
 - Drinker = drinker's paradox (small form)
             (called Ex in Bell [[Bell]])
+- EM      = excluded-middle
+
+- Ext_pred_repr     = choice of a representative among extensional predicates
+- Ext_pred          = extensionality of predicates
+- Ext_fun_prop_repr = choice of a representative among extensional functions to Prop
 
 We let also
 
@@ -76,6 +90,10 @@ Table of contents
 
 8. Choice -> Dependent choice -> Countable choice
 
+9.1. AC_fun_ext = AC_fun + Ext_fun_repr + EM
+
+9.2. AC_fun_ext = AC_fun + Ext_prop_fun_repr + PI
+
 References:
 
 [[Bell]] John L. Bell, Choice principles in intuitionistic set theory,
@@ -84,8 +102,13 @@ unpublished.
 [[Bell93]] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic
 Type Theories, Mathematical Logic Quarterly, volume 39, 1993.
 
+[[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent to
+AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.
+
 [[Carlström05]] Jesper Carlström, Interpreting descriptions in
 intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005.
+
+[[Werner97]] Benjamin Werner, Sets in Types, Types in Sets, TACS, 1997.
 *)
 
 Set Implicit Arguments.
@@ -108,8 +131,6 @@ Variables A B :Type.
 
 Variable P:A->Prop.
 
-Variable R:A->B->Prop.
-
 (** ** Constructive choice and description *)
 
 (** AC_rel *)
@@ -121,6 +142,10 @@ Definition RelationalChoice_on :=
 
 (** AC_fun *)
 
+(* Note: This is called Type-Theoretic Description Axiom (TTDA) in
+   [[Werner97]] (using a non-standard meaning of "description"). This
+   is called intensional axiom of choice (AC_int) in [[Carlström04]] *)
+
 Definition FunctionalChoice_on :=
   forall R:A->B->Prop,
     (forall x : A, exists y : B, R x y) ->
@@ -148,6 +173,55 @@ Definition FunctionalRelReification_on :=
     (forall x : A, exists! y : B, R x y) ->
     (exists f : A->B, forall x : A, R x (f x)).
 
+(** AC_fun_repr *)
+
+(* Note: This is called Type-Theoretic Choice Axiom (TTCA) in
+   [[Werner97]] (by reference to the extensional set-theoretic
+   formulation of choice); Note also a typo in its intended
+   formulation in [[Werner97]]. *)
+
+Require Import RelationClasses Logic.
+
+Definition RepresentativeFunctionalChoice_on :=
+  forall R:A->A->Prop,
+    (Equivalence R) ->
+    (exists f : A->A, forall x : A, (R x (f x)) /\ forall x', R x x' -> f x = f x').
+
+(** AC_fun_setoid *)
+
+Definition SetoidFunctionalChoice_on :=
+  forall R : A -> A -> Prop,
+  forall T : A -> B -> Prop,
+  Equivalence R ->
+  (forall x x' y, R x x' -> T x y -> T x' y) ->
+  (forall x, exists y, T x y) ->
+  exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x').
+
+(** AC_fun_setoid_gen *)
+
+(* Note: This is called extensional axiom of choice (AC_ext) in
+   [[Carlström04]]. *)
+
+Definition GeneralizedSetoidFunctionalChoice_on :=
+  forall R : A -> A -> Prop,
+  forall S : B -> B -> Prop,
+  forall T : A -> B -> Prop,
+  Equivalence R ->
+  Equivalence S ->
+  (forall x x' y y', R x x' -> S y y' -> T x y -> T x' y') ->
+  (forall x, exists y, T x y) ->
+  exists f : A -> B,
+    forall x : A, T x (f x) /\ (forall x' : A, R x x' -> S (f x) (f x')).
+
+(** AC_fun_setoid_simple *)
+
+Definition SimpleSetoidFunctionalChoice_on A B :=
+  forall R : A -> A -> Prop,
+  forall T : A -> B -> Prop,
+  Equivalence R ->
+  (forall x, exists y, forall x', R x x' -> T x' y) ->
+  exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x').
+
 (** ID_epsilon (constructive version of indefinite description;
     combined with proof-irrelevance, it may be connected to
     Carlström's type theory with a constructive indefinite description
@@ -234,6 +308,14 @@ Notation FunctionalChoiceOnInhabitedSet :=
   (forall A B : Type, inhabited B -> FunctionalChoice_on A B).
 Notation FunctionalRelReification :=
   (forall A B : Type, FunctionalRelReification_on A B).
+Notation RepresentativeFunctionalChoice :=
+  (forall A : Type, RepresentativeFunctionalChoice_on A).
+Notation SetoidFunctionalChoice :=
+  (forall A  B: Type, SetoidFunctionalChoice_on A B).
+Notation GeneralizedSetoidFunctionalChoice :=
+  (forall A B : Type, GeneralizedSetoidFunctionalChoice_on A B).
+Notation SimpleSetoidFunctionalChoice :=
+  (forall A B : Type, SimpleSetoidFunctionalChoice_on A B).
 
 Notation GuardedRelationalChoice :=
   (forall A B : Type, GuardedRelationalChoice_on A B).
@@ -271,6 +353,26 @@ Definition SmallDrinker'sParadox :=
   forall (A:Type) (P:A -> Prop), inhabited A ->
     exists x, (exists x, P x) -> P x.
 
+Definition ExcludedMiddle :=
+  forall P:Prop, P \/ ~ P.
+
+(** Extensional schemes *)
+
+Local Notation ExtensionalPropositionRepresentative :=
+  (forall (A:Type),
+   exists h : Prop -> Prop,
+   forall P : Prop, (P <-> h P) /\ forall Q, (P <-> Q) -> h P = h Q).
+
+Local Notation ExtensionalPredicateRepresentative :=
+  (forall (A:Type),
+   exists h : (A->Prop) -> (A->Prop),
+   forall (P : A -> Prop), (forall x, P x <-> h P x) /\ forall Q, (forall x, P x <-> Q x) -> h P = h Q).
+
+Local Notation ExtensionalFunctionRepresentative :=
+  (forall (A B:Type),
+   exists h : (A->B) -> (A->B),
+   forall (f : A -> B), (forall x, f x = h f x) /\ forall g, (forall x, f x = g x) -> h f = h g).
+
 (**********************************************************************)
 (** * AC_rel + AC! = AC_fun
 
@@ -284,7 +386,7 @@ Definition SmallDrinker'sParadox :=
    relational formulation) without known inconsistency with classical logic,
    though functional relation reification conflicts with classical logic *)
 
-Lemma description_rel_choice_imp_funct_choice :
+Lemma functional_rel_reification_and_rel_choice_imp_fun_choice :
   forall A B : Type,
     FunctionalRelReification_on A B -> RelationalChoice_on A B -> FunctionalChoice_on A B.
 Proof.
@@ -298,7 +400,10 @@ Proof.
   apply HR'R; assumption.
 Qed.
 
-Lemma funct_choice_imp_rel_choice :
+Notation description_rel_choice_imp_funct_choice :=
+  functional_rel_reification_and_rel_choice_imp_fun_choice (compat "8.6").
+
+Lemma fun_choice_imp_rel_choice :
   forall A B : Type, FunctionalChoice_on A B -> RelationalChoice_on A B.
 Proof.
   intros A B FunCh R H.
@@ -311,7 +416,9 @@ Proof.
     trivial.
 Qed.
 
-Lemma funct_choice_imp_description :
+Notation funct_choice_imp_rel_choice := fun_choice_imp_rel_choice (compat "8.6").
+
+Lemma fun_choice_imp_functional_rel_reification :
   forall A B : Type, FunctionalChoice_on A B -> FunctionalRelReification_on A B.
 Proof.
   intros A B FunCh R H.
@@ -324,17 +431,21 @@ Proof.
   exists f; exact H0.
 Qed.
 
-Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr :
+Notation funct_choice_imp_description := fun_choice_imp_functional_rel_reification (compat "8.6").
+
+Corollary fun_choice_iff_rel_choice_and_functional_rel_reification :
   forall A B : Type, FunctionalChoice_on A B <->
     RelationalChoice_on A B /\ FunctionalRelReification_on A B.
 Proof.
   intros A B. split.
   intro H; split;
-    [ exact (funct_choice_imp_rel_choice H)
-      | exact (funct_choice_imp_description H) ].
-  intros [H H0]; exact (description_rel_choice_imp_funct_choice H0 H).
+    [ exact (fun_choice_imp_rel_choice H)
+      | exact (fun_choice_imp_functional_rel_reification H) ].
+  intros [H H0]; exact (functional_rel_reification_and_rel_choice_imp_fun_choice H0 H).
 Qed.
 
+Notation FunChoice_Equiv_RelChoice_and_ParamDefinDescr :=
+ fun_choice_iff_rel_choice_and_functional_rel_reification (compat "8.6").
 (**********************************************************************)
 (** * Connection between the guarded, non guarded and omniscient choices *)
 
@@ -862,3 +973,334 @@ Proof.
   rewrite Heq in HR.
   assumption.
 Qed.
+
+(**********************************************************************)
+(** * About the axiom of choice over setoids                          *)
+
+Require Import ClassicalFacts PropExtensionalityFacts.
+
+(**********************************************************************)
+(** ** Consequences of the choice of a representative in an equivalence class *)
+
+Theorem repr_fun_choice_imp_ext_prop_repr :
+  RepresentativeFunctionalChoice -> ExtensionalPropositionRepresentative.
+Proof.
+  intros ReprFunChoice A.
+  pose (R P Q := P <-> Q).
+  assert (Hequiv:Equivalence R) by (split; firstorder).
+  apply (ReprFunChoice _ R Hequiv).
+Qed.
+
+Theorem repr_fun_choice_imp_ext_pred_repr :
+  RepresentativeFunctionalChoice -> ExtensionalPredicateRepresentative.
+Proof.
+  intros ReprFunChoice A.
+  pose (R P Q := forall x : A, P x <-> Q x).
+  assert (Hequiv:Equivalence R) by (split; firstorder).
+  apply (ReprFunChoice _ R Hequiv).
+Qed.
+
+Theorem repr_fun_choice_imp_ext_function_repr :
+  RepresentativeFunctionalChoice -> ExtensionalFunctionRepresentative.
+Proof.
+  intros ReprFunChoice A B.
+  pose (R (f g : A -> B) := forall x : A, f x = g x).
+  assert (Hequiv:Equivalence R).
+  { split; try easy. firstorder using eq_trans. }
+  apply (ReprFunChoice _ R Hequiv).
+Qed.
+
+(** *** This is a variant of Diaconescu and Goodman-Myhill theorems *)
+
+Theorem repr_fun_choice_imp_excluded_middle :
+  RepresentativeFunctionalChoice -> ExcludedMiddle.
+Proof.
+  intros ReprFunChoice.
+  apply representative_boolean_partition_imp_excluded_middle, ReprFunChoice.
+Qed.
+
+Theorem repr_fun_choice_imp_relational_choice :
+  RepresentativeFunctionalChoice -> RelationalChoice.
+Proof.
+  intros ReprFunChoice A B T Hexists.
+  pose (D := (A*B)%type).
+  pose (R (z z':D) :=
+    let x := fst z in
+    let x' := fst z' in
+    let y := snd z in
+    let y' := snd z' in
+    x = x' /\ (T x y -> y = y' \/ T x y') /\ (T x y' -> y = y' \/ T x y)).
+  assert (Hequiv : Equivalence R).
+  { split.
+    - split. easy. firstorder.
+    - intros (x,y) (x',y') (H1,(H2,H2')). split. easy. simpl fst in *. simpl snd in *.
+      subst x'. split; intro H.
+      + destruct (H2' H); firstorder.
+      + destruct (H2 H); firstorder.
+    - intros (x,y) (x',y') (x'',y'') (H1,(H2,H2')) (H3,(H4,H4')).
+      simpl fst in *. simpl snd in *. subst x'' x'. split. easy. split; intro H.
+      + simpl fst in *. simpl snd in *. destruct (H2 H) as [<-|H0].
+        * destruct (H4 H); firstorder.
+        * destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder.
+      + simpl fst in *. simpl snd in *. destruct (H4' H) as [<-|H0].
+        * destruct (H2' H); firstorder.
+        * destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder. }
+  destruct (ReprFunChoice D R Hequiv) as (g,Hg).
+  set (T' x y := T x y /\ exists y', T x y' /\ g (x,y') = (x,y)).
+  exists T'. split.
+  - intros x y (H,_); easy.
+  - intro x. destruct (Hexists x) as (y,Hy).
+    exists (snd (g (x,y))).
+    destruct (Hg (x,y)) as ((Heq1,(H',H'')),Hgxyuniq); clear Hg.
+    destruct (H' Hy) as [Heq2|Hgy]; clear H'.
+    + split. split.
+      * rewrite <- Heq2. assumption.
+      * exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1, Heq2. subst; easy.
+      * intros y' (Hy',(y'',(Hy'',Heq))).
+        rewrite (Hgxyuniq (x,y'')), Heq. easy. split. easy.
+        split; right; easy.
+    + split. split.
+      * assumption.
+      * exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1. subst x'; easy.
+      * intros y' (Hy',(y'',(Hy'',Heq))).
+        rewrite (Hgxyuniq (x,y'')), Heq. easy. split. easy.
+        split; right; easy.
+Qed.
+
+(**********************************************************************)
+(** ** AC_fun_setoid = AC_fun_setoid_gen = AC_fun_setoid_simple       *)
+
+Theorem gen_setoid_fun_choice_imp_setoid_fun_choice  :
+  forall A B, GeneralizedSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B.
+Proof.
+  intros A B GenSetoidFunChoice R T Hequiv Hcompat Hex.
+  apply GenSetoidFunChoice; try easy.
+  apply eq_equivalence.
+  intros * H <-. firstorder.
+Qed.
+
+Theorem setoid_fun_choice_imp_gen_setoid_fun_choice :
+  forall A B, SetoidFunctionalChoice_on A B -> GeneralizedSetoidFunctionalChoice_on A B.
+Proof.
+  intros A B SetoidFunChoice R S T HequivR HequivS Hcompat Hex.
+  destruct SetoidFunChoice with (R:=R) (T:=T) as (f,Hf); try easy.
+  { intros; apply (Hcompat x x' y y); try easy. }
+  exists f. intros x; specialize Hf with x as (Hf,Huniq). intuition. now erewrite Huniq.
+Qed.
+
+Corollary setoid_fun_choice_iff_gen_setoid_fun_choice :
+  forall A B, SetoidFunctionalChoice_on A B <-> GeneralizedSetoidFunctionalChoice_on A B.
+Proof.
+  split; auto using gen_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_gen_setoid_fun_choice.
+Qed.
+
+Theorem setoid_fun_choice_imp_simple_setoid_fun_choice  :
+   forall A B, SetoidFunctionalChoice_on A B -> SimpleSetoidFunctionalChoice_on A B.
+Proof.
+  intros A B SetoidFunChoice R T Hequiv Hexists.
+  pose (T' x y := forall x', R x x' -> T x' y).
+  assert (Hcompat : forall (x x' : A) (y : B), R x x' -> T' x y -> T' x' y) by firstorder.
+  destruct (SetoidFunChoice R T' Hequiv Hcompat Hexists) as (f,Hf).
+  exists f. firstorder.
+Qed.
+
+Theorem simple_setoid_fun_choice_imp_setoid_fun_choice :
+  forall A B, SimpleSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B.
+Proof.
+  intros A B SimpleSetoidFunChoice R T Hequiv Hcompat Hexists.
+  destruct (SimpleSetoidFunChoice R T Hequiv) as (f,Hf); firstorder.
+Qed.
+
+Corollary setoid_fun_choice_iff_simple_setoid_fun_choice :
+  forall A B, SetoidFunctionalChoice_on A B <-> SimpleSetoidFunctionalChoice_on A B.
+Proof.
+  split; auto using simple_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_simple_setoid_fun_choice.
+Qed.
+
+(**********************************************************************)
+(** ** AC_fun_setoid = AC! + AC_fun_repr                              *)
+
+Theorem setoid_fun_choice_imp_fun_choice :
+  forall A B, SetoidFunctionalChoice_on A B -> FunctionalChoice_on A B.
+Proof.
+  intros A B SetoidFunChoice T Hexists.
+  destruct SetoidFunChoice with (R:=@eq A) (T:=T) as (f,Hf).
+  - apply eq_equivalence.
+  - now intros * ->.
+  - assumption.
+  - exists f. firstorder.
+Qed.
+
+Corollary setoid_fun_choice_imp_functional_rel_reification :
+  forall A B, SetoidFunctionalChoice_on A B -> FunctionalRelReification_on A B.
+Proof.
+  intros A B SetoidFunChoice.
+  apply fun_choice_imp_functional_rel_reification.
+  now apply setoid_fun_choice_imp_fun_choice.
+Qed.
+
+Theorem setoid_fun_choice_imp_repr_fun_choice :
+  SetoidFunctionalChoice -> RepresentativeFunctionalChoice .
+Proof.
+  intros SetoidFunChoice A R Hequiv.
+  apply SetoidFunChoice; firstorder.
+Qed.
+
+Theorem functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice :
+  FunctionalRelReification -> RepresentativeFunctionalChoice -> SetoidFunctionalChoice.
+Proof.
+  intros FunRelReify ReprFunChoice A B R T Hequiv Hcompat Hexists.
+  assert (FunChoice : FunctionalChoice).
+  { intros A' B'. apply functional_rel_reification_and_rel_choice_imp_fun_choice.
+    - apply FunRelReify.
+    - now apply repr_fun_choice_imp_relational_choice. }
+  destruct (FunChoice _ _ T Hexists) as (f,Hf).
+  destruct (ReprFunChoice A R Hequiv) as (g,Hg).
+  exists (fun a => f (g a)).
+  intro x. destruct (Hg x) as (Hgx,HRuniq).
+  split.
+  - eapply Hcompat. symmetry. apply Hgx. apply Hf.
+  - intros y Hxy. f_equal. auto.
+Qed.
+
+Theorem functional_rel_reification_and_repr_fun_choice_iff_setoid_fun_choice :
+  FunctionalRelReification /\ RepresentativeFunctionalChoice <-> SetoidFunctionalChoice.
+Proof.
+  split; intros.
+  - now apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice.
+  - split.
+    + now intros A B; apply setoid_fun_choice_imp_functional_rel_reification.
+    + now apply setoid_fun_choice_imp_repr_fun_choice.
+Qed.
+
+(** Note: What characterization to give of
+RepresentativeFunctionalChoice? A formulation of it as a functional
+relation would certainly be equivalent to the formulation of
+SetoidFunctionalChoice as a functional relation, but in their
+functional forms, SetoidFunctionalChoice seems strictly stronger *)
+
+(**********************************************************************)
+(** * AC_fun_setoid = AC_fun + Ext_fun_repr + EM                      *)
+
+Import EqNotations.
+
+(** ** This is the main theorem in [[Carlström04]] *)
+
+(** Note: all ingredients have a computational meaning when taken in
+  separation. However, to compute with the functional choice,
+  existential quantification has to be thought as a strong
+  existential, which is incompatible with the computational content of
+  excluded-middle *)
+
+Theorem fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice :
+  FunctionalChoice -> ExtensionalFunctionRepresentative -> ExcludedMiddle -> RepresentativeFunctionalChoice.
+Proof.
+  intros FunChoice SetoidFunRepr EM A R (Hrefl,Hsym,Htrans).
+  assert (H:forall P:Prop, exists b, b = true <-> P).
+  { intros P. destruct (EM P).
+    - exists true; firstorder.
+    - exists false; easy. }
+  destruct (FunChoice _ _ _ H) as (c,Hc).
+  pose (class_of a y := c (R a y)).
+  pose (isclass f := exists x:A, f x = true).
+  pose (class := {f:A -> bool | isclass f}).
+  pose (contains (c:class) (a:A) := proj1_sig c a = true).
+  destruct (FunChoice class A contains) as (f,Hf).
+  - intros f. destruct (proj2_sig f) as (x,Hx).
+    exists x. easy.
+  - destruct (SetoidFunRepr A bool) as (h,Hh).
+    assert (Hisclass:forall a, isclass (h (class_of a))).
+    { intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa).
+      rewrite <- Ha. apply Hc. apply Hrefl. }
+   pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class).
+    exists (fun a => f (f' a)).
+    intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split.
+    + specialize Hf with (f' x). unfold contains in Hf. simpl in Hf. rewrite <- Hx in Hf. apply Hc. assumption.
+    + intros y Hxy.
+       f_equal.
+       assert (Heq1: h (class_of x) = h (class_of y)).
+       { apply Huniqx. intro z. unfold class_of.
+         destruct (c (R x z)) eqn:Hxz.
+         - symmetry. apply Hc. apply -> Hc in Hxz. firstorder.
+         - destruct (c (R y z)) eqn:Hyz.
+           + apply -> Hc in Hyz. rewrite <- Hxz. apply Hc. firstorder.
+           + easy. }
+       assert (Heq2:rew Heq1 in Hisclass x = Hisclass y).
+       { apply proof_irrelevance_cci, EM. }
+       unfold f'.
+       rewrite <- Heq2.
+       rewrite <- Heq1.
+       reflexivity.
+Qed.
+
+Theorem setoid_functional_choice_first_characterization :
+  FunctionalChoice /\ ExtensionalFunctionRepresentative /\ ExcludedMiddle <-> SetoidFunctionalChoice.
+Proof.
+  split.
+  - intros (FunChoice & SetoidFunRepr & EM).
+    apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice.
+    + intros A B. apply fun_choice_imp_functional_rel_reification, FunChoice.
+    + now apply fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice.
+  - intro SetoidFunChoice. repeat split.
+    + now intros A B; apply setoid_fun_choice_imp_fun_choice.
+    + apply repr_fun_choice_imp_ext_function_repr.
+       now apply setoid_fun_choice_imp_repr_fun_choice.
+    + apply repr_fun_choice_imp_excluded_middle.
+       now apply setoid_fun_choice_imp_repr_fun_choice.
+Qed.
+
+(**********************************************************************)
+(** ** AC_fun_setoid = AC_fun + Ext_pred_repr + PI                    *)
+
+(** Note: all ingredients have a computational meaning when taken in
+  separation. However, to compute with the functional choice,
+  existential quantification has to be thought as a strong
+  existential, which is incompatible with proof-irrelevance which
+  requires existential quantification to be truncated *)
+
+Theorem fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice :
+  FunctionalChoice -> ExtensionalPredicateRepresentative -> ProofIrrelevance -> RepresentativeFunctionalChoice.
+Proof.
+  intros FunChoice PredExtRepr PI A R (Hrefl,Hsym,Htrans).
+  pose (isclass P := exists x:A, P x).
+  pose (class := {P:A -> Prop | isclass P}).
+  pose (contains (c:class) (a:A) := proj1_sig c a).
+  pose (class_of a := R a).
+  destruct (FunChoice class A contains) as (f,Hf).
+  - intros c. apply proj2_sig.
+  - destruct (PredExtRepr A) as (h,Hh).
+    assert (Hisclass:forall a, isclass (h (class_of a))).
+    { intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa).
+      rewrite <- Ha; apply Hrefl. }
+    pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class).
+    exists (fun a => f (f' a)).
+    intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split.
+    + specialize Hf with (f' x). simpl in Hf. rewrite <- Hx in Hf. assumption.
+    + intros y Hxy.
+       f_equal.
+       assert (Heq1: h (class_of x) = h (class_of y)).
+       { apply Huniqx. intro z. unfold class_of. firstorder. }
+       assert (Heq2:rew Heq1 in Hisclass x = Hisclass y).
+       { apply PI. }
+       unfold f'.
+       rewrite <- Heq2.
+       rewrite <- Heq1.
+       reflexivity.
+Qed.
+
+Theorem setoid_functional_choice_second_characterization :
+  FunctionalChoice /\ ExtensionalPredicateRepresentative /\ ProofIrrelevance <-> SetoidFunctionalChoice.
+Proof.
+  split.
+  - intros (FunChoice & ExtPredRepr & PI).
+    apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice.
+    + intros A B. now apply fun_choice_imp_functional_rel_reification.
+    + now apply fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice.
+  - intro SetoidFunChoice. repeat split.
+    + now intros A B; apply setoid_fun_choice_imp_fun_choice.
+    + apply repr_fun_choice_imp_ext_pred_repr.
+       now apply setoid_fun_choice_imp_repr_fun_choice.
+    + red. apply proof_irrelevance_cci.
+       apply repr_fun_choice_imp_excluded_middle.
+       now apply setoid_fun_choice_imp_repr_fun_choice.
+Qed.
diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v
index afd64efdf..021408a37 100644
--- a/theories/Logic/ClassicalFacts.v
+++ b/theories/Logic/ClassicalFacts.v
@@ -34,8 +34,11 @@ Table of contents:
 
 3 3. Independence of general premises and drinker's paradox
 
-4. Classical logic and principle of unrestricted minimization
+4. Principles equivalent to classical logic
 
+4.1 Classical logic = principle of unrestricted minimization
+
+4.2 Classical logic = choice of representatives in a partition of bool
 *)
 
 (************************************************************************)
@@ -94,12 +97,14 @@ Qed.
 (** A weakest form of propositional extensionality: extensionality for
     provable propositions only *)
 
+Require Import PropExtensionalityFacts.
+
 Definition provable_prop_extensionality := forall A:Prop, A -> A = True.
 
 Lemma provable_prop_ext :
   prop_extensionality -> provable_prop_extensionality.
 Proof.
-  intros Ext A Ha; apply Ext; split; trivial.
+  exact PropExt_imp_ProvPropExt.
 Qed.
 
 (************************************************************************)
@@ -516,7 +521,7 @@ End Weak_proof_irrelevance_CCI.
 (** ** Weak excluded-middle *)
 
 (** The weak classical logic based on [~~A \/ ~A] is referred to with
-    name KC in {[ChagrovZakharyaschev97]]
+    name KC in [[ChagrovZakharyaschev97]]
 
    [[ChagrovZakharyaschev97]] Alexander Chagrov and Michael
    Zakharyaschev, "Modal Logic", Clarendon Press, 1997.
@@ -661,6 +666,8 @@ Proof.
     exists x0; exact Hnot.
 Qed.
 
+(** * Axioms equivalent to classical logic *)
+
 (** ** Principle of unrestricted minimization *)
 
 Require Import Coq.Arith.PeanoNat.
@@ -736,3 +743,56 @@ Section Example_of_undecidable_predicate_with_the_minimization_property.
   Qed.
 
 End Example_of_undecidable_predicate_with_the_minimization_property.
+
+(** ** Choice of representatives in a partition of bool *)
+
+(** This is similar to Bell's "weak extensional selection principle"  in [[Bell]]
+
+   [[Bell]] John L. Bell, Choice principles in intuitionistic set theory, unpublished.
+*)
+
+Require Import RelationClasses.
+
+Local Notation representative_boolean_partition :=
+  (forall R:bool->bool->Prop,
+    Equivalence R -> exists f, forall x, R x (f x) /\ forall y, R x y -> f x = f y).
+
+Theorem representative_boolean_partition_imp_excluded_middle :
+  representative_boolean_partition -> excluded_middle.
+Proof.
+  intros ReprFunChoice P.
+  pose (R (b1 b2 : bool) := b1 = b2 \/ P).
+  assert (Equivalence R).
+  { split.
+    - now left.
+    - destruct 1. now left. now right.
+    - destruct 1, 1; try now right. left; now transitivity y. }
+  destruct (ReprFunChoice R H) as (f,Hf). clear H.
+  destruct (Bool.bool_dec (f true) (f false)) as [Heq|Hneq].
+  + left.
+     destruct (Hf false) as ([Hfalse|HP],_); try easy.
+     destruct (Hf true) as ([Htrue|HP],_); try easy.
+     congruence.
+  + right. intro HP.
+     destruct (Hf true) as (_,H). apply Hneq, H. now right.
+Qed.
+
+Theorem excluded_middle_imp_representative_boolean_partition :
+  excluded_middle -> representative_boolean_partition.
+Proof.
+  intros EM R H.
+  destruct (EM (R true false)).
+  - exists (fun _ => true).
+    intros []; firstorder.
+  - exists (fun b => b).
+    intro b. split.
+    + reflexivity.
+    + destruct b, y; intros HR; easy || now symmetry in HR.
+Qed.
+
+Theorem excluded_middle_iff_representative_boolean_partition :
+  excluded_middle <-> representative_boolean_partition.
+Proof.
+  split; auto using excluded_middle_imp_representative_boolean_partition,
+                    representative_boolean_partition_imp_excluded_middle.
+Qed.
diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v
index 23af5afc6..896be7c33 100644
--- a/theories/Logic/Diaconescu.v
+++ b/theories/Logic/Diaconescu.v
@@ -8,9 +8,9 @@
 (************************************************************************)
 
 (** Diaconescu showed that the Axiom of Choice entails Excluded-Middle
-   in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show
+   in topoi [[Diaconescu75]]. Lacas and Werner adapted the proof to show
    that the axiom of choice in equivalence classes entails
-   Excluded-Middle in Type Theory [LacasWerner99].
+   Excluded-Middle in Type Theory [[LacasWerner99]].
 
    Three variants of Diaconescu's result in type theory are shown below.
 
@@ -23,22 +23,22 @@
       Benjamin Werner)
 
    C. A proof that extensional Hilbert epsilon's description operator
-      entails excluded-middle (taken from Bell [Bell93])
+      entails excluded-middle (taken from Bell [[Bell93]])
 
-   See also [Carlström] for a discussion of the connection between the
+   See also [[Carlström04]] for a discussion of the connection between the
    Extensional Axiom of Choice and Excluded-Middle
 
-   [Diaconescu75] Radu Diaconescu, Axiom of Choice and Complementation,
+   [[Diaconescu75]] Radu Diaconescu, Axiom of Choice and Complementation,
    in Proceedings of AMS, vol 51, pp 176-178, 1975.
 
-   [LacasWerner99] Samuel Lacas, Benjamin Werner, Which Choices imply
+   [[LacasWerner99]] Samuel Lacas, Benjamin Werner, Which Choices imply
    the excluded middle?, preprint, 1999.
 
-   [Bell93] John L. Bell, Hilbert's epsilon operator and classical
+   [[Bell93]] John L. Bell, Hilbert's epsilon operator and classical
    logic, Journal of Philosophical Logic, 22: 1-18, 1993
 
-   [Carlström04] Jesper Carlström, EM + Ext_ + AC_int <-> AC_ext,
-   Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.
+   [[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent
+   to AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.
 *)
 
 (**********************************************************************)
@@ -263,7 +263,7 @@ End ProofIrrel_RelChoice_imp_EqEM.
 (**********************************************************************)
 (** * Extensional Hilbert's epsilon description operator -> Excluded-Middle *)
 
-(** Proof sketch from Bell [Bell93] (with thanks to P. Castéran) *)
+(** Proof sketch from Bell [[Bell93]] (with thanks to P. Castéran) *)
 
 Local Notation inhabited A := A (only parsing).
 
diff --git a/theories/Logic/ExtensionalFunctionRepresentative.v b/theories/Logic/ExtensionalFunctionRepresentative.v
new file mode 100644
index 000000000..a9da68e16
--- /dev/null
+++ b/theories/Logic/ExtensionalFunctionRepresentative.v
@@ -0,0 +1,24 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This module states a limited form axiom of functional
+    extensionality which selects a canonical representative in each
+    class of extensional functions *)
+
+(** Its main interest is that it is the needed ingredient to provide
+    axiom of choice on setoids (a.k.a. axiom of extensional choice)
+    when combined with classical logic and axiom of (intensonal)
+    choice *)
+
+(** It provides extensionality of functions while still supporting (a
+    priori) an intensional interpretation of equality *)
+
+Axiom extensional_function_representative :
+  forall A B, exists repr, forall (f : A -> B),
+  (forall x, f x = repr f x) /\
+  (forall g, (forall x, f x = g x) -> repr f = repr g).
diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v
index 56e03e965..a10c180cc 100644
--- a/theories/Logic/Hurkens.v
+++ b/theories/Logic/Hurkens.v
@@ -360,13 +360,12 @@ Module NoRetractToModalProposition.
 Section Paradox.
 
 Variable M : Prop -> Prop.
-Hypothesis unit : forall A:Prop, A -> M A.
-Hypothesis join : forall A:Prop, M (M A) -> M A.
 Hypothesis incr : forall A B:Prop, (A->B) -> M A -> M B.
 
 Lemma strength: forall A (P:A->Prop), M(forall x:A,P x) -> forall x:A,M(P x).
 Proof.
-  eauto.
+  intros A P h x.
+  eapply incr in h; eauto.
 Qed.
 
 (** ** The universe of modal propositions *)
@@ -470,7 +469,7 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)).
 Theorem paradox : forall B:NProp, El B.
 Proof.
   intros B.
-  unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))).
+  unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))).
   + exact (fun P => ~~P).
   + exact bool.
   + exact p2b.
@@ -480,8 +479,6 @@ Proof.
   + cbn. auto.
   + cbn. auto.
   + cbn. auto.
-  + auto.
-  + auto.
 Qed.
 
 End Paradox.
@@ -516,7 +513,7 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)).
 Theorem mparadox : forall B:NProp, El B.
 Proof.
   intros B.
-  unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))).
+  unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))).
   + exact (fun P => P).
   + exact bool.
   + exact p2b.
@@ -526,8 +523,6 @@ Proof.
   + cbn. auto.
   + cbn. auto.
   + cbn. auto.
-  + auto.
-  + auto.
 Qed.
 
 End MParadox.
diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v
index 2f95856b4..86d05e8fb 100644
--- a/theories/Logic/JMeq.v
+++ b/theories/Logic/JMeq.v
@@ -130,7 +130,7 @@ Qed.
     is as strong as [eq_dep U P p x q y] (this uses [JMeq_eq]) *)
 
 Lemma JMeq_eq_dep : 
-  forall U (P:U->Prop) p q (x:P p) (y:P q), 
+  forall U (P:U->Type) p q (x:P p) (y:P q), 
   p = q -> JMeq x y -> eq_dep U P p x q y.
 Proof.
 intros.
diff --git a/printing/ppvernacsig.mli b/theories/Logic/PropExtensionality.v
index 5e5e4bcf4..796c60273 100644
--- a/printing/ppvernacsig.mli
+++ b/theories/Logic/PropExtensionality.v
@@ -6,15 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-module type Pp = sig
+(** This module states propositional extensionality and draws
+    consequences of it *)
 
-  (** Prints a fixpoint body *)
-  val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds
+Axiom propositional_extensionality :
+  forall (P Q : Prop), (P <-> Q) -> P = Q.
 
-  (** Prints a vernac expression *)
-  val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds
+Require Import ClassicalFacts.
 
-  (** Prints a vernac expression and closes it with a dot. *)
-  val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds
+Theorem proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.
+Proof.
+  apply ext_prop_dep_proof_irrel_cic.
+  exact propositional_extensionality.
+Qed.
 
-end
diff --git a/theories/Logic/PropExtensionalityFacts.v b/theories/Logic/PropExtensionalityFacts.v
new file mode 100644
index 000000000..7e455dfa1
--- /dev/null
+++ b/theories/Logic/PropExtensionalityFacts.v
@@ -0,0 +1,109 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Some facts and definitions about propositional and predicate extensionality
+
+We investigate the relations between the following extensionality principles
+
+- Proposition extensionality
+- Predicate extensionality
+- Propositional functional extensionality
+- Provable-proposition extensionality
+- Refutable-proposition extensionality
+- Extensional proposition representatives
+- Extensional predicate representatives
+- Extensional propositional function representatives
+
+Table of contents
+
+1. Definitions
+
+2.1 Predicate extensionality <-> Proposition extensionality + Propositional functional extensionality
+
+2.2 Propositional extensionality -> Provable propositional extensionality
+
+2.3 Propositional extensionality -> Refutable propositional extensionality
+
+*)
+
+Set Implicit Arguments.
+
+(**********************************************************************)
+(** * Definitions *)
+
+(** Propositional extensionality *)
+
+Local Notation PropositionalExtensionality :=
+  (forall A B : Prop, (A <-> B) -> A = B).
+
+(** Provable-proposition extensionality *)
+
+Local Notation ProvablePropositionExtensionality :=
+  (forall A:Prop, A -> A = True).
+
+(** Refutable-proposition extensionality *)
+
+Local Notation RefutablePropositionExtensionality :=
+  (forall A:Prop, ~A -> A = False).
+
+(** Predicate extensionality *)
+
+Local Notation PredicateExtensionality :=
+  (forall (A:Type) (P Q : A -> Prop), (forall x, P x <-> Q x) -> P = Q).
+
+(** Propositional functional extensionality *)
+
+Local Notation PropositionalFunctionalExtensionality :=
+  (forall (A:Type) (P Q : A -> Prop), (forall x, P x = Q x) -> P = Q).
+
+(**********************************************************************)
+(** * Propositional and predicate extensionality                      *)
+
+(**********************************************************************)
+(** ** Predicate extensionality <-> Propositional extensionality + Propositional functional extensionality *)
+
+Lemma PredExt_imp_PropExt : PredicateExtensionality -> PropositionalExtensionality.
+Proof.
+  intros Ext A B Equiv. 
+  change A with ((fun _ => A) I).
+  now rewrite Ext with (P := fun _ : True =>A) (Q := fun _ => B).
+Qed.
+
+Lemma PredExt_imp_PropFunExt : PredicateExtensionality -> PropositionalFunctionalExtensionality.
+Proof.
+  intros Ext A P Q Eq. apply Ext. intros x. now rewrite (Eq x).
+Qed.
+
+Lemma PropExt_and_PropFunExt_imp_PredExt :
+  PropositionalExtensionality -> PropositionalFunctionalExtensionality -> PredicateExtensionality.
+Proof.
+  intros Ext FunExt A P Q Equiv.
+  apply FunExt. intros x. now apply Ext.
+Qed.
+
+Theorem PropExt_and_PropFunExt_iff_PredExt :
+  PropositionalExtensionality /\ PropositionalFunctionalExtensionality <-> PredicateExtensionality.
+Proof.
+  firstorder using PredExt_imp_PropExt, PredExt_imp_PropFunExt, PropExt_and_PropFunExt_imp_PredExt.
+Qed.
+
+(**********************************************************************)
+(** ** Propositional extensionality and provable proposition extensionality *)
+
+Lemma PropExt_imp_ProvPropExt : PropositionalExtensionality -> ProvablePropositionExtensionality.
+Proof.
+  intros Ext A Ha; apply Ext; split; trivial.
+Qed.
+
+(**********************************************************************)
+(** ** Propositional extensionality and refutable proposition extensionality *)
+
+Lemma PropExt_imp_RefutPropExt : PropositionalExtensionality -> RefutablePropositionExtensionality.
+Proof.
+  intros Ext A Ha; apply Ext; split; easy.
+Qed.
diff --git a/theories/Logic/SetoidChoice.v b/theories/Logic/SetoidChoice.v
new file mode 100644
index 000000000..84432dda1
--- /dev/null
+++ b/theories/Logic/SetoidChoice.v
@@ -0,0 +1,60 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This module states the functional form of the axiom of choice over
+  setoids, commonly called extensional axiom of choice [[Carlström04]],
+  [[Martin-Löf05]]. This is obtained by a decomposition of the axiom
+  into the following components:
+
+  - classical logic
+  - relational axiom of choice
+  - axiom of unique choice
+  - a limited form of functional extensionality
+
+  Among other results, it entails:
+  - proof irrelevance
+  - choice of a representative in equivalence classes
+
+  [[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent to
+  AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.
+
+  [[Martin-Löf05] Per Martin-Löf, 100 years of Zermelo’s axiom of
+  choice: what was the problem with it?, lecture notes for KTH/SU
+  colloquium, 2005.
+
+*)
+
+Require Export ClassicalChoice. (* classical logic, relational choice, unique choice *)
+Require Export ExtensionalFunctionRepresentative.
+
+Require Import ChoiceFacts.
+Require Import ClassicalFacts.
+Require Import RelationClasses.
+
+Theorem setoid_choice :
+  forall A B,
+  forall R : A -> A -> Prop,
+  forall T : A -> B -> Prop,
+  Equivalence R ->
+  (forall x x' y, R x x' -> T x y -> T x' y) ->
+  (forall x, exists y, T x y) ->
+  exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x').
+Proof.
+  apply setoid_functional_choice_first_characterization. split; [|split].
+  - exact choice.
+  - exact extensional_function_representative.
+  - exact classic.
+Qed.
+
+Theorem representative_choice :
+  forall A (R:A->A->Prop), (Equivalence R) ->
+  exists f : A->A, forall x : A, R x (f x) /\ forall x', R x x' -> f x = f x'.
+Proof.
+  apply setoid_fun_choice_imp_repr_fun_choice.
+  exact setoid_choice.
+Qed.
diff --git a/theories/Logic/vo.itarget b/theories/Logic/vo.itarget
index 323597395..8b0aa6691 100644
--- a/theories/Logic/vo.itarget
+++ b/theories/Logic/vo.itarget
@@ -1,4 +1,5 @@
 Berardi.vo
+PropExtensionalityFacts.vo
 ChoiceFacts.vo
 ClassicalChoice.vo
 ClassicalDescription.vo
@@ -20,11 +21,14 @@ WeakFan.vo
 WKL.vo
 FunctionalExtensionality.vo
 ExtensionalityFacts.vo
+ExtensionalFunctionRepresentative.vo
 Hurkens.vo
 IndefiniteDescription.vo
 JMeq.vo
 ProofIrrelevanceFacts.vo
 ProofIrrelevance.vo
+PropExtensionality.vo
 RelationalChoice.vo
 SetIsType.vo
-FinFun.vo
\ No newline at end of file
+SetoidChoice.vo
+FinFun.vo
diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v
index 7baf102aa..d6385ee31 100644
--- a/theories/PArith/BinPos.v
+++ b/theories/PArith/BinPos.v
@@ -813,6 +813,34 @@ Proof.
   rewrite compare_cont_spec. unfold ge. destruct (p ?= q); easy'.
 Qed.
 
+Lemma compare_cont_Lt_not_Lt p q :
+  compare_cont Lt p q <> Lt <-> p > q.
+Proof.
+  rewrite compare_cont_Lt_Lt.
+  unfold gt, le, compare.
+  now destruct compare_cont; split; try apply comparison_eq_stable.
+Qed.
+
+Lemma compare_cont_Lt_not_Gt p q :
+  compare_cont Lt p q <> Gt <-> p <= q.
+Proof.
+  apply not_iff_compat, compare_cont_Lt_Gt.
+Qed.
+
+Lemma compare_cont_Gt_not_Lt p q :
+  compare_cont Gt p q <> Lt <-> p >= q.
+Proof.
+  apply not_iff_compat, compare_cont_Gt_Lt.
+Qed.
+
+Lemma compare_cont_Gt_not_Gt p q :
+  compare_cont Gt p q <> Gt <-> p < q.
+Proof.
+  rewrite compare_cont_Gt_Gt.
+  unfold ge, lt, compare.
+  now destruct compare_cont; split; try apply comparison_eq_stable.
+Qed.
+
 (** We can express recursive equations for [compare] *)
 
 Lemma compare_xO_xO p q : (p~0 ?= q~0) = (p ?= q).
diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v
index 0ed6d557c..e94ef408d 100644
--- a/theories/QArith/Qround.v
+++ b/theories/QArith/Qround.v
@@ -141,7 +141,7 @@ Qed.
 Lemma Zdiv_Qdiv (n m: Z): (n / m)%Z = Qfloor (n / m).
 Proof.
  unfold Qfloor. intros. simpl.
- destruct m as [?|?|p]; simpl.
+ destruct m as [ | | p]; simpl.
   now rewrite Zdiv_0_r, Z.mul_0_r.
   now rewrite Z.mul_1_r.
  rewrite <- Z.opp_eq_mul_m1.
diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v
index a98d529fa..0e1608a32 100644
--- a/theories/Reals/Alembert.v
+++ b/theories/Reals/Alembert.v
@@ -78,7 +78,7 @@ Proof.
   ring.
   discrR.
   discrR.
-  pattern 1 at 3; replace 1 with (/ 1);
+  replace 1 with (/ 1);
     [ apply tech7; discrR | apply Rinv_1 ].
   replace (An (S x)) with (An (S x + 0)%nat).
   apply (tech6 (fun i:nat => An (S x + i)%nat) (/ 2)).
diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v
index 6fca9c8ad..67584f775 100644
--- a/theories/Reals/ArithProp.v
+++ b/theories/Reals/ArithProp.v
@@ -143,7 +143,7 @@ Proof.
   assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl;
     cut (0 < y).
   intro; unfold Rminus;
-    replace (- ((IZR (up (x / y)) + -1) * y)) with ((1 - IZR (up (x / y))) * y);
+    replace (- ((IZR (up (x / y)) + -(1)) * y)) with ((1 - IZR (up (x / y))) * y);
       [ idtac | ring ].
   split.
   apply Rmult_le_reg_l with (/ y).
diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v
index 4e2a7c3c6..05911cd53 100644
--- a/theories/Reals/DiscrR.v
+++ b/theories/Reals/DiscrR.v
@@ -31,9 +31,6 @@ Ltac discrR :=
   try
    match goal with
    |  |- (?X1 <> ?X2) =>
-       change 2 with (IZR 2);
-       change 1 with (IZR 1);
-       change 0 with (IZR 0);
        repeat
          rewrite <- plus_IZR ||
            rewrite <- mult_IZR ||
@@ -52,9 +49,6 @@ Ltac prove_sup0 :=
   end.
 
 Ltac omega_sup :=
-  change 2 with (IZR 2);
-  change 1 with (IZR 1);
-  change 0 with (IZR 0);
   repeat
     rewrite <- plus_IZR ||
       rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
@@ -72,9 +66,6 @@ Ltac prove_sup :=
   end.
 
 Ltac Rcompute :=
-  change 2 with (IZR 2);
-  change 1 with (IZR 1);
-  change 0 with (IZR 0);
   repeat
     rewrite <- plus_IZR ||
       rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v
index 569518f7b..e9de24898 100644
--- a/theories/Reals/Exp_prop.v
+++ b/theories/Reals/Exp_prop.v
@@ -439,20 +439,16 @@ Proof.
   repeat rewrite <- Rmult_assoc.
   rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l.
-  replace (INR N * INR N) with (Rsqr (INR N)); [ idtac | reflexivity ].
-  rewrite Rmult_assoc.
-  rewrite Rmult_comm.
-  replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ].
+  change 4 with (Rsqr 2).
   rewrite <- Rsqr_mult.
   apply Rsqr_incr_1.
-  replace 2 with (INR 2).
-  rewrite <- mult_INR; apply H1.
-  reflexivity.
+  change 2 with (INR 2).
+  rewrite Rmult_comm, <- mult_INR; apply H1.
   left; apply lt_INR_0; apply H.
   left; apply Rmult_lt_0_compat.
-  prove_sup0.
   apply lt_INR_0; apply div2_not_R0.
   apply lt_n_S; apply H.
+  now apply IZR_lt.
   cut (1 < S N)%nat.
   intro; unfold Rsqr; apply prod_neq_R0; apply not_O_INR; intro;
     assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4;
diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v
index 19db476fd..2d2385703 100644
--- a/theories/Reals/Machin.v
+++ b/theories/Reals/Machin.v
@@ -53,7 +53,7 @@ assert (-(PI/4) <= atan x).
  destruct xm1 as [xm1 | xm1].
   rewrite <- atan_1, <- atan_opp; apply Rlt_le, atan_increasing.
   assumption.
- solve[rewrite <- xm1, atan_opp, atan_1; apply Rle_refl].
+ solve[rewrite <- xm1; change (-1) with (-(1)); rewrite atan_opp, atan_1; apply Rle_refl].
 assert (-(PI/4) < atan y).
  rewrite <- atan_1, <- atan_opp; apply atan_increasing.
  assumption.
diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v
index 379fee6f4..dd2108159 100644
--- a/theories/Reals/RIneq.v
+++ b/theories/Reals/RIneq.v
@@ -1743,24 +1743,40 @@ Proof.
   intros z; idtac; apply Z_of_nat_complete; assumption.
 Qed.
 
+Lemma INR_IPR : forall p, INR (Pos.to_nat p) = IPR p.
+Proof.
+  assert (H: forall p, 2 * INR (Pos.to_nat p) = IPR_2 p).
+    induction p as [p|p|] ; simpl IPR_2.
+    rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- IHp.
+    now rewrite (Rplus_comm (2 * _)).
+    now rewrite Pos2Nat.inj_xO, mult_INR, <- IHp.
+    apply Rmult_1_r.
+  intros [p|p|] ; unfold IPR.
+  rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H.
+  apply Rplus_comm.
+  now rewrite Pos2Nat.inj_xO, mult_INR, <- H.
+  easy.
+Qed.
+
 (**********)
 Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z.of_nat n).
 Proof.
-  simple induction n; auto with real.
-  intros; simpl; rewrite SuccNat2Pos.id_succ;
-    auto with real.
+  intros [|n].
+  easy.
+  simpl Z.of_nat. unfold IZR.
+  now rewrite <- INR_IPR, SuccNat2Pos.id_succ.
 Qed.
 
 Lemma plus_IZR_NEG_POS :
   forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q).
 Proof.
   intros p q; simpl. rewrite Z.pos_sub_spec.
-  case Pos.compare_spec; intros H; simpl.
+  case Pos.compare_spec; intros H; unfold IZR.
   subst. ring.
-  rewrite Pos2Nat.inj_sub by trivial.
+  rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial.
   rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt).
   ring.
-  rewrite Pos2Nat.inj_sub by trivial.
+  rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial.
   rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt).
   ring.
 Qed.
@@ -1769,26 +1785,18 @@ Qed.
 Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m.
 Proof.
   intro z; destruct z; intro t; destruct t; intros; auto with real.
-  simpl; intros; rewrite Pos2Nat.inj_add; auto with real.
+  simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add. apply plus_INR.
   apply plus_IZR_NEG_POS.
   rewrite Z.add_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS.
-  simpl; intros; rewrite Pos2Nat.inj_add; rewrite plus_INR;
-    auto with real.
+  simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR.
+  apply Ropp_plus_distr.
 Qed.
 
 (**********)
 Lemma mult_IZR : forall n m:Z, IZR (n * m) = IZR n * IZR m.
 Proof.
-  intros z t; case z; case t; simpl; auto with real.
-  intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real.
-  intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real.
-  rewrite Rmult_comm.
-  rewrite Ropp_mult_distr_l_reverse; auto with real.
-  apply Ropp_eq_compat; rewrite mult_comm; auto with real.
-  intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real.
-  rewrite Ropp_mult_distr_l_reverse; auto with real.
-  intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real.
-  rewrite Rmult_opp_opp; auto with real.
+  intros z t; case z; case t; simpl; auto with real;
+    unfold IZR; intros m n; rewrite <- 3!INR_IPR, Pos2Nat.inj_mul, mult_INR; ring.
 Qed.
 
 Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Z.pow z (Z.of_nat n)).
@@ -1804,13 +1812,13 @@ Qed.
 (**********)
 Lemma succ_IZR : forall n:Z, IZR (Z.succ n) = IZR n + 1.
 Proof.
-  intro; change 1 with (IZR 1); unfold Z.succ; apply plus_IZR.
+  intro; unfold Z.succ; apply plus_IZR.
 Qed.
 
 (**********)
 Lemma opp_IZR : forall n:Z, IZR (- n) = - IZR n.
 Proof.
-  intro z; case z; simpl; auto with real.
+  intros [|z|z]; unfold IZR; simpl; auto with real.
 Qed.
 
 Definition Ropp_Ropp_IZR := opp_IZR.
@@ -1833,10 +1841,12 @@ Qed.
 Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z.
 Proof.
   intro z; case z; simpl; intros.
-  absurd (0 < 0); auto with real.
-  unfold Z.lt; simpl; trivial.
-  case Rlt_not_le with (1 := H).
-  replace 0 with (-0); auto with real.
+  elim (Rlt_irrefl _ H).
+  easy.
+  elim (Rlt_not_le _ _ H).
+  unfold IZR.
+  rewrite <- INR_IPR.
+  auto with real.
 Qed.
 
 (**********)
@@ -1852,9 +1862,12 @@ Qed.
 Lemma eq_IZR_R0 : forall n:Z, IZR n = 0 -> n = 0%Z.
 Proof.
   intro z; destruct z; simpl; intros; auto with zarith.
-  case (Rlt_not_eq 0 (INR (Pos.to_nat p))); auto with real.
-  case (Rlt_not_eq (- INR (Pos.to_nat p)) 0); auto with real.
-  apply Ropp_lt_gt_0_contravar. unfold Rgt; apply pos_INR_nat_of_P.
+  elim Rgt_not_eq with (2 := H).
+  unfold IZR. rewrite <- INR_IPR.
+  apply lt_0_INR, Pos2Nat.is_pos.
+  elim Rlt_not_eq with (2 := H).
+  unfold IZR. rewrite <- INR_IPR.
+  apply Ropp_lt_gt_0_contravar, lt_0_INR, Pos2Nat.is_pos.
 Qed.
 
 (**********)
@@ -2003,6 +2016,31 @@ Proof.
   [ apply not_0_INR; discriminate | unfold INR; ring ].
 Qed.
 
+Lemma R_rm : ring_morph
+  R0 R1 Rplus Rmult Rminus Ropp eq
+  0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool IZR.
+Proof.
+constructor ; try easy.
+exact plus_IZR.
+exact minus_IZR.
+exact mult_IZR.
+exact opp_IZR.
+intros x y H.
+apply f_equal.
+now apply Zeq_bool_eq.
+Qed.
+
+Lemma Zeq_bool_IZR x y :
+  IZR x = IZR y -> Zeq_bool x y = true.
+Proof.
+intros H.
+apply Zeq_is_eq_bool.
+now apply eq_IZR.
+Qed.
+
+Add Field RField : Rfield
+  (completeness Zeq_bool_IZR, morphism R_rm, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]).
+
 (*********************************************************)
 (** ** Other rules about < and <=                        *)
 (*********************************************************)
@@ -2017,42 +2055,18 @@ Qed.
 Lemma le_epsilon :
   forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2.
 Proof.
-  intros x y; intros; elim (Rtotal_order x y); intro.
-  left; assumption.
-  elim H0; intro.
-  right; assumption.
-  clear H0; generalize (Rgt_minus x y H1); intro H2; change (0 < x - y) in H2.
-  cut (0 < 2).
-  intro.
-  generalize (Rmult_lt_0_compat (x - y) (/ 2) H2 (Rinv_0_lt_compat 2 H0));
-    intro H3; generalize (H ((x - y) * / 2) H3);
-      replace (y + (x - y) * / 2) with ((y + x) * / 2).
-  intro H4;
-    generalize (Rmult_le_compat_l 2 x ((y + x) * / 2) (Rlt_le 0 2 H0) H4);
-      rewrite <- (Rmult_comm ((y + x) * / 2)); rewrite Rmult_assoc;
-        rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; replace (2 * x) with (x + x).
-  rewrite (Rplus_comm y); intro H5; apply Rplus_le_reg_l with x; assumption.
-  ring.
-  replace 2 with (INR 2); [ apply not_0_INR; discriminate | reflexivity ].
-  pattern y at 2; replace y with (y / 2 + y / 2).
-  unfold Rminus, Rdiv.
-  repeat rewrite Rmult_plus_distr_r.
-  ring.
-  cut (forall z:R, 2 * z = z + z).
-  intro.
-  rewrite <- (H4 (y / 2)).
-  unfold Rdiv.
-  rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
-  replace 2 with (INR 2).
-  apply not_0_INR.
-  discriminate.
-  unfold INR; reflexivity.
-  intro; ring.
-  cut (0%nat <> 2%nat);
-    [ intro H0; generalize (lt_0_INR 2 (neq_O_lt 2 H0)); unfold INR;
-      intro; assumption
-      | discriminate ].
+  intros x y H.
+  destruct (Rle_or_lt x y) as [H1|H1].
+  exact H1.
+  apply Rplus_le_reg_r with x.
+  replace (y + x) with (2 * (y + (x - y) * / 2)) by field.
+  replace (x + x) with (2 * x) by ring.
+  apply Rmult_le_compat_l.
+  now apply (IZR_le 0 2).
+  apply H.
+  apply Rmult_lt_0_compat.
+  now apply Rgt_minus.
+  apply Rinv_0_lt_compat, Rlt_0_2.
 Qed.
 
 (**********)
diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v
index b6d072837..e9b1762af 100644
--- a/theories/Reals/R_Ifp.v
+++ b/theories/Reals/R_Ifp.v
@@ -112,21 +112,12 @@ Lemma base_Int_part :
 Proof.
   intro; unfold Int_part; elim (archimed r); intros.
   split; rewrite <- (Z_R_minus (up r) 1); simpl.
-  generalize (Rle_minus (IZR (up r) - r) 1 H0); intro; unfold Rminus in H1;
-    rewrite (Rplus_assoc (IZR (up r)) (- r) (-1)) in H1;
-      rewrite (Rplus_comm (- r) (-1)) in H1;
-        rewrite <- (Rplus_assoc (IZR (up r)) (-1) (- r)) in H1;
-          fold (IZR (up r) - 1) in H1; fold (IZR (up r) - 1 - r) in H1;
-            apply Rminus_le; auto with zarith real.
-  generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro;
-    rewrite (Rplus_comm (-1) (IZR (up r))) in H1;
-      generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1);
-        intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2;
-          fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2;
-            rewrite (Rplus_comm (- r) (-1 + r)) in H2;
-              rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2;
-                elim (Rplus_ne (-1)); intros a b; rewrite a in H2;
-                  clear a b; auto with zarith real.
+  apply Rminus_le.
+  replace (IZR (up r) - 1 - r) with (IZR (up r) - r - 1) by ring.
+  now apply Rle_minus.
+  apply Rminus_gt.
+  replace (IZR (up r) - 1 - r - -1) with (IZR (up r) - r) by ring.
+  now apply Rgt_minus.
 Qed.
 
 (**********)
@@ -240,7 +231,6 @@ Proof.
                                                                                                                   clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
                                                                                                                     rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H;
                                                                                                                       cut (1 = IZR 1); auto with zarith real.
-  intro; rewrite H1 in H; clear H1;
     rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H;
       generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H);
         intros; clear H H0; unfold Int_part at 1;
@@ -324,12 +314,12 @@ Proof.
                                                                                                       rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0;
                                                                                                         elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0;
                                                                                                           clear a b; rewrite <- (Rplus_opp_l 1) in H0;
-                                                                                                            rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1)
+                                                                                                            rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-(1)) 1)
                                                                                                               in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0;
                                                                                                                 rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
                                                                                                                   rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H;
-                                                                                                                    cut (1 = IZR 1); auto with zarith real.
-  intro; rewrite H1 in H; rewrite H1 in H0; clear H1;
+                                                                                                                    auto with zarith real.
+  change (_ + -1) with (IZR (Int_part r1 - Int_part r2) - 1) in H;
     rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H;
       rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0;
         rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0;
@@ -442,9 +432,9 @@ Proof.
                                                                 in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
                                                                   elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0;
                                                                     clear a b;
+                                                                      change 2 with (1 + 1) in H0;
                                                                       rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0;
-                                                                        cut (1 = IZR 1); auto with zarith real.
-  intro; rewrite H1 in H0; rewrite H1 in H; clear H1;
+                                                                        auto with zarith real.
     rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H;
       rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
         rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H;
@@ -509,7 +499,6 @@ Proof.
                                                                     intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2));
                                                                       intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1);
                                                                         auto with zarith real.
-  intro; rewrite H in H1; clear H;
     rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
       rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1;
         rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1;
@@ -536,7 +525,7 @@ Proof.
                     rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
                       unfold Rminus;
                         rewrite
-                          (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-1))
+                          (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-(1)))
                           ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1);
                             trivial with zarith real.
 Qed.
diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v
index 445ffcb21..a8937e36f 100644
--- a/theories/Reals/R_sqr.v
+++ b/theories/Reals/R_sqr.v
@@ -296,56 +296,9 @@ Lemma canonical_Rsqr :
     a * Rsqr (x + b / (2 * a)) + (4 * a * c - Rsqr b) / (4 * a).
 Proof.
   intros.
-  rewrite Rsqr_plus.
-  repeat rewrite Rmult_plus_distr_l.
-  repeat rewrite Rplus_assoc.
-  apply Rplus_eq_compat_l.
-  unfold Rdiv, Rminus.
-  replace (2 * 1 + 2 * 1) with 4; [ idtac | ring ].
-  rewrite (Rmult_plus_distr_r (4 * a * c) (- Rsqr b) (/ (4 * a))).
-  rewrite Rsqr_mult.
-  repeat rewrite Rinv_mult_distr.
-  repeat rewrite (Rmult_comm a).
-  repeat rewrite Rmult_assoc.
-  rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r.
-  rewrite (Rmult_comm 2).
-  repeat rewrite Rmult_assoc.
-  rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r.
-  rewrite (Rmult_comm (/ 2)).
-  rewrite (Rmult_comm 2).
-  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r.
-  rewrite (Rmult_comm a).
-  repeat rewrite Rmult_assoc.
-  rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r.
-  rewrite (Rmult_comm 2).
-  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r.
-  repeat rewrite Rplus_assoc.
-  rewrite (Rplus_comm (Rsqr b * (Rsqr (/ a * / 2) * a))).
-  repeat rewrite Rplus_assoc.
-  rewrite (Rmult_comm x).
-  apply Rplus_eq_compat_l.
-  rewrite (Rmult_comm (/ a)).
-  unfold Rsqr; repeat rewrite Rmult_assoc.
-  rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r.
-  ring.
-  apply (cond_nonzero a).
-  discrR.
-  apply (cond_nonzero a).
-  discrR.
-  discrR.
-  apply (cond_nonzero a).
-  discrR.
-  discrR.
-  discrR.
-  apply (cond_nonzero a).
-  discrR.
-  apply (cond_nonzero a).
+  unfold Rsqr.
+  field.
+  apply a.
 Qed.
 
 Lemma Rsqr_eq : forall x y:R, Rsqr x = Rsqr y -> x = y \/ x = - y.
diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v
index a6b1a26e0..0c1e0b7e8 100644
--- a/theories/Reals/R_sqrt.v
+++ b/theories/Reals/R_sqrt.v
@@ -359,107 +359,22 @@ Lemma Rsqr_sol_eq_0_1 :
     x = sol_x1 a b c \/ x = sol_x2 a b c -> a * Rsqr x + b * x + c = 0.
 Proof.
   intros; elim H0; intro.
-  unfold sol_x1 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv;
-    repeat rewrite Rsqr_mult; rewrite Rsqr_plus; rewrite <- Rsqr_neg;
-      rewrite Rsqr_sqrt.
-  rewrite Rsqr_inv.
-  unfold Rsqr; repeat rewrite Rinv_mult_distr.
-  repeat rewrite Rmult_assoc; rewrite (Rmult_comm a).
-  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; rewrite Rmult_plus_distr_r.
-  repeat rewrite Rmult_assoc.
-  pattern 2 at 2; rewrite (Rmult_comm 2).
-  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r.
-  rewrite
-    (Rmult_plus_distr_r (- b) (sqrt (b * b - 2 * (2 * (a * c)))) (/ 2 * / a))
-    .
-  rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc.
-  replace
-  (- b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) +
-    (b * (- b * (/ 2 * / a)) +
-      (b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + c))) with
-  (b * (- b * (/ 2 * / a)) + c).
-  unfold Rminus; repeat rewrite <- Rplus_assoc.
-  replace (b * b + b * b) with (2 * (b * b)).
-  rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc.
-  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc.
-  rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r.
-  rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
-    rewrite (Rmult_comm 2).
-  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc;
-    rewrite (Rmult_comm 2).
-  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; repeat rewrite Rmult_assoc.
-  rewrite (Rmult_comm a); rewrite Rmult_assoc.
-  rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; rewrite <- Rmult_opp_opp.
-  ring.
-  apply (cond_nonzero a).
-  discrR.
-  discrR.
-  discrR.
-  ring.
-  ring.
-  discrR.
-  apply (cond_nonzero a).
-  discrR.
-  apply (cond_nonzero a).
-  apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
-  apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
-  apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
-  assumption.
-  unfold sol_x2 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv;
-    repeat rewrite Rsqr_mult; rewrite Rsqr_minus; rewrite <- Rsqr_neg;
-      rewrite Rsqr_sqrt.
-  rewrite Rsqr_inv.
-  unfold Rsqr; repeat rewrite Rinv_mult_distr;
-    repeat rewrite Rmult_assoc.
-  rewrite (Rmult_comm a); repeat rewrite Rmult_assoc.
-  rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; unfold Rminus; rewrite Rmult_plus_distr_r.
-  rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
-    pattern 2 at 2; rewrite (Rmult_comm 2).
-  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r;
-    rewrite
-      (Rmult_plus_distr_r (- b) (- sqrt (b * b + - (2 * (2 * (a * c)))))
-        (/ 2 * / a)).
-  rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc.
-  rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_involutive.
-  replace
-  (b * (sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) +
-    (b * (- b * (/ 2 * / a)) +
-      (b * (- sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) + c))) with
-  (b * (- b * (/ 2 * / a)) + c).
-  repeat rewrite <- Rplus_assoc; replace (b * b + b * b) with (2 * (b * b)).
-  rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc;
-    rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc;
-      rewrite <- Rinv_l_sym.
-  rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc.
-  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc.
-  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; repeat rewrite Rmult_assoc; rewrite (Rmult_comm a);
-    rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; rewrite <- Rmult_opp_opp; ring.
-  apply (cond_nonzero a).
-  discrR.
-  discrR.
-  discrR.
-  ring.
-  ring.
-  discrR.
-  apply (cond_nonzero a).
-  discrR.
-  discrR.
-  apply (cond_nonzero a).
-  apply prod_neq_R0; discrR || apply (cond_nonzero a).
-  apply prod_neq_R0; discrR || apply (cond_nonzero a).
-  apply prod_neq_R0; discrR || apply (cond_nonzero a).
-  assumption.
+  rewrite H1.
+  unfold sol_x1, Delta, Rsqr.
+  field_simplify.
+  rewrite <- (Rsqr_pow2 (sqrt _)), Rsqr_sqrt.
+  field.
+  apply a.
+  apply H.
+  apply a.
+  rewrite H1.
+  unfold sol_x2, Delta, Rsqr.
+  field_simplify.
+  rewrite <- (Rsqr_pow2 (sqrt _)), Rsqr_sqrt.
+  field.
+  apply a.
+  apply H.
+  apply a.
 Qed.
 
 Lemma Rsqr_sol_eq_0_0 :
@@ -505,10 +420,10 @@ Proof.
   rewrite (Rmult_comm (/ a)).
   rewrite Rmult_assoc.
   rewrite <- Rinv_mult_distr.
-  replace (2 * (2 * a) * a) with (Rsqr (2 * a)).
+  replace (4 * a * a) with (Rsqr (2 * a)).
   reflexivity.
   ring_Rsqr.
-  rewrite <- Rmult_assoc; apply prod_neq_R0;
+  apply prod_neq_R0;
     [ discrR | apply (cond_nonzero a) ].
   apply (cond_nonzero a).
   assumption.
diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v
index 0254218c4..27cb356a0 100644
--- a/theories/Reals/Ranalysis2.v
+++ b/theories/Reals/Ranalysis2.v
@@ -88,17 +88,11 @@ Proof.
   right; unfold Rdiv.
   repeat rewrite Rabs_mult.
   rewrite Rabs_Rinv; discrR.
-  replace (Rabs 8) with 8.
-  replace 8 with 8; [ idtac | ring ].
-  rewrite Rinv_mult_distr; [ idtac | discrR | discrR ].
-  replace (2 * / Rabs (f2 x) * (Rabs eps * Rabs (f2 x) * (/ 2 * / 4))) with
-  (Rabs eps * / 4 * (2 * / 2) * (Rabs (f2 x) * / Rabs (f2 x)));
-  [ idtac | ring ].
-  replace (Rabs eps) with eps.
-  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
-  ring.
-  symmetry ; apply Rabs_right; left; assumption.
-  symmetry ; apply Rabs_right; left; prove_sup.
+  rewrite (Rabs_pos_eq 8) by now apply IZR_le.
+  rewrite (Rabs_pos_eq eps).
+  field.
+  now apply Rabs_no_R0.
+  now apply Rlt_le.
 Qed.
 
 Lemma maj_term2 :
diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v
index 4e88714d6..d4597aeba 100644
--- a/theories/Reals/Ranalysis3.v
+++ b/theories/Reals/Ranalysis3.v
@@ -201,8 +201,8 @@ Proof.
   apply Rabs_pos_lt.
   unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc.
   repeat apply prod_neq_R0; try assumption.
-  red; intro; rewrite H15 in H6; elim (Rlt_irrefl _ H6).
-  apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption.
+  now apply Rgt_not_eq.
+  apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption].
   apply H13.
   split.
   apply D_x_no_cond; assumption.
@@ -213,8 +213,7 @@ Proof.
   red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
   assumption.
   assumption.
-  apply Rinv_neq_0_compat; repeat apply prod_neq_R0;
-    [ discrR | discrR | discrR | assumption ].
+  apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption].
 (***********************************)
 (*        Third case               *)
 (*     (f1 x)<>0  l1=0  l2=0       *)
@@ -224,11 +223,11 @@ Proof.
   elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
     [ idtac
       | apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc;
-        repeat apply prod_neq_R0;
+        repeat apply prod_neq_R0 ;
           [ assumption
             | assumption
-            | red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6)
-            | apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption ] ].
+            | now apply Rgt_not_eq
+            | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ].
   intros alp_f2d H12.
   cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)).
   intro.
@@ -295,8 +294,10 @@ Proof.
   elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
     [ idtac
       | apply Rabs_pos_lt; unfold Rsqr, Rdiv;
-        repeat rewrite Rinv_mult_distr; repeat apply prod_neq_R0;
-          try assumption || discrR ].
+        repeat apply prod_neq_R0 ;
+          [ assumption..
+            | now apply Rgt_not_eq
+            | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ].
   intros alp_f2d H11.
   assert (H12 := derivable_continuous_pt _ _ X).
   unfold continuity_pt in H12.
@@ -380,15 +381,9 @@ Proof.
   repeat apply prod_neq_R0; try assumption.
   red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6).
   apply Rinv_neq_0_compat; discrR.
-  apply Rinv_neq_0_compat; discrR.
-  apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; assumption.
   apply Rinv_neq_0_compat; assumption.
   discrR.
-  discrR.
-  discrR.
-  discrR.
-  discrR.
   apply prod_neq_R0; [ discrR | assumption ].
   elim H13; intros.
   apply H19.
@@ -408,16 +403,9 @@ Proof.
   repeat apply prod_neq_R0; try assumption.
   red; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6).
   apply Rinv_neq_0_compat; discrR.
-  apply Rinv_neq_0_compat; discrR.
-  apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; assumption.
   apply Rinv_neq_0_compat; assumption.
   apply prod_neq_R0; [ discrR | assumption ].
-  red; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
-  apply Rinv_neq_0_compat; discrR.
-  apply Rinv_neq_0_compat; discrR.
-  apply Rinv_neq_0_compat; discrR.
-  apply Rinv_neq_0_compat; assumption.
 (***********************************)
 (*         Fifth case              *)
 (*    (f1 x)<>0  l1<>0  l2=0       *)
diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v
index 661bc8c76..23daedb8b 100644
--- a/theories/Reals/Ranalysis4.v
+++ b/theories/Reals/Ranalysis4.v
@@ -130,15 +130,8 @@ Proof.
   intro; exists (mkposreal (- x) H1); intros.
   rewrite (Rabs_left x).
   rewrite (Rabs_left (x + h)).
-  rewrite Rplus_comm.
-  rewrite Ropp_plus_distr.
-  unfold Rminus; rewrite Ropp_involutive; rewrite Rplus_assoc;
-    rewrite Rplus_opp_l.
-  rewrite Rplus_0_r; unfold Rdiv.
-  rewrite Ropp_mult_distr_l_reverse.
-  rewrite <- Rinv_r_sym.
-  rewrite Ropp_involutive; rewrite Rplus_opp_l; rewrite Rabs_R0; apply H0.
-  apply H2.
+  replace ((-(x + h) - - x) / h - -1) with 0 by now field.
+  rewrite Rabs_R0; apply H0.
   destruct (Rcase_abs h) as [Hlt|Hgt].
   apply Ropp_lt_cancel.
   rewrite Ropp_0; rewrite Ropp_plus_distr; apply Rplus_lt_0_compat.
diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v
index d172139f5..f9da88aad 100644
--- a/theories/Reals/Ranalysis5.v
+++ b/theories/Reals/Ranalysis5.v
@@ -249,8 +249,10 @@ assert (Sublemma : forall x y lb ub, lb <= x <= ub /\ lb <= y <= ub -> lb <= (x+
   split.
   replace lb with ((lb + lb) * /2) by field.
   unfold Rdiv ; apply Rmult_le_compat_r ; intuition.
+  now apply Rlt_le, Rinv_0_lt_compat, IZR_lt.
   replace ub with ((ub + ub) * /2) by field.
   unfold Rdiv ; apply Rmult_le_compat_r ; intuition.
+  now apply Rlt_le, Rinv_0_lt_compat, IZR_lt.
 intros x y P N x_lt_y.
 induction N.
  simpl ; intuition.
@@ -1030,6 +1032,7 @@ intros x ub lb lb_lt_x x_lt_ub.
  assert (T : 0 < ub - lb).
   fourier.
  unfold Rdiv ; apply Rlt_mult_inv_pos ; intuition.
+now apply IZR_lt.
 Qed.
 
 Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb<x) (x_lt_ub:x<ub) : posreal.
@@ -1102,7 +1105,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn
     rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg.
     replace (- (fn N (x + h) - fn N x)) with (fn N x - fn N (x + h)) by field.
     assumption.
-   solve[apply Rlt_not_eq ; intuition].
+  now apply Rlt_not_eq, IZR_lt.
   rewrite <- Hc'; clear Hc Hc'.
   replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c).
   replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field.
diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v
index e13ef1f2c..e438750df 100644
--- a/theories/Reals/Ratan.v
+++ b/theories/Reals/Ratan.v
@@ -132,7 +132,7 @@ intros [ | N] Npos n decr to0 cv nN.
     unfold Rminus; apply Rplus_le_compat_l, Ropp_le_contravar.
     solve[apply Rge_le, (growing_prop _ _ _ (CV_ALT_step0 f decr) dist)].
    unfold Rminus; rewrite tech5, Ropp_plus_distr, <- Rplus_assoc.
-   unfold tg_alt at 2; rewrite pow_1_odd, Ropp_mult_distr_l_reverse; fourier.
+   unfold tg_alt at 2; rewrite pow_1_odd; fourier.
  rewrite Nodd; destruct (alternated_series_ineq _ _ p decr to0 cv) as [B _].
  destruct (alternated_series_ineq _ _ (S p) decr to0 cv) as [_ C].
  assert (keep : (2 * S p = S (S ( 2 * p)))%nat) by ring.
@@ -161,7 +161,6 @@ clear WLOG; intros Hyp [ | n] decr to0 cv _.
  generalize (alternated_series_ineq f l 0 decr to0 cv).
  unfold R_dist, tg_alt; simpl; rewrite !Rmult_1_l, !Rmult_1_r.
  assert (f 1%nat <= f 0%nat) by apply decr.
- rewrite Ropp_mult_distr_l_reverse.
  intros [A B]; rewrite Rabs_pos_eq; fourier.
 apply Rle_trans with (f 1%nat).
  apply (Hyp 1%nat (le_n 1) (S n) decr to0 cv).
@@ -320,31 +319,12 @@ apply PI2_lower_bound;[split; fourier | ].
 destruct (pre_cos_bound (3/2) 1) as [t _]; [fourier | fourier | ].
 apply Rlt_le_trans with (2 := t); clear t.
 unfold cos_approx; simpl; unfold cos_term.
-simpl mult; replace ((-1)^ 0) with 1 by ring; replace ((-1)^2) with 1 by ring;
- replace ((-1)^4) with 1 by ring; replace ((-1)^1) with (-1) by ring;
- replace ((-1)^3) with (-1) by ring; replace 3 with (IZR 3) by (simpl; ring);
- replace 2 with (IZR 2) by (simpl; ring); simpl Z.of_nat;
- rewrite !INR_IZR_INZ, Ropp_mult_distr_l_reverse, Rmult_1_l.
-match goal with |- _ < ?a =>
-replace a with ((- IZR 3 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) *
-    IZR (Z.of_nat (fact 4)) +
-    IZR 3 ^ 4 * IZR 2 ^ 2 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) *
-    IZR (Z.of_nat (fact 6)) -
-    IZR 3 ^ 2 * IZR 2 ^ 4 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 4)) *
-    IZR (Z.of_nat (fact 6)) +
-    IZR 2 ^ 6 * IZR (Z.of_nat (fact 2)) * IZR (Z.of_nat (fact 4)) *
-    IZR (Z.of_nat (fact 6))) /
-   (IZR 2 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) *
-    IZR (Z.of_nat (fact 4)) * IZR (Z.of_nat (fact 6))));[ | field;
-    repeat apply conj;((rewrite <- INR_IZR_INZ; apply INR_fact_neq_0) ||
-         (apply Rgt_not_eq; apply (IZR_lt 0); reflexivity)) ]
-end.
-rewrite !fact_simpl, !Nat2Z.inj_mul; simpl Z.of_nat.
-unfold Rdiv; apply Rmult_lt_0_compat.
-unfold Rminus; rewrite !pow_IZR, <- !opp_IZR, <- !mult_IZR, <- !opp_IZR, 
-  <- !plus_IZR; apply (IZR_lt 0); reflexivity.
-apply Rinv_0_lt_compat; rewrite !pow_IZR, <- !mult_IZR; apply (IZR_lt 0).
-reflexivity.
+rewrite !INR_IZR_INZ.
+simpl.
+field_simplify.
+unfold Rdiv.
+rewrite Rmult_0_l.
+apply Rdiv_lt_0_compat ; now apply IZR_lt.
 Qed.
 
 Lemma PI2_1 : 1 < PI/2.
@@ -502,11 +482,11 @@ split.
   rewrite (Rmult_comm (-1)); simpl ((/(Rabs y + 1)) ^ 0).
   unfold Rdiv; rewrite Rinv_1, !Rmult_assoc, <- !Rmult_plus_distr_l.
   apply tmp;[assumption | ].
-  rewrite Rplus_assoc, Rmult_1_l; pattern 1 at 3; rewrite <- Rplus_0_r.
+  rewrite Rplus_assoc, Rmult_1_l; pattern 1 at 2; rewrite <- Rplus_0_r.
   apply Rplus_lt_compat_l.
   rewrite <- Rmult_assoc.
   match goal with |- (?a * (-1)) + _ < 0 =>
-   rewrite <- (Rplus_opp_l a), Ropp_mult_distr_r_reverse, Rmult_1_r
+   rewrite <- (Rplus_opp_l a); change (-1) with (-(1)); rewrite Ropp_mult_distr_r_reverse, Rmult_1_r
   end.
   apply Rplus_lt_compat_l.
   assert (0 < u ^ 2) by (apply pow_lt; assumption).
@@ -853,6 +833,8 @@ intros x Hx eps Heps.
    apply Rlt_trans with (2 := H).
    apply Rinv_0_lt_compat.
    exact Heps.
+   unfold N.
+   rewrite INR_IZR_INZ, positive_nat_Z.
    exact HN.
    apply lt_INR.
    omega.
@@ -1076,8 +1058,9 @@ apply Rlt_not_eq; apply Rle_lt_trans with 0;[ | apply Rlt_0_1].
 assert (t := pow2_ge_0 x); fourier.
 replace (1 + x ^ 2) with (1 - - (x ^ 2)) by ring; rewrite <- (tech3 _ n dif).
 apply sum_eq; unfold tg_alt, Datan_seq; intros i _.
-rewrite pow_mult, <- Rpow_mult_distr, Ropp_mult_distr_l_reverse, Rmult_1_l.
-reflexivity.
+rewrite pow_mult, <- Rpow_mult_distr.
+f_equal.
+ring.
 Qed.
 
 Lemma Datan_seq_increasing : forall x y n, (n > 0)%nat -> 0 <= x < y -> Datan_seq x n < Datan_seq y n.
@@ -1165,6 +1148,7 @@ assert (tool : forall a b, a / b - /b = (-1 + a) /b).
  reflexivity.
 set (u := 1 + x ^ 2); rewrite tool; unfold Rminus; rewrite <- Rplus_assoc.
 unfold Rdiv, u.
+change (-1) with (-(1)).
 rewrite Rplus_opp_l, Rplus_0_l, Ropp_mult_distr_l_reverse, Rabs_Ropp.
 rewrite Rabs_mult; clear tool u.
 assert (tool : forall k, Rabs ((-x ^ 2) ^ k) = Rabs ((x ^ 2) ^ k)).
diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v
index 9fbda92a2..7f9db3b18 100644
--- a/theories/Reals/Raxioms.v
+++ b/theories/Reals/Raxioms.v
@@ -115,19 +115,6 @@ Arguments INR n%nat.
 
 
 (**********************************************************)
-(** *    Injection from [Z] to [R]                        *)
-(**********************************************************)
-
-(**********)
-Definition IZR (z:Z) : R :=
-  match z with
-  | Z0 => 0
-  | Zpos n => INR (Pos.to_nat n)
-  | Zneg n => - INR (Pos.to_nat n)
-  end.
-Arguments IZR z%Z.
-
-(**********************************************************)
 (** *    [R] Archimedean                                  *)
 (**********************************************************)
 
diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v
index c889d7347..df1662497 100644
--- a/theories/Reals/Rbasic_fun.v
+++ b/theories/Reals/Rbasic_fun.v
@@ -451,20 +451,16 @@ Qed.
 
 Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x.
 Proof.
-  intro; cut (- x = -1 * x).
-  intros; rewrite H.
+  intro; replace (-x) with (-1 * x) by ring.
   rewrite Rabs_mult.
-  cut (Rabs (-1) = 1).
-  intros; rewrite H0.
-  ring.
+  replace (Rabs (-1)) with 1.
+  apply Rmult_1_l.
   unfold Rabs; case (Rcase_abs (-1)).
   intro; ring.
-  intro H0; generalize (Rge_le (-1) 0 H0); intros.
-  generalize (Ropp_le_ge_contravar 0 (-1) H1).
-  rewrite Ropp_involutive; rewrite Ropp_0.
-  intro; generalize (Rgt_not_le 1 0 Rlt_0_1); intro; generalize (Rge_le 0 1 H2);
-    intro; exfalso; auto.
-  ring.
+  rewrite <- Ropp_0.
+  intro H0; apply Ropp_ge_cancel in H0.
+  elim (Rge_not_lt _ _ H0).
+  apply Rlt_0_1.
 Qed.
 
 (*********)
@@ -613,11 +609,12 @@ Qed.
 
 Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Z.abs z).
 Proof.
-  intros z; case z; simpl; auto with real.
-  apply Rabs_right; auto with real.
-  intros p0; apply Rabs_right; auto with real zarith.
+  intros z; case z; unfold Zabs.
+  apply Rabs_R0.
+  now intros p0; apply Rabs_pos_eq, (IZR_le 0).
+  unfold IZR at 1.
   intros p0; rewrite Rabs_Ropp.
-  apply Rabs_right; auto with real zarith.
+  now apply Rabs_pos_eq, (IZR_le 0).
 Qed.
 
 Lemma abs_IZR : forall z, IZR (Z.abs z) = Rabs (IZR z).
diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v
index f3f8f7409..cb5dea93a 100644
--- a/theories/Reals/Rdefinitions.v
+++ b/theories/Reals/Rdefinitions.v
@@ -69,3 +69,32 @@ Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope.
 Notation "x <= y < z"  := (x <= y /\ y <  z) : R_scope.
 Notation "x < y < z"   := (x <  y /\ y <  z) : R_scope.
 Notation "x < y <= z"  := (x <  y /\ y <= z) : R_scope.
+
+(**********************************************************)
+(** *    Injection from [Z] to [R]                        *)
+(**********************************************************)
+
+(* compact representation for 2*p *)
+Fixpoint IPR_2 (p:positive) : R :=
+  match p with
+  | xH => R1 + R1
+  | xO p => (R1 + R1) * IPR_2 p
+  | xI p => (R1 + R1) * (R1 + IPR_2 p)
+  end.
+
+Definition IPR (p:positive) : R :=
+  match p with
+  | xH => R1
+  | xO p => IPR_2 p
+  | xI p => R1 + IPR_2 p
+  end.
+Arguments IPR p%positive : simpl never.
+
+(**********)
+Definition IZR (z:Z) : R :=
+  match z with
+  | Z0 => R0
+  | Zpos n => IPR n
+  | Zneg n => - IPR n
+  end.
+Arguments IZR z%Z : simpl never.
diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v
index bd330ac9b..5fb6bd2b7 100644
--- a/theories/Reals/Rderiv.v
+++ b/theories/Reals/Rderiv.v
@@ -296,14 +296,10 @@ Proof.
       intros; generalize (H0 eps H1); clear H0; intro; elim H0;
         clear H0; intros; elim H0; clear H0; simpl;
           intros; split with x; split; auto.
-  intros; generalize (H2 x1 H3); clear H2; intro;
-    rewrite Ropp_mult_distr_l_reverse in H2;
-      rewrite Ropp_mult_distr_l_reverse in H2;
-        rewrite Ropp_mult_distr_l_reverse in H2;
-          rewrite (let (H1, H2) := Rmult_ne (f x1) in H2) in H2;
-            rewrite (let (H1, H2) := Rmult_ne (f x0) in H2) in H2;
-              rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2;
-                assumption.
+  intros; generalize (H2 x1 H3); clear H2; intro.
+  replace (- f x1 - - f x0) with (-1 * f x1 - -1 * f x0) by ring.
+  replace (- df x0) with (-1 * df x0) by ring.
+  exact H2.
 Qed.
 
 (*********)
diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v
index 0a49d4983..99acdd0a1 100644
--- a/theories/Reals/Rfunctions.v
+++ b/theories/Reals/Rfunctions.v
@@ -416,8 +416,9 @@ Proof.
   simpl; apply Rabs_R1.
   replace (S n) with (n + 1)%nat; [ rewrite pow_add | ring ].
   rewrite Rabs_mult.
-  rewrite Hrecn; rewrite Rmult_1_l; simpl; rewrite Rmult_1_r;
-    rewrite Rabs_Ropp; apply Rabs_R1.
+  rewrite Hrecn; rewrite Rmult_1_l; simpl; rewrite Rmult_1_r.
+  change (-1) with (-(1)).
+  rewrite Rabs_Ropp; apply Rabs_R1.
 Qed.
 
 Lemma pow_mult : forall (x:R) (n1 n2:nat), x ^ (n1 * n2) = (x ^ n1) ^ n2.
diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v
index e424a732a..f07140752 100644
--- a/theories/Reals/Rlimit.v
+++ b/theories/Reals/Rlimit.v
@@ -407,8 +407,7 @@ Proof.
                       generalize
                         (Rplus_lt_compat (R_dist (f x2) l) eps (R_dist (f x2) l') eps H H0);
                         unfold R_dist; intros; rewrite (Rabs_minus_sym (f x2) l) in H1;
-                          rewrite (Rmult_comm 2 eps); rewrite (Rmult_plus_distr_l eps 1 1);
-                            elim (Rmult_ne eps); intros a b; rewrite a; clear a b;
+                          rewrite (Rmult_comm 2 eps); replace (eps *2) with (eps + eps) by ring;
                               generalize (R_dist_tri l l' (f x2)); unfold R_dist;
                                 intros;
                                   apply
diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v
index 791718a45..f331bb203 100644
--- a/theories/Reals/Rpow_def.v
+++ b/theories/Reals/Rpow_def.v
@@ -10,6 +10,6 @@ Require Import Rdefinitions.
 
 Fixpoint pow (r:R) (n:nat) : R :=
   match n with
-    | O => R1
+    | O => 1
     | S n => Rmult r (pow r n)
   end.
diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v
index b3ce6fa33..f62ed2a6c 100644
--- a/theories/Reals/Rpower.v
+++ b/theories/Reals/Rpower.v
@@ -55,25 +55,8 @@ Proof.
     simpl in H0.
   replace (/ 3) with
   (1 * / 1 + -1 * 1 * / 1 + -1 * (-1 * 1) * / 2 +
-    -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)).
+    -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)) by field.
   apply H0.
-  repeat rewrite Rinv_1; repeat rewrite Rmult_1_r;
-    rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l;
-      rewrite Ropp_involutive; rewrite Rplus_opp_r; rewrite Rmult_1_r;
-        rewrite Rplus_0_l; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 6.
-  rewrite Rmult_plus_distr_l; replace (2 + 1 + 1 + 1 + 1) with 6.
-  rewrite <- (Rmult_comm (/ 6)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_l; replace 6 with 6.
-  do 2 rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_r; rewrite (Rmult_comm 3); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym.
-  ring.
-  discrR.
-  discrR.
-  ring.
-  discrR.
-  ring.
-  discrR.
   apply H.
   unfold Un_decreasing; intros;
     apply Rmult_le_reg_l with (INR (fact n)).
@@ -505,12 +488,9 @@ Proof.
   rewrite Rinv_r.
   apply exp_lt_inv.
   apply Rle_lt_trans with (1 := exp_le_3).
-  change (3 < 2 ^R 2).
+  change (3 < 2 ^R (1 + 1)).
   repeat rewrite Rpower_plus; repeat rewrite Rpower_1.
-  repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
-    repeat rewrite Rmult_1_l.
-  pattern 3 at 1; rewrite <- Rplus_0_r; replace (2 + 2) with (3 + 1);
-    [ apply Rplus_lt_compat_l; apply Rlt_0_1 | ring ].
+  now apply (IZR_lt 3 4).
   prove_sup0.
   discrR.
 Qed.
@@ -732,7 +712,7 @@ Definition arcsinh x := ln (x + sqrt (x ^ 2 + 1)).
 Lemma arcsinh_sinh : forall x, arcsinh (sinh x) = x.
 intros x; unfold sinh, arcsinh.
 assert (Rminus_eq_0 : forall r, r - r = 0) by (intros; ring).
-pattern 1 at 5; rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus.
+rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus.
 rewrite exp_plus.
 match goal with |- context[sqrt ?a] => 
   replace a with (((exp x + exp(-x))/2)^2) by field
diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v
index 744fd6641..c6b0c3f37 100644
--- a/theories/Reals/Rseries.v
+++ b/theories/Reals/Rseries.v
@@ -207,7 +207,7 @@ Section sequence.
 
     assert (Rabs (/2) < 1).
     rewrite Rabs_pos_eq.
-    rewrite <- Rinv_1 at 3.
+    rewrite <- Rinv_1.
     apply Rinv_lt_contravar.
     rewrite Rmult_1_l.
     now apply (IZR_lt 0 2).
diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v
index 4d2418639..17b9677ef 100644
--- a/theories/Reals/Rtrigo1.v
+++ b/theories/Reals/Rtrigo1.v
@@ -182,13 +182,10 @@ destruct (pre_cos_bound _ 0 lo up) as [_ upper].
 apply Rle_lt_trans with (1 := upper).
 apply Rlt_le_trans with (2 := lower).
 unfold cos_approx, sin_approx.
-simpl sum_f_R0; replace 7 with (IZR 7) by (simpl; field).
-replace 8 with (IZR 8) by (simpl; field).
+simpl sum_f_R0.
 unfold cos_term, sin_term; simpl fact; rewrite !INR_IZR_INZ.
-simpl plus; simpl mult.
-field_simplify;
-  try (repeat apply conj; apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity).
-unfold Rminus; rewrite !pow_IZR, <- !mult_IZR, <- !opp_IZR, <- ?plus_IZR.
+simpl plus; simpl mult; simpl Z_of_nat.
+field_simplify.
 match goal with 
   |- IZR ?a / ?b < ?c / ?d =>
   apply Rmult_lt_reg_r with d;[apply (IZR_lt 0); reflexivity |
@@ -198,7 +195,7 @@ match goal with
 end.
 unfold Rdiv; rewrite !Rmult_assoc, Rinv_l, Rmult_1_r;
  [ | apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity].
-repeat (rewrite <- !plus_IZR || rewrite <- !mult_IZR).
+rewrite <- !mult_IZR.
 apply IZR_lt; reflexivity.
 Qed.
 
@@ -323,6 +320,7 @@ Lemma sin_PI : sin PI = 0.
 Proof.
   assert (H := sin2_cos2 PI).
   rewrite cos_PI in H.
+  change (-1) with (-(1)) in H.
   rewrite <- Rsqr_neg in H.
   rewrite Rsqr_1 in H.
   cut (Rsqr (sin PI) = 0).
@@ -533,9 +531,8 @@ Qed.
 
 Lemma sin_PI_x : forall x:R, sin (PI - x) = sin x.
 Proof.
-  intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI; rewrite Rmult_0_l;
-    unfold Rminus in |- *; rewrite Rplus_0_l; rewrite Ropp_mult_distr_l_reverse;
-      rewrite Ropp_involutive; apply Rmult_1_l.
+  intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI.
+  ring.
 Qed.
 
 Lemma sin_period : forall (x:R) (k:nat), sin (x + 2 * INR k * PI) = sin x.
@@ -593,9 +590,9 @@ Proof.
     generalize
       (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1)
         (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H)));
-      rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0;
+      rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0.
         generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
-          repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l;
+          repeat rewrite <- Rplus_assoc; change (-1) with (-(1)); rewrite Rplus_opp_l;
             rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
               generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
                 repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x));
@@ -603,6 +600,7 @@ Proof.
   auto with real.
   cut (sin x < -1).
   intro; generalize (Ropp_lt_gt_contravar (sin x) (-1) H);
+    change (-1) with (-(1));
     rewrite Ropp_involutive; clear H; intro;
       generalize
         (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1)
@@ -610,7 +608,7 @@ Proof.
         rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0;
           rewrite sin2 in H0; unfold Rminus in H0;
             generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
-              repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l;
+              rewrite <- Rplus_assoc; change (-1) with (-(1)); rewrite Rplus_opp_l;
                 rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
                   generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
                     repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x));
@@ -712,17 +710,16 @@ Proof.
   do 2 rewrite fact_simpl; do 2 rewrite mult_INR.
   repeat rewrite <- Rmult_assoc.
   rewrite <- (Rmult_comm (INR (fact (2 * n + 1)))).
-  rewrite Rmult_assoc.
   apply Rmult_lt_compat_l.
   apply lt_INR_0; apply neq_O_lt.
   assert (H2 := fact_neq_0 (2 * n + 1)).
   red in |- *; intro; elim H2; symmetry  in |- *; assumption.
   do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; set (x := INR n);
     unfold INR in |- *.
-  replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6);
+  replace (((1 + 1) * x + 1 + 1 + 1) * ((1 + 1) * x + 1 + 1)) with (4 * x * x + 10 * x + 6);
   [ idtac | ring ].
-  apply Rplus_lt_reg_l with (-4); rewrite Rplus_opp_l;
-    replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2);
+  apply Rplus_lt_reg_l with (-(4)); rewrite Rplus_opp_l;
+    replace (-(4) + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2);
     [ idtac | ring ].
   apply Rplus_le_lt_0_compat.
   cut (0 <= x).
@@ -767,7 +764,7 @@ Proof.
   unfold Rdiv in |- *; pattern PI at 2 in |- *; rewrite <- Rmult_1_r.
   apply Rmult_lt_compat_l.
   apply PI_RGT_0.
-  pattern 1 at 3 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar.
+  rewrite <- Rinv_1; apply Rinv_lt_contravar.
   rewrite Rmult_1_l; prove_sup0.
   pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     apply Rlt_0_1.
@@ -1260,44 +1257,22 @@ Proof.
   intros x y H1 H2 H3 H4; rewrite <- (cos_neg x); rewrite <- (cos_neg y);
     rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1);
       unfold INR in |- *;
-        replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))).
-  replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))).
+        replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))) by field.
+  replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))) by field.
   repeat rewrite cos_shift; intro H5;
     generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1);
       generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2);
         generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3);
           generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4).
-  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
-  replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
-  replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
-  replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
+  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring.
+  replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring.
+  replace (-3 * (PI / 2) + 2 * PI) with (PI / 2) by field.
+  replace (-3 * (PI / 2) + PI) with (- (PI / 2)) by field.
   clear H1 H2 H3 H4; intros H1 H2 H3 H4;
     apply Rplus_lt_reg_l with (-3 * (PI / 2));
-      replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
-  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
+      replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring.
+  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring.
   apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5).
-  unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse.
-  apply Rplus_comm.
-  unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse.
-  apply Rplus_comm.
-  pattern PI at 3 in |- *; rewrite double_var.
-  ring.
-  rewrite double; pattern PI at 3 4 in |- *; rewrite double_var.
-  ring.
-  unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse.
-  apply Rplus_comm.
-  unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse.
-  apply Rplus_comm.
-  rewrite Rmult_1_r.
-  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-  ring.
-  rewrite Rmult_1_r.
-  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-  ring.
 Qed.
 
 Lemma cos_increasing_1 :
@@ -1737,7 +1712,7 @@ Proof.
   rewrite H5.
   rewrite mult_INR.
   simpl in |- *.
-  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)).
   rewrite sin_period.
   apply sin_0.
   rewrite H5.
@@ -1747,7 +1722,7 @@ Proof.
   rewrite Rmult_1_l; rewrite sin_plus.
   rewrite sin_PI.
   rewrite Rmult_0_r.
-  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)).
   rewrite sin_period.
   rewrite sin_0; ring.
   apply le_IZR.
@@ -1769,7 +1744,7 @@ Proof.
   rewrite H5.
   rewrite mult_INR.
   simpl in |- *.
-  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)).
   rewrite sin_period.
   rewrite sin_0; ring.
   rewrite H5.
@@ -1779,7 +1754,7 @@ Proof.
   rewrite Rmult_1_l; rewrite sin_plus.
   rewrite sin_PI.
   rewrite Rmult_0_r.
-  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)).
   rewrite sin_period.
   rewrite sin_0; ring.
   apply le_IZR.
@@ -1858,7 +1833,7 @@ Proof.
   - right; left; auto.
   - left.
     clear Hi. subst.
-    replace 0 with (IZR 0 * PI) by (simpl; ring). f_equal. f_equal.
+    replace 0 with (IZR 0 * PI) by apply Rmult_0_l. f_equal. f_equal.
     apply one_IZR_lt1.
     split.
     + apply Rlt_le_trans with 0;
diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v
index a5092d22d..092bc30d0 100644
--- a/theories/Reals/Rtrigo_alt.v
+++ b/theories/Reals/Rtrigo_alt.v
@@ -320,7 +320,7 @@ Proof.
   (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
   unfold Rminus; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
     repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1);
-      rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc;
+      rewrite (Rplus_comm (-(1))); repeat rewrite Rplus_assoc;
         rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp;
           rewrite Ropp_plus_distr; rewrite Ropp_involutive;
             unfold Rminus in H6; apply H6.
@@ -367,10 +367,10 @@ Proof.
   reflexivity.
   ring.
   intro; elim H2; intros; split.
-  apply Rplus_le_reg_l with (-1).
+  apply Rplus_le_reg_l with (-(1)).
   rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
     rewrite (Rplus_comm (-1)); apply H3.
-  apply Rplus_le_reg_l with (-1).
+  apply Rplus_le_reg_l with (-(1)).
   rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
     rewrite (Rplus_comm (-1)); apply H4.
   unfold cos_term; simpl; unfold Rdiv; rewrite Rinv_1;
diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v
index 9ba14ee73..53056cabd 100644
--- a/theories/Reals/Rtrigo_calc.v
+++ b/theories/Reals/Rtrigo_calc.v
@@ -32,48 +32,22 @@ Proof.
 Qed.
 
 Lemma sin_cos_PI4 : sin (PI / 4) = cos (PI / 4).
-Proof with trivial.
-  rewrite cos_sin...
-  replace (PI / 2 + PI / 4) with (- (PI / 4) + PI)...
-  rewrite neg_sin; rewrite sin_neg; ring...
-  cut (PI = PI / 2 + PI / 2); [ intro | apply double_var ]...
-  pattern PI at 2 3; rewrite H; pattern PI at 2 3; rewrite H...
-  assert (H0 : 2 <> 0);
-    [ discrR | unfold Rdiv; rewrite Rinv_mult_distr; try ring ]...
+Proof.
+  rewrite cos_sin.
+  replace (PI / 2 + PI / 4) with (- (PI / 4) + PI) by field.
+  rewrite neg_sin, sin_neg; ring.
 Qed.
 
 Lemma sin_PI3_cos_PI6 : sin (PI / 3) = cos (PI / 6).
-Proof with trivial.
-  replace (PI / 6) with (PI / 2 - PI / 3)...
-  rewrite cos_shift...
-  assert (H0 : 6 <> 0); [ discrR | idtac ]...
-  assert (H1 : 3 <> 0); [ discrR | idtac ]...
-  assert (H2 : 2 <> 0); [ discrR | idtac ]...
-  apply Rmult_eq_reg_l with 6...
-  rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
-  unfold Rdiv; repeat rewrite Rmult_assoc...
-  rewrite <- Rinv_l_sym...
-  rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
-  rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
-    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
-  ring...
+Proof.
+  replace (PI / 6) with (PI / 2 - PI / 3) by field.
+  now rewrite cos_shift.
 Qed.
 
 Lemma sin_PI6_cos_PI3 : cos (PI / 3) = sin (PI / 6).
-Proof with trivial.
-  replace (PI / 6) with (PI / 2 - PI / 3)...
-  rewrite sin_shift...
-  assert (H0 : 6 <> 0); [ discrR | idtac ]...
-  assert (H1 : 3 <> 0); [ discrR | idtac ]...
-  assert (H2 : 2 <> 0); [ discrR | idtac ]...
-  apply Rmult_eq_reg_l with 6...
-  rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
-  unfold Rdiv; repeat rewrite Rmult_assoc...
-  rewrite <- Rinv_l_sym...
-  rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
-  rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
-    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
-  ring...
+Proof.
+  replace (PI / 6) with (PI / 2 - PI / 3) by field.
+  now rewrite sin_shift.
 Qed.
 
 Lemma PI6_RGT_0 : 0 < PI / 6.
@@ -90,29 +64,20 @@ Proof.
 Qed.
 
 Lemma sin_PI6 : sin (PI / 6) = 1 / 2.
-Proof with trivial.
-  assert (H : 2 <> 0); [ discrR | idtac ]...
-  apply Rmult_eq_reg_l with (2 * cos (PI / 6))...
+Proof.
+  apply Rmult_eq_reg_l with (2 * cos (PI / 6)).
   replace (2 * cos (PI / 6) * sin (PI / 6)) with
-  (2 * sin (PI / 6) * cos (PI / 6))...
-  rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3)...
-  rewrite sin_PI3_cos_PI6...
-  unfold Rdiv; rewrite Rmult_1_l; rewrite Rmult_assoc;
-    pattern 2 at 2; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
-      rewrite <- Rinv_l_sym...
-  rewrite Rmult_1_r...
-  unfold Rdiv; rewrite Rinv_mult_distr...
-  rewrite (Rmult_comm (/ 2)); rewrite (Rmult_comm 2);
-    repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
-  rewrite Rmult_1_r...
-  discrR...
-  ring...
-  apply prod_neq_R0...
+  (2 * sin (PI / 6) * cos (PI / 6)) by ring.
+  rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3) by field.
+  rewrite sin_PI3_cos_PI6.
+  field.
+  apply prod_neq_R0.
+  discrR.
   cut (0 < cos (PI / 6));
     [ intro H1; auto with real
       | apply cos_gt_0;
         [ apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)
-          | apply PI6_RLT_PI2 ] ]...
+          | apply PI6_RLT_PI2 ] ].
 Qed.
 
 Lemma sqrt2_neq_0 : sqrt 2 <> 0.
@@ -188,20 +153,13 @@ Proof with trivial.
   apply Rinv_0_lt_compat; apply Rlt_sqrt2_0...
   rewrite Rsqr_div...
   rewrite Rsqr_1; rewrite Rsqr_sqrt...
-  assert (H : 2 <> 0); [ discrR | idtac ]...
   unfold Rsqr; pattern (cos (PI / 4)) at 1;
     rewrite <- sin_cos_PI4;
       replace (sin (PI / 4) * cos (PI / 4)) with
-      (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4)))...
-  rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2)...
+      (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4))) by field.
+  rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2) by field.
   rewrite sin_PI2...
-  apply Rmult_1_r...
-  unfold Rdiv; rewrite (Rmult_comm 2); rewrite Rinv_mult_distr...
-  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
-  rewrite Rmult_1_r...
-  unfold Rdiv; rewrite Rmult_1_l; repeat rewrite <- Rmult_assoc...
-  rewrite <- Rinv_l_sym...
-  rewrite Rmult_1_l...
+  field.
   left; prove_sup...
   apply sqrt2_neq_0...
 Qed.
@@ -219,24 +177,17 @@ Proof.
 Qed.
 
 Lemma cos3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2.
-Proof with trivial.
-  replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
-  rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4...
-  unfold Rdiv; rewrite Ropp_mult_distr_l_reverse...
-  unfold Rminus; rewrite Ropp_involutive; pattern PI at 1;
-    rewrite double_var; unfold Rdiv; rewrite Rmult_plus_distr_r;
-      repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
-        [ ring | discrR | discrR ]...
+Proof.
+  replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field.
+  rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4.
+  unfold Rdiv.
+  ring.
 Qed.
 
 Lemma sin3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2.
-Proof with trivial.
-  replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
-  rewrite sin_shift; rewrite cos_neg; rewrite cos_PI4...
-  unfold Rminus; rewrite Ropp_involutive; pattern PI at 1;
-    rewrite double_var; unfold Rdiv; rewrite Rmult_plus_distr_r;
-      repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
-        [ ring | discrR | discrR ]...
+Proof.
+  replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field.
+  now rewrite sin_shift, cos_neg, cos_PI4.
 Qed.
 
 Lemma cos_PI6 : cos (PI / 6) = sqrt 3 / 2.
@@ -248,19 +199,11 @@ Proof with trivial.
   left; apply (Rmult_lt_0_compat (sqrt 3) (/ 2))...
   apply Rlt_sqrt3_0...
   apply Rinv_0_lt_compat; prove_sup0...
-  assert (H : 2 <> 0); [ discrR | idtac ]...
-  assert (H1 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
   rewrite Rsqr_div...
   rewrite cos2; unfold Rsqr; rewrite sin_PI6; rewrite sqrt_def...
-  unfold Rdiv; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
-  rewrite Rmult_minus_distr_l; rewrite (Rmult_comm 3);
-    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym...
-  rewrite Rmult_1_l; rewrite Rmult_1_r...
-  rewrite <- (Rmult_comm (/ 2)); repeat rewrite <- Rmult_assoc...
-  rewrite <- Rinv_l_sym...
-  rewrite Rmult_1_l; rewrite <- Rinv_r_sym...
-  ring...
-  left; prove_sup0...
+  field.
+  left ; prove_sup0.
+  discrR.
 Qed.
 
 Lemma tan_PI6 : tan (PI / 6) = 1 / sqrt 3.
@@ -306,56 +249,32 @@ Proof.
 Qed.
 
 Lemma cos_2PI3 : cos (2 * (PI / 3)) = -1 / 2.
-Proof with trivial.
-  assert (H : 2 <> 0); [ discrR | idtac ]...
-  assert (H0 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
-  rewrite double; rewrite cos_plus; rewrite sin_PI3; rewrite cos_PI3;
-    unfold Rdiv; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
-  rewrite Rmult_minus_distr_l; repeat rewrite Rmult_assoc;
-    rewrite (Rmult_comm 2)...
-  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
-  rewrite Rmult_1_r; rewrite <- Rinv_r_sym...
-  pattern 2 at 4; rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym...
-  rewrite Rmult_1_r; rewrite Ropp_mult_distr_r_reverse; rewrite Rmult_1_r...
-  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
-  rewrite Rmult_1_r; rewrite (Rmult_comm 2); rewrite (Rmult_comm (/ 2))...
-  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
-  rewrite Rmult_1_r; rewrite sqrt_def...
-  ring...
-  left; prove_sup...
+Proof.
+  rewrite cos_2a, sin_PI3, cos_PI3.
+  replace (sqrt 3 / 2 * (sqrt 3 / 2)) with ((sqrt 3 * sqrt 3) / 4) by field.
+  rewrite sqrt_sqrt.
+  field.
+  left ; prove_sup0.
 Qed.
 
 Lemma tan_2PI3 : tan (2 * (PI / 3)) = - sqrt 3.
-Proof with trivial.
-  assert (H : 2 <> 0); [ discrR | idtac ]...
-  unfold tan; rewrite sin_2PI3; rewrite cos_2PI3; unfold Rdiv;
-    rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l;
-      rewrite <- Ropp_inv_permute...
-  rewrite Rinv_involutive...
-  rewrite Rmult_assoc; rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_l_sym...
-  ring...
-  apply Rinv_neq_0_compat...
+Proof.
+  unfold tan; rewrite sin_2PI3, cos_2PI3.
+  field.
 Qed.
 
 Lemma cos_5PI4 : cos (5 * (PI / 4)) = -1 / sqrt 2.
-Proof with trivial.
-  replace (5 * (PI / 4)) with (PI / 4 + PI)...
-  rewrite neg_cos; rewrite cos_PI4; unfold Rdiv;
-    rewrite Ropp_mult_distr_l_reverse...
-  pattern PI at 2; rewrite double_var; pattern PI at 2 3;
-    rewrite double_var; assert (H : 2 <> 0);
-      [ discrR | unfold Rdiv; repeat rewrite Rinv_mult_distr; try ring ]...
+Proof.
+  replace (5 * (PI / 4)) with (PI / 4 + PI) by field.
+  rewrite neg_cos; rewrite cos_PI4; unfold Rdiv.
+  ring.
 Qed.
 
 Lemma sin_5PI4 : sin (5 * (PI / 4)) = -1 / sqrt 2.
-Proof with trivial.
-  replace (5 * (PI / 4)) with (PI / 4 + PI)...
-  rewrite neg_sin; rewrite sin_PI4; unfold Rdiv;
-    rewrite Ropp_mult_distr_l_reverse...
-  pattern PI at 2; rewrite double_var; pattern PI at 2 3;
-    rewrite double_var; assert (H : 2 <> 0);
-      [ discrR | unfold Rdiv; repeat rewrite Rinv_mult_distr; try ring ]...
+Proof.
+  replace (5 * (PI / 4)) with (PI / 4 + PI) by field.
+  rewrite neg_sin; rewrite sin_PI4; unfold Rdiv.
+  ring.
 Qed.
 
 Lemma sin_cos5PI4 : cos (5 * (PI / 4)) = sin (5 * (PI / 4)).
diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v
index eed612d94..d9c18d358 100644
--- a/theories/Reals/Rtrigo_reg.v
+++ b/theories/Reals/Rtrigo_reg.v
@@ -251,6 +251,7 @@ Proof.
   exists delta; intros.
   rewrite Rplus_0_l; replace (cos h - cos 0) with (-2 * Rsqr (sin (h / 2))).
   unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r.
+  change (-2) with (-(2)).
   unfold Rdiv; do 2 rewrite Ropp_mult_distr_l_reverse.
   rewrite Rabs_Ropp.
   replace (2 * Rsqr (sin (h * / 2)) * / h) with
@@ -266,7 +267,7 @@ Proof.
   apply Rabs_pos.
   assert (H9 := SIN_bound (h / 2)).
   unfold Rabs; case (Rcase_abs (sin (h / 2))); intro.
-  pattern 1 at 3; rewrite <- (Ropp_involutive 1).
+  rewrite <- (Ropp_involutive 1).
   apply Ropp_le_contravar.
   elim H9; intros; assumption.
   elim H9; intros; assumption.
@@ -395,15 +396,8 @@ Proof.
   apply Rlt_le_trans with alp.
   apply H7.
   unfold alp; apply Rmin_l.
-  rewrite sin_plus; unfold Rminus, Rdiv;
-    repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
-      repeat rewrite Rmult_assoc; repeat rewrite Rplus_assoc;
-        apply Rplus_eq_compat_l.
-  rewrite (Rplus_comm (sin x * (-1 * / h))); repeat rewrite Rplus_assoc;
-    apply Rplus_eq_compat_l.
-  rewrite Ropp_mult_distr_r_reverse; rewrite Ropp_mult_distr_l_reverse;
-    rewrite Rmult_1_r; rewrite Rmult_1_l; rewrite Ropp_mult_distr_r_reverse;
-      rewrite <- Ropp_mult_distr_l_reverse; apply Rplus_comm.
+  rewrite sin_plus.
+  now field.
   unfold alp; unfold Rmin; case (Rle_dec alp1 alp2); intro.
   apply (cond_pos alp1).
   apply (cond_pos alp2).
diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v
index d43baee8c..12d5cbbf0 100644
--- a/theories/Reals/Sqrt_reg.v
+++ b/theories/Reals/Sqrt_reg.v
@@ -21,6 +21,7 @@ Proof.
   destruct (total_order_T h 0) as [[Hlt|Heq]|Hgt].
   repeat rewrite Rabs_left.
   unfold Rminus; do 2 rewrite <- (Rplus_comm (-1)).
+  change (-1) with (-(1)).
   do 2 rewrite Ropp_plus_distr; rewrite Ropp_involutive;
     apply Rplus_le_compat_l.
   apply Ropp_le_contravar; apply sqrt_le_1.
diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v
index 5aa397f8a..1e3ab6687 100644
--- a/theories/ZArith/BinInt.v
+++ b/theories/ZArith/BinInt.v
@@ -1367,7 +1367,7 @@ Lemma inj_testbit a n : 0<=n ->
  Z.testbit (Z.pos a) n = N.testbit (N.pos a) (Z.to_N n).
 Proof. apply Z.testbit_Zpos. Qed.
 
-(** Some results concerning Z.neg *)
+(** Some results concerning Z.neg and Z.pos *)
 
 Lemma inj_neg p q : Z.neg p = Z.neg q -> p = q.
 Proof. now injection 1. Qed.
@@ -1375,18 +1375,54 @@ Proof. now injection 1. Qed.
 Lemma inj_neg_iff p q : Z.neg p = Z.neg q <-> p = q.
 Proof. split. apply inj_neg. intros; now f_equal. Qed.
 
+Lemma inj_pos p q : Z.pos p = Z.pos q -> p = q.
+Proof. now injection 1. Qed.
+
+Lemma inj_pos_iff p q : Z.pos p = Z.pos q <-> p = q.
+Proof. split. apply inj_pos. intros; now f_equal. Qed.
+
 Lemma neg_is_neg p : Z.neg p < 0.
 Proof. reflexivity. Qed.
 
 Lemma neg_is_nonpos p : Z.neg p <= 0.
 Proof. easy. Qed.
 
+Lemma pos_is_pos p : 0 < Z.pos p.
+Proof. reflexivity. Qed.
+
+Lemma pos_is_nonneg p : 0 <= Z.pos p.
+Proof. easy. Qed.
+
+Lemma neg_le_pos p q : Zneg p <= Zpos q.
+Proof. easy. Qed.
+
+Lemma neg_lt_pos p q : Zneg p < Zpos q.
+Proof. easy. Qed.
+
+Lemma neg_le_neg p q : (q <= p)%positive -> Zneg p <= Zneg q.
+Proof. intros; unfold Z.le; simpl. now rewrite <- Pos.compare_antisym. Qed.
+
+Lemma neg_lt_neg p q : (q < p)%positive -> Zneg p < Zneg q.
+Proof. intros; unfold Z.lt; simpl. now rewrite <- Pos.compare_antisym. Qed.
+
+Lemma pos_le_pos p q : (p <= q)%positive -> Zpos p <= Zpos q.
+Proof. easy. Qed.
+
+Lemma pos_lt_pos p q : (p < q)%positive -> Zpos p < Zpos q.
+Proof. easy. Qed.
+
 Lemma neg_xO p : Z.neg p~0 = 2 * Z.neg p.
 Proof. reflexivity. Qed.
 
 Lemma neg_xI p : Z.neg p~1 = 2 * Z.neg p - 1.
 Proof. reflexivity. Qed.
 
+Lemma pos_xO p : Z.pos p~0 = 2 * Z.pos p.
+Proof. reflexivity. Qed.
+
+Lemma pos_xI p : Z.pos p~1 = 2 * Z.pos p + 1.
+Proof. reflexivity. Qed.
+
 Lemma opp_neg p : - Z.neg p = Z.pos p.
 Proof. reflexivity. Qed.
 
@@ -1402,6 +1438,9 @@ Proof. reflexivity. Qed.
 Lemma add_neg_pos p q : Z.neg p + Z.pos q = Z.pos_sub q p.
 Proof. reflexivity. Qed.
 
+Lemma add_pos_pos p q : Z.pos p + Z.pos q = Z.pos (p+q).
+Proof. reflexivity. Qed.
+
 Lemma divide_pos_neg_r n p : (n|Z.pos p) <-> (n|Z.neg p).
 Proof. apply Z.divide_Zpos_Zneg_r. Qed.
 
@@ -1412,6 +1451,10 @@ Lemma testbit_neg a n : 0<=n ->
  Z.testbit (Z.neg a) n = negb (N.testbit (Pos.pred_N a) (Z.to_N n)).
 Proof. apply Z.testbit_Zneg. Qed.
 
+Lemma testbit_pos a n : 0<=n ->
+ Z.testbit (Z.pos a) n = N.testbit (N.pos a) (Z.to_N n).
+Proof. apply Z.testbit_Zpos. Qed.
+
 End Pos2Z.
 
 Module Z2Pos.
diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v
index 73dee0cf2..18915216a 100644
--- a/theories/ZArith/Zorder.v
+++ b/theories/ZArith/Zorder.v
@@ -339,7 +339,7 @@ Notation Zle_0_1 := Z.le_0_1 (compat "8.3").
 
 Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q.
 Proof.
-  easy.
+  exact Pos2Z.neg_le_pos.
 Qed.
 
 Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0.
@@ -350,12 +350,12 @@ Qed.
 (* weaker but useful (in [Z.pow] for instance) *)
 Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p.
 Proof.
- easy.
+  exact Pos2Z.pos_is_nonneg.
 Qed.
 
 Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0.
 Proof.
- easy.
+  exact Pos2Z.neg_is_neg.
 Qed.
 
 Lemma Zle_0_nat : forall n:nat, 0 <= Z.of_nat n.
diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml
index b7dd5f2a1..22b1408c0 100644
--- a/tools/coq_makefile.ml
+++ b/tools/coq_makefile.ml
@@ -50,9 +50,9 @@ let section s =
 let lib_dirs =
   ["kernel"; "lib"; "library"; "parsing";
    "pretyping"; "interp"; "printing"; "intf";
-   "proofs"; "tactics"; "tools"; "ltacprof";
-   "toplevel"; "stm"; "grammar"; "config";
-   "ltac"; "engine"]
+   "proofs"; "tactics"; "tools";
+   "vernac"; "stm"; "toplevel"; "grammar"; "config";
+   "engine"]
 
 
 let usage () =
@@ -125,12 +125,9 @@ let physical_dir_of_logical_dir ldir =
   let le = String.length ldir - 1 in
   let pdir =
     if le >= 0 && ldir.[le] = '.' then String.sub ldir 0 (le - 1)
-    else String.copy ldir
+    else ldir
   in
-  for i = 0 to le - 1 do
-    if pdir.[i] = '.' then pdir.[i] <- '/';
-  done;
-  pdir
+  String.map (fun c -> if c = '.' then '/' else c) pdir
 
 let standard opt =
   print "byte:\n";
@@ -524,10 +521,10 @@ let variables is_install opt (args,defs) =
     List.iter (fun c -> print " \\
   -I \"$(COQLIB)/"; print c; print "\"") Coq_config.plugins_dirs; print "\n";
     print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\n";
-    print "CAMLC?=$(OCAMLFIND) ocamlc -c -rectypes -thread\n";
-    print "CAMLOPTC?=$(OCAMLFIND) opt -c -rectypes -thread\n";
-    print "CAMLLINK?=$(OCAMLFIND) ocamlc -rectypes -thread\n";
-    print "CAMLOPTLINK?=$(OCAMLFIND) opt -rectypes -thread\n";
+    print "CAMLC?=$(OCAMLFIND) ocamlc -c -rectypes -thread -safe-string\n";
+    print "CAMLOPTC?=$(OCAMLFIND) opt -c -rectypes -thread -safe-string\n";
+    print "CAMLLINK?=$(OCAMLFIND) ocamlc -rectypes -thread -safe-string\n";
+    print "CAMLOPTLINK?=$(OCAMLFIND) opt -rectypes -thread -safe-string\n";
     print "CAMLDEP?=$(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack\n";
     print "CAMLLIB?=$(shell $(OCAMLFIND) printconf stdlib)\n";
     print "GRAMMARS?=grammar.cma\n";
@@ -676,6 +673,7 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other
       print "VO=vo\n";
       print "VOFILES:=$(VFILES:.v=.$(VO))\n";
       classify_files_by_root "VOFILES" l inc;
+      classify_files_by_root "VFILES" l inc;
       print "GLOBFILES:=$(VFILES:.v=.glob)\n";
       print "GFILES:=$(VFILES:.v=.g)\n";
       print "HTMLFILES:=$(VFILES:.v=.html)\n";
@@ -767,9 +765,9 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other
     begin
       print "mlihtml: $(MLIFILES:.mli=.cmi)\n";
       print "\t mkdir $@ || rm -rf $@/*\n";
-      print "\t$(OCAMLFIND) ocamldoc -html -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
+      print "\t$(OCAMLFIND) ocamldoc -html -safe-string -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
       print "all-mli.tex: $(MLIFILES:.mli=.cmi)\n";
-      print "\t$(OCAMLFIND) ocamldoc -latex -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
+      print "\t$(OCAMLFIND) ocamldoc -latex -safe-string -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
     end;
   if !some_vfile then
     begin
@@ -885,7 +883,7 @@ let check_overlapping_include (_,inc_i,inc_r) =
  *)
 let merlin targets (ml_inc,_,_) =
   print ".merlin:\n";
-  print "\t@echo 'FLG -rectypes' > .merlin\n" ;
+  print "\t@echo 'FLG -rectypes -safe-string' > .merlin\n" ;
   List.iter (fun c ->
       printf "\t@echo \"B $(COQLIB)%s\" >> .merlin\n" c)
     lib_dirs ;
diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml
index f817ed5a2..3d92c9356 100644
--- a/tools/coqdoc/alpha.ml
+++ b/tools/coqdoc/alpha.ml
@@ -26,12 +26,7 @@ let norm_char c =
   if !latin1 then norm_char_latin1 c else
   Char.uppercase c
 
-let norm_string s =
-  let u = String.copy s in
-  for i = 0 to String.length s - 1 do
-    u.[i] <- norm_char s.[i]
-  done;
-  u
+let norm_string = String.map (fun s -> norm_char s)
 
 let compare_char c1 c2 = match norm_char c1, norm_char c2 with
   | ('A'..'Z' as c1), ('A'..'Z' as c2) -> compare c1 c2
diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml
index 9be791a8d..34108eff4 100644
--- a/tools/coqdoc/index.ml
+++ b/tools/coqdoc/index.ml
@@ -197,7 +197,7 @@ let prepare_entry s = function
       let h = try String.index_from s 0 ':' with _ -> err () in
       let i = try String.index_from s (h+1) ':' with _ -> err () in
       let sc = String.sub s (h+1) (i-h-1) in
-      let ntn = String.make (String.length s - i) ' ' in
+      let ntn = Bytes.make (String.length s - i) ' ' in
       let k = ref 0 in
       let j = ref (i+1) in
       let quoted = ref false in
@@ -205,22 +205,22 @@ let prepare_entry s = function
       while !j <= l do
 	if not !quoted then begin
 	  (match s.[!j] with
-	  | '_' -> ntn.[!k] <- ' '; incr k
-	  | 'x' -> ntn.[!k] <- '_'; incr k
+	  | '_' -> Bytes.set ntn !k ' '; incr k
+	  | 'x' -> Bytes.set ntn !k '_'; incr k
 	  | '\'' -> quoted := true
 	  | _ -> assert false)
 	end
 	else
 	  if s.[!j] = '\'' then
 	    if (!j = l || s.[!j+1] = '_') then quoted := false
-	    else (incr j; ntn.[!k] <- s.[!j]; incr k)
+	    else (incr j; Bytes.set ntn !k s.[!j]; incr k)
 	  else begin
-	    ntn.[!k] <- s.[!j];
+	    Bytes.set ntn !k s.[!j];
 	    incr k
 	  end;
 	incr j
       done;
-      let ntn = String.sub ntn 0 !k in
+      let ntn = Bytes.sub_string ntn 0 !k in
       if sc = "" then ntn else ntn ^ " (" ^ sc ^ ")"
   | _ ->
       s
diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml
index eaf938e8c..645b3665e 100644
--- a/tools/coqmktop.ml
+++ b/tools/coqmktop.ml
@@ -75,6 +75,7 @@ let std_includes basedir =
   let rebase d = match basedir with None -> d | Some base -> base / d in
   ["-I"; rebase ".";
    "-I"; rebase "lib";
+   "-I"; rebase "vernac";       (* For Mltop *)
    "-I"; rebase "toplevel";
    "-I"; rebase "kernel/byterun";
    "-I"; Envars.camlp4lib () ] @
diff --git a/tools/coqworkmgr.ml b/tools/coqworkmgr.ml
index d7bdf907a..b8e69d6c6 100644
--- a/tools/coqworkmgr.ml
+++ b/tools/coqworkmgr.ml
@@ -72,10 +72,13 @@ let really_read_fd fd s off len =
 let raw_input_line fd =
   try
     let b = Buffer.create 80 in
-    let s = String.make 1 '\000' in
-    while s <> "\n" do
+    let s = Bytes.make 1 '\000' in
+    let endl = Bytes.of_string "\n" in
+    let endr = Bytes.of_string "\r" in
+    while Bytes.compare s endl <> 0 do
       really_read_fd fd s 0 1;
-      if s <> "\n" && s <> "\r" then Buffer.add_string b s;
+      if Bytes.compare s endl <> 0 && Bytes.compare s endr <> 0
+      then Buffer.add_bytes b s;
     done;
     Buffer.contents b
   with Unix.Unix_error _ -> raise End_of_file
diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml
index 8fcca535d..932097607 100644
--- a/tools/fake_ide.ml
+++ b/tools/fake_ide.ml
@@ -12,24 +12,15 @@ let error s =
   prerr_endline ("fake_id: error: "^s);
   exit 1
 
+let pperr_endline pp = Format.eprintf "@[%a@]\n%!" Pp.pp_with pp
+
 type coqtop = {
   xml_printer : Xml_printer.t;
   xml_parser : Xml_parser.t;
 }
 
-let print_xml chan xml =
-  let rec print = function
-  | Xml_datatype.PCData s -> output_string chan s
-  | Xml_datatype.Element (_, _, children) -> List.iter print children
-  in
-  print xml
-
-let error_xml s =
-  Printf.eprintf "fake_id: error: %a\n%!" print_xml s;
-  exit 1
-
-let logger level content =
-  Printf.eprintf "%a\n%! " print_xml (Richpp.repr content)
+let print_error msg =
+  Format.eprintf "fake_id: error: @[%a@]\n%!" Pp.pp_with msg
 
 let base_eval_call ?(print=true) ?(fail=true) call coqtop =
   if print then prerr_endline (Xmlprotocol.pr_call call);
@@ -37,20 +28,15 @@ let base_eval_call ?(print=true) ?(fail=true) call coqtop =
   Xml_printer.print coqtop.xml_printer xml_query;
   let rec loop () =
     let xml = Xml_parser.parse coqtop.xml_parser in
-    match Xmlprotocol.is_message xml with
-    | Some (level, _loc, content) ->
-      logger level content;
+    if Xmlprotocol.is_feedback xml then
       loop ()
-    | None ->
-      if Xmlprotocol.is_feedback xml then
-        loop ()
-      else Xmlprotocol.to_answer call xml
+    else Xmlprotocol.to_answer call xml
   in
   let res = loop () in
   if print then prerr_endline (Xmlprotocol.pr_full_value call res);
   match res with
-  | Interface.Fail (_,_,s) when fail -> error_xml (Richpp.repr s)
-  | Interface.Fail (_,_,s) as x -> Printf.eprintf "%a\n%!" print_xml (Richpp.repr s); x
+  | Interface.Fail (_,_,s) when fail -> print_error s; exit 1
+  | Interface.Fail (_,_,s) as x      -> print_error s; x
   | x -> x
 
 let eval_call c q = ignore(base_eval_call c q)
@@ -186,7 +172,7 @@ let print_document () =
           Str.global_replace (Str.regexp "^[\n ]*") ""
       (if String.length s > 20 then String.sub s 0 17 ^ "..."
        else s) in
-  prerr_endline (Pp.string_of_ppcmds
+  pperr_endline (
     (Document.print doc
       (fun b state_id { name; text } ->
         Pp.str (Printf.sprintf "%s[%10s, %3s] %s"
@@ -199,7 +185,7 @@ let print_document () =
 module GUILogic = struct
 
   let after_add = function
-    | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s)
+    | Interface.Fail (_,_,s) -> print_error s; exit 1
     | Interface.Good (id, (Util.Inl (), _)) ->
         Document.assign_tip_id doc id
     | Interface.Good (id, (Util.Inr tip, _)) ->
@@ -211,7 +197,7 @@ module GUILogic = struct
   let at id id' _ = Stateid.equal id' id
   
   let after_edit_at (id,need_unfocus) = function
-    | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s)
+    | Interface.Fail (_,_,s) -> print_error s; exit 1
     | Interface.Good (Util.Inl ()) ->
         if need_unfocus then Document.unfocus doc;
         ignore(Document.cut_at doc id);
@@ -310,11 +296,12 @@ let main =
   Sys.set_signal Sys.sigpipe
     (Sys.Signal_handle
        (fun _ -> prerr_endline "Broken Pipe (coqtop died ?)"; exit 1));
+  let def_args = ["--xml_format=Ppcmds"; "-ideslave"] in
   let coqtop_name, coqtop_args, input_file = match Sys.argv with
-    | [| _; f |] -> "coqtop",[|"-ideslave"|], f
+    | [| _; f |] -> "coqtop", Array.of_list def_args, f
     | [| _; f; ct |] ->
         let ct = Str.split (Str.regexp " ") ct in
-        List.hd ct, Array.of_list ("-ideslave" :: List.tl ct), f
+        List.hd ct, Array.of_list (def_args @ List.tl ct), f
     | _ -> usage () in
   let inc = if input_file = "-" then stdin else open_in input_file in
   let coq =
@@ -334,7 +321,7 @@ let main =
   let finish () =
     match base_eval_call (Xmlprotocol.status true) coq with
     | Interface.Good _ -> exit 0
-    | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) in
+    | Interface.Fail (_,_,s) -> print_error s; exit 1 in
   (* The main loop *)
   init ();
   while true do
diff --git a/tools/gallina-db.el b/tools/gallina-db.el
index baabebb13..9664f69f8 100644
--- a/tools/gallina-db.el
+++ b/tools/gallina-db.el
@@ -163,7 +163,7 @@ for DB structure."
 
 (defun coq-sort-menu-entries (menu)
   (sort menu 
-	'(lambda (x y) (string< 
+	(lambda (x y) (string< 
 			(downcase (elt x 0)) 
 			(downcase (elt y 0))))))
 
diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml
index e9771cfa4..0cc6ca317 100644
--- a/toplevel/coqloop.ml
+++ b/toplevel/coqloop.ml
@@ -13,14 +13,15 @@ open Flags
 open Vernac
 open Pcoq
 
-let top_stderr x = msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft x
+let top_stderr x =
+  Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with x
 
 (* A buffer for the character read from a channel. We store the command
  * entered to be able to report errors without pretty-printing. *)
 
 type input_buffer = {
   mutable prompt : unit -> string;
-  mutable str : string; (* buffer of already read characters *)
+  mutable str : Bytes.t; (* buffer of already read characters *)
   mutable len : int;    (* number of chars in the buffer *)
   mutable bols : int list; (* offsets in str of beginning of lines *)
   mutable tokens : Gram.coq_parsable; (* stream of tokens *)
@@ -28,9 +29,9 @@ type input_buffer = {
 
 (* Double the size of the buffer. *)
 
-let resize_buffer ibuf =
-  let nstr = String.create (2 * String.length ibuf.str + 1) in
-  String.blit ibuf.str 0 nstr 0 (String.length ibuf.str);
+let resize_buffer ibuf = let open Bytes in
+  let nstr = create (2 * length ibuf.str + 1) in
+  blit ibuf.str 0 nstr 0 (length ibuf.str);
   ibuf.str <- nstr
 
 (* Delete all irrelevant lines of the input buffer. Keep the last line
@@ -40,7 +41,7 @@ let resynch_buffer ibuf =
   match ibuf.bols with
     | ll::_ ->
         let new_len = ibuf.len - ll in
-        String.blit ibuf.str ll ibuf.str 0 new_len;
+        Bytes.blit ibuf.str ll ibuf.str 0 new_len;
         ibuf.len <- new_len;
         ibuf.bols <- [];
         ibuf.start <- ibuf.start + ll
@@ -65,8 +66,8 @@ let prompt_char ic ibuf count =
   try
     let c = input_char ic in
     if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols;
-    if ibuf.len == String.length ibuf.str then resize_buffer ibuf;
-    ibuf.str.[ibuf.len] <- c;
+    if ibuf.len == Bytes.length ibuf.str then resize_buffer ibuf;
+    Bytes.set ibuf.str ibuf.len c;
     ibuf.len <- ibuf.len + 1;
     Some c
   with End_of_file ->
@@ -75,7 +76,7 @@ let prompt_char ic ibuf count =
 (* Reinitialize the char stream (after a Drop) *)
 
 let reset_input_buffer ic ibuf =
-  ibuf.str <- "";
+  ibuf.str <- Bytes.empty;
   ibuf.len <- 0;
   ibuf.bols <- [];
   ibuf.tokens <- Gram.parsable (Stream.from (prompt_char ic ibuf));
@@ -109,19 +110,19 @@ let dotted_location (b,e) =
   else
     (String.make (e-b-1) '.', " ")
 
-let blanch_utf8_string s bp ep =
-  let s' = String.make (ep-bp) ' ' in
+let blanch_utf8_string s bp ep = let open Bytes in
+  let s' = make (ep-bp) ' ' in
   let j = ref 0 in
   for i = bp to ep - 1 do
-    let n = Char.code s.[i] in
+    let n = Char.code (get s i) in
     (* Heuristic: assume utf-8 chars are printed using a single
     fixed-size char and therefore contract all utf-8 code into one
     space; in any case, preserve tabulation so
     that its effective interpretation in terms of spacing is preserved *)
-    if s.[i] == '\t' then s'.[!j] <- '\t';
+    if get s i == '\t' then set s' !j '\t';
     if n < 0x80 || 0xC0 <= n then incr j
   done;
-  String.sub s' 0 !j
+  Bytes.sub_string s' 0 !j
 
 let print_highlight_location ib loc =
   let (bp,ep) = Loc.unloc loc in
@@ -132,17 +133,17 @@ let print_highlight_location ib loc =
       | ([],(bl,el)) ->
 	  let shift = blanch_utf8_string ib.str bl bp in
 	  let span = String.length (blanch_utf8_string ib.str bp ep) in
-	  (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++
+	  (str"> " ++ str(Bytes.sub_string ib.str bl (el-bl-1)) ++ fnl () ++
            str"> " ++ str(shift) ++ str(String.make span '^'))
       | ((b1,e1)::ml,(bn,en)) ->
           let (d1,s1) = dotted_location (b1,bp) in
           let (dn,sn) = dotted_location (ep,en) in
           let l1 = (str"> " ++ str d1 ++ str s1 ++
-                      str(String.sub ib.str bp (e1-bp))) in
+                      str(Bytes.sub_string ib.str bp (e1-bp))) in
           let li =
             prlist (fun (bi,ei) ->
-                      (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in
-          let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++
+                      (str"> " ++ str(Bytes.sub_string ib.str bi (ei-bi)))) ml in
+          let ln = (str"> " ++ str(Bytes.sub_string ib.str bn (ep-bn)) ++
                       str sn ++ str dn) in
 	  (l1 ++ li ++ ln)
   in
@@ -220,7 +221,7 @@ let top_buffer =
     ^ emacs_prompt_endstring()
   in
   { prompt = pr;
-    str = "";
+    str = Bytes.empty;
     len = 0;
     bols = [];
     tokens = Gram.parsable (Stream.of_list []);
@@ -251,7 +252,8 @@ let print_toplevel_error (e, info) =
       else mt ()
     else print_location_in_file loc
   in
-  locmsg ++ CErrors.iprint (e, info)
+  let hdr msg = hov 0 (Topfmt.err_hdr ++ msg) in
+  locmsg ++ hdr (CErrors.iprint (e, info))
 
 (* Read the input stream until a dot is encountered *)
 let parse_to_dot =
@@ -283,6 +285,33 @@ let read_sentence input =
     discard_to_dot ();
     iraise reraise
 
+(** Coqloop Console feedback handler *)
+let coqloop_feed (fb : Feedback.feedback) = let open Feedback in
+  match fb.contents with
+  | Processed   -> ()
+  | Incomplete  -> ()
+  | Complete    -> ()
+  | ProcessingIn _ -> ()
+  | InProgress _ -> ()
+  | WorkerStatus (_,_) -> ()
+  | AddedAxiom  -> ()
+  | GlobRef (_,_,_,_,_) -> ()
+  | GlobDef (_,_,_,_) -> ()
+  | FileDependency (_,_) -> ()
+  | FileLoaded (_,_) -> ()
+  | Custom (_,_,_) -> ()
+  | Message (Error,loc,msg) ->
+    (* We ignore errors here as we (still) have a different error
+       printer for the toplevel. It is hard to solve due the many
+       error paths presents, and the different compromise of feedback
+       error forwaring in the stm depending on the mode *)
+    ()
+  | Message (lvl,loc,msg) ->
+    if !Flags.print_emacs then
+      Topfmt.emacs_logger ?loc lvl msg
+    else
+      Topfmt.std_logger ?loc lvl msg
+
 (** [do_vernac] reads and executes a toplevel phrase, and print error
     messages when an exception is raised, except for the following:
     - Drop: kill the Coq toplevel, going down to the Caml toplevel if it exists.
@@ -305,12 +334,13 @@ let do_vernac () =
         top_stderr (fnl ()); raise CErrors.Quit
     | CErrors.Drop ->  (* Last chance *)
         if Mltop.is_ocaml_top() then raise CErrors.Drop
-        else Feedback.msg_error (str"There is no ML toplevel.")
+        else top_stderr (str "There is no ML toplevel.")
     | any ->
+        (** Main error printer, note that this didn't it the "emacs"
+            legacy path. *)
         let any = CErrors.push any in
         let msg = print_toplevel_error any ++ fnl () in
-        pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft msg;
-        Format.pp_print_flush !Pp_control.std_ft ()
+        top_stderr msg
 
 (** Main coq loop : read vernacular expressions until Drop is entered.
     Ctrl-C is handled internally as Sys.Break instead of aborting Coq.
@@ -318,22 +348,13 @@ let do_vernac () =
     exit the loop are Drop and Quit. Any other exception there indicates
     an issue with [print_toplevel_error] above. *)
 
-(*
-let feed_emacs = function
-  | { Interface.id = Interface.State id;
-      Interface.content = Interface.GlobRef (_,a,_,c,_) }  -> 
-    prerr_endline ("<info>" ^"<id>"^Stateid.to_string id ^"</id>"
-		   ^a^" "^c^ "</info>")
-  | _  -> ()
-*)
-
 (* Flush in a compatible order with 8.5 *)
 (* This mimics the semantics of the old Pp.flush_all *)
 let loop_flush_all () =
   Pervasives.flush stderr;
   Pervasives.flush stdout;
-  Format.pp_print_flush !Pp_control.std_ft ();
-  Format.pp_print_flush !Pp_control.err_ft ()
+  Format.pp_print_flush !Topfmt.std_ft ();
+  Format.pp_print_flush !Topfmt.err_ft ()
 
 let rec loop () =
   Sys.catch_break true;
@@ -346,9 +367,9 @@ let rec loop () =
     | CErrors.Drop -> ()
     | CErrors.Quit -> exit 0
     | any ->
-      Feedback.msg_error (str"Anomaly: main loop exited with exception: " ++
-                str (Printexc.to_string any) ++
-                fnl() ++
-                str"Please report" ++
-                strbrk" at " ++ str Coq_config.wwwbugtracker ++ str ".");
+      top_stderr (str"Anomaly: main loop exited with exception: " ++
+                  str (Printexc.to_string any) ++
+                  fnl() ++
+                  str"Please report" ++
+                  strbrk" at " ++ str Coq_config.wwwbugtracker ++ str ".");
       loop ()
diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli
index e40353e0f..eb61084e0 100644
--- a/toplevel/coqloop.mli
+++ b/toplevel/coqloop.mli
@@ -15,7 +15,7 @@ open Pp
 
 type input_buffer = {
   mutable prompt : unit -> string;
-  mutable str : string; (** buffer of already read characters *)
+  mutable str : Bytes.t; (** buffer of already read characters *)
   mutable len : int;    (** number of chars in the buffer *)
   mutable bols : int list; (** offsets in str of begining of lines *)
   mutable tokens : Pcoq.Gram.coq_parsable; (** stream of tokens *)
@@ -32,6 +32,8 @@ val set_prompt : (unit -> string) -> unit
 
 val print_toplevel_error : Exninfo.iexn -> std_ppcmds
 
+val coqloop_feed : Feedback.feedback -> unit
+
 (** Parse and execute one vernac command. *)
 
 val do_vernac : unit -> unit
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index d9f8ed881..0cd5498fe 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -61,15 +61,15 @@ let init_color () =
     match colors with
     | None ->
       (** Default colors *)
-      Feedback.init_color_output ()
+      Topfmt.init_color_output ()
     | Some "" ->
       (** No color output *)
       ()
     | Some s ->
       (** Overwrite all colors *)
-      Ppstyle.clear_styles ();
-      Ppstyle.parse_config s;
-      Feedback.init_color_output ()
+      Topfmt.clear_styles ();
+      Topfmt.parse_color_config s;
+      Topfmt.init_color_output ()
   end
 
 let toploop_init = ref begin fun x ->
@@ -78,15 +78,27 @@ let toploop_init = ref begin fun x ->
   x
   end
 
-let toploop_run = ref (fun () ->
+(* Feedback received in the init stage, this is different as the STM
+   will not be generally be initialized, thus stateid, etc... may be
+   bogus. For now we just print to the console too *)
+let coqtop_init_feed = Coqloop.coqloop_feed
+
+(* Default toplevel loop *)
+let console_toploop_run () =
+  (* We initialize the console only if we run the toploop_run *)
+  let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in
   if Dumpglob.dump () then begin
     if_verbose warning "Dumpglob cannot be used in interactive mode.";
     Dumpglob.noglob ()
   end;
   Coqloop.loop();
+  (* We remove the feeder but it could be ok not to do so *)
+  Feedback.del_feeder tl_feed;
   (* Initialise and launch the Ocaml toplevel *)
   Coqinit.init_ocaml_path();
-  Mltop.ocaml_toploop())
+  Mltop.ocaml_toploop()
+
+let toploop_run = ref console_toploop_run
 
 let output_context = ref false
 
@@ -122,11 +134,10 @@ let engage () =
 let set_batch_mode () = batch_mode := true
 
 let toplevel_default_name = DirPath.make [Id.of_string "Top"]
-let toplevel_name = ref (Some toplevel_default_name)
+let toplevel_name = ref toplevel_default_name
 let set_toplevel_name dir =
   if DirPath.is_empty dir then error "Need a non empty toplevel module name";
-  toplevel_name := Some dir
-let unset_toplevel_name () = toplevel_name := None
+  toplevel_name := dir
 
 let remove_top_ml () = Mltop.remove ()
 
@@ -228,7 +239,6 @@ let compile_files () =
   if !compile_list == [] then ()
   else
     let init_state = States.freeze ~marshallable:`No in
-    Feedback.(add_feeder debug_feeder);
     List.iter (fun vf ->
         States.unfreeze init_state;
         compile_file vf)
@@ -240,7 +250,6 @@ let set_emacs () =
   if not (Option.is_empty !toploop) then
     error "Flag -emacs is incompatible with a custom toplevel loop";
   Flags.print_emacs := true;
-  Feedback.(set_logger emacs_logger);
   Vernacentries.qed_display_script := false;
   color := `OFF
 
@@ -298,24 +307,16 @@ let usage () =
 
 let print_style_tags () =
   let () = init_color () in
-  let tags = Ppstyle.dump () in
+  let tags = Topfmt.dump_tags () in
   let iter (t, st) =
-    let st = match st with Some st -> st | None -> Terminal.make () in
-    let opt =
-      Terminal.eval st ^
-      String.concat "." (Ppstyle.repr t) ^
-      Terminal.reset ^ "\n"
-    in
+    let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in
     print_string opt
   in
-  let make (t, st) = match st with
-  | None -> None
-  | Some st ->
+  let make (t, st) =
     let tags = List.map string_of_int (Terminal.repr st) in
-    let t = String.concat "." (Ppstyle.repr t) in
-    Some (t ^ "=" ^ String.concat ";" tags)
+    (t ^ "=" ^ String.concat ";" tags)
   in
-  let repr = List.map_filter make tags in
+  let repr = List.map make tags in
   let () = Printf.printf "COQ_COLORS=\"%s\"\n" (String.concat ":" repr) in
   let () = List.iter iter tags in
   flush_all ()
@@ -431,6 +432,13 @@ let get_native_name s =
       Nativelib.output_dir; Library.native_name_from_filename s]
   with _ -> ""
 
+(** Prints info which is either an error or an anomaly and then exits
+    with the appropriate error code *)
+let fatal_error info anomaly =
+  let msg = info ++ fnl () in
+  Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with msg;
+  exit (if anomaly then 129 else 1)
+
 let parse_args arglist =
   let args = ref arglist in
   let extras = ref [] in
@@ -556,7 +564,6 @@ let parse_args arglist =
       if Coq_config.no_native_compiler then
 	warning "Native compilation was disabled at configure time."
       else native_compiler := true
-    |"-notop" -> unset_toplevel_name ()
     |"-output-context" -> output_context := true
     |"-profile-ltac" -> Flags.profile_ltac := true
     |"-q" -> no_load_rc ()
@@ -595,16 +602,15 @@ let parse_args arglist =
     parse ()
   with
     | UserError(_, s) as e ->
-      if is_empty s then exit 1
+      if ismt s then exit 1
       else fatal_error (CErrors.print e) false
     | any -> fatal_error (CErrors.print any) (CErrors.is_anomaly any)
 
 let init_toplevel arglist =
   init_gc ();
   Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
+  let init_feeder = Feedback.add_feeder coqtop_init_feed in
   Lib.init();
-  (* Default Proofb Mode starts with an alternative default. *)
-  Goptions.set_string_option_value ["Default";"Proof";"Mode"] "Classic";
   begin
     try
       let extras = parse_args arglist in
@@ -630,7 +636,7 @@ let init_toplevel arglist =
       engage ();
       if (not !batch_mode || List.is_empty !compile_list)
          && Global.env_is_initial ()
-      then Option.iter Declaremods.start_library !toplevel_name;
+      then Declaremods.start_library !toplevel_name;
       init_library_roots ();
       load_vernac_obj ();
       require ();
@@ -658,7 +664,8 @@ let init_toplevel arglist =
       Feedback.msg_notice (with_option raw_print Prettyp.print_full_pure_context () ++ fnl ());
     Profile.print_profile ();
     exit 0
-  end
+  end;
+  Feedback.del_feeder init_feeder
 
 let start () =
   let () = init_toplevel (List.tl (Array.to_list Sys.argv)) in
diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib
index d68922363..10bf48647 100644
--- a/toplevel/toplevel.mllib
+++ b/toplevel/toplevel.mllib
@@ -1,19 +1,3 @@
-Himsg
-ExplainErr
-Class
-Locality
-Metasyntax
-Auto_ind_decl
-Search
-Indschemes
-Obligations
-Command
-Classes
-Record
-Assumptions
-Vernacinterp
-Mltop
-Vernacentries
 Vernac
 Usage
 Coqloop
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index 38ceacf5e..66f782ffb 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -30,7 +30,6 @@ let print_usage_channel co command =
 \n  -R dir coqdir          recursively map physical dir to logical coqdir\
 \n  -Q dir coqdir          map physical dir to logical coqdir\
 \n  -top coqdir            set the toplevel name to be coqdir instead of Top\
-\n  -notop                 set the toplevel name to be the empty logical path\
 \n  -exclude-dir f         exclude subdirectories named f for option -R\
 \n\
 \n  -noinit                start without loading the Init library\
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
index 0e72a044c..06908abb6 100644
--- a/toplevel/vernac.ml
+++ b/toplevel/vernac.ml
@@ -105,10 +105,10 @@ let verbose_phrase verbch loc =
   match verbch with
     | Some ch ->
 	let len = snd loc - fst loc in
-	let s = String.create len in
+	let s = Bytes.create len in
         seek_in ch (fst loc);
         really_input ch s 0 len;
-        Feedback.msg_notice (str s)
+        Feedback.msg_notice (str (Bytes.to_string s))
     | None -> ()
 
 exception End_of_input
@@ -126,7 +126,7 @@ let chan_beautify = ref stdout
 let beautify_suffix = ".beautified"
 
 let set_formatter_translator ch =
-  let out s b e = output ch s b e in
+  let out s b e = output_substring ch s b e in
   Format.set_formatter_output_functions out (fun () -> flush ch);
   Format.set_max_boxes max_int
 
@@ -143,7 +143,8 @@ let pr_new_syntax_in_context loc chan_beautify ocom =
       | None -> mt() in
     let after = comment (CLexer.extract_comments (snd loc)) in
     if !beautify_file then
-      Pp.msg_with !Pp_control.std_ft (hov 0 (before ++ com ++ after))
+      (Pp.pp_with !Topfmt.std_ft (hov 0 (before ++ com ++ after));
+       Format.pp_print_flush !Topfmt.std_ft ())
     else
       Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com)));
     States.unfreeze fs;
@@ -161,13 +162,11 @@ let pr_new_syntax po loc chan_beautify ocom =
 
 let pp_cmd_header loc com =
   let shorten s = try (String.sub s 0 30)^"..." with _ -> s in
-  let noblank s =
-    for i = 0 to String.length s - 1 do
-      match s.[i] with
-	| ' ' | '\n' | '\t' | '\r' -> s.[i] <- '~'
-	| _ -> ()
-    done;
-    s
+  let noblank s = String.map (fun c ->
+      match c with
+	| ' ' | '\n' | '\t' | '\r' -> '~'
+	| x -> x
+      ) s
   in
   let (start,stop) = Loc.unloc loc in
   let safe_pr_vernac x =
@@ -180,9 +179,10 @@ let pp_cmd_header loc com =
 (* This is a special case where we assume we are in console batch mode
    and take control of the console.
  *)
+(* FIXME *)
 let print_cmd_header loc com =
-  Pp.pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft (pp_cmd_header loc com);
-  Format.pp_print_flush !Pp_control.std_ft ()
+  Pp.pp_with !Topfmt.std_ft (pp_cmd_header loc com);
+  Format.pp_print_flush !Topfmt.std_ft ()
 
 let rec interp_vernac po chan_beautify checknav (loc,com) =
   let interp = function
@@ -343,7 +343,7 @@ let compile verbosely f =
       let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in
       Library.save_library_raw lfdv sum lib univs proofs
 
-let compile v f = 
+let compile v f =
   ignore(CoqworkmgrApi.get 1);
   compile v f;
   CoqworkmgrApi.giveback 1
diff --git a/toplevel/assumptions.ml b/vernac/assumptions.ml
index deb2ed3e0..deb2ed3e0 100644
--- a/toplevel/assumptions.ml
+++ b/vernac/assumptions.ml
diff --git a/toplevel/assumptions.mli b/vernac/assumptions.mli
index 072675783..072675783 100644
--- a/toplevel/assumptions.mli
+++ b/vernac/assumptions.mli
diff --git a/toplevel/auto_ind_decl.ml b/vernac/auto_ind_decl.ml
index 9e216dc4a..10ac7135b 100644
--- a/toplevel/auto_ind_decl.ml
+++ b/vernac/auto_ind_decl.ml
@@ -450,14 +450,14 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
                with Not_found ->
 		 (* spiwack: the format of this error message should probably
 	                     be improved. *)
-		 let err_msg = string_of_ppcmds
+		 let err_msg =
 	                                (str "boolean->Leibniz:" ++
                                          str "You have to declare the" ++
 			   	         str "decidability over " ++
 				         Printer.pr_econstr tt1 ++
 				         str " first.")
 		 in
-		 error err_msg
+		 user_err err_msg
                in let bl_args =
                         Array.append (Array.append
                           (Array.map (fun x -> x) v)
diff --git a/toplevel/auto_ind_decl.mli b/vernac/auto_ind_decl.mli
index 60232ba8f..60232ba8f 100644
--- a/toplevel/auto_ind_decl.mli
+++ b/vernac/auto_ind_decl.mli
diff --git a/toplevel/class.ml b/vernac/class.ml
index 95114ec39..95114ec39 100644
--- a/toplevel/class.ml
+++ b/vernac/class.ml
diff --git a/toplevel/class.mli b/vernac/class.mli
index 5f9ae28f6..5f9ae28f6 100644
--- a/toplevel/class.mli
+++ b/vernac/class.mli
diff --git a/toplevel/classes.ml b/vernac/classes.ml
index 415b98f2d..415b98f2d 100644
--- a/toplevel/classes.ml
+++ b/vernac/classes.ml
diff --git a/toplevel/classes.mli b/vernac/classes.mli
index d2cb788ea..d2cb788ea 100644
--- a/toplevel/classes.mli
+++ b/vernac/classes.mli
diff --git a/toplevel/command.ml b/vernac/command.ml
index 8879768c2..32b0abb8a 100644
--- a/toplevel/command.ml
+++ b/vernac/command.ml
@@ -81,7 +81,7 @@ let red_constant_entry n ce sigma = function
         let Sigma (c, _, _) = redfun.e_redfun env sigma c in
         EConstr.Unsafe.to_constr c
       in
-      { ce with const_entry_body = Future.chain ~greedy:true ~pure:true proof_out
+      { ce with const_entry_body = Future.chain ~pure:true proof_out
         (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) }
 
 let warn_implicits_in_term =
diff --git a/toplevel/command.mli b/vernac/command.mli
index fae783ef0..fae783ef0 100644
--- a/toplevel/command.mli
+++ b/vernac/command.mli
diff --git a/toplevel/discharge.ml b/vernac/discharge.ml
index b898f3e83..b898f3e83 100644
--- a/toplevel/discharge.ml
+++ b/vernac/discharge.ml
diff --git a/toplevel/discharge.mli b/vernac/discharge.mli
index 18d1b6776..18d1b6776 100644
--- a/toplevel/discharge.mli
+++ b/vernac/discharge.mli
diff --git a/toplevel/doc.tex b/vernac/doc.tex
index f2550fda1..f2550fda1 100644
--- a/toplevel/doc.tex
+++ b/vernac/doc.tex
diff --git a/toplevel/explainErr.ml b/vernac/explainErr.ml
index 414087718..dd3ddf4f4 100644
--- a/toplevel/explainErr.ml
+++ b/vernac/explainErr.ml
@@ -45,15 +45,9 @@ let _ = CErrors.register_handler explain_exn_default
 
 (** Pre-explain a vernac interpretation error *)
 
-let wrap_vernac_error with_header (exn, info) strm =
-  if with_header then
-    let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in
-    let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in
-    (e, info)
-  else
-    (EvaluatedError (strm, None), info)
+let wrap_vernac_error (exn, info) strm = (EvaluatedError (strm, None), info)
 
-let process_vernac_interp_error with_header exn = match fst exn with
+let process_vernac_interp_error exn = match fst exn with
   | Univ.UniverseInconsistency i ->
     let msg =
       if !Constrextern.print_universes then
@@ -61,41 +55,41 @@ let process_vernac_interp_error with_header exn = match fst exn with
 	  Univ.explain_universe_inconsistency Universes.pr_with_global_universes i
       else
 	mt() in
-    wrap_vernac_error with_header exn (str "Universe inconsistency" ++ msg ++ str ".")
+    wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".")
   | TypeError(ctx,te) ->
       let te = Himsg.map_ptype_error EConstr.of_constr te in
-      wrap_vernac_error with_header exn (Himsg.explain_type_error ctx Evd.empty te)
+      wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te)
   | PretypeError(ctx,sigma,te) ->
-      wrap_vernac_error with_header exn (Himsg.explain_pretype_error ctx sigma te)
+      wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te)
   | Typeclasses_errors.TypeClassError(env, te) ->
-      wrap_vernac_error with_header exn (Himsg.explain_typeclass_error env te)
+      wrap_vernac_error exn (Himsg.explain_typeclass_error env te)
   | InductiveError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_inductive_error e)
+      wrap_vernac_error exn (Himsg.explain_inductive_error e)
   | Modops.ModuleTypingError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_module_error e)
+      wrap_vernac_error exn (Himsg.explain_module_error e)
   | Modintern.ModuleInternalizationError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_module_internalization_error e)
+      wrap_vernac_error exn (Himsg.explain_module_internalization_error e)
   | RecursionSchemeError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_recursion_scheme_error e)
+      wrap_vernac_error exn (Himsg.explain_recursion_scheme_error e)
   | Cases.PatternMatchingError (env,sigma,e) ->
-      wrap_vernac_error with_header exn (Himsg.explain_pattern_matching_error env sigma e)
+      wrap_vernac_error exn (Himsg.explain_pattern_matching_error env sigma e)
   | Tacred.ReductionTacticError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_reduction_tactic_error e)
+      wrap_vernac_error exn (Himsg.explain_reduction_tactic_error e)
   | Logic.RefinerError e ->
-      wrap_vernac_error with_header exn (Himsg.explain_refiner_error e)
+      wrap_vernac_error exn (Himsg.explain_refiner_error e)
   | Nametab.GlobalizationError q ->
-      wrap_vernac_error with_header exn
+      wrap_vernac_error exn
         (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++
 	 spc () ++ str "was not found" ++
 	 spc () ++ str "in the current" ++ spc () ++ str "environment.")
   | Refiner.FailError (i,s) ->
       let s = Lazy.force s in
-      wrap_vernac_error with_header exn
+      wrap_vernac_error exn
 	(str "Tactic failure" ++
-         (if Pp.is_empty s then s else str ": " ++ s) ++
+         (if Pp.ismt s then s else str ": " ++ s) ++
          if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").")
   | AlreadyDeclared msg ->
-      wrap_vernac_error with_header exn (msg ++ str ".")
+      wrap_vernac_error exn (msg ++ str ".")
   | _ ->
       exn
 
@@ -109,9 +103,9 @@ let additional_error_info = ref []
 let register_additional_error_info f =
   additional_error_info := f :: !additional_error_info
 
-let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, info) =
+let process_vernac_interp_error ?(allow_uncaught=true) (exc, info) =
   let exc = strip_wrapping_exceptions exc in
-  let e = process_vernac_interp_error with_header (exc, info) in
+  let e = process_vernac_interp_error (exc, info) in
   let () =
     if not allow_uncaught && not (CErrors.handled (fst e)) then
       let (e, info) = e in
diff --git a/toplevel/explainErr.mli b/vernac/explainErr.mli
index a67c887af..370ad7e3b 100644
--- a/toplevel/explainErr.mli
+++ b/vernac/explainErr.mli
@@ -11,7 +11,7 @@ exception EvaluatedError of Pp.std_ppcmds * exn option
 
 (** Pre-explain a vernac interpretation error *)
 
-val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> Util.iexn -> Util.iexn
+val process_vernac_interp_error : ?allow_uncaught:bool -> Util.iexn -> Util.iexn
 
 (** General explain function. Should not be used directly now,
     see instead function [Errors.print] and variants *)
diff --git a/toplevel/himsg.ml b/vernac/himsg.ml
index 17bb87f2a..17bb87f2a 100644
--- a/toplevel/himsg.ml
+++ b/vernac/himsg.ml
diff --git a/toplevel/himsg.mli b/vernac/himsg.mli
index 6915ea921..6915ea921 100644
--- a/toplevel/himsg.mli
+++ b/vernac/himsg.mli
diff --git a/toplevel/ind_tables.ml b/vernac/ind_tables.ml
index 85d0b6194..85d0b6194 100644
--- a/toplevel/ind_tables.ml
+++ b/vernac/ind_tables.ml
diff --git a/toplevel/ind_tables.mli b/vernac/ind_tables.mli
index 20f30d6d1..20f30d6d1 100644
--- a/toplevel/ind_tables.mli
+++ b/vernac/ind_tables.mli
diff --git a/toplevel/indschemes.ml b/vernac/indschemes.ml
index 9ba4e46e4..9ba4e46e4 100644
--- a/toplevel/indschemes.ml
+++ b/vernac/indschemes.ml
diff --git a/toplevel/indschemes.mli b/vernac/indschemes.mli
index e5d79fd51..e5d79fd51 100644
--- a/toplevel/indschemes.mli
+++ b/vernac/indschemes.mli
diff --git a/stm/lemmas.ml b/vernac/lemmas.ml
index 77fb960e1..f5d7a661e 100644
--- a/stm/lemmas.ml
+++ b/vernac/lemmas.ml
@@ -60,7 +60,7 @@ let adjust_guardness_conditions const = function
   (* Try all combinations... not optimal *)
      let env = Global.env() in
      { const with const_entry_body =
-        Future.chain ~greedy:true ~pure:true const.const_entry_body
+        Future.chain ~pure:true const.const_entry_body
         (fun ((body, ctx), eff) ->
           match kind_of_term body with
           | Fix ((nv,0),(_,_,fixdefs as fixdecls)) ->
diff --git a/stm/lemmas.mli b/vernac/lemmas.mli
index 681413a29..681413a29 100644
--- a/stm/lemmas.mli
+++ b/vernac/lemmas.mli
diff --git a/toplevel/locality.ml b/vernac/locality.ml
index 03640676e..03640676e 100644
--- a/toplevel/locality.ml
+++ b/vernac/locality.ml
diff --git a/toplevel/locality.mli b/vernac/locality.mli
index 2ec392eef..2ec392eef 100644
--- a/toplevel/locality.mli
+++ b/vernac/locality.mli
diff --git a/toplevel/metasyntax.ml b/vernac/metasyntax.ml
index 0aaf6afd7..7e98d114a 100644
--- a/toplevel/metasyntax.ml
+++ b/vernac/metasyntax.ml
@@ -932,8 +932,8 @@ let find_precedence lev etyps symbols =
   let first_symbol =
     let rec aux = function
       | Break _ :: t -> aux t
-      | h :: t -> h
-      | [] -> assert false (* rule is known to be productive *) in
+      | h :: t -> Some h
+      | [] -> None in
     aux symbols in
   let last_is_terminal () =
     let rec aux b = function
@@ -943,7 +943,8 @@ let find_precedence lev etyps symbols =
       | [] -> b in
     aux false symbols in
   match first_symbol with
-  | NonTerminal x ->
+  | None -> [],0
+  | Some (NonTerminal x) ->
       (try match List.assoc x etyps with
 	| ETConstr _ ->
 	    error "The level of the leftmost non-terminal cannot be changed."
@@ -966,11 +967,11 @@ let find_precedence lev etyps symbols =
 	if Option.is_empty lev then
 	  error "A left-recursive notation must have an explicit level."
 	else [],Option.get lev)
-  | Terminal _ when last_is_terminal () ->
+  | Some (Terminal _) when last_is_terminal () ->
       if Option.is_empty lev then
 	([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."], 0)
       else [],Option.get lev
-  | _ ->
+  | Some _ ->
       if Option.is_empty lev then error "Cannot determine the level.";
       [],Option.get lev
 
@@ -1049,6 +1050,9 @@ let compute_syntax_data df modifiers =
   let open SynData in
   let open NotationMods in
   let mods = interp_modifiers modifiers in
+  let onlyprint = mods.only_printing in
+  let onlyparse = mods.only_parsing in
+  if onlyprint && onlyparse then error "A notation cannot be both 'only printing' and 'only parsing'.";
   let assoc = Option.append mods.assoc (Some NonA) in
   let toks = split_notation_string df in
   let recvars,mainvars,symbols = analyze_notation_tokens toks in
@@ -1058,7 +1062,7 @@ let compute_syntax_data df modifiers =
   let ntn_for_interp = make_notation_key symbols in
   let symbols' = remove_curly_brackets symbols in
   let ntn_for_grammar = make_notation_key symbols' in
-  check_rule_productivity symbols';
+  if not onlyprint then check_rule_productivity symbols';
 
   (* Misc *)
   let need_squash = not (List.equal Notation.symbol_eq symbols symbols') in
diff --git a/toplevel/metasyntax.mli b/vernac/metasyntax.mli
index 57c120402..57c120402 100644
--- a/toplevel/metasyntax.mli
+++ b/vernac/metasyntax.mli
diff --git a/toplevel/mltop.ml b/vernac/mltop.ml
index 2396cf04a..2396cf04a 100644
--- a/toplevel/mltop.ml
+++ b/vernac/mltop.ml
diff --git a/toplevel/mltop.mli b/vernac/mltop.mli
index 6633cb937..6633cb937 100644
--- a/toplevel/mltop.mli
+++ b/vernac/mltop.mli
diff --git a/toplevel/obligations.ml b/vernac/obligations.ml
index f4a786a73..ea2401b5c 100644
--- a/toplevel/obligations.ml
+++ b/vernac/obligations.ml
@@ -25,6 +25,8 @@ module NamedDecl = Context.Named.Declaration
 let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false)
 let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false)
 
+let get_fix_exn, stm_get_fix_exn = Hook.make ()
+
 let succfix (depth, fixrels) =
   (succ depth, List.map succ fixrels)
 
@@ -486,7 +488,7 @@ let declare_definition prg =
   let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None)
     (Evd.evar_universe_context_subst prg.prg_ctx) in
   let opaque = prg.prg_opaque in
-  let fix_exn = Stm.get_fix_exn () in
+  let fix_exn = Hook.get get_fix_exn () in
   let pl, ctx =
     Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) in
   let ce =
@@ -569,7 +571,7 @@ let declare_mutual_definition l =
   in
   (* Declare the recursive definitions *)
   let ctx = Evd.evar_context_universe_context first.prg_ctx in
-  let fix_exn = Stm.get_fix_exn () in
+  let fix_exn = Hook.get get_fix_exn () in
   let kns = List.map4 (!declare_fix_ref ~opaque (local, poly, kind) ctx)
     fixnames fixdecls fixtypes fiximps in
     (* Declare notations *)
diff --git a/toplevel/obligations.mli b/vernac/obligations.mli
index 80b689144..11366fe91 100644
--- a/toplevel/obligations.mli
+++ b/vernac/obligations.mli
@@ -24,6 +24,12 @@ val declare_definition_ref :
      Safe_typing.private_constants Entries.definition_entry -> Impargs.manual_implicits
        -> global_reference Lemmas.declaration_hook -> global_reference) ref
 
+(* This is a hack to make it possible for Obligations to craft a Qed
+ * behind the scenes.  The fix_exn the Stm attaches to the Future proof
+ * is not available here, so we provide a side channel to get it *)
+val stm_get_fix_exn : (unit -> Exninfo.iexn -> Exninfo.iexn) Hook.t
+
+
 val check_evars : env -> evar_map -> unit
 
 val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t
diff --git a/toplevel/record.ml b/vernac/record.ml
index c9b75129f..e1c99fa2a 100644
--- a/toplevel/record.ml
+++ b/vernac/record.ml
@@ -111,7 +111,8 @@ let typecheck_params_and_fields def id pl t ps nots fs =
       List.iter 
 	(function LocalRawDef (b, _) -> error default_binder_kind b
 	   | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls
-           | LocalPattern _ -> assert false) ps
+           | LocalPattern (loc,_,_) ->
+              Loc.raise ~loc (Stream.Error "pattern with quote not allowed in record parameters.")) ps
   in 
   let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in
   let newps = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) newps in
diff --git a/toplevel/record.mli b/vernac/record.mli
index c50e57786..c50e57786 100644
--- a/toplevel/record.mli
+++ b/vernac/record.mli
diff --git a/toplevel/search.ml b/vernac/search.ml
index 17a1eff72..6279b17ae 100644
--- a/toplevel/search.ml
+++ b/vernac/search.ml
@@ -367,7 +367,7 @@ let interface_search =
     let answer = {
       coq_object_prefix = prefix;
       coq_object_qualid = qualid;
-      coq_object_object = string_of_ppcmds (pr_lconstr_env env Evd.empty constr);
+      coq_object_object = constr;
     } in
     ans := answer :: !ans;
   in
diff --git a/toplevel/search.mli b/vernac/search.mli
index c9167c485..82b79f75d 100644
--- a/toplevel/search.mli
+++ b/vernac/search.mli
@@ -67,7 +67,7 @@ type 'a coq_object = {
 }
 
 val interface_search : ?glnum:int -> (search_constraint * bool) list ->
-  string coq_object list
+  constr coq_object list
 
 (** {6 Generic search function} *)
 
diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml
new file mode 100644
index 000000000..f843484f7
--- /dev/null
+++ b/vernac/topfmt.ml
@@ -0,0 +1,289 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Feedback
+open Pp
+
+(** Pp control also belongs here as the terminal is private to the toplevel *)
+
+type pp_global_params = {
+  margin : int;
+  max_indent : int;
+  max_depth : int;
+  ellipsis : string }
+
+(* Default parameters of pretty-printing *)
+
+let dflt_gp = {
+  margin     = 78;
+  max_indent = 50;
+  max_depth  = 50;
+  ellipsis   = "..." }
+
+(* A deeper pretty-printer to print proof scripts *)
+
+let deep_gp = {
+  margin     = 78;
+  max_indent = 50;
+  max_depth  = 10000;
+  ellipsis   = "..." }
+
+(* set_gp : Format.formatter -> pp_global_params -> unit
+ * set the parameters of a formatter *)
+
+let set_gp ft gp =
+  Format.pp_set_margin ft gp.margin ;
+  Format.pp_set_max_indent ft gp.max_indent ;
+  Format.pp_set_max_boxes ft gp.max_depth ;
+  Format.pp_set_ellipsis_text ft gp.ellipsis
+
+let set_dflt_gp ft = set_gp ft dflt_gp
+
+let get_gp ft =
+  { margin = Format.pp_get_margin ft ();
+    max_indent = Format.pp_get_max_indent ft ();
+    max_depth = Format.pp_get_max_boxes ft ();
+    ellipsis = Format.pp_get_ellipsis_text ft () }
+
+(* with_fp : 'a pp_formatter_params -> Format.formatter
+ * returns of formatter for given formatter functions *)
+
+let with_fp chan out_function flush_function =
+  let ft = Format.make_formatter out_function flush_function in
+  Format.pp_set_formatter_out_channel ft chan;
+  ft
+
+(* Output on a channel ch *)
+
+let with_output_to ch =
+  let ft = with_fp ch (output_substring ch) (fun () -> flush ch) in
+  set_gp ft deep_gp;
+  ft
+
+let std_ft = ref Format.std_formatter
+let _ = set_dflt_gp !std_ft
+
+let err_ft = ref Format.err_formatter
+let _ = set_gp !err_ft deep_gp
+
+let deep_ft = ref (with_output_to stdout)
+let _ = set_gp !deep_ft deep_gp
+
+(* For parametrization through vernacular *)
+let default = Format.pp_get_max_boxes !std_ft ()
+let default_margin = Format.pp_get_margin !std_ft ()
+
+let get_depth_boxes () = Some (Format.pp_get_max_boxes !std_ft ())
+let set_depth_boxes v =
+  Format.pp_set_max_boxes !std_ft (match v with None -> default | Some v -> v)
+
+let get_margin () = Some (Format.pp_get_margin !std_ft ())
+let set_margin v =
+  let v = match v with None -> default_margin | Some v -> v in
+  Format.pp_set_margin Format.str_formatter v;
+  Format.pp_set_margin !std_ft v;
+  Format.pp_set_margin !deep_ft v;
+  (* Heuristic, based on usage: the column on the right of max_indent
+     column is 20% of width, capped to 30 characters *)
+  let m = max (64 * v / 100) (v-30) in
+  Format.pp_set_max_indent Format.str_formatter m;
+  Format.pp_set_max_indent !std_ft m;
+  Format.pp_set_max_indent !deep_ft m
+
+(** Console display of feedback *)
+
+(** Default tags *)
+module Tag = struct
+
+  let error   = "message.error"
+  let warning = "message.warning"
+  let debug   = "message.debug"
+
+end
+
+type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit
+
+let msgnl_with fmt strm =
+  pp_with fmt (strm ++ fnl ());
+  Format.pp_print_flush fmt ()
+
+(* XXX: This is really painful! *)
+module Emacs = struct
+
+  (* Special chars for emacs, to detect warnings inside goal output *)
+  let emacs_quote_start = String.make 1 (Char.chr 254)
+  let emacs_quote_end   = String.make 1 (Char.chr 255)
+
+  let emacs_quote_err g =
+    hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end)
+
+  let emacs_quote_info_start = "<infomsg>"
+  let emacs_quote_info_end = "</infomsg>"
+
+  let emacs_quote_info g =
+    hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end)
+
+end
+
+open Emacs
+
+let  dbg_hdr = tag Tag.debug   (str "Debug:")   ++ spc ()
+let info_hdr = mt ()
+let warn_hdr = tag Tag.warning (str "Warning:") ++ spc ()
+let  err_hdr = tag Tag.error   (str "Error:")   ++ spc ()
+
+let make_body quoter info ?loc s =
+  let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in
+  quoter (hov 0 (loc ++ info ++ s))
+
+(* Generic logger *)
+let gen_logger dbg err ?loc level msg = match level with
+  | Debug   -> msgnl_with !std_ft (make_body dbg  dbg_hdr ?loc msg)
+  | Info    -> msgnl_with !std_ft (make_body dbg info_hdr ?loc msg)
+  (* XXX: What to do with loc here? *)
+  | Notice  -> msgnl_with !std_ft msg
+  | Warning -> Flags.if_warn (fun () ->
+               msgnl_with !err_ft (make_body err warn_hdr ?loc msg)) ()
+  | Error   -> msgnl_with !err_ft (make_body err  err_hdr ?loc msg)
+
+(** Standard loggers *)
+
+(* We provide a generic clear_log_backend callback for backends
+   wanting to do clenaup after the print.
+*)
+let std_logger_cleanup = ref (fun () -> ())
+
+let std_logger ?loc level msg =
+  gen_logger (fun x -> x) (fun x -> x) ?loc level msg;
+  !std_logger_cleanup ()
+
+(** Color logging. Moved from Ppstyle, it may need some more refactoring  *)
+
+(* Tag map for terminal style *)
+let default_tag_map () = let open Terminal in [
+  (* Local to console toplevel *)
+    "message.error"    , make ~bold:true ~fg_color:`WHITE ~bg_color:`RED ()
+  ; "message.warning"  , make ~bold:true ~fg_color:`WHITE ~bg_color:`YELLOW ()
+  ; "message.debug"    , make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA ()
+  (* Coming from the printer *)
+  ; "constr.evar"      , make            ~fg_color:`LIGHT_BLUE ()
+  ; "constr.keyword"   , make ~bold:true ()
+  ; "constr.type"      , make ~bold:true ~fg_color:`YELLOW ()
+  ; "constr.notation"  , make ~fg_color:`WHITE ()
+  (* ["constr"; "variable"] is not assigned *)
+  ; "constr.reference" , make ~fg_color:`LIGHT_GREEN ()
+  ; "constr.path"      , make ~fg_color:`LIGHT_MAGENTA ()
+  ; "module.definition", make ~bold:true ~fg_color:`LIGHT_RED ()
+  ; "module.keyword"   , make ~bold:true ()
+  ; "tactic.keyword"   , make ~bold:true ()
+  ; "tactic.primitive" , make ~fg_color:`LIGHT_GREEN ()
+  ; "tactic.string"    , make ~fg_color:`LIGHT_RED ()
+  ]
+
+let tag_map = ref CString.Map.empty
+
+let init_tag_map styles =
+  let set accu (name, st) = CString.Map.add name st accu in
+  tag_map := List.fold_left set !tag_map styles
+
+let clear_styles () =
+  tag_map := CString.Map.empty
+
+let parse_color_config file =
+  let styles = Terminal.parse file in
+  init_tag_map styles
+
+let dump_tags () = CString.Map.bindings !tag_map
+
+(** Not thread-safe. We should put a lock somewhere if we print from
+    different threads. Do we? *)
+let make_style_stack () =
+  (** Default tag is to reset everything *)
+  let empty = Terminal.make () in
+  let default_tag = Terminal.({
+      fg_color = Some `DEFAULT;
+      bg_color = Some `DEFAULT;
+      bold = Some false;
+      italic = Some false;
+      underline = Some false;
+      negative = Some false;
+    })
+  in
+  let style_stack = ref [] in
+  let peek () = match !style_stack with
+  | []      -> default_tag  (** Anomalous case, but for robustness *)
+  | st :: _ -> st
+  in
+  let push tag =
+    let style =
+      try CString.Map.find tag !tag_map
+      with | Not_found -> empty
+    in
+    (** Use the merging of the latest tag and the one being currently pushed.
+    This may be useful if for instance the latest tag changes the background and
+    the current one the foreground, so that the two effects are additioned. *)
+    let style = Terminal.merge (peek ()) style in
+    style_stack := style :: !style_stack;
+    Terminal.eval style
+  in
+  let pop _ = match !style_stack with
+  | []       -> (** Something went wrong, we fallback *)
+                Terminal.eval default_tag
+  | _ :: rem -> style_stack := rem;
+                Terminal.eval (peek ())
+  in
+  let clear () = style_stack := [] in
+  push, pop, clear
+
+let init_color_output () =
+  init_tag_map (default_tag_map ());
+  let push_tag, pop_tag, clear_tag = make_style_stack () in
+  std_logger_cleanup := clear_tag;
+  let tag_handler = {
+    Format.mark_open_tag   = push_tag;
+    Format.mark_close_tag  = pop_tag;
+    Format.print_open_tag  = ignore;
+    Format.print_close_tag = ignore;
+  } in
+  Format.pp_set_mark_tags !std_ft true;
+  Format.pp_set_mark_tags !err_ft true;
+  Format.pp_set_formatter_tag_functions !std_ft tag_handler;
+  Format.pp_set_formatter_tag_functions !err_ft tag_handler
+
+(* Rules for emacs:
+   - Debug/info: emacs_quote_info
+   - Warning/Error: emacs_quote_err
+   - Notice: unquoted
+ *)
+let emacs_logger = gen_logger emacs_quote_info emacs_quote_err
+
+(* Output to file, used only in extraction so a candidate for removal *)
+let ft_logger old_logger ft ?loc level mesg =
+  let id x = x in
+  match level with
+  | Debug   -> msgnl_with ft (make_body id  dbg_hdr mesg)
+  | Info    -> msgnl_with ft (make_body id info_hdr mesg)
+  | Notice  -> msgnl_with ft mesg
+  | Warning -> old_logger ?loc level mesg
+  | Error   -> old_logger ?loc level mesg
+
+let with_output_to_file fname func input =
+  (* XXX FIXME: redirect std_ft  *)
+  (* let old_logger = !logger in *)
+  let channel = open_out (String.concat "." [fname; "out"]) in
+  (* logger := ft_logger old_logger (Format.formatter_of_out_channel channel); *)
+  try
+    let output = func input in
+    (* logger := old_logger; *)
+    close_out channel;
+    output
+  with reraise ->
+    let reraise = Backtrace.add_backtrace reraise in
+    (* logger := old_logger; *)
+    close_out channel;
+    Exninfo.iraise reraise
diff --git a/lib/pp_control.mli b/vernac/topfmt.mli
index d26f89eb3..1555f80a9 100644
--- a/lib/pp_control.mli
+++ b/vernac/topfmt.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** Parameters of pretty-printing. *)
+(** Console printing options *)
 
 type pp_global_params = {
   margin : int;
@@ -20,13 +20,12 @@ val set_gp : Format.formatter -> pp_global_params -> unit
 val set_dflt_gp : Format.formatter -> unit
 val get_gp : Format.formatter -> pp_global_params
 
-
 (** {6 Output functions of pretty-printing. } *)
 
 val with_output_to : out_channel -> Format.formatter
 
-val std_ft : Format.formatter ref
-val err_ft : Format.formatter ref
+val std_ft  : Format.formatter ref
+val err_ft  : Format.formatter ref
 val deep_ft : Format.formatter ref
 
 (** {6 For parametrization through vernacular. } *)
@@ -36,3 +35,21 @@ val get_depth_boxes : unit -> int option
 
 val set_margin : int option -> unit
 val get_margin : unit -> int option
+
+(** Headers for tagging *)
+val err_hdr : Pp.std_ppcmds
+
+(** Console display of feedback *)
+val std_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit
+
+val emacs_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit
+
+val init_color_output : unit -> unit
+val clear_styles : unit -> unit
+val parse_color_config : string -> unit
+val dump_tags : unit -> (string * Terminal.style) list
+
+(** [with_output_to_file file f x] executes [f x] with logging
+    redirected to a file [file] *)
+val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b
+
diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib
new file mode 100644
index 000000000..283c095eb
--- /dev/null
+++ b/vernac/vernac.mllib
@@ -0,0 +1,18 @@
+Lemmas
+Himsg
+ExplainErr
+Class
+Locality
+Metasyntax
+Auto_ind_decl
+Search
+Indschemes
+Obligations
+Command
+Classes
+Record
+Assumptions
+Vernacinterp
+Mltop
+Topfmt
+Vernacentries
diff --git a/toplevel/vernacentries.ml b/vernac/vernacentries.ml
index 6d4d7ffa9..66796d1dc 100644
--- a/toplevel/vernacentries.ml
+++ b/vernac/vernacentries.ml
@@ -39,8 +39,9 @@ module NamedDecl = Context.Named.Declaration
 let (f_interp_redexp, interp_redexp_hook) = Hook.make ()
 
 let debug = false
-let prerr_endline x =
-  if debug then prerr_endline (x ()) else ()
+(* XXX Should move to a common library *)
+let vernac_pperr_endline pp =
+  if debug then Format.eprintf "@[%a@]@\n%!" Pp.pp_with (pp ()) else ()
 
 (* Misc *)
 
@@ -166,7 +167,7 @@ let show_match id =
 let print_path_entry p =
   let dir = pr_dirpath (Loadpath.logical p) in
   let path = str (Loadpath.physical p) in
-  (dir ++ str " " ++ tbrk (0, 0) ++ path)
+  Pp.hov 2 (dir ++ spc () ++ path)
 
 let print_loadpath dir =
   let l = Loadpath.get_load_paths () in
@@ -176,9 +177,8 @@ let print_loadpath dir =
     let filter p = is_dirpath_prefix_of dir (Loadpath.logical p) in
     List.filter filter l
   in
-  Pp.t (str "Logical Path:                 " ++
-                tab () ++ str "Physical path:" ++ fnl () ++
-                prlist_with_sep fnl print_path_entry l)
+  str "Logical Path / Physical path:" ++ fnl () ++
+    prlist_with_sep fnl print_path_entry l
 
 let print_modules () =
   let opened = Library.opened_libraries ()
@@ -517,14 +517,8 @@ let vernac_start_proof locality p kind l lettop =
 let qed_display_script = ref true
 
 let vernac_end_proof ?proof = function
-  | Admitted -> save_proof ?proof Admitted
-  | Proved (_,_) as e ->
-    if is_verbose () && !qed_display_script && !Flags.coqtop_ui then
-      Stm.show_script ?proof ();
-    save_proof ?proof e
-
-  (* A stupid macro that should be replaced by ``Exact c. Save.'' all along
-     the theories [??] *)
+  | Admitted          -> save_proof ?proof Admitted
+  | Proved (_,_) as e -> save_proof ?proof e
 
 let vernac_exact_proof c =
   (* spiwack: for simplicity I do not enforce that "Proof proof_term" is
@@ -1458,8 +1452,8 @@ let _ =
       optdepr  = false;
       optname  = "the printing depth";
       optkey   = ["Printing";"Depth"];
-      optread  = Pp_control.get_depth_boxes;
-      optwrite = Pp_control.set_depth_boxes }
+      optread  = Topfmt.get_depth_boxes;
+      optwrite = Topfmt.set_depth_boxes }
 
 let _ =
   declare_int_option
@@ -1467,8 +1461,8 @@ let _ =
       optdepr  = false;
       optname  = "the printing width";
       optkey   = ["Printing";"Width"];
-      optread  = Pp_control.get_margin;
-      optwrite = Pp_control.set_margin }
+      optread  = Topfmt.get_margin;
+      optwrite = Topfmt.set_margin }
 
 let _ =
   declare_bool_option
@@ -1874,6 +1868,7 @@ let vernac_bullet (bullet:Proof_global.Bullet.t) =
     Proof_global.Bullet.put p bullet)
 
 let vernac_show = let open Feedback in function
+  | ShowScript -> assert false  (* Only the stm knows the script *)
   | ShowGoal goalref ->
     let info = match goalref with
       | OpenSubgoals -> pr_open_subgoals ()
@@ -1888,7 +1883,6 @@ let vernac_show = let open Feedback in function
       Constrextern.with_implicits msg_notice (pr_nth_open_subgoal n)
   | ShowProof -> show_proof ()
   | ShowNode -> show_node ()
-  | ShowScript -> Stm.show_script ()
   | ShowExistentials -> show_top_evars ()
   | ShowUniverses -> show_universes ()
   | ShowTree -> show_prooftree ()
@@ -1915,6 +1909,12 @@ let vernac_check_guard () =
 
 exception End_of_input
 
+(* XXX: This won't properly set the proof mode, as of today, it is
+   controlled by the STM. Thus, we would need access information from
+   the classifier. The proper fix is to move it to the STM, however,
+   the way the proof mode is set there makes the task non trivial
+   without a considerable amount of refactoring.
+ *)
 let vernac_load interp fname =
   let interp x =
     let proof_mode = Proof_global.get_default_proof_mode_name () in
@@ -1940,18 +1940,47 @@ let vernac_load interp fname =
  * still parsed as the obsolete_locality grammar entry for retrocompatibility.
  * loc is the Loc.t of the vernacular command being interpreted. *)
 let interp ?proof ~loc locality poly c =
-  prerr_endline (fun () -> "interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c));
+  vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac c);
   match c with
-  (* Done later in this file *)
+  (* The below vernac are candidates for removal from the main type
+     and to be put into a new doc_command datatype: *)
+
   | VernacLoad _ -> assert false
+
+  (* Done later in this file *)
   | VernacFail _ -> assert false
   | VernacTime _ -> assert false
   | VernacRedirect _ -> assert false
   | VernacTimeout _ -> assert false
   | VernacStm _ -> assert false
 
+  (* The STM should handle that, but LOAD bypasses the STM... *)
+  | VernacAbortAll    -> CErrors.user_err  (str "AbortAll cannot be used through the Load command")
+  | VernacRestart     -> CErrors.user_err  (str "Restart cannot be used through the Load command")
+  | VernacUndo _      -> CErrors.user_err  (str "Undo cannot be used through the Load command")
+  | VernacUndoTo _    -> CErrors.user_err  (str "UndoTo cannot be used through the Load command")
+  | VernacBacktrack _ -> CErrors.user_err  (str "Backtrack cannot be used through the Load command")
+
+  (* Toplevel control *)
+  | VernacToplevelControl e -> raise e
+
+  (* Resetting *)
+  | VernacResetName _  -> anomaly (str "VernacResetName not handled by Stm")
+  | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm")
+  | VernacBack _       -> anomaly (str "VernacBack not handled by Stm")
+  | VernacBackTo _     -> anomaly (str "VernacBackTo not handled by Stm")
+
+  (* Horrible Hack that should die. *)
   | VernacError e -> raise e
 
+  (* This one is possible to handle here *)
+  | VernacAbort id    -> CErrors.user_err  (str "Abort cannot be used through the Load command")
+
+  (* Handled elsewhere *)
+  | VernacProgram _
+  | VernacPolymorphic _
+  | VernacLocal _ -> assert false
+
   (* Syntax *)
   | VernacSyntaxExtension (local,sl) ->
       vernac_syntax_extension locality local sl
@@ -2023,12 +2052,6 @@ let interp ?proof ~loc locality poly c =
   | VernacWriteState s -> vernac_write_state s
   | VernacRestoreState s -> vernac_restore_state s
 
-  (* Resetting *)
-  | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm")
-  | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm")
-  | VernacBack _ -> anomaly (str "VernacBack not handled by Stm")
-  | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm")
-
   (* Commands *)
   | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b
   | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids
@@ -2060,14 +2083,6 @@ let interp ?proof ~loc locality poly c =
   | VernacRegister (id, r) -> vernac_register id r
   | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n")
 
-  (* The STM should handle that, but LOAD bypasses the STM... *)
-  | VernacAbort id -> CErrors.user_err  (str "Abort cannot be used through the Load command")
-  | VernacAbortAll -> CErrors.user_err  (str "AbortAll cannot be used through the Load command")
-  | VernacRestart -> CErrors.user_err  (str "Restart cannot be used through the Load command")
-  | VernacUndo _ -> CErrors.user_err  (str "Undo cannot be used through the Load command")
-  | VernacUndoTo _ -> CErrors.user_err  (str "UndoTo cannot be used through the Load command")
-  | VernacBacktrack _ -> CErrors.user_err  (str "Backtrack cannot be used through the Load command")
-  
   (* Proof management *)
   | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false
   | VernacFocus n -> vernac_focus n
@@ -2090,17 +2105,10 @@ let interp ?proof ~loc locality poly c =
       Aux_file.record_in_aux_at loc "VernacProof" "tac:yes using:yes";
       vernac_set_end_tac tac; vernac_set_used_variables l
   | VernacProofMode mn -> Proof_global.set_proof_mode mn
-  (* Toplevel control *)
-  | VernacToplevelControl e -> raise e
 
   (* Extensions *)
   | VernacExtend (opn,args) -> Vernacinterp.call ?locality (opn,args)
 
-  (* Handled elsewhere *)
-  | VernacProgram _
-  | VernacPolymorphic _
-  | VernacLocal _ -> assert false
-
 (* Vernaculars that take a locality flag *)
 let check_vernac_supports_locality c l =
   match l, c with
@@ -2192,7 +2200,7 @@ let with_fail b f =
            | e ->
               let e = CErrors.push e in
               raise (HasFailed (CErrors.iprint
-                (ExplainErr.process_vernac_interp_error ~allow_uncaught:false ~with_header:false e))))
+                (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e))))
         ()
     with e when CErrors.noncritical e ->
       let (e, _) = CErrors.push e in
@@ -2225,7 +2233,7 @@ let interp ?(verbosely=true) ?proof (loc,c) =
         current_timeout := Some n;
         aux ?locality ?polymorphism isprogcmd v
     | VernacRedirect (s, (_,v)) ->
-         Feedback.with_output_to_file s (aux false) v
+         Topfmt.with_output_to_file s (aux false) v
     | VernacTime (_,v) ->
         System.with_time !Flags.time
           (aux ?locality ?polymorphism isprogcmd) v;
@@ -2259,6 +2267,3 @@ let interp ?(verbosely=true) ?proof (loc,c) =
   in
     if verbosely then Flags.verbosely (aux false) c
     else aux false c
-
-let () = Hook.set Stm.interp_hook interp
-let () = Hook.set Stm.with_fail_hook with_fail
diff --git a/toplevel/vernacentries.mli b/vernac/vernacentries.mli
index 7cdc8dd06..7cdc8dd06 100644
--- a/toplevel/vernacentries.mli
+++ b/vernac/vernacentries.mli
diff --git a/toplevel/vernacinterp.ml b/vernac/vernacinterp.ml
index f26ef460d..f26ef460d 100644
--- a/toplevel/vernacinterp.ml
+++ b/vernac/vernacinterp.ml
diff --git a/toplevel/vernacinterp.mli b/vernac/vernacinterp.mli
index 5149b5416..5149b5416 100644
--- a/toplevel/vernacinterp.mli
+++ b/vernac/vernacinterp.mli