Imported Upstream version 8.0pl1upstream/8.0pl1

61 files changed, 8071 insertions, 0 deletions

diff --git a/contrib/extraction/BUGS b/contrib/extraction/BUGS
new file mode 100644
index 00000000..7f3f59c1
--- /dev/null
+++ b/contrib/extraction/BUGS
@@ -0,0 +1,2 @@
+It's not a bug, it's a lack of feature !!
+Cf TODO.
diff --git a/contrib/extraction/CHANGES b/contrib/extraction/CHANGES
new file mode 100644
index 00000000..83ea4910
--- /dev/null
+++ b/contrib/extraction/CHANGES
@@ -0,0 +1,409 @@
+7.4 -> 8.0
+
+No revolution this time. Mostly "behind-the-scene" clean-up and bug-fixes, 
+but also a few steps toward a more user-friendly extraction:
+
+* syntax of extraction: 
+- The old   (Recursive) Extraction Module M.
+  is now    (Recursive) Extraction Library M.
+  The old name was misleading since this command only works with M being a 
+  library M.v, and not a module produced by interactive command Module M. 
+- The other commands 
+    Extraction foo.
+    Recursive Extraction foo bar.
+    Extraction "myfile.ml" foo bar. 
+  now accept that foo can be a module name instead of just a constant name. 
+
+* Support of type scheme axioms (i.e. axiom whose type is an arity 
+  (x1:X1)...(xn:Xn)s with s a sort). For example: 
+
+   Axiom myprod : Set -> Set -> Set.
+   Extract Constant myprod "'a" "'b" => "'a * 'b". 
+   Recursive Extraction myprod. 
+   -------> type ('a,'b) myprod = 'a * 'b		
+
+* More flexible support of axioms. When an axiom isn't realized via Extract 
+  Constant before extraction, a warning is produced (instead of an error), 
+  and the extracted code must be completed later by hand. To find what
+  needs to be completed, search for the following string: AXIOM TO BE REALIZED
+
+* Cosmetics: When extraction produces a file, it tells it. 
+
+* (Experimental) It is allowed to extract under a opened interactive module
+  (but still outside sections). Feature to be used with caution. 
+
+* A problem has been identified concerning .v files used as normal interactive 
+  modules, like in 
+    
+    <file A.v>
+    Definition foo :=O.
+    <End file A.v>
+
+    <at toplevel>
+    Require A.
+    Module M:=A
+    Extraction M.
+
+  I might try to support that in the future. In the meanwhile, the
+  current behaviour of extraction is to forbid this.
+
+* bug fixes: 
+- many concerning Records. 
+- a Stack Overflow with mutual inductive (PR#320)
+- some optimizations have been removed since they were not type-safe:
+  For example if e has type:  type 'x a = A
+  Then:       match e with A -> A     -----X---->    e
+  To be investigated further.
+
+
+7.3 -> 7.4
+
+* The two main new features: 
+  - Automatic generation of Obj.magic when the extracted code 
+  in Ocaml is not directly typable.
+  - An experimental extraction of Coq's new modules to Ocaml modules. 
+
+* Concerning those Obj.magic: 
+  - The extraction now computes the expected type of any terms. Then 
+  it compares it with the actual type of the produced code. And when 
+  a mismatch is found, a Obj.magic is inserted. 
+  
+  - As a rule, any extracted development that was compiling out of the box 
+  should not contain any Obj.magic. At the other hand, generation of 
+  Obj.magic is not optimized yet: there might be several of them at a place 
+  were one would have been enough. 
+  
+  - Examples of code needing those Obj.magic: 
+     * contrib/extraction/test_extraction.v in the Coq source
+     * in the users' contributions: 
+	Lannion
+	Lyon/CIRCUITS
+        Rocq/HIGMAN
+ 
+  - As a side-effect of this Obj.magic feature, we now print the types 
+  of the extracted terms, both in .ml files as commented documentation 
+  and in interfaces .mli files
+
+  - This feature hasn't been ported yet to Haskell. We are aware of 
+  some unsafe casting functions like "unsafeCoerce" on some Haskell implems.
+  So it will eventually be done.
+
+* Concerning the extraction of Coq's new modules: 
+  - Taking in account the new Coq's modules system has implied a *huge*
+  rewrite of most of the extraction code.
+
+  - The extraction core (translation from Coq to an abstract mini-ML) 
+  is now complete and fairly stable, and supports modules, modules type 
+  and functors and all that stuff.
+
+  - The ocaml pretty-print part, especially the renaming issue, is 
+  clearly weaker, and certainly still contains bugs. 
+
+  - Nothing done for translating these Coq Modules to Haskell.
+
+  - A temporary drawback of this module extraction implementation is that 
+  efficiency (especially extraction speed) has been somehow neglected.
+  To improve ...
+
+  - As an interesting side-effect, definitions are now printed according to 
+  the user's original order. No more of this "dependency-correct but weird"
+  order. In particular realized axioms via Extract Constant are now at their 
+  right place, and not at the beginning. 
+
+* Other news: 
+  
+  - Records are now printed using the Ocaml record syntax
+ 
+  - Syntax output toward Scheme. Quite funny, but quite experimental and 
+  not documented. I recommend using the bigloo compiler since it contains 
+  natively some pattern matching.
+
+  - the dummy constant "__" have changed. see README
+
+  - a few bug-fixes (#191 and others)
+
+7.2 -> 7.3
+
+* Improved documentation in the Reference Manual.
+
+* Theoretical bad news: 
+- a naughty example (see the end of test_extraction.v)
+forced me to stop eliminating lambdas and arguments corresponding to 
+so-called "arity" in the general case. 
+
+- The dummy constant used in extraction ( let prop = () in ocaml ) 
+may in some cases be applied to arguments. This problem is dealt by 
+generating sufficient abstraction before the (). 
+
+
+* Theoretical good news: 
+- there is now a mechanism that remove useless prop/arity lambdas at the 
+top of function declarations. If your function had signature 
+nat -> prop -> nat in the previous extraction, it will now be nat -> nat. 
+So the extractions of common terms should look very much like the old 
+V6.2 one, except in some particular cases (functions as parameters, partial 
+applications, etc). In particular the bad news above have nearly no 
+impact...
+
+
+* By the way there is no more "let prop = ()" in ocaml. Those () are
+directly inlined. And in Haskell the dummy constant is now __ (two
+underscore) and is defined by 
+__ = Prelude.error "Logical or arity value used"
+This dummy constant should never be evaluated when computing an
+informative value, thanks to the lazy strategy. Hence the error message. 
+
+
+* Syntax changes, see Documentation for details: 
+
+Extraction Language Ocaml.
+Extraction Language Haskell. 
+Extraction Language Toplevel.
+
+That fixes the target language of extraction. Default is Ocaml, even in the 
+coq toplevel: you can now do copy-paste from the coq toplevel without 
+renaming problems. Toplevel language is the ocaml pseudo-language used 
+previously used inside the coq toplevel: coq names are printed with the coq 
+way, i.e. with no renaming. 
+
+So there is no more particular commands for Haskell, like 
+Haskell Extraction "file" id. Just set your favourite language and go... 
+
+
+* Haskell extraction has been tested at last (and corrected...). 
+See specificities in Documentation. 
+
+
+* Extraction of CoInductive in Ocaml language is now correct: it uses the 
+Lazy.force and lazy features of Ocaml. 
+
+
+* Modular extraction in Ocaml is now far more readable: 
+instead of qualifying everywhere (A.foo), there are now some "open" at the 
+beginning of files. Possible clashes are dealt with. 
+
+
+* By default, any recursive function associated with an inductive type 
+(foo_rec and foo_rect when foo is inductive type) will now be inlined 
+in extracted code. 
+
+
+* A few constants are explicitely declared to be inlined in extracted code. 
+For the moment there are: 
+	Wf.Acc_rec
+	Wf.Acc_rect
+	Wf.well_founded_induction
+	Wf.well_founded_induction_type
+Those constants does not match the auto-inlining criterion based on strictness.
+Of course, you can still overide this behaviour via some Extraction NoInline. 
+
+* There is now a web page showing the extraction of all standard theories: 
+http://www.lri.fr/~letouzey/extraction
+
+
+7.1 -> 7.2 :
+
+* Syntax changes, see Documentation for more details: 
+
+Set/Unset Extraction Optimize. 
+
+Default is Set. This control all optimizations made on the ML terms 
+(mostly reduction of dummy beta/iota redexes, but also simplications on 
+Cases, etc). Put this option to Unset if you what a ML term as close as 
+possible to the Coq term.
+
+Set/Unset Extraction AutoInline. 
+
+Default in Set, so by default, the extraction mechanism feels free to 
+inline the bodies of some defined constants, according to some heuristics 
+like size of bodies, useness of some arguments, etc. Those heuristics are 
+not always perfect, you may want to disable this feature, do it by Unset. 
+
+Extraction Inline toto foo. 
+Extraction NoInline titi faa bor. 
+
+In addition to the automatic inline feature, you can now tell precisely to 
+inline some more constants by the Extraction Inline command. Conversely, 
+you can forbid the inlining of some specific constants by automatic inlining. 
+Those two commands enable a precise control of what is inlined and what is not. 
+
+Print Extraction Inline. 
+
+Sum up the current state of the table recording the custom inlings 
+(Extraction (No)Inline). 
+
+Reset Extraction Inline. 
+
+Put the table recording the custom inlings back to empty. 
+
+As a consequence, there is no more need for options inside the commands of 
+extraction: 
+
+Extraction foo. 
+Recursive Extraction foo bar. 
+Extraction "file" foo bar. 
+Extraction Module Mymodule. 
+Recursive Extraction Module Mymodule. 
+
+New: The last syntax extracts the module Mymodule and all the modules 
+it depends on. 
+
+You can also try the Haskell versions (not tested yet): 
+
+Haskell Extraction foo.
+Haskell Recursive Extraction foo bar.
+Haskell Extraction "file" foo bar.
+Haskell Extraction Module Mymodule.
+Haskell Recursive Extraction Module Mymodule.
+
+And there's still the realization syntax: 
+
+Extract Constant coq_bla => "caml_bla".
+Extract Inlined Constant coq_bla => "caml_bla".
+Extract Inductive myinductive => mycamlind [my_caml_constr1 ... ].
+
+Note that now, the Extract Inlined Constant command is sugar for an Extract 
+Constant followed by a Extraction Inline. So be careful with 
+Reset Extraction Inline. 
+
+ 
+
+* Lot of works around optimization of produced code. Should make code more 
+readable. 
+
+- fixpoint definitions : there should be no more stupid printings like 
+
+let foo x = 
+  let rec f x = 
+    .... (f y) ....
+  in f x
+
+but rather 
+
+let rec foo x = 
+  .... (foo y) .... 
+
+- generalized iota (in particular iota and permutation cases/cases):
+
+A generalized iota redex is a "Cases e of ...." where e is ok. 
+And the recursive predicate "ok" is given by:  
+e is ok if e is a Constructor or a Cases where all branches are ok.
+In the case of generalized iota redex, it might be good idea to reduce it, 
+so we do it. 
+Example: 
+
+match (match t with 
+         O -> Left
+       | S n -> match n with 
+                  O -> Right 
+                | S m -> Left) with 
+ Left -> blabla 
+| Right -> bloblo
+
+After simplification, that gives: 
+
+match t with 
+  O -> blabla
+| S n -> match n with 
+          O -> bloblo
+        | S n -> blabla
+
+As shown on the example, code duplication can occur. In practice 
+it seems not to happen frequently. 
+
+- "constant" case:
+In V7.1 we used to simplify cases where all branches are the same. 
+In V7.2 we can simplify in addition terms like 
+	cases e of 
+	  C1 x y -> f (C x y)
+	| C2 z -> f (C2 z) 
+If x y z don't occur in f, we can produce (f e). 
+
+- permutation cases/fun: 
+extracted code has frequenty functions in branches of cases: 
+
+let foo x = match x with 
+   O -> fun _ -> .... 
+ | S y -> fun _ -> .... 
+
+the optimization consist in lifting the common "fun _ ->", and that gives
+ 
+let foo x _ = match x with 
+   O -> .....
+ | S y -> ....
+ 
+
+* Some bug corrections (many thanks in particular to Michel Levy). 
+
+* Testing in coq contributions: 
+If you are interested in extraction, you can look at the extraction tests 
+I'have put in the following coq contributions 
+
+Bordeaux/Additions			computation of fibonacci(2000)
+Bordeaux/EXCEPTIONS			multiplication using exception.
+Bordeaux/SearchTrees			list -> binary tree. maximum.
+Dyade/BDDS				boolean tautology checker.
+Lyon/CIRCUITS				multiplication via a modelization of a circuit.
+Lyon/FIRING-SQUAD			print the states of the firing squad.
+Marseille/CIRCUITS			compares integers via a modelization of a circuit. 
+Nancy/FOUnify				unification of two first-orderde deux termes.
+Rocq/ARITH/Chinese			computation of the chinese remaindering.  
+Rocq/COC				small coc typechecker. (test by B. Barras, not by me)
+Rocq/HIGMAN				run the proof on one example. 
+Rocq/GRAPHS				linear constraints checker in Z. 
+Sophia-Antipolis/Stalmarck		boolean tautology checker.
+Suresnes/BDD				boolean tautology checker.
+
+Just do "make" in those contributions, the extraction test is integrated. 
+More tests will follow on more contributions.
+
+
+
+7.0 -> 7.1 : mostly bug corrections. No theoretical problems dealed with.
+
+* The semantics of Extract Constant changed: If you provide a extraction 
+for p by Extract Constant p => "0", your generated ML file will begin by 
+a let p = 0. The old semantics, which was to replace p everywhere by the
+provided terms, is still available via the Extract Inlined Constant p => 
+"0" syntax.
+
+
+* There are more optimizations applied to the generated code: 
+- identity cases: match e with P x y -> P x y | Q z -> Q z | ...
+is simplified into e. Especially interesting with the sumbool terms: 
+there will be no more match ... with Left -> Left | Right -> Right
+
+- constant cases: match e with P x y -> c | Q z -> c | ...
+is simplified into c as soon as x, y, z do not occur in c.
+So no more match ... with Left -> Left | Right -> Left.
+  
+
+* the extraction at Toplevel (Extraction foo and Recursive Extraction foo),
+which was only a development tool at the beginning, is now closer to 
+the real extraction to a file. In particular optimizations are done, 
+and constants like recursors ( ..._rec ) are expanded. 
+
+
+* the singleton optimization is now protected against circular type.
+( Remind : this optimization is the one that simplify 
+type 'a sig = Exists of 'a  into type 'a sig = 'a and 
+match e with (Exists c) -> d into let c = e in d ) 
+
+
+* Fixed one bug concerning casted code
+
+
+* The inductives generated should now have always correct type-var list 
+('a,'b,'c...)
+
+
+* Code cleanup until three days before release. Messing-up code 
+in the last three days before release.
+
+
+
+
+
+
+
+6.x -> 7.0 : Everything changed. See README
diff --git a/contrib/extraction/README b/contrib/extraction/README
new file mode 100644
index 00000000..7350365e
--- /dev/null
+++ b/contrib/extraction/README
@@ -0,0 +1,139 @@
+
+Status of Extraction in Coq version 7.x
+======================================
+
+(* 22 jan 2003 : Updated for version 7.4 *)
+
+
+J.C. Filliātre
+P. Letouzey
+
+
+
+Extraction code has been completely rewritten since version V6.3. 
+This work is still not finished, but most parts of it are already usable. 
+In consequence it is included in the Coq V7.0 final release. 
+But don't be mistaken: 
+
+	THIS WORK IS STILL EXPERIMENTAL !
+
+1) Principles 
+
+The main goal of the new extraction is to handle any Coq term, even 
+those upon sort Type, and to produce code that always compiles. 
+Thus it will never answer something like "Not an ML type", but rather
+a dummy term like the ML unit. 
+
+Translation between Coq and ML is based upon the following principles: 
+
+- Terms of sort Prop don't have any computational meaning, so they are
+merged into one ML term "__". This part is done according to P. Letouzey's 
+works (*) and (**).
+
+This dummy constant "__" used to be implemented by the unit (), but 
+we recently found that this constant might be applied in some cases. 
+So "__" is now in Ocaml a fixpoint that forgets its arguments: 
+
+           let __ = let rec f _ = Obj.repr f in Obj.repr f
+
+
+- Terms that are type schemes (i.e. something of type ( : )( : )...s with 
+s a sort ) don't have any ML counterpart at the term level, since they 
+are types transformers. In fact they do not have any computational
+meaning either. So we also merge them into that dummy term "__".
+
+- A Coq term gives a ML term or a ML type depending of its type: 
+type schemes will (try to) give ML types, and all other terms give ML terms.
+
+And the rest of the translation is (almost) straightforward: an inductive
+gives an inductive, etc...
+
+This gives ML code that have no special reason to typecheck, due 
+to the incompatibilities between Coq and ML typing systems. In fact
+most of the time everything goes right. For example, it is sufficient 
+to extract and compile everything in the "theories" directory 
+(cf test subdirectory).
+
+We now verify during extraction that the produced code is typecheckable, 
+and if it is not we insert unsafe type casting at critical points in the 
+code. For the moment, it is an Ocaml-only feature, using the "Obj.magic"
+function, but the same kind of trick will be soon made in Haskell.
+
+
+2) Differences with previous extraction (V6.3 and before)
+
+2.a) The pros 
+
+The ability to extract every Coq term, as explain in the previous 
+paragraph. 
+
+The ability to extract from a file an ML module (cf Extraction Module in the 
+documentation)
+
+You can have a taste of extraction directly at the toplevel by 
+using the "Extraction <ident>" or the "Recursive Extraction <ident>".
+This toplevel extraction was already there in V6.3, but was printing 
+Fw terms. It now prints in the language of your choice: 
+Ocaml, Haskell, Scheme, or an Ocaml-like with Coq namings. 
+
+The optimization done on extracted code has been ported between 
+V6.3 and V7 and enhanced, and in particular the mechanism of automatic
+expansion. 
+
+2.b) The cons 
+
+The presence of some parasite "__" as dummy arguments
+in functions. This denotes the rests of a proof part. The previous 
+extraction was able to remove them totally. The current implementation
+removes a good deal of them (more that in 7.0), but not all. 
+
+This problem is due to extraction upon Type.
+For example, let's take this pathological term: 
+	(if b then Set else Prop)  : Type
+The only way to know if this is an Set (to keep) or a Prop (to remove) 
+is to compute the boolean b, and we do not want to do that during 
+extraction. 
+
+There is no more "ML import" feature. You can compensate by using 
+Axioms, and then "Extract Constant ..." 
+
+3) Examples 
+
+The file "test-extraction.v" is made of some examples used while debugging.
+
+In the subdirectory "test", you can test extraction on the Coq theories.
+Go there.
+"make tree" to make a local copy of the "theories" tree
+"make" to extract & compile most of the theories file in Ocaml
+"make -f Makefile.haskell" to extract & compile in Haskell
+
+See also Reference Manual for explanation of extraction syntaxes
+and more examples. 
+
+
+(*):
+Exécution de termes de preuves: une nouvelle méthode d'extraction 
+pour le Calcul des Constructions Inductives, Pierre Letouzey,
+DEA thesis, 2000, 
+http://www.lri.fr/~letouzey/download/rapport_dea.ps.gz
+
+(**) 
+A New Extraction for Coq, Pierre Letouzey, 
+Types 2002 Post-Workshop Proceedings, to appear, 
+draft at http://www.lri.fr/~letouzey/download/extraction2002.ps.gz
+
+
+Any feedback is welcome: 
+Pierre.Letouzey@lri.fr
+Jean.Christophe.Filliatre@lri.fr
+
+
+
+
+
+
+
+
+
+
+
diff --git a/contrib/extraction/TODO b/contrib/extraction/TODO
new file mode 100644
index 00000000..174be06e
--- /dev/null
+++ b/contrib/extraction/TODO
@@ -0,0 +1,31 @@
+
+ 16. Haskell : 
+     - equivalent of Obj.magic (unsafeCoerce ?) 
+     - look again at the syntax (make it independant of layout ...)  
+     - producing .hi files
+     - modules/modules types/functors in Haskell ?
+
+ 17. Scheme : 
+     - modular Scheme ? 
+
+ 18. Improve speed (profiling)
+
+ 19. Look again at those hugly renamings functions. 
+     Especially get rid of ML clashes like 
+   
+    let t = 0
+    module M = struct 
+       let t = 1 
+       let u = The.External.t (* ?? *)
+    end
+
+ 20. Support the .v-as-internal-module, like in 
+    
+    <file A.v>
+    Definition foo :=O.
+    <End file A.v>
+
+    <at toplevel>
+    Require A.
+    Module M:=A
+    Extraction M.
\ No newline at end of file
diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml
new file mode 100644
index 00000000..53a2631e
--- /dev/null
+++ b/contrib/extraction/common.ml
@@ -0,0 +1,441 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: common.ml,v 1.51.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+open Pp
+open Util
+open Names
+open Term
+open Declarations
+open Nameops
+open Libnames
+open Table
+open Miniml
+open Modutil
+open Ocaml
+
+(*S Renamings. *)
+
+(*s Tables of global renamings *)
+
+let keywords = ref Idset.empty
+let global_ids = ref Idset.empty
+let modular = ref false
+
+(* For each [global_reference], this table will contain the different parts 
+   of its renamings, in [string list] form. *)
+let renamings = Hashtbl.create 97
+let rename r l = Hashtbl.add renamings r l
+let get_renamings r = Hashtbl.find renamings r 
+
+(* Idem for [module_path]. *)
+let mp_renamings = Hashtbl.create 97
+let mp_rename mp l = Hashtbl.add mp_renamings mp l
+let mp_get_renamings mp = Hashtbl.find mp_renamings mp 
+
+let modvisited = ref MPset.empty
+let modcontents = ref Gset.empty
+let add_module_contents mp s = modcontents := Gset.add (mp,s) !modcontents
+let module_contents mp s = Gset.mem (mp,s) !modcontents
+
+let to_qualify = ref Refset.empty
+
+let mod_1st_level = ref Idmap.empty
+
+(*s Uppercase/lowercase renamings. *) 
+
+let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false
+
+let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false
+
+(* This function creates from [id] a correct uppercase/lowercase identifier. 
+   This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes 
+   with previous [Coq_id] variable, these prefixes are duplicated if already 
+   existing. *)
+
+let modular_rename up id = 
+  let s = string_of_id id in
+  let prefix = if up then "Coq_" else "coq_" in 
+  let check = if up then is_upper else is_lower in 
+  if not (check s) ||
+    (Idset.mem id !keywords) ||
+    (String.length s >= 4 && String.sub s 0 4 = prefix) 
+  then prefix ^ s
+  else s
+
+let rename_module = modular_rename true 
+
+(* [clash mp0 l s mpl] checks if [mp0-l-s] can be printed as [l-s] when 
+   [mpl] is the context of visible modules. More precisely, we check if 
+   there exists a mp1, module (sub-)path of an element of [mpl], such as 
+   module [mp1-l] contains [s]. 
+   The verification stops if we encounter [mp1=mp0]. *)
+
+exception Stop 
+
+let clash mp0 l s mpl = 
+  let rec clash_one mp = match mp with
+    | _ when mp = mp0 -> raise Stop
+    | MPdot (mp',_) -> 
+	(module_contents (add_labels_mp mp l) s) || (clash_one mp') 
+    | mp when is_toplevel mp -> false
+    | _ -> module_contents (add_labels_mp mp l) s
+  in
+  let rec clash_list = function 
+    | [] -> false
+    | mp :: mpl -> (clash_one mp) || (clash_list mpl) 
+  in try clash_list mpl with Stop -> false
+
+(*s [contents_first_level mp] finds the names of the first-level objects 
+  exported by module [mp]. Nota: it might fail if [mp] isn't a directly 
+  visible module. Ex: [MPself] under functor, [MPbound], etc ... *)
+
+let contents_first_level mp = 
+  if not (MPset.mem mp !modvisited) then begin 
+    modvisited := MPset.add mp !modvisited; 
+    match (Global.lookup_module mp).mod_type with 
+      | MTBsig (msid,msb) -> 
+	  let add b id = add_module_contents mp (modular_rename b id) in 
+	  let upper_type = (lang () = Haskell) in
+	  List.iter 
+	    (function 
+	       | (l, SPBconst cb) -> 
+		   (match Extraction.constant_kind (Global.env ()) cb with 
+		      | Extraction.Logical -> () 
+		      | Extraction.Type -> add upper_type (id_of_label l)
+		      | Extraction.Term -> add false (id_of_label l))
+	       | (_, SPBmind mib) ->
+		   Array.iter 
+		     (fun mip -> if mip.mind_sort <> (Prop Null) then begin
+			add upper_type mip.mind_typename; 
+			Array.iter (add true) mip.mind_consnames
+		      end)
+		     mib.mind_packets
+	       | _ -> ())
+	    (Modops.subst_signature_msid msid mp msb)
+      | _ -> ()
+  end
+
+(*s Initial renamings creation, for modular extraction. *) 
+
+let rec mp_create_modular_renamings mp = 
+  try mp_get_renamings mp 
+  with Not_found -> 
+    let ren = match mp with 
+      | MPdot (mp,l) -> 
+	  (rename_module (id_of_label l)) :: (mp_create_modular_renamings mp)
+      | MPself msid -> [rename_module (id_of_msid msid)]
+      | MPbound mbid -> [rename_module (id_of_mbid mbid)]
+      | MPfile f -> [String.capitalize (string_of_id (List.hd (repr_dirpath f)))]
+    in mp_rename mp ren; ren
+
+
+let create_modular_renamings struc = 
+  let current_module = fst (List.hd struc) in 
+  let modfiles = ref MPset.empty in 
+  let { up = u ; down = d } = struct_get_references_set struc 
+  in 
+  (* 1) creates renamings of objects *)
+  let add upper r = 
+    let mp = modpath (kn_of_r r) in 
+    let l = mp_create_modular_renamings mp in 
+    let s = modular_rename upper (id_of_global r) in 
+    global_ids := Idset.add (id_of_string s) !global_ids;    
+    rename r (s::l); 
+    begin try 
+      let mp = modfile_of_mp mp in 
+      if mp <> current_module then modfiles := MPset.add mp !modfiles
+    with Not_found -> () 
+    end; 
+  in
+  Refset.iter (add true) u; 
+  Refset.iter (add false) d; 
+  
+  (* 2) determines the opened libraries. *)
+  let used_modules = MPset.elements !modfiles in 
+
+  (* [s] will contain all first-level sub-modules of [cur_mp] *)
+  let s = ref Stringset.empty in 
+  begin 
+    let add l = s := Stringset.add (rename_module (id_of_label l)) !s in 
+    match (Global.lookup_module current_module).mod_type with 
+      | MTBsig (_,msb) ->
+	  List.iter (function (l,SPBmodule _) -> add l | _ -> ()) msb
+      | _ -> ()
+  end;
+  (* We now compare [s] with the modules coming from [used_modules]. *)
+  List.iter 
+    (function 
+       | MPfile d -> 
+	   let s_mp = 
+	     String.capitalize (string_of_id (List.hd (repr_dirpath d))) in 
+	   if Stringset.mem s_mp !s then error_module_clash s_mp 
+	   else s:= Stringset.add s_mp !s 
+       | _ -> assert false)
+    used_modules;
+
+  (* 3) determines the potential clashes *)
+  List.iter contents_first_level used_modules; 
+  let used_modules' = List.rev used_modules in 
+  let needs_qualify r = 
+    let mp = modpath (kn_of_r r) in 
+    if (is_modfile mp) && mp <> current_module && 
+      (clash mp [] (List.hd (get_renamings r)) used_modules')
+    then to_qualify := Refset.add r !to_qualify
+  in
+  Refset.iter needs_qualify u;
+  Refset.iter needs_qualify d; 
+  used_modules
+
+(*s Initial renamings creation, for monolithic extraction. *)
+
+let begins_with_CoqXX s = 
+  (String.length s >= 4) && 
+  (String.sub s 0 3 = "Coq") &&
+  (try 
+     for i = 4 to (String.index s '_')-1 do 
+       match s.[i] with 
+	 | '0'..'9' -> () 
+	 | _ -> raise Not_found
+     done; 
+     true
+   with Not_found -> false)
+
+let mod_1st_level_rename l =
+  let coqid = id_of_string "Coq" in 
+  let id = id_of_label l in 
+  try 
+    let coqset = Idmap.find id !mod_1st_level in 
+    let nextcoq = next_ident_away coqid coqset in 
+    mod_1st_level := Idmap.add id (nextcoq::coqset) !mod_1st_level; 
+    (string_of_id nextcoq)^"_"^(string_of_id id) 
+  with Not_found -> 
+    let s = string_of_id id in 
+    if is_lower s || begins_with_CoqXX s then
+      (mod_1st_level := Idmap.add id [coqid] !mod_1st_level; "Coq_"^s)
+    else
+      (mod_1st_level := Idmap.add id [] !mod_1st_level; s)
+
+let rec mp_create_mono_renamings mp = 
+  try mp_get_renamings mp 
+  with Not_found -> 
+    let ren = match mp with 
+       | _ when (at_toplevel mp) -> [""]
+       | MPdot (mp,l) -> 
+	   let lmp = mp_create_mono_renamings mp in
+	   if lmp = [""] then (mod_1st_level_rename l)::lmp
+	   else (rename_module (id_of_label l))::lmp
+       | MPself msid -> [rename_module (id_of_msid msid)]
+       | MPbound mbid -> [rename_module (id_of_mbid mbid)]
+       | _ -> assert false
+    in mp_rename mp ren; ren
+
+let create_mono_renamings struc = 
+  let { up = u ; down = d } = struct_get_references_list struc in 
+  let add upper r = 
+    let mp = modpath (kn_of_r r) in 
+    let l = mp_create_mono_renamings mp in
+    let mycase = if upper then uppercase_id else lowercase_id in 
+    let id = 
+      if l = [""] then 
+	next_ident_away (mycase (id_of_global r)) (Idset.elements !global_ids)
+      else id_of_string (modular_rename upper (id_of_global r))
+    in 
+    global_ids := Idset.add id !global_ids;    
+    rename r ((string_of_id id)::l) 
+  in
+  List.iter (add true) (List.rev u); 
+  List.iter (add false) (List.rev d)
+		    
+(*s Renaming issues at toplevel *)
+
+module TopParams = struct
+  let globals () = Idset.empty
+  let pp_global _ r = pr_id (id_of_global r)
+  let pp_module _ mp = str (string_of_mp mp)
+end
+
+(*s Renaming issues for a monolithic or modular extraction. *)
+
+module StdParams = struct
+
+  let globals () = !global_ids
+
+  (* TODO: remettre des conditions [lang () = Haskell] disant de qualifier. *)
+
+  let rec dottify = function 
+    | [] -> assert false 
+    | [s] -> s 
+    | s::[""] -> s 
+    | s::l -> (dottify l)^"."^s
+
+  let pp_global mpl r = 
+    let ls = get_renamings r in 
+    let s = List.hd ls in 
+    let mp = modpath (kn_of_r r) in 
+    let ls = 
+      if mp = List.hd mpl then [s] (* simpliest situation *)
+      else 
+	try (* has [mp] something in common with one of those in [mpl] ? *)
+	  let pref = common_prefix_from_list mp mpl in 
+	  (*i TODO: possibilité de clash i*)
+	  list_firstn ((mp_length mp)-(mp_length pref)+1) ls
+	with Not_found -> (* [mp] is othogonal with every element of [mp]. *)
+	  let base = base_mp mp in 
+	  if !modular &&  
+	    (at_toplevel mp) && 
+	    not (Refset.mem r !to_qualify) && 
+	    not (clash base [] s mpl) 
+	  then snd (list_sep_last ls)
+	  else ls
+    in 
+    add_module_contents mp s; (* update the visible environment *)
+    str (dottify ls)
+
+  let pp_module mpl mp = 
+    let ls = 
+      if !modular 
+      then mp_create_modular_renamings mp 
+      else mp_create_mono_renamings mp 
+    in 
+    let ls = 
+      try (* has [mp] something in common with one of those in [mpl] ? *)
+	let pref = common_prefix_from_list mp mpl in 
+	(*i TODO: clash possible i*)
+	list_firstn ((mp_length mp)-(mp_length pref)) ls
+      with Not_found -> (* [mp] is othogonal with every element of [mp]. *)
+	let base = base_mp mp in 
+	if !modular && (at_toplevel mp) 
+	then snd (list_sep_last ls)
+	else ls
+    in str (dottify ls) 
+
+end
+
+module ToplevelPp = Ocaml.Make(TopParams)
+module OcamlPp = Ocaml.Make(StdParams)
+module HaskellPp = Haskell.Make(StdParams)
+module SchemePp = Scheme.Make(StdParams)
+
+let pp_decl mp d = match lang () with 
+  | Ocaml -> OcamlPp.pp_decl mp d 
+  | Haskell -> HaskellPp.pp_decl mp d
+  | Scheme -> SchemePp.pp_decl mp d 
+  | Toplevel -> ToplevelPp.pp_decl mp d 
+
+let pp_struct s = match lang () with 
+  | Ocaml -> OcamlPp.pp_struct s 
+  | Haskell -> HaskellPp.pp_struct s
+  | Scheme -> SchemePp.pp_struct s
+  | Toplevel -> ToplevelPp.pp_struct s
+
+let pp_signature s = match lang () with 
+  | Ocaml -> OcamlPp.pp_signature s 
+  | Haskell -> HaskellPp.pp_signature s
+  | _ -> assert false
+
+let set_keywords () =
+  (match lang () with 
+    | Ocaml -> keywords := Ocaml.keywords
+    | Haskell -> keywords := Haskell.keywords
+    | Scheme -> keywords := Scheme.keywords
+    | Toplevel -> keywords := Idset.empty);
+  global_ids := !keywords; 
+  to_qualify := Refset.empty
+    
+let preamble prm = match lang () with 
+  | Ocaml -> Ocaml.preamble prm   
+  | Haskell -> Haskell.preamble prm
+  | Scheme -> Scheme.preamble prm
+  | Toplevel -> (fun _ _ -> mt ())
+
+let preamble_sig prm = match lang () with 
+  | Ocaml -> Ocaml.preamble_sig prm   
+  | _ -> assert false
+
+(*S Extraction of one decl to stdout. *)
+
+let print_one_decl struc mp decl = 
+  set_keywords (); 
+  modular := false; 
+  create_mono_renamings struc;
+  msgnl (pp_decl [mp] decl)
+
+(*S Extraction to a file. *)
+
+let info f = 
+  Options.if_verbose msgnl 
+    (str ("The file "^f^" has been created by extraction."))
+
+let print_structure_to_file f prm struc =
+  cons_cofix := Refset.empty;
+  Hashtbl.clear renamings;
+  mod_1st_level := Idmap.empty; 
+  modcontents := Gset.empty;
+  modvisited := MPset.empty; 
+  set_keywords ();
+  modular := prm.modular; 
+  let used_modules =
+    if lang () = Toplevel then []
+    else if prm.modular then create_modular_renamings struc
+    else (create_mono_renamings struc; [])
+  in 
+  let print_dummys =
+    (struct_ast_search MLdummy struc, 
+     struct_type_search Tdummy struc, 
+     struct_type_search Tunknown struc)
+  in
+  (* print the implementation *)
+  let cout = option_app (fun (f,_) -> open_out f) f in 
+  let ft = match cout with 
+    | None -> !Pp_control.std_ft
+    | Some cout -> Pp_control.with_output_to cout in 
+  begin try 
+    msg_with ft (preamble prm used_modules print_dummys);
+    msg_with ft (pp_struct struc);
+    option_iter close_out cout; 
+  with e -> 
+    option_iter close_out cout; raise e
+  end;
+  option_iter (fun (f,_) -> info f) f;
+  (* print the signature *)
+  match f with 
+    | Some (_,f) when lang () = Ocaml -> 
+	let cout = open_out f in
+	let ft = Pp_control.with_output_to cout in
+	begin try 
+	  msg_with ft (preamble_sig prm used_modules print_dummys);
+	  msg_with ft (pp_signature (signature_of_structure struc));
+	  close_out cout;
+	with e -> 
+	  close_out cout; raise e 
+	end; 
+	info f 
+    | _ -> ()
+	  
+
+(*i 
+  (* DO NOT REMOVE: used when making names resolution *)
+  let cout = open_out (f^".ren") in 
+  let ft = Pp_control.with_output_to cout in
+  Hashtbl.iter 
+    (fun r id -> 
+       if short_module r = !current_module then 
+	 msgnl_with ft (pr_id id ++ str " " ++ pr_sp (sp_of_r r)))
+    renamings;
+  pp_flush_with ft ();
+  close_out cout;
+i*)    
+
+
+
+
+
+
+
diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli
new file mode 100644
index 00000000..3e5efa0c
--- /dev/null
+++ b/contrib/extraction/common.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: common.mli,v 1.19.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+open Names
+open Miniml
+open Mlutil
+
+val print_one_decl :
+  ml_structure -> module_path -> ml_decl -> unit
+
+val print_structure_to_file : 
+  (string * string) option -> extraction_params -> ml_structure -> unit
+
+
diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml
new file mode 100644
index 00000000..d725a1d7
--- /dev/null
+++ b/contrib/extraction/extract_env.ml
@@ -0,0 +1,382 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: extract_env.ml,v 1.74.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+open Term
+open Declarations
+open Names
+open Libnames
+open Pp
+open Util
+open Miniml
+open Table
+open Extraction
+open Modutil
+open Common
+
+(*s Obtaining Coq environment. *)
+
+let toplevel_env () = 
+  let seg = Lib.contents_after None in 
+  let get_reference = function 
+    | (_,kn), Lib.Leaf o ->
+	let mp,_,l = repr_kn kn in 
+	let seb = match Libobject.object_tag o with
+	  | "CONSTANT" -> SEBconst (Global.lookup_constant kn)
+	  | "INDUCTIVE" -> SEBmind (Global.lookup_mind kn) 
+	  | "MODULE" -> SEBmodule (Global.lookup_module (MPdot (mp,l)))
+	  | "MODULE TYPE" -> SEBmodtype (Global.lookup_modtype kn)
+	  | _ -> failwith "caught"
+	in l,seb
+    | _ -> failwith "caught"
+  in 
+  match current_toplevel () with 
+    | MPself msid -> MEBstruct (msid, List.rev (map_succeed get_reference seg))
+    | _ -> assert false
+
+let environment_until dir_opt = 
+  let rec parse = function 
+    | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()]
+    | [] -> [] 
+    | d :: l -> 
+	match (Global.lookup_module (MPfile d)).mod_expr with 
+	  | Some meb -> 
+	      if dir_opt = Some d then [MPfile d, meb]
+	      else (MPfile d, meb) :: (parse l)
+	  | _ -> assert false
+  in parse (Library.loaded_libraries ())
+
+type visit = { mutable kn : KNset.t; mutable mp : MPset.t }
+
+let in_kn v kn = KNset.mem kn v.kn
+let in_mp v mp = MPset.mem mp v.mp
+
+let visit_mp v mp = v.mp <- MPset.union (prefixes_mp mp) v.mp
+let visit_kn v kn = v.kn <- KNset.add kn v.kn; visit_mp v (modpath kn)
+let visit_ref v r = visit_kn v (kn_of_r r) 
+
+exception Impossible
+
+let check_arity env cb = 
+  if Reduction.is_arity env cb.const_type then raise Impossible
+
+let check_fix env cb i = 
+  match cb.const_body with 
+    | None -> raise Impossible
+    | Some lbody -> 
+	match kind_of_term (Declarations.force lbody) with 
+	  | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd)
+	  | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd)
+	  | _ -> raise Impossible
+
+let factor_fix env l cb msb = 
+  let _,recd as check = check_fix env cb 0 in 
+  let n = Array.length (let fi,_,_ = recd in fi) in
+  if n = 1 then [|l|], recd, msb
+  else begin 
+    if List.length msb < n-1 then raise Impossible; 
+    let msb', msb'' = list_chop (n-1) msb in 
+    let labels = Array.make n l in 
+    list_iter_i 
+      (fun j -> 
+	 function 
+	   | (l,SEBconst cb') -> 
+	       if check <> check_fix env cb' (j+1) then raise Impossible; 
+	       labels.(j+1) <- l; 
+	   | _ -> raise Impossible) msb'; 
+    labels, recd, msb''
+  end
+
+let get_decl_references v d = 
+  let f = visit_ref v in decl_iter_references f f f d
+
+let get_spec_references v s = 
+  let f = visit_ref v in spec_iter_references f f f s
+
+let rec extract_msig env v mp = function 
+  | [] -> [] 
+  | (l,SPBconst cb) :: msig -> 
+      let kn = make_kn mp empty_dirpath l in 
+      let s = extract_constant_spec env kn cb in 
+      if logical_spec s then extract_msig env v mp msig
+      else begin
+	get_spec_references v s; 
+	(l,Spec s) :: (extract_msig env v mp msig)
+      end
+  | (l,SPBmind cb) :: msig -> 
+      let kn = make_kn mp empty_dirpath l in 
+      let s = Sind (kn, extract_inductive env kn) in 
+      if logical_spec s then extract_msig env v mp msig
+      else begin 
+	get_spec_references v s; 
+	(l,Spec s) :: (extract_msig env v mp msig)
+      end
+  | (l,SPBmodule {msb_modtype=mtb}) :: msig -> 
+(*i      let mpo = Some (MPdot (mp,l)) in  i*)
+      (l,Smodule (extract_mtb env v None (*i mpo i*) mtb)) :: (extract_msig env v mp msig)
+  | (l,SPBmodtype mtb) :: msig -> 
+      (l,Smodtype (extract_mtb env v None mtb)) :: (extract_msig env v mp msig)
+
+and extract_mtb env v mpo = function 
+  | MTBident kn -> visit_kn v kn; MTident kn 
+  | MTBfunsig (mbid, mtb, mtb') -> 
+      let mp = MPbound mbid in 
+      let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in 
+      MTfunsig (mbid, extract_mtb env v None mtb, 
+		extract_mtb env' v None mtb') 
+  | MTBsig (msid, msig) -> 
+      let mp, msig = match mpo with 
+	| None -> MPself msid, msig
+	| Some mp -> mp, Modops.subst_signature_msid msid mp msig
+      in
+      let env' = Modops.add_signature mp msig env in 
+      MTsig (msid, extract_msig env' v mp msig) 
+
+let rec extract_msb env v mp all = function 
+  | [] -> [] 
+  | (l,SEBconst cb) :: msb -> 
+      (try 
+	 let vl,recd,msb = factor_fix env l cb msb in 
+	 let vkn = Array.map (fun id -> make_kn mp empty_dirpath id) vl in
+	 let ms = extract_msb env v mp all msb in 
+	 let b = array_exists (in_kn v) vkn in 
+	 if all || b then 
+	   let d = extract_fixpoint env vkn recd in 
+	   if (not b) && (logical_decl d) then ms 
+	   else begin get_decl_references v d; (l,SEdecl d) :: ms end
+	 else ms
+       with Impossible ->
+	 let ms = extract_msb env v mp all msb in 
+	 let kn = make_kn mp empty_dirpath l in 
+	 let b = in_kn v kn in 
+	 if all || b then 
+	   let d = extract_constant env kn cb in
+	   if (not b) && (logical_decl d) then ms 
+	   else begin get_decl_references v d; (l,SEdecl d) :: ms end
+	 else ms)
+  | (l,SEBmind mib) :: msb ->
+      let ms = extract_msb env v mp all msb in
+      let kn = make_kn mp empty_dirpath l in 
+      let b = in_kn v kn in 
+      if all || b then 
+	let d = Dind (kn, extract_inductive env kn) in 
+	if (not b) && (logical_decl d) then ms 
+	else begin get_decl_references v d; (l,SEdecl d) :: ms end
+      else ms
+  | (l,SEBmodule mb) :: msb -> 
+      let ms = extract_msb env v mp all msb in
+      let mp = MPdot (mp,l) in 
+      if all || in_mp v mp then 
+	(l,SEmodule (extract_module env v mp true mb)) :: ms
+      else ms
+  | (l,SEBmodtype mtb) :: msb ->
+      let ms = extract_msb env v mp all msb in
+      let kn = make_kn mp empty_dirpath l in
+      if all || in_kn v kn then 
+	(l,SEmodtype (extract_mtb env v None mtb)) :: ms
+      else ms
+
+and extract_meb env v mpo all = function 
+  | MEBident (MPfile d) -> error_MPfile_as_mod d (* temporary (I hope) *)
+  | MEBident mp -> visit_mp v mp; MEident mp 
+  | MEBapply (meb, meb',_) -> 
+      MEapply (extract_meb env v None true meb, 
+	       extract_meb env v None true meb')
+  | MEBfunctor (mbid, mtb, meb) -> 
+      let mp = MPbound mbid in 
+      let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in 
+      MEfunctor (mbid, extract_mtb env v None mtb, 
+		 extract_meb env' v None true meb)
+  | MEBstruct (msid, msb) -> 
+      let mp,msb = match mpo with 
+	| None -> MPself msid, msb 
+	| Some mp -> mp, subst_msb (map_msid msid mp) msb
+      in 
+      let env' = add_structure mp msb env in 
+      MEstruct (msid, extract_msb env' v mp all msb) 
+
+and extract_module env v mp all mb = 
+  (* [mb.mod_expr <> None ], since we look at modules from outside. *)
+  (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *)
+  let meb = out_some mb.mod_expr in
+  let mtb = match mb.mod_user_type with None -> mb.mod_type | Some mt -> mt in
+  (* Because of the "with" construct, the module type can be [MTBsig] with *)
+  (* a msid different from the one of the module. Here is the patch. *)
+  let mtb = replicate_msid meb mtb in
+  { ml_mod_expr = extract_meb env v (Some mp) all meb;
+    ml_mod_type = extract_mtb env v None mtb }
+
+let unpack = function MEstruct (_,sel) -> sel | _ -> assert false 
+
+let mono_environment refs mpl = 
+  let l = environment_until None in 
+  let v = 
+    let add_kn r = KNset.add (kn_of_r r) in 
+    let kns = List.fold_right add_kn refs KNset.empty in 
+    let add_mp mp = MPset.union (prefixes_mp mp) in
+    let mps = List.fold_right add_mp mpl MPset.empty in 
+    let mps = KNset.fold (fun k -> add_mp (modpath k)) kns mps in 
+    { kn = kns; mp = mps }
+  in 
+  let env = Global.env () in 
+  List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) false m)) 
+    (List.rev l)
+
+(*s Recursive extraction in the Coq toplevel. The vernacular command is
+    \verb!Recursive Extraction! [qualid1] ... [qualidn]. We use [extract_env]
+    to get the saturated environment to extract. *)
+
+let mono_extraction (f,m) qualids = 
+  check_inside_section (); 
+  check_inside_module ();
+  let rec find = function 
+    | [] -> [],[]
+    | q::l -> 
+	let refs,mps = find l in 
+	try 
+	  let mp = Nametab.locate_module (snd (qualid_of_reference q))
+	  in refs,(mp::mps)
+	with Not_found -> (Nametab.global q)::refs, mps 
+  in 	    
+  let refs,mps = find qualids in
+  let prm = {modular=false; mod_name = m; to_appear= refs} in
+  let struc = optimize_struct prm None (mono_environment refs mps) in 
+  print_structure_to_file f prm struc; 
+  reset_tables ()
+
+let extraction_rec = mono_extraction (None,id_of_string "Main")
+
+(*s Extraction in the Coq toplevel. We display the extracted term in
+    Ocaml syntax and we use the Coq printers for globals. The
+    vernacular command is \verb!Extraction! [qualid]. *)
+
+let extraction qid = 
+  check_inside_section (); 
+  check_inside_module ();
+  try 
+    let _ = Nametab.locate_module (snd (qualid_of_reference qid)) in 
+    extraction_rec [qid]
+  with Not_found -> 
+    let r = Nametab.global qid in 
+    if is_custom r then
+      msgnl (str "User defined extraction:" ++ spc () ++ 
+	     str (find_custom r) ++ fnl ()) 
+    else begin 
+      let prm = 
+	{ modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in 
+      let kn = kn_of_r r in 
+      let struc = optimize_struct prm None (mono_environment [r] []) in 
+      let d = get_decl_in_structure r struc in 
+      print_one_decl struc (modpath kn) d;
+      reset_tables ()
+    end
+
+(*s Extraction to a file (necessarily recursive). 
+    The vernacular command is 
+    \verb!Extraction "file"! [qualid1] ... [qualidn].*)
+
+let lang_suffix () = match lang () with 
+  | Ocaml -> ".ml",".mli"
+  | Haskell -> ".hs",".hi"
+  | Scheme -> ".scm",".scm"
+  | Toplevel -> assert false
+
+let filename f = 
+  let s,s' = lang_suffix () in
+  if Filename.check_suffix f s then 
+    let f' = Filename.chop_suffix f s in 
+    Some (f,f'^s'),id_of_string f' 
+  else Some (f^s,f^s'),id_of_string f
+
+let extraction_file f vl =
+  if lang () = Toplevel then error_toplevel () 
+  else mono_extraction (filename f) vl
+
+(*s Extraction of a module at the toplevel. *)
+
+let extraction_module m = 
+  check_inside_section (); 
+  check_inside_module ();
+  match lang () with 
+    | Toplevel -> error_toplevel ()
+    | Scheme -> error_scheme ()
+    | _ -> 
+	let q = snd (qualid_of_reference m) in 
+	let mp = 
+	  try Nametab.locate_module q
+	  with Not_found -> error_unknown_module q
+	in 
+	let b = is_modfile mp in 
+	let prm = {modular=b; mod_name = id_of_string ""; to_appear= []} in
+	let l = environment_until None in 
+	let v = { kn = KNset.empty ; mp = prefixes_mp mp } in
+	let env = Global.env () in 
+	let struc = 
+	  List.rev_map
+	    (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) b m)) 
+	    (List.rev l)
+	in 
+	let struc = optimize_struct prm None struc in 
+	let struc = 
+	  let bmp = base_mp mp in 
+	  try [bmp, List.assoc bmp struc] with Not_found -> assert false
+	in
+	print_structure_to_file None prm struc; 
+	reset_tables ()
+
+(*s (Recursive) Extraction of a library. The vernacular command is 
+  \verb!(Recursive) Extraction Library! [M]. *) 
+
+let module_file_name m = match lang () with 
+  | Ocaml -> let f = String.uncapitalize (string_of_id m) in  f^".ml", f^".mli"
+  | Haskell -> let f = String.capitalize (string_of_id m) in f^".hs", f^".hi"
+  | _ -> assert false
+
+let dir_module_of_id m = 
+  let q = make_short_qualid m in 
+  try Nametab.full_name_module q with Not_found -> error_unknown_module q
+
+let extraction_library is_rec m =
+  check_inside_section (); 
+  check_inside_module ();  
+  match lang () with 
+    | Toplevel -> error_toplevel ()
+    | Scheme -> error_scheme ()
+    | _ -> 
+	let dir_m = dir_module_of_id m in 
+	let v = { kn = KNset.empty; mp = MPset.singleton (MPfile dir_m) } in 
+	let l = environment_until (Some dir_m) in 
+	let struc = 
+	  let env = Global.env () in
+	  let select l (mp,meb) = 
+	    if in_mp v mp (* [mp] est long -> [in_mp] peut etre sans [long_mp] *)
+	    then (mp, unpack (extract_meb env v (Some mp) true meb)) :: l 
+	    else l
+	  in 
+	  List.fold_left select [] (List.rev l)
+	in 
+	let dummy_prm = {modular=true; mod_name=m; to_appear=[]} in
+	let struc = optimize_struct dummy_prm None struc in 
+	let rec print = function 
+	  | [] -> () 
+	  | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l 
+	  | (MPfile dir, sel) as e :: l -> 
+	      let short_m = snd (split_dirpath dir) in
+	      let f = module_file_name short_m in 
+	      let prm = {modular=true;mod_name=short_m;to_appear=[]} in
+	      print_structure_to_file (Some f) prm [e]; 
+	      print l 
+	  | _ -> assert false
+	in print struc; 
+	reset_tables ()
+
+
+
+
+
diff --git a/contrib/extraction/extract_env.mli b/contrib/extraction/extract_env.mli
new file mode 100644
index 00000000..8ce64342
--- /dev/null
+++ b/contrib/extraction/extract_env.mli
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: extract_env.mli,v 1.13.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+(*s This module declares the extraction commands. *)
+
+open Names
+open Libnames
+
+val extraction : reference -> unit
+val extraction_rec : reference list -> unit
+val extraction_file : string -> reference list -> unit
+val extraction_module : reference -> unit
+val extraction_library : bool -> identifier -> unit
diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml
new file mode 100644
index 00000000..46bf06dd
--- /dev/null
+++ b/contrib/extraction/extraction.ml
@@ -0,0 +1,855 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: extraction.ml,v 1.136.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Declarations
+open Environ
+open Reduction
+open Reductionops
+open Inductive
+open Termops
+open Inductiveops
+open Recordops
+open Nameops
+open Summary
+open Libnames
+open Nametab
+open Miniml
+open Table
+open Mlutil
+(*i*)
+
+exception I of inductive_info
+
+(* A set of all inductive currently being computed, 
+   to avoid loops in [extract_inductive] *)
+let internal_call = ref KNset.empty
+
+let none = Evd.empty
+
+let type_of env c = Retyping.get_type_of env none (strip_outer_cast c)
+
+let sort_of env c = Retyping.get_sort_family_of env none (strip_outer_cast c)
+
+let is_axiom env kn = (Environ.lookup_constant kn env).const_body = None
+
+(*S Generation of flags and signatures. *)
+
+(* The type [flag] gives us information about any Coq term: 
+   \begin{itemize}
+   \item [TypeScheme] denotes a type scheme, that is 
+     something that will become a type after enough applications. 
+     More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with 
+     [s = Set], [Prop] or [Type] 
+   \item [Default] denotes the other cases. It may be inexact after 
+     instanciation. For example [(X:Type)X] is [Default] and may give [Set]
+     after instanciation, which is rather [TypeScheme]
+   \item [Logic] denotes a term of sort [Prop], or a type scheme on sort [Prop]
+   \item [Info] is the opposite. The same example [(X:Type)X] shows 
+     that an [Info] term might in fact be [Logic] later on. 
+   \end{itemize} *)
+
+type info = Logic | Info
+
+type scheme = TypeScheme | Default
+
+type flag = info * scheme
+
+(*s [flag_of_type] transforms a type [t] into a [flag]. 
+  Really important function. *)
+
+let rec flag_of_type env t = 
+  let t = whd_betadeltaiota env none t in 
+  match kind_of_term t with
+    | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c
+    | Sort (Prop Null) -> (Logic,TypeScheme)
+    | Sort _ -> (Info,TypeScheme)
+    | _ -> if (sort_of env t) = InProp then (Logic,Default) else (Info,Default)
+
+(*s Two particular cases of [flag_of_type]. *)
+
+let is_default env t = (flag_of_type env t = (Info, Default))
+
+let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme))
+
+(*s [type_sign] gernerates a signature aimed at treating a type application. *)
+
+let rec type_sign env c = 
+  match kind_of_term (whd_betadeltaiota env none c) with
+    | Prod (n,t,d) -> 
+	(is_info_scheme env t)::(type_sign (push_rel_assum (n,t) env) d)
+    | _ -> []
+
+let rec type_scheme_nb_args env c = 
+  match kind_of_term (whd_betadeltaiota env none c) with
+    | Prod (n,t,d) -> 
+	let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in 
+	if is_info_scheme env t then n+1 else n
+    | _ -> 0
+
+let _ = register_type_scheme_nb_args type_scheme_nb_args
+
+(*s [type_sign_vl] does the same, plus a type var list. *)
+
+let rec type_sign_vl env c = 
+  match kind_of_term (whd_betadeltaiota env none c) with
+    | Prod (n,t,d) -> 
+	let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in 
+	if not (is_info_scheme env t) then false::s, vl
+	else true::s, (next_ident_away (id_of_name n) vl) :: vl
+    | _ -> [],[]
+
+let rec nb_default_params env c = 
+  match kind_of_term (whd_betadeltaiota env none c) with
+    | Prod (n,t,d) ->
+	let n = nb_default_params (push_rel_assum (n,t) env) d in 
+	if is_default env t then n+1 else n
+    | _ -> 0
+
+(*S Management of type variable contexts. *)
+
+(* A De Bruijn variable context (db) is a context for translating Coq [Rel]  
+   into ML type [Tvar]. *)
+
+(*s From a type signature toward a type variable context (db). *)
+
+let db_from_sign s = 
+  let rec make i acc = function 
+    | [] -> acc  
+    | true :: l -> make (i+1) (i::acc) l
+    | false :: l -> make i (0::acc) l
+  in make 1 [] s
+
+(*s Create a type variable context from indications taken from 
+  an inductive type (see just below). *) 
+
+let rec db_from_ind dbmap i = 
+  if i = 0 then []
+  else (try Intmap.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1))
+
+(*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument 
+  of a constructor corresponds to the j-th type var of the ML inductive. *)
+
+(* \begin{itemize}
+   \item [si] : signature of the inductive
+   \item [i] :  counter of Coq args for [(I args)] 
+   \item [j] : counter of ML type vars 
+   \item [relmax] : total args number of the constructor 
+   \end{itemize} *)
+
+let parse_ind_args si args relmax = 
+  let rec parse i j = function 
+    | [] -> Intmap.empty
+    | false :: s -> parse (i+1) j s
+    | true :: s -> 
+      (match kind_of_term args.(i-1) with 
+	 | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s)
+	 | _ -> parse (i+1) (j+1) s)
+  in parse 1 1 si 
+
+(*S Extraction of a type. *)
+
+(* [extract_type env db c args] is used to produce an ML type from the 
+   coq term [(c args)], which is supposed to be a Coq type. *)
+
+(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
+
+(* [j] stands for the next ML type var. [j=0] means we do not 
+   generate ML type var anymore (in subterms for example). *) 
+
+let rec extract_type env db j c args = 
+  match kind_of_term (whd_betaiotazeta c) with
+    | App (d, args') ->
+	(* We just accumulate the arguments. *)
+	extract_type env db j d (Array.to_list args' @ args)
+    | Lambda (_,_,d) -> 
+	(match args with 
+	   | [] -> assert false (* otherwise the lambda would be reductible. *)
+	   | a :: args -> extract_type env db j (subst1 a d) args)
+    | Prod (n,t,d) ->
+	assert (args = []); 
+	let env' = push_rel_assum (n,t) env in 
+	(match flag_of_type env t with 
+	   | (Info, Default) -> 
+	       (* Standard case: two [extract_type] ... *)
+	       let mld = extract_type env' (0::db) j d [] in 
+	       if mld = Tdummy then Tdummy 
+	       else Tarr (extract_type env db 0 t [], mld) 
+	   | (Info, TypeScheme) when j > 0 -> 
+	       (* A new type var. *)
+	       let mld = extract_type env' (j::db) (j+1) d [] in 
+	       if mld = Tdummy then Tdummy else Tarr (Tdummy, mld)
+	   | _ -> 
+	       let mld = extract_type env' (0::db) j d [] in 
+	       if mld = Tdummy then Tdummy else Tarr (Tdummy, mld))
+    | Sort _ -> Tdummy (* The two logical cases. *)
+    | _ when sort_of env (applist (c, args)) = InProp -> Tdummy 
+    | Rel n -> 
+	(match lookup_rel n env with
+           | (_,Some t,_) -> extract_type env db j (lift n t) args
+	   | _ -> 
+	       (* Asks [db] a translation for [n]. *)
+	       if n > List.length db then Tunknown 
+	       else let n' = List.nth db (n-1) in 
+	       if n' = 0 then Tunknown else Tvar n')
+    | Const kn -> 
+	let r = ConstRef kn in 
+	let cb = lookup_constant kn env in 
+	let typ = cb.const_type in 
+	(match flag_of_type env typ with 
+	   | (Info, TypeScheme) -> 
+	       let mlt = extract_type_app env db (r, type_sign env typ) args in 
+	       (match cb.const_body with 
+		  | None -> mlt
+		  | Some _ when is_custom r -> mlt 
+		  | Some lbody -> 
+		      let newc = applist (Declarations.force lbody, args) in 
+		      let mlt' = extract_type env db j newc [] in 
+		      (* ML type abbreviations interact badly with Coq *)
+		      (* reduction, so [mlt] and [mlt'] might be different: *)
+		      (* The more precise is [mlt'], extracted after reduction *)
+		      (* The shortest is [mlt], which use abbreviations *)
+		      (* If possible, we take [mlt], otherwise [mlt']. *)
+		      if type_eq (mlt_env env) mlt mlt' then mlt else mlt')
+	   | _ -> (* only other case here: Info, Default, i.e. not an ML type *)
+	       (match cb.const_body with 
+		  | None -> Tunknown (* Brutal approximation ... *)
+		  | Some lbody -> 
+		      (* We try to reduce. *)
+		      let newc = applist (Declarations.force lbody, args) in 
+		      extract_type env db j newc []))
+    | Ind ((kn,i) as ip) ->
+	let s = (extract_ind env kn).ind_packets.(i).ip_sign in  
+	extract_type_app env db (IndRef (kn,i),s) args
+    | Case _ | Fix _ | CoFix _ -> Tunknown
+    | _ -> assert false
+
+(* [extract_maybe_type] calls [extract_type] when used on a Coq type, 
+   and otherwise returns [Tdummy] or [Tunknown] *)
+
+and extract_maybe_type env db c = 
+  let t = whd_betadeltaiota env none (type_of env c) in 
+  if isSort t then extract_type env db 0 c [] 
+  else if sort_of env t = InProp then Tdummy else Tunknown
+
+(*s Auxiliary function dealing with type application. 
+  Precondition: [r] is a type scheme represented by the signature [s], 
+  and is completely applied: [List.length args = List.length s]. *)
+		  
+and extract_type_app env db (r,s) args =
+  let ml_args = 
+    List.fold_right 
+      (fun (b,c) a -> if b then 
+	 let p = List.length (fst (splay_prod env none (type_of env c))) in
+         let db = iterate (fun l -> 0 :: l) p db in
+         (extract_type_scheme env db c p) :: a
+       else a)
+      (List.combine s args) []
+  in Tglob (r,  ml_args)
+
+(*S Extraction of a type scheme. *)
+
+(* [extract_type_scheme env db c p] works on a Coq term [c] which is
+  an informative type scheme. It means that [c] is not a Coq type, but will 
+  be when applied to sufficiently many arguments ([p] in fact).  
+  This function decomposes p lambdas, with eta-expansion if needed. *)
+
+(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
+
+and extract_type_scheme env db c p = 
+  if p=0 then extract_type env db 0 c [] 
+  else 
+    let c = whd_betaiotazeta c in 
+    match kind_of_term c with 
+      | Lambda (n,t,d) -> 
+          extract_type_scheme (push_rel_assum (n,t) env) db d (p-1)
+      | _ ->  
+          let rels = fst (splay_prod env none (type_of env c)) in
+          let env = push_rels_assum rels env in  
+          let eta_args = List.rev_map mkRel (interval 1 p) in 
+          extract_type env db 0 (lift p c) eta_args
+
+
+(*S Extraction of an inductive type. *)
+
+and extract_ind env kn = (* kn is supposed to be in long form *)
+  try 
+    if KNset.mem kn !internal_call then lookup_ind kn (* Already started. *)
+    else if visible_kn kn then lookup_ind kn (* Standard situation. *)
+    else raise Not_found (* Never trust the table for a internal kn. *)
+  with Not_found -> 
+    internal_call := KNset.add kn !internal_call;
+    let mib = Environ.lookup_mind kn env in 
+    (* Everything concerning parameters. *)
+    (* We do that first, since they are common to all the [mib]. *)
+    let mip0 = mib.mind_packets.(0) in 
+    let npar = mip0.mind_nparams in
+    let epar = push_rel_context mip0.mind_params_ctxt env in
+    (* First pass: we store inductive signatures together with *)
+    (* their type var list. *)
+    let packets = 
+      Array.map 
+	(fun mip -> 
+	   let b = mip.mind_sort <> (Prop Null) in 
+	   let s,v = if b then type_sign_vl env mip.mind_nf_arity else [],[] in
+	   let t = Array.make (Array.length mip.mind_nf_lc) [] in 
+	   { ip_typename = mip.mind_typename;
+	     ip_consnames = mip.mind_consnames;
+	     ip_logical = (not b); 
+	     ip_sign = s; 
+	     ip_vars = v; 
+	     ip_types = t }) 
+	mib.mind_packets 
+    in 
+    add_ind kn {ind_info = Standard; ind_nparams = npar; ind_packets = packets};
+    (* Second pass: we extract constructors *)
+    for i = 0 to mib.mind_ntypes - 1 do
+      let p = packets.(i) in 
+      if not p.ip_logical then
+	let types = arities_of_constructors env (kn,i) in 
+	for j = 0 to Array.length types - 1 do 
+	  let t = snd (decompose_prod_n npar types.(j)) in
+	  let prods,head = dest_prod epar t in 
+	  let nprods = List.length prods in 
+          let args = match kind_of_term head with
+            | App (f,args) -> args (* [kind_of_term f = Ind ip] *)
+            | _ -> [||]
+          in
+	  let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in 
+	  let db = db_from_ind dbmap npar in 
+	  p.ip_types.(j) <- extract_type_cons epar db dbmap t (npar+1)
+	done
+    done;
+    (* Third pass: we determine special cases. *)
+    let ind_info = 
+      try 
+	if not mib.mind_finite then raise (I Coinductive); 
+	if mib.mind_ntypes <> 1 then raise (I Standard); 
+	let p = packets.(0) in 
+	if p.ip_logical then raise (I Standard);
+	if Array.length p.ip_types <> 1 then raise (I Standard);
+	let typ = p.ip_types.(0) in 
+	let l = List.filter (type_neq (mlt_env env) Tdummy) typ in 
+	if List.length l = 1 && not (type_mem_kn kn (List.hd l)) 
+	then raise (I Singleton); 
+	if l = [] then raise (I Standard);
+	let ip = (kn, 0) in 
+	if is_custom (IndRef ip) then raise (I Standard); 
+	let projs = 
+	  try (find_structure ip).s_PROJ 
+	  with Not_found -> raise (I Standard);
+	in 
+	let n = nb_default_params env mip0.mind_nf_arity in
+	let projs = try List.map out_some projs with _ -> raise (I Standard) in
+	let is_true_proj kn = 
+          let (_,body) = Sign.decompose_lam_assum (constant_value env kn) in
+          match kind_of_term body with
+              | Rel _ -> false
+              | Case _ -> true
+              | _ -> assert false
+	in 
+	let projs = List.filter is_true_proj projs in 
+ 	let rec check = function 
+          | [] -> [],[]
+          | (typ, kn) :: l -> 
+              let l1,l2 = check l in 
+              if type_eq (mlt_env env) Tdummy typ then l1,l2 
+              else 
+                let r = ConstRef kn in 
+                if List.mem false (type_to_sign (mlt_env env) typ) 
+                then r :: l1, l2 
+                else r :: l1, r :: l2
+	in 
+	add_record kn n (check (List.combine typ projs)); 
+	raise (I Record)
+      with (I info) -> info
+    in
+    let i = {ind_info = ind_info; ind_nparams = npar; ind_packets = packets} in 
+    add_ind kn i; 
+    internal_call := KNset.remove kn !internal_call;
+    i
+
+(*s [extract_type_cons] extracts the type of an inductive 
+  constructor toward the corresponding list of ML types. *)
+
+(* \begin{itemize}
+   \item [db] is a context for translating Coq [Rel] into ML type [Tvar] 
+   \item [dbmap] is a translation map (produced by a call to [parse_in_args])
+   \item [i] is the rank of the current product (initially [params_nb+1]) 
+   \end{itemize} *)
+
+and extract_type_cons env db dbmap c i =
+  match kind_of_term (whd_betadeltaiota env none c) with 
+    | Prod (n,t,d) -> 
+	let env' = push_rel_assum (n,t) env in
+	let db' = (try Intmap.find i dbmap with Not_found -> 0) :: db in
+	let l = extract_type_cons env' db' dbmap d (i+1) in 
+	(extract_type env db 0 t []) :: l 
+    | _ -> [] 
+
+(*s Recording the ML type abbreviation of a Coq type scheme constant. *)
+
+and mlt_env env r = match r with 
+  | ConstRef kn -> 
+      (try 
+	 if not (visible_kn kn) then raise Not_found; 
+	 match lookup_term kn with 
+	   | Dtype (_,vl,mlt) -> Some mlt
+	   | _ -> None
+       with Not_found -> 
+	 let cb = Environ.lookup_constant kn env in
+	 let typ = cb.const_type in
+	 match cb.const_body with
+	   | None -> None
+	   | Some l_body -> 
+	       (match flag_of_type env typ with 
+		  | Info,TypeScheme -> 
+		      let body = Declarations.force l_body in
+		      let s,vl = type_sign_vl env typ in 
+		      let db = db_from_sign s in 
+		      let t = extract_type_scheme env db body (List.length s) 
+		      in add_term kn (Dtype (r, vl, t)); Some t
+		  | _ -> None))
+  | _ -> None
+
+let type_expand env = type_expand (mlt_env env)
+let type_neq env = type_neq (mlt_env env)
+let type_to_sign env = type_to_sign (mlt_env env)
+let type_expunge env = type_expunge (mlt_env env)
+
+(*s Extraction of the type of a constant. *)
+
+let record_constant_type env kn opt_typ = 
+  try 
+    if not (visible_kn kn) then raise Not_found; 
+    lookup_type kn 
+  with Not_found ->
+    let typ = match opt_typ with 
+      | None -> constant_type env kn 
+      | Some typ -> typ 
+    in let mlt = extract_type env [] 1 typ [] 
+    in let schema = (type_maxvar mlt, mlt)
+    in add_type kn schema; schema
+
+(*S Extraction of a term. *)
+
+(* Precondition: [(c args)] is not a type scheme, and is informative. *)
+
+(* [mle] is a ML environment [Mlenv.t]. *)
+(* [mlt] is the ML type we want our extraction of [(c args)] to have. *)
+
+let rec extract_term env mle mlt c args = 
+  match kind_of_term c with
+    | App (f,a) ->
+	extract_term env mle mlt f (Array.to_list a @ args)
+    | Lambda (n, t, d) ->
+	let id = id_of_name n in 
+	(match args with 
+	   | a :: l -> 
+	       (* We make as many [LetIn] as possible. *)
+ 	       let d' = mkLetIn (Name id,a,t,applistc d (List.map (lift 1) l))
+	       in extract_term env mle mlt d' []
+	   | [] -> 
+	       let env' = push_rel_assum (Name id, t) env in 
+	       let id, a = 
+		 if is_default env t 
+		 then id, new_meta () 
+		 else dummy_name, Tdummy in 
+	       let b = new_meta () in 
+	       (* If [mlt] cannot be unified with an arrow type, then magic! *)
+	       let magic = needs_magic (mlt, Tarr (a, b)) in 
+	       let d' = extract_term env' (Mlenv.push_type mle a) b d [] in 
+	       put_magic_if magic (MLlam (id, d')))
+    | LetIn (n, c1, t1, c2) ->
+	let id = id_of_name n in 
+	let env' = push_rel (Name id, Some c1, t1) env in 
+	let args' = List.map (lift 1) args in 
+	if is_default env t1 then 
+	  let a = new_meta () in 
+	  let c1' = extract_term env mle a c1 [] in
+	  (* The type of [c1'] is generalized and stored in [mle]. *)
+	  let mle' = Mlenv.push_gen mle a in 
+	  MLletin (id, c1', extract_term env' mle' mlt c2 args') 
+	else 
+	  let mle' = Mlenv.push_std_type mle Tdummy in 
+	  ast_pop (extract_term env' mle' mlt c2 args')
+    | Const kn ->
+	extract_cst_app env mle mlt kn args
+    | Construct cp ->
+	extract_cons_app env mle mlt cp args
+    | Rel n ->
+	(* As soon as the expected [mlt] for the head is known, *)
+	(* we unify it with an fresh copy of the stored type of [Rel n]. *)
+	let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n)
+	in extract_app env mle mlt extract_rel args 
+    | Case ({ci_ind=ip},_,c0,br) ->
+ 	extract_app env mle mlt (extract_case env mle (ip,c0,br)) args
+    | Fix ((_,i),recd) ->
+ 	extract_app env mle mlt (extract_fix env mle i recd) args 
+    | CoFix (i,recd) ->
+ 	extract_app env mle mlt (extract_fix env mle i recd) args
+    | Cast (c, _) -> extract_term env mle mlt c args
+    | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false 
+
+(*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) 
+
+and extract_maybe_term env mle mlt c =
+  if is_default env (type_of env c) then extract_term env mle mlt c [] 
+  else put_magic (mlt, Tdummy) MLdummy
+
+(*s Generic way to deal with an application. *)
+
+(* We first type all arguments starting with unknown meta types. 
+   This gives us the expected type of the head. Then we use the 
+   [mk_head] to produce the ML head from this type. *)
+
+and extract_app env mle mlt mk_head args = 
+  let metas = List.map new_meta args in 
+  let type_head = type_recomp (metas, mlt) in 
+  let mlargs = List.map2 (extract_maybe_term env mle) metas args in 
+  if mlargs = [] then mk_head type_head else MLapp (mk_head type_head, mlargs)
+
+(*s Auxiliary function used to extract arguments of constant or constructor. *)
+
+and make_mlargs env e s args typs = 
+  let l = ref s in 
+  let keep () = match !l with [] -> true | b :: s -> l:=s; b in
+  let rec f = function  
+    | [], [] -> [] 
+    | a::la, t::lt when keep() -> extract_maybe_term env e t a :: (f (la,lt))
+    | _::la, _::lt -> f (la,lt)
+    | _ -> assert false 
+  in f (args,typs)
+
+(*s Extraction of a constant applied to arguments. *)
+
+and extract_cst_app env mle mlt kn args = 
+  (* First, the [ml_schema] of the constant, in expanded version. *) 
+  let nb,t = record_constant_type env kn None in 
+  let schema = nb, type_expand env t in 
+  (* Then the expected type of this constant. *)
+  let metas = List.map new_meta args in 
+  (* We compare stored and expected types in two steps. *)
+  (* First, can [kn] be applied to all args ? *)
+  let a = new_meta () in 
+  let magic1 = needs_magic (type_recomp (metas, a), instantiation schema) in 
+  (* Second, is the resulting type compatible with the expected type [mlt] ? *)
+  let magic2 = needs_magic (a, mlt) in 
+  (* The internal head receives a magic if [magic1] *)
+  let head = put_magic_if magic1 (MLglob (ConstRef kn)) in 
+  (* Now, the extraction of the arguments. *)
+  let s = type_to_sign env (snd schema) in 
+  let ls = List.length s in 
+  let la = List.length args in
+  let mla = make_mlargs env mle s args metas in 
+  let mla =
+    if not magic1 then 
+      try 
+	let l,l' = list_chop (projection_arity (ConstRef kn)) mla in 
+	if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l'
+	else mla
+      with _ -> mla
+    else mla
+  in 			    
+  (* Different situations depending of the number of arguments: *)
+  if ls = 0 then put_magic_if magic2 head
+  else if List.mem true s then 
+    if la >= ls then put_magic_if (magic2 && not magic1) (MLapp (head, mla))
+    else 
+      (* Not enough arguments. We complete via eta-expansion. *)
+      let ls' = ls-la in
+      let s' = list_lastn ls' s in
+      let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
+      put_magic_if magic2 (anonym_or_dummy_lams (MLapp (head, mla)) s')
+  else 
+    (* In the special case of always false signature, one dummy lam is left. *)
+    (* So a [MLdummy] is left accordingly. *) 
+    if la >= ls 
+    then put_magic_if (magic2 && not magic1) (MLapp (head, MLdummy :: mla))
+    else put_magic_if magic2 (dummy_lams head (ls-la-1))
+
+(*s Extraction of an inductive constructor applied to arguments. *)
+
+(* \begin{itemize}
+   \item In ML, contructor arguments are uncurryfied. 
+   \item We managed to suppress logical parts inside inductive definitions,
+   but they must appears outside (for partial applications for instance)
+   \item We also suppressed all Coq parameters to the inductives, since
+   they are fixed, and thus are not used for the computation.
+   \end{itemize} *)
+
+and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
+  (* First, we build the type of the constructor, stored in small pieces. *)
+  let mi = extract_ind env kn in 
+  let params_nb = mi.ind_nparams in 
+  let oi = mi.ind_packets.(i) in 
+  let nb_tvars = List.length oi.ip_vars
+  and types = List.map (type_expand env) oi.ip_types.(j-1) in
+  let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in 
+  let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in
+  let type_cons = instantiation (nb_tvars, type_cons) in 
+  (* Then, the usual variables [s], [ls], [la], ... *)
+  let s = List.map ((<>) Tdummy) types in
+  let ls = List.length s in 
+  let la = List.length args in 
+  assert (la <= ls + params_nb);
+  let la' = max 0 (la - params_nb) in 
+  let args' = list_lastn la' args in 
+  (* Now, we build the expected type of the constructor *)
+  let metas = List.map new_meta args' in 
+  (* If stored and expected types differ, then magic! *)
+  let a = new_meta () in 
+  let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in
+  let magic2 = needs_magic (a, mlt) in 
+  let head mla = 
+    if mi.ind_info = Singleton then 
+      put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *)
+    else put_magic_if magic1 (MLcons (ConstructRef cp, mla))
+  in 
+  (* Different situations depending of the number of arguments: *)
+  if la < params_nb then 
+    let head' = head (eta_args_sign ls s) in 
+    put_magic_if magic2 
+      (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la))
+  else 
+    let mla = make_mlargs env mle s args' metas in 
+    if la = ls + params_nb 
+    then put_magic_if (magic2 && not magic1) (head mla)
+    else (* [ params_nb <= la <= ls + params_nb ] *) 
+      let ls' = params_nb + ls - la in 
+      let s' = list_lastn ls' s in 
+      let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
+      put_magic_if magic2 (anonym_or_dummy_lams (head mla) s')
+
+(*S Extraction of a case. *)
+
+and extract_case env mle ((kn,i) as ip,c,br) mlt = 
+  (* [br]: bodies of each branch (in functional form) *)
+  (* [ni]: number of arguments without parameters in each branch *)
+  let ni = mis_constr_nargs_env env ip in
+  let br_size = Array.length br in 
+  assert (Array.length ni = br_size); 
+  if br_size = 0 then begin
+    add_recursors env kn; (* May have passed unseen if logical ... *)
+    MLexn "absurd case"
+  end else 
+    (* [c] has an inductive type, and is not a type scheme type. *)
+    let t = type_of env c in 
+    (* The only non-informative case: [c] is of sort [Prop] *)
+    if (sort_of env t) = InProp then 
+      begin 
+	add_recursors env kn; (* May have passed unseen if logical ... *)
+	(* Logical singleton case: *)
+	(* [match c with C i j k -> t] becomes [t'] *)
+	assert (br_size = 1);
+	let s = iterate (fun l -> false :: l) ni.(0) [] in
+	let mlt = iterate (fun t -> Tarr (Tdummy, t)) ni.(0) mlt in 
+	let e = extract_maybe_term env mle mlt br.(0) in 
+	snd (case_expunge s e)
+      end 
+    else 
+      let mi = extract_ind env kn in 
+      let params_nb = mi.ind_nparams in 
+      let oi = mi.ind_packets.(i) in 
+      let metas = Array.init (List.length oi.ip_vars) new_meta in 
+      (* The extraction of the head. *)
+      let type_head = Tglob (IndRef ip, Array.to_list metas) in
+      let a = extract_term env mle type_head c [] in 
+      (* The extraction of each branch. *)
+      let extract_branch i = 
+	(* The types of the arguments of the corresponding constructor. *)
+	let f t = type_subst_vect metas (type_expand env t) in 
+	let l = List.map f oi.ip_types.(i) in
+	(* Extraction of the branch (in functional form). *)
+	let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in 
+	(* We suppress dummy arguments according to signature. *)
+	let ids,e = case_expunge (List.map ((<>) Tdummy) l) e in
+	(ConstructRef (ip,i+1), List.rev ids, e)
+      in
+      if mi.ind_info = Singleton then 
+	begin 
+	  (* Informative singleton case: *)
+	  (* [match c with C i -> t] becomes [let i = c' in t'] *)
+	  assert (br_size = 1);
+	  let (_,ids,e') = extract_branch 0 in
+	  assert (List.length ids = 1);
+	  MLletin (List.hd ids,a,e')
+	end 
+      else 
+	(* Standard case: we apply [extract_branch]. *)
+	MLcase (a, Array.init br_size extract_branch)
+  
+(*s Extraction of a (co)-fixpoint. *)
+
+and extract_fix env mle i (fi,ti,ci as recd) mlt = 
+  let env = push_rec_types recd env in 
+  let metas = Array.map new_meta fi in
+  metas.(i) <- mlt; 
+  let mle = Array.fold_left Mlenv.push_type mle metas in 
+  let ei = array_map2 (extract_maybe_term env mle) metas ci in 
+  MLfix (i, Array.map id_of_name fi, ei)
+
+(*S ML declarations. *)
+
+(* [decomp_lams_eta env c t] finds the number [n] of products in the type [t], 
+   and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *)
+
+let rec decomp_lams_eta_n n env c t = 
+  let rels = fst (decomp_n_prod env none n t) in 
+  let rels = List.map (fun (id,_,c) -> (id,c)) rels in 
+  let m = nb_lam c in 
+  if m >= n then decompose_lam_n n c 
+  else
+    let rels',c = decompose_lam c in 
+    let d = n - m in 
+    (* we'd better keep rels' as long as possible. *)
+    let rels = (list_firstn d rels) @ rels' in
+    let eta_args = List.rev_map mkRel (interval 1 d) in 
+    rels, applist (lift d c,eta_args)
+
+(*s From a constant to a ML declaration. *)
+
+let extract_std_constant env kn body typ = 
+  reset_meta_count (); 
+  (* The short type [t] (i.e. possibly with abbreviations). *)
+  let t = snd (record_constant_type env kn (Some typ)) in 
+  (* The real type [t']: without head lambdas, expanded, *)
+  (* and with [Tvar] translated to [Tvar'] (not instantiable). *)
+  let l,t' = type_decomp (type_expand env (var2var' t)) in 
+  let s = List.map ((<>) Tdummy) l in 
+  (* The initial ML environment. *)
+  let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in 
+  (* Decomposing the top level lambdas of [body]. *)
+  let rels,c = decomp_lams_eta_n (List.length s) env body typ in
+  (* The lambdas names. *)
+  let ids = List.map (fun (n,_) -> id_of_name n) rels in 
+  (* The according Coq environment. *)
+  let env = push_rels_assum rels env in
+  (* The real extraction: *)
+  let e = extract_term env mle t' c [] in
+  (* Expunging term and type from dummy lambdas. *) 
+  term_expunge s (ids,e), type_expunge env t
+
+let extract_fixpoint env vkn (fi,ti,ci) = 
+  let n = Array.length vkn in 
+  let types = Array.make n Tdummy
+  and terms = Array.make n MLdummy in 
+  (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *)
+  let sub = List.rev_map mkConst (Array.to_list vkn) in 
+  for i = 0 to n-1 do 
+    if sort_of env ti.(i) <> InProp then begin 
+      let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in
+      terms.(i) <- e; 
+      types.(i) <- t;
+    end 
+  done; 
+  Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) 
+		 
+let extract_constant env kn cb = 
+  let r = ConstRef kn in 
+  let typ = cb.const_type in
+  match cb.const_body with
+    | None -> (* A logical axiom is risky, an informative one is fatal. *) 
+        (match flag_of_type env typ with
+	   | (Info,TypeScheme) -> 
+	       if not (is_custom r) then warning_info_ax r; 
+	       let n = type_scheme_nb_args env typ in 
+	       let ids = iterate (fun l -> anonymous::l) n [] in 
+	       Dtype (r, ids, Taxiom) 
+           | (Info,Default) -> 
+	       if not (is_custom r) then warning_info_ax r; 
+	       let t = snd (record_constant_type env kn (Some typ)) in 
+	       Dterm (r, MLaxiom, type_expunge env t) 
+           | (Logic,TypeScheme) -> warning_log_ax r; Dtype (r, [], Tdummy)
+	   | (Logic,Default) -> warning_log_ax r; Dterm (r, MLdummy, Tdummy))
+    | Some body ->
+	(match flag_of_type env typ with
+	   | (Logic, Default) -> Dterm (r, MLdummy, Tdummy)
+	   | (Logic, TypeScheme) -> Dtype (r, [], Tdummy)
+	   | (Info, Default) -> 
+	       let e,t = extract_std_constant env kn (force body) typ in 
+	       Dterm (r,e,t)
+	   | (Info, TypeScheme) -> 
+	       let s,vl = type_sign_vl env typ in 
+               let db = db_from_sign s in 
+               let t = extract_type_scheme env db (force body) (List.length s) 
+	       in Dtype (r, vl, t))
+
+let extract_constant_spec env kn cb = 
+  let r = ConstRef kn in 
+  let typ = cb.const_type in
+  match flag_of_type env typ with 
+    | (Logic, TypeScheme) -> Stype (r, [], Some Tdummy)
+    | (Logic, Default) -> Sval (r, Tdummy) 
+    | (Info, TypeScheme) -> 
+	let s,vl = type_sign_vl env typ in 
+	(match cb.const_body with 
+	  | None -> Stype (r, vl, None)
+	  | Some body -> 
+	      let db = db_from_sign s in 
+	      let t = extract_type_scheme env db (force body) (List.length s)
+	      in Stype (r, vl, Some t)) 
+    | (Info, Default) -> 
+	let t = snd (record_constant_type env kn (Some typ)) in 
+	Sval (r, type_expunge env t)
+
+let extract_inductive env kn = 
+  let ind = extract_ind env kn in 
+  add_recursors env kn; 
+  let f l = List.filter (type_neq env Tdummy) l in 
+  let packets = 
+    Array.map (fun p -> { p with ip_types = Array.map f p.ip_types }) 
+      ind.ind_packets
+  in { ind with ind_packets = packets }
+
+(*s From a global reference to a ML declaration. *)
+
+let extract_declaration env r = match r with
+  | ConstRef kn -> extract_constant env kn (Environ.lookup_constant kn env)
+  | IndRef (kn,_) -> Dind (kn, extract_inductive env kn)
+  | ConstructRef ((kn,_),_) -> Dind (kn, extract_inductive env kn)
+  | VarRef kn -> assert false
+
+(*s Without doing complete extraction, just guess what a constant would be. *) 
+
+type kind = Logical | Term | Type 
+    
+let constant_kind env cb = 
+  match flag_of_type env cb.const_type with 
+    | (Logic,_) -> Logical
+    | (Info,TypeScheme) -> Type
+    | (Info,Default) -> Term
+
+(*s Is a [ml_decl] logical ? *) 
+
+let logical_decl = function 
+  | Dterm (_,MLdummy,Tdummy) -> true
+  | Dtype (_,[],Tdummy) -> true 
+  | Dfix (_,av,tv) -> 
+      (array_for_all ((=) MLdummy) av) && (array_for_all ((=) Tdummy) tv)
+  | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
+  | _ -> false
+
+(*s Is a [ml_spec] logical ? *)
+
+let logical_spec = function 
+  | Stype (_, [], Some Tdummy) -> true
+  | Sval (_,Tdummy) -> true
+  | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
+  | _ -> false
+
+  
+
+
+
+
diff --git a/contrib/extraction/extraction.mli b/contrib/extraction/extraction.mli
new file mode 100644
index 00000000..fc5782c9
--- /dev/null
+++ b/contrib/extraction/extraction.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: extraction.mli,v 1.27.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+(*s Extraction from Coq terms to Miniml. *)
+
+open Names
+open Term
+open Declarations
+open Environ
+open Libnames
+open Miniml
+
+val extract_constant : env -> kernel_name -> constant_body -> ml_decl
+
+val extract_constant_spec : env -> kernel_name -> constant_body -> ml_spec
+
+val extract_fixpoint : 
+  env -> kernel_name array -> (constr, types) prec_declaration -> ml_decl 
+
+val extract_inductive : env -> kernel_name -> ml_ind
+
+(*s ML declaration corresponding to a Coq reference. *)
+
+val extract_declaration : env -> global_reference -> ml_decl
+
+(*s Without doing complete extraction, just guess what a constant would be. *) 
+
+type kind = Logical | Term | Type 
+
+val constant_kind : env -> constant_body -> kind
+
+(*s Is a [ml_decl] or a [ml_spec] logical ? *) 
+
+val logical_decl : ml_decl -> bool
+val logical_spec : ml_spec -> bool
diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4
new file mode 100644
index 00000000..33a6117d
--- /dev/null
+++ b/contrib/extraction/g_extraction.ml4
@@ -0,0 +1,119 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* ML names *)
+
+open Vernacexpr
+open Pcoq
+open Genarg
+open Pp
+
+let pr_mlname _ _ s =
+  spc () ++
+  (if !Options.v7 && not (Options.do_translate()) then qs s
+  else Pptacticnew.qsnew s)
+
+ARGUMENT EXTEND mlname
+  TYPED AS string
+  PRINTED BY pr_mlname
+| [ preident(id) ] -> [ id ]
+| [ string(s) ] -> [ s ]
+END
+
+open Table
+open Extract_env
+
+VERNAC ARGUMENT EXTEND language
+| [ "Ocaml" ] -> [ Ocaml ]
+| [ "Haskell" ] -> [ Haskell ]
+| [ "Scheme" ] -> [ Scheme ]
+| [ "Toplevel" ] -> [ Toplevel ]
+END
+
+(* Temporary for translator *)
+if !Options.v7 then
+  let pr_language _ _ = function
+    | Ocaml -> str " Ocaml"
+    | Haskell -> str " Haskell"
+    | Scheme -> str " Scheme"
+    | Toplevel -> str " Toplevel"
+  in
+  let globwit_language = Obj.magic rawwit_language in
+  let wit_language = Obj.magic rawwit_language in
+  Pptactic.declare_extra_genarg_pprule true
+    (rawwit_language, pr_language)
+    (globwit_language, pr_language)
+    (wit_language, pr_language);
+
+(* Extraction commands *)
+
+VERNAC COMMAND EXTEND Extraction
+(* Extraction in the Coq toplevel *)
+| [ "Extraction" global(x) ] -> [ extraction x ]
+| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ extraction_rec l ]
+
+(* Monolithic extraction to a file *)
+| [ "Extraction" string(f) ne_global_list(l) ] 
+  -> [ extraction_file f l ]
+END
+
+(* Modular extraction (one Coq library = one ML module) *)
+VERNAC COMMAND EXTEND ExtractionLibrary
+| [ "Extraction" "Library" ident(m) ]
+  -> [ extraction_library false m ]
+END
+
+VERNAC COMMAND EXTEND RecursiveExtractionLibrary
+| [ "Recursive" "Extraction" "Library" ident(m) ]
+  -> [ extraction_library true m ]
+END
+
+(* Target Language *)
+VERNAC COMMAND EXTEND ExtractionLanguage
+| [ "Extraction" "Language" language(l) ] 
+  -> [ extraction_language l ]
+END
+
+VERNAC COMMAND EXTEND ExtractionInline
+(* Custom inlining directives *)
+| [ "Extraction" "Inline" ne_global_list(l) ] 
+  -> [ extraction_inline true l ]
+END
+
+VERNAC COMMAND EXTEND ExtractionNoInline
+| [ "Extraction" "NoInline" ne_global_list(l) ] 
+  -> [ extraction_inline false l ]
+END
+
+VERNAC COMMAND EXTEND PrintExtractionInline
+| [ "Print" "Extraction" "Inline" ]
+  -> [ print_extraction_inline () ]
+END
+
+VERNAC COMMAND EXTEND ResetExtractionInline
+| [ "Reset" "Extraction" "Inline" ]
+  -> [ reset_extraction_inline () ]
+END
+
+(* Overriding of a Coq object by an ML one *)
+VERNAC COMMAND EXTEND ExtractionConstant
+| [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ]
+  -> [ extract_constant_inline false x idl y ]
+END
+
+VERNAC COMMAND EXTEND ExtractionInlinedConstant
+| [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ]
+  -> [ extract_constant_inline true x [] y ]
+END
+
+VERNAC COMMAND EXTEND ExtractionInductive
+| [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" ]
+  -> [ extract_inductive x (id,idl) ]
+END
diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml
new file mode 100644
index 00000000..29c8cd18
--- /dev/null
+++ b/contrib/extraction/haskell.ml
@@ -0,0 +1,280 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: haskell.ml,v 1.40.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Production of Haskell syntax. *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Libnames
+open Table
+open Miniml
+open Mlutil
+open Ocaml
+
+(*s Haskell renaming issues. *)
+
+let keywords =     
+  List.fold_right (fun s -> Idset.add (id_of_string s))
+  [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else";
+    "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; 
+    "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__";
+    "as"; "qualified"; "hiding" ; "unit" ]
+  Idset.empty
+
+let preamble prm used_modules (mldummy,tdummy,tunknown) =
+  let pp_mp = function 
+    | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
+    | _ -> assert false 
+  in  
+  str "module " ++ pr_upper_id prm.mod_name ++ str " where" ++ fnl () 
+  ++ fnl() ++ 
+  str "import qualified Prelude" ++ fnl() ++
+  prlist (fun mp -> str "import qualified " ++ pp_mp mp ++ fnl ()) used_modules
+  ++ fnl () ++
+  (if mldummy then 
+     str "__ = Prelude.error \"Logical or arity value used\"" 
+     ++ fnl () ++ fnl()
+   else mt())
+
+let preamble_sig prm used_modules (mldummy,tdummy,tunknown) = failwith "TODO" 
+
+let pp_abst = function
+  | [] -> (mt ())
+  | l  -> (str "\\" ++
+             prlist_with_sep (fun () -> (str " ")) pr_id l ++
+             str " ->" ++ spc ())
+
+let pr_lower_id id = pr_id (lowercase_id id)
+
+(*s The pretty-printing functor. *)
+
+module Make = functor(P : Mlpp_param) -> struct
+
+let local_mpl = ref ([] : module_path list)
+
+let pp_global r = P.pp_global !local_mpl r
+let empty_env () = [], P.globals()
+
+(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
+    are needed or not. *)
+
+let rec pp_type par vl t =
+  let rec pp_rec par = function
+    | Tmeta _ | Tvar' _ -> assert false 
+    | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i))
+    | Tglob (r,[]) -> pp_global r	
+    | Tglob (r,l) -> 
+	pp_par par 
+	  (pp_global r ++ spc () ++ prlist_with_sep spc (pp_type true vl) l)
+    | Tarr (t1,t2) ->
+	pp_par par 
+	  (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
+    | Tdummy -> str "()"
+    | Tunknown -> str "()"
+    | Taxiom -> str "() -- AXIOM TO BE REALIZED\n"
+    | Tcustom s -> str s
+ in 
+  hov 0 (pp_rec par t)
+
+(*s Pretty-printing of expressions. [par] indicates whether
+    parentheses are needed or not. [env] is the list of names for the
+    de Bruijn variables. [args] is the list of collected arguments
+    (already pretty-printed). *)
+
+let expr_needs_par = function
+  | MLlam _  -> true
+  | MLcase _ -> true
+  | _        -> false 
+
+
+let rec pp_expr par env args =
+  let par' = args <> [] || par
+  and apply st = pp_apply st par args in 
+  function
+    | MLrel n -> 
+	let id = get_db_name n env in apply (pr_id id)
+    | MLapp (f,args') ->
+	let stl = List.map (pp_expr true env []) args' in
+        pp_expr par env (stl @ args) f
+    | MLlam _ as a -> 
+      	let fl,a' = collect_lams a in
+	let fl,env' = push_vars fl env in
+	let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in
+	apply (pp_par par' st)
+    | MLletin (id,a1,a2) ->
+	let i,env' = push_vars [id] env in
+	let pp_id = pr_id (List.hd i)
+	and pp_a1 = pp_expr false env [] a1
+	and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in
+	hv 0 
+	  (apply 
+	     (pp_par par' 
+		(hv 0 
+		   (hov 5 
+		      (str "let" ++ spc () ++ pp_id ++ str " = " ++ pp_a1) ++ 
+		    spc () ++ str "in") ++
+		 spc () ++ hov 0 pp_a2)))
+    | MLglob r -> 
+	apply (pp_global r)
+    | MLcons (r,[]) ->
+	assert (args=[]); pp_global r
+    | MLcons (r,[a]) ->
+	assert (args=[]);
+	pp_par par (pp_global r ++ spc () ++ pp_expr true env [] a)
+    | MLcons (r,args') ->
+	assert (args=[]);
+	pp_par par (pp_global r ++ spc () ++ 
+		    prlist_with_sep spc (pp_expr true env []) args')
+    | MLcase (t, pv) ->
+      	apply (pp_par par' 
+		 (v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++
+		       fnl () ++ str "  " ++ pp_pat env pv)))
+    | MLfix (i,ids,defs) ->
+	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
+      	pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
+    | MLexn s -> 
+	(* An [MLexn] may be applied, but I don't really care. *)
+	pp_par par (str "Prelude.error" ++ spc () ++ qs s)
+    | MLdummy ->
+	str "__" (* An [MLdummy] may be applied, but I don't really care. *)
+    | MLmagic a ->  pp_expr par env args a
+    | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"")
+
+and pp_pat env pv = 
+  let pp_one_pat (name,ids,t) =
+    let ids,env' = push_vars (List.rev ids) env in
+    let par = expr_needs_par t in
+    hov 2 (pp_global name ++
+	   (match ids with 
+	      | [] -> mt ()
+	      | _  -> (str " " ++ 
+		       prlist_with_sep 
+			 (fun () -> (spc ())) pr_id (List.rev ids))) ++
+	   str " ->" ++ spc () ++ pp_expr par env' [] t)
+  in 
+  (prvect_with_sep (fun () -> (fnl () ++ str "  ")) pp_one_pat pv)
+
+(*s names of the functions ([ids]) are already pushed in [env],
+    and passed here just for convenience. *)
+
+and pp_fix par env i (ids,bl) args =
+  pp_par par
+    (v 0  
+       (v 2 (str "let" ++ fnl () ++
+	     prvect_with_sep fnl 
+	       (fun (fi,ti) -> pp_function env (pr_id fi) ti) 
+	       (array_map2 (fun a b -> a,b) ids bl)) ++ 
+	fnl () ++ 
+	hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
+
+and pp_function env f t =
+  let bl,t' = collect_lams t in
+  let bl,env' = push_vars bl env in
+  (f ++ pr_binding (List.rev bl) ++
+     str " =" ++ fnl () ++ str "  " ++
+     hov 2 (pp_expr false env' [] t'))
+	
+(*s Pretty-printing of inductive types declaration. *)
+
+let pp_comment s = str "-- " ++ s ++ fnl ()
+
+let pp_logical_ind packet = 
+  pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++
+  pp_comment (str "with constructors : " ++ 
+	      prvect_with_sep spc pr_id packet.ip_consnames)
+
+let pp_singleton kn packet = 
+  let l = rename_tvars keywords packet.ip_vars in 
+  let l' = List.rev l in 
+  hov 2 (str "type " ++ pp_global (IndRef (kn,0)) ++ spc () ++ 
+	 prlist_with_sep spc pr_id l ++
+	 (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++
+	 pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++
+	 pp_comment (str "singleton inductive, whose constructor was " ++ 
+		     pr_id packet.ip_consnames.(0)))
+
+let pp_one_ind ip pl cv =
+  let pl = rename_tvars keywords pl in
+  let pp_constructor (r,l) =
+    (pp_global r ++
+     match l with
+       | [] -> (mt ()) 
+       | _  -> (str " " ++
+      	       	prlist_with_sep 
+		  (fun () -> (str " ")) (pp_type true (List.rev pl)) l))
+  in
+  str (if cv = [||] then "type " else "data ") ++ 
+  pp_global (IndRef ip) ++ str " " ++
+  prlist_with_sep (fun () -> str " ") pr_lower_id pl ++
+  (if pl = [] then mt () else str " ") ++
+  if cv = [||] then str "= () -- empty inductive"
+  else 
+    (v 0 (str "= " ++
+	  prvect_with_sep (fun () -> fnl () ++ str "  | ") pp_constructor 
+	    (Array.mapi (fun i c -> ConstructRef (ip,i+1),c) cv)))
+  
+let rec pp_ind first kn i ind =
+  if i >= Array.length ind.ind_packets then 
+    if first then mt () else fnl () 
+  else 
+    let ip = (kn,i) in 
+    let p = ind.ind_packets.(i) in 
+    if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind 
+    else 
+      if p.ip_logical then  
+	pp_logical_ind p ++ pp_ind first kn (i+1) ind
+      else 
+	pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++ 
+	pp_ind false kn (i+1) ind
+	  
+
+(*s Pretty-printing of a declaration. *)
+
+let pp_decl mpl = 
+  local_mpl := mpl;
+  function
+  | Dind (kn,i) when i.ind_info = Singleton -> 
+      pp_singleton kn i.ind_packets.(0) ++ fnl ()
+  | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i)
+  | Dtype (r, l, t) ->
+      if is_inline_custom r then mt () 
+      else 
+	let l = rename_tvars keywords l in
+	let l' = List.rev l in 
+	hov 2 (str "type " ++ pp_global r ++ spc () ++ 
+	       prlist (fun id -> pr_id id ++ str " ") l ++
+	       str "=" ++ spc () ++ pp_type false l' t) ++ fnl () ++ fnl ()
+  | Dfix (rv, defs,_) ->
+      let ppv = Array.map pp_global rv in 
+      prlist_with_sep (fun () -> fnl () ++ fnl ())
+	(fun (pi,ti) -> pp_function (empty_env ()) pi ti)
+	(List.combine (Array.to_list ppv) (Array.to_list defs)) 
+      ++ fnl () ++ fnl ()
+  | Dterm (r, a, _) ->
+      if is_inline_custom r then mt () 
+      else 
+	hov 0 (pp_function (empty_env ()) (pp_global r) a ++ fnl () ++ fnl ())
+
+let pp_structure_elem mpl = function 
+  | (l,SEdecl d) -> pp_decl mpl d
+  | (l,SEmodule m) -> 
+      failwith "TODO: Haskell extraction of modules not implemented yet"
+  | (l,SEmodtype m) -> 
+      failwith "TODO: Haskell extraction of modules not implemented yet"
+
+let pp_struct = 
+  prlist (fun (mp,sel) -> prlist (pp_structure_elem [mp]) sel)
+
+let pp_signature s = failwith "TODO"
+
+end
+
diff --git a/contrib/extraction/haskell.mli b/contrib/extraction/haskell.mli
new file mode 100644
index 00000000..4da5db0c
--- /dev/null
+++ b/contrib/extraction/haskell.mli
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: haskell.mli,v 1.15.6.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+open Pp
+open Names
+open Miniml
+
+val keywords : Idset.t
+
+val preamble : 
+  extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds
+
+module Make : functor(P : Mlpp_param) -> Mlpp
diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli
new file mode 100644
index 00000000..866ff847
--- /dev/null
+++ b/contrib/extraction/miniml.mli
@@ -0,0 +1,159 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: miniml.mli,v 1.46.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Target language for extraction: a core ML called MiniML. *)
+
+open Pp
+open Util
+open Names
+open Libnames
+
+(* The [signature] type is used to know how many arguments a CIC
+   object expects, and what these arguments will become in the ML
+   object. *)
+   
+(* Convention: outmost lambda/product gives the head of the list, 
+   and [true] means that the argument is to be kept. *)
+
+type signature = bool list
+
+(*s ML type expressions. *)
+
+type ml_type = 
+  | Tarr    of ml_type * ml_type
+  | Tglob   of global_reference * ml_type list 
+  | Tvar    of int
+  | Tvar'   of int (* same as Tvar, used to avoid clash *)
+  | Tmeta   of ml_meta (* used during ML type reconstruction *)
+  | Tdummy
+  | Tunknown
+  | Taxiom
+  | Tcustom of string
+
+and ml_meta = { id : int; mutable contents : ml_type option }
+
+(* ML type schema. 
+   The integer is the number of variable in the schema. *)
+
+type ml_schema = int * ml_type 
+
+(*s ML inductive types. *)
+
+type inductive_info = Record | Singleton | Coinductive | Standard
+
+(* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. 
+   If the inductive is logical ([ip_logical = false]), then all other fields
+   are unused. Otherwise, 
+   [ip_sign] is a signature concerning the arguments of the inductive, 
+   [ip_vars] contains the names of the type variables surviving in ML, 
+   [ip_types] contains the ML types of all constructors.    
+*)
+
+type ml_ind_packet = { 
+  ip_typename : identifier; 
+  ip_consnames : identifier array; 
+  ip_logical : bool;
+  ip_sign : signature; 
+  ip_vars : identifier list; 
+  ip_types : (ml_type list) array }  
+
+(* [ip_nparams] contains the number of parameters. *)
+
+type ml_ind = {
+  ind_info : inductive_info;
+  ind_nparams : int; 	       
+  ind_packets : ml_ind_packet array }
+
+(*s ML terms. *)
+
+type ml_ast = 
+  | MLrel    of int
+  | MLapp    of ml_ast * ml_ast list
+  | MLlam    of identifier * ml_ast
+  | MLletin  of identifier * ml_ast * ml_ast
+  | MLglob   of global_reference
+  | MLcons   of global_reference * ml_ast list
+  | MLcase   of ml_ast * (global_reference * identifier list * ml_ast) array
+  | MLfix    of int * identifier array * ml_ast array
+  | MLexn    of string
+  | MLdummy
+  | MLaxiom
+  | MLmagic  of ml_ast
+
+(*s ML declarations. *)
+
+type ml_decl = 
+  | Dind  of kernel_name * ml_ind
+  | Dtype of global_reference * identifier list * ml_type
+  | Dterm of global_reference * ml_ast * ml_type
+  | Dfix  of global_reference array * ml_ast array * ml_type array
+
+type ml_spec = 
+  | Sind  of kernel_name * ml_ind
+  | Stype of global_reference * identifier list * ml_type option 
+  | Sval  of global_reference * ml_type
+
+type ml_specif = 
+  | Spec of ml_spec 
+  | Smodule of ml_module_type
+  | Smodtype of ml_module_type
+
+and ml_module_type = 
+  | MTident of kernel_name
+  | MTfunsig of mod_bound_id * ml_module_type * ml_module_type
+  | MTsig of mod_self_id * ml_module_sig
+
+and ml_module_sig = (label * ml_specif) list
+
+type ml_structure_elem = 
+  | SEdecl of ml_decl
+  | SEmodule of ml_module
+  | SEmodtype of ml_module_type
+
+and ml_module_expr =
+  | MEident of module_path
+  | MEfunctor of mod_bound_id * ml_module_type * ml_module_expr 
+  | MEstruct of mod_self_id * ml_module_structure
+  | MEapply of ml_module_expr * ml_module_expr
+
+and ml_module_structure = (label * ml_structure_elem) list
+
+and ml_module = 
+    { ml_mod_expr : ml_module_expr; 
+      ml_mod_type : ml_module_type }
+
+(* NB: we do not translate the [mod_equiv] field, since [mod_equiv = mp] 
+   implies that [mod_expr = MEBident mp]. Same with [msb_equiv]. *)
+
+type ml_structure = (module_path * ml_module_structure) list
+
+type ml_signature = (module_path * ml_module_sig) list
+
+(*s Pretty-printing of MiniML in a given concrete syntax is parameterized
+    by a function [pp_global] that pretty-prints global references. 
+    The resulting pretty-printer is a module of type [Mlpp] providing
+    functions to print types, terms and declarations. *)
+
+module type Mlpp_param = sig
+  val globals : unit -> Idset.t
+  val pp_global : module_path list -> global_reference -> std_ppcmds
+  val pp_module : module_path list -> module_path -> std_ppcmds
+end
+
+module type Mlpp = sig
+  val pp_decl : module_path list -> ml_decl -> std_ppcmds
+  val pp_struct : ml_structure -> std_ppcmds
+  val pp_signature : ml_signature -> std_ppcmds
+end
+
+type extraction_params =  
+  { modular : bool; 
+    mod_name : identifier; 
+    to_appear : global_reference list }
diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml
new file mode 100644
index 00000000..fbe423a7
--- /dev/null
+++ b/contrib/extraction/mlutil.ml
@@ -0,0 +1,1136 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: mlutil.ml,v 1.104.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Libnames
+open Nametab
+open Table
+open Miniml
+(*i*)
+
+(*s Exceptions. *)
+
+exception Found
+exception Impossible
+
+(*S Names operations. *)
+
+let anonymous = id_of_string "x"
+let dummy_name = id_of_string "_"
+
+let id_of_name = function
+  | Anonymous -> anonymous
+  | Name id when id = dummy_name -> anonymous
+  | Name id -> id 
+
+(*S Operations upon ML types (with meta). *)
+
+let meta_count = ref 0 
+		     
+let reset_meta_count () = meta_count := 0
+			      
+let new_meta _ = 
+  incr meta_count; 
+  Tmeta {id = !meta_count; contents = None}
+
+(*s Sustitution of [Tvar i] by [t] in a ML type. *)
+
+let type_subst i t0 t = 
+  let rec subst t = match t with
+    | Tvar j when i = j -> t0
+    | Tmeta {contents=None} -> t 
+    | Tmeta {contents=Some u} -> subst u
+    | Tarr (a,b) -> Tarr (subst a, subst b)
+    | Tglob (r, l) -> Tglob (r, List.map subst l)
+    | a -> a 
+  in subst t
+       
+(* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *)
+
+let type_subst_list l t = 
+  let rec subst t = match t with 
+    | Tvar j -> List.nth l (j-1)
+    | Tmeta {contents=None} -> t
+    | Tmeta {contents=Some u} -> subst u
+    | Tarr (a,b) -> Tarr (subst a, subst b)
+    | Tglob (r, l) -> Tglob (r, List.map subst l)
+    | a -> a
+  in subst t
+
+(* Simultaneous substitution of [[|Tvar 1; ... ; Tvar n|]] by [v] in a ML type. *)
+
+let type_subst_vect v t = 
+  let rec subst t = match t with 
+    | Tvar j -> v.(j-1)
+    | Tmeta {contents=None} -> t
+    | Tmeta {contents=Some u} -> subst u
+    | Tarr (a,b) -> Tarr (subst a, subst b)
+    | Tglob (r, l) -> Tglob (r, List.map subst l)
+    | a -> a
+  in subst t
+
+(*s From a type schema to a type. All [Tvar] become fresh [Tmeta]. *)
+
+let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t
+
+(*s Occur-check of a free meta in a type *)
+
+let rec type_occurs alpha t =
+  match t with
+  | Tmeta {id=beta; contents=None} -> alpha = beta
+  | Tmeta {contents=Some u} -> type_occurs alpha u
+  | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2
+  | Tglob (r,l) -> List.exists (type_occurs alpha) l  
+  | _ -> false
+
+(*s Most General Unificator *)
+
+let rec mgu = function
+  | Tmeta m, Tmeta m' when m.id = m'.id -> ()
+  | Tmeta m, t when m.contents=None -> 
+      if type_occurs m.id t then raise Impossible
+      else m.contents <- Some t
+  | t, Tmeta m when m.contents=None -> 
+      if type_occurs m.id t then raise Impossible
+      else m.contents <- Some t
+  | Tmeta {contents=Some u}, t -> mgu (u, t)
+  | t, Tmeta {contents=Some u} -> mgu (t, u)
+  | Tarr(a, b), Tarr(a', b') ->
+      mgu (a, a'); mgu (b, b')
+  | Tglob (r,l), Tglob (r',l') when r = r' ->
+       List.iter mgu (List.combine l l')
+  | Tvar i, Tvar j when i = j -> ()
+  | Tvar' i, Tvar' j when i = j -> ()
+  | Tdummy, Tdummy -> ()
+  | Tunknown, Tunknown -> ()
+  | _ -> raise Impossible
+
+let needs_magic p = try mgu p; false with Impossible -> true
+
+let put_magic_if b a = if b then MLmagic a else a
+
+let put_magic p a = if needs_magic p then MLmagic a else a
+
+
+(*S ML type env. *)
+
+module Mlenv = struct 
+  
+  let meta_cmp m m' = compare m.id m'.id 
+  module Metaset = Set.Make(struct type t = ml_meta let compare = meta_cmp end)
+
+  (* Main MLenv type. [env] is the real environment, whereas [free] 
+     (tries to) record the free meta variables occurring in [env]. *)
+
+  type t = { env : ml_schema list; mutable free : Metaset.t}
+
+  (* Empty environment. *)
+
+  let empty = { env = []; free = Metaset.empty }
+
+  (* [get] returns a instantiated copy of the n-th most recently added 
+     type in the environment. *)
+
+  let get mle n = 
+    assert (List.length mle.env >= n); 
+    instantiation (List.nth mle.env (n-1))
+
+  (* [find_free] finds the free meta in a type. *) 
+
+  let rec find_free set = function 
+    | Tmeta m when m.contents = None -> Metaset.add m set
+    | Tmeta {contents = Some t} -> find_free set t
+    | Tarr (a,b) -> find_free (find_free set a) b
+    | Tglob (_,l) -> List.fold_left find_free set l
+    | _ -> set
+
+  (* The [free] set of an environment can be outdate after 
+     some unifications. [clean_free] takes care of that. *) 
+			
+  let clean_free mle = 
+    let rem = ref Metaset.empty 
+    and add = ref Metaset.empty in 
+    let clean m = match m.contents with 
+      | None -> () 
+      | Some u -> rem := Metaset.add m !rem; add := find_free !add u
+    in 
+    Metaset.iter clean mle.free; 
+    mle.free <- Metaset.union (Metaset.diff mle.free !rem) !add
+
+  (* From a type to a type schema. If a [Tmeta] is still uninstantiated
+     and does appears in the [mle], then it becomes a [Tvar]. *)
+
+  let generalization mle t = 
+    let c = ref 0 in 
+    let map = ref (Intmap.empty : int Intmap.t) in 
+    let add_new i = incr c; map := Intmap.add i !c !map; !c in 
+    let rec meta2var t = match t with 
+      | Tmeta {contents=Some u} -> meta2var u 
+      | Tmeta ({id=i} as m) -> 
+	  (try Tvar (Intmap.find i !map) 
+	   with Not_found ->  
+	     if Metaset.mem m mle.free then t 
+	     else Tvar (add_new i))
+      | Tarr (t1,t2) -> Tarr (meta2var t1, meta2var t2)
+      | Tglob (r,l) -> Tglob (r, List.map meta2var l) 
+      | t -> t 
+    in !c, meta2var t
+	
+  (* Adding a type in an environment, after generalizing. *)
+
+  let push_gen mle t = 
+    clean_free mle; 
+    { env = generalization mle t :: mle.env; free = mle.free }
+
+  (* Adding a type with no [Tvar], hence no generalization needed. *)
+
+  let push_type {env=e;free=f} t = 
+    { env = (0,t) :: e; free = find_free f t} 
+    
+  (* Adding a type with no [Tvar] nor [Tmeta]. *)
+
+  let push_std_type {env=e;free=f} t = 
+    { env = (0,t) :: e; free = f}
+
+end
+
+(*S Operations upon ML types (without meta). *)
+
+(*s Does a section path occur in a ML type ? *)
+
+let rec type_mem_kn kn = function 
+  | Tmeta _ -> assert false
+  | Tglob (r,l) -> (kn_of_r r) = kn || List.exists (type_mem_kn kn) l
+  | Tarr (a,b) -> (type_mem_kn kn a) || (type_mem_kn kn b)
+  | _ -> false
+
+(*s Greatest variable occurring in [t]. *)
+
+let type_maxvar t = 
+  let rec parse n = function 
+    | Tmeta _ -> assert false
+    | Tvar i -> max i n 
+    | Tarr (a,b) -> parse (parse n a) b
+    | Tglob (_,l) -> List.fold_left parse n l 
+    | _ -> n 
+  in parse 0 t
+
+(*s From [a -> b -> c] to [[a;b],c]. *) 
+
+let rec type_decomp = function 
+  | Tmeta _ -> assert false
+  | Tarr (a,b) -> let l,h = type_decomp b in a::l, h 
+  | a -> [],a
+
+(*s The converse: From [[a;b],c] to [a -> b -> c]. *)
+
+let rec type_recomp (l,t) = match l with 
+  | [] -> t 
+  | a::l -> Tarr (a, type_recomp (l,t))
+
+(*s Translating [Tvar] to [Tvar'] to avoid clash. *)
+
+let rec var2var' = function 
+  | Tmeta _ -> assert false
+  | Tvar i -> Tvar' i
+  | Tarr (a,b) -> Tarr (var2var' a, var2var' b)
+  | Tglob (r,l) -> Tglob (r, List.map var2var' l)
+  | a -> a
+
+type abbrev_map = global_reference -> ml_type option
+
+(*s Delta-reduction of type constants everywhere in a ML type [t].
+   [env] is a function of type [ml_type_env]. *)
+
+let type_expand env t = 
+  let rec expand = function
+    | Tmeta _ -> assert false
+    | Tglob (r,l) as t ->    
+	(match env r with 
+	   | Some mlt -> expand (type_subst_list l mlt) 
+	   | None -> Tglob (r, List.map expand l))
+    | Tarr (a,b) -> Tarr (expand a, expand b)
+    | a -> a
+  in expand t
+
+(*s Idem, but only at the top level of implications. *)
+
+let is_arrow = function Tarr _ -> true | _ -> false
+
+let type_weak_expand env t = 
+  let rec expand = function
+    | Tmeta _ -> assert false
+    | Tglob (r,l) as t ->    
+	(match env r with 
+	   | Some mlt -> 
+	       let u = expand (type_subst_list l mlt) in 
+	       if is_arrow u then u else t
+	   | None -> t)
+    | Tarr (a,b) -> Tarr (a, expand b)
+    | a -> a
+  in expand t
+
+(*s Equality over ML types modulo delta-reduction *)
+
+let type_eq env t t' = (type_expand env t = type_expand env t')
+
+let type_neq env t t' = (type_expand env t <> type_expand env t')
+
+(*s Generating a signature from a ML type. *)
+
+let type_to_sign env t = 
+  let rec f = function 
+    | Tmeta _ -> assert false
+    | Tarr (a,b) -> (Tdummy <> a) :: (f b)
+    | _ -> [] 
+  in f (type_expand env t)
+
+(*s Removing [Tdummy] from the top level of a ML type. *)
+
+let type_expunge env t = 
+  let s = type_to_sign env t in 
+  if s = [] then t 
+  else if List.mem true s then 
+    let rec f t s = 
+      if List.mem false s then 
+	match t with 
+	  | Tmeta _ -> assert false
+	  | Tarr (a,b) -> 
+	      let t = f b (List.tl s) in 
+	      if List.hd s then Tarr (a, t) else t  
+	  | Tglob (r,l) ->
+	      (match env r with 
+		 | Some mlt -> f (type_subst_list l mlt) s
+		 | None -> assert false)
+	  | _ -> assert false
+      else t 
+    in f t s 
+  else Tarr (Tdummy, snd (type_decomp (type_weak_expand env t))) 
+
+(*S Generic functions over ML ast terms. *)
+
+(*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care 
+   of the number of bingings crossed before reaching the [MLrel]. *)
+
+let ast_iter_rel f = 
+  let rec iter n = function
+    | MLrel i -> f (i-n)
+    | MLlam (_,a) -> iter (n+1) a
+    | MLletin (_,a,b) -> iter n a; iter (n+1) b
+    | MLcase (a,v) ->
+	iter n a; Array.iter (fun (_,l,t) -> iter (n + (List.length l)) t) v
+    | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v
+    | MLapp (a,l) -> iter n a; List.iter (iter n) l
+    | MLcons (_,l) ->  List.iter (iter n) l
+    | MLmagic a -> iter n a
+    | MLglob _ | MLexn _ | MLdummy | MLaxiom -> ()
+  in iter 0 
+
+(*s Map over asts. *)
+
+let ast_map_case f (c,ids,a) = (c,ids,f a)
+
+let ast_map f = function
+  | MLlam (i,a) -> MLlam (i, f a)
+  | MLletin (i,a,b) -> MLletin (i, f a, f b)
+  | MLcase (a,v) -> MLcase (f a, Array.map (ast_map_case f) v)
+  | MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v)
+  | MLapp (a,l) -> MLapp (f a, List.map f l)
+  | MLcons (c,l) -> MLcons (c, List.map f l)
+  | MLmagic a -> MLmagic (f a)
+  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a
+
+(*s Map over asts, with binding depth as parameter. *)
+
+let ast_map_lift_case f n (c,ids,a) = (c,ids, f (n+(List.length ids)) a)
+
+let ast_map_lift f n = function 
+  | MLlam (i,a) -> MLlam (i, f (n+1) a)
+  | MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b)
+  | MLcase (a,v) -> MLcase (f n a,Array.map (ast_map_lift_case f n) v)
+  | MLfix (i,ids,v) -> 
+      let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v)
+  | MLapp (a,l) -> MLapp (f n a, List.map (f n) l)
+  | MLcons (c,l) -> MLcons (c, List.map (f n) l)
+  | MLmagic a -> MLmagic (f n a)
+  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a	
+
+(*s Iter over asts. *) 
+
+let ast_iter_case f (c,ids,a) = f a
+
+let ast_iter f = function
+  | MLlam (i,a) -> f a
+  | MLletin (i,a,b) -> f a; f b
+  | MLcase (a,v) -> f a; Array.iter (ast_iter_case f) v
+  | MLfix (i,ids,v) -> Array.iter f v
+  | MLapp (a,l) -> f a; List.iter f l
+  | MLcons (c,l) -> List.iter f l
+  | MLmagic a -> f a
+  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> ()
+
+(*S Operations concerning De Bruijn indices. *)
+
+(*s [ast_occurs k t] returns [true] if [(Rel k)] occurs in [t]. *)
+
+let ast_occurs k t = 
+  try 
+    ast_iter_rel (fun i -> if i = k then raise Found) t; false 
+  with Found -> true
+
+(*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)] 
+   in [t] with [k<=i<=k'] *)
+
+let ast_occurs_itvl k k' t = 
+  try 
+    ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false 
+  with Found -> true
+
+(*s Number of occurences of [Rel k] and [Rel 1] in [t]. *)
+
+let nb_occur_k k t =
+  let cpt = ref 0 in 
+  ast_iter_rel (fun i -> if i = k then incr cpt) t;
+  !cpt
+
+let nb_occur t = nb_occur_k 1 t
+
+(* Number of occurences of [Rel 1] in [t], with special treatment of match:
+   occurences in different branches aren't added, but we rather use max. *)
+
+let nb_occur_match = 
+  let rec nb k = function 
+    | MLrel i -> if i = k then 1 else 0
+    | MLcase(a,v) -> 
+        (nb k a) +
+	Array.fold_left 
+	  (fun r (_,ids,a) -> max r (nb (k+(List.length ids)) a)) 0 v
+    | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b) 
+    | MLfix (_,ids,v) -> let k = k+(Array.length ids) in 
+      Array.fold_left (fun r a -> r+(nb k a)) 0 v
+    | MLlam (_,a) -> nb (k+1) a
+    | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l
+    | MLcons (_,l) -> List.fold_left (fun r a -> r+(nb k a)) 0 l 
+    | MLmagic a -> nb k a
+    | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0
+  in nb 1
+
+(*s Lifting on terms.
+    [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *)
+
+let ast_lift k t = 
+  let rec liftrec n = function
+    | MLrel i as a -> if i-n < 1 then a else MLrel (i+k)
+    | a -> ast_map_lift liftrec n a
+  in if k = 0 then t else liftrec 0 t
+
+let ast_pop t = ast_lift (-1) t
+
+(*s [permut_rels k k' c] translates [Rel 1 ... Rel k] to [Rel (k'+1) ... 
+  Rel (k'+k)] and [Rel (k+1) ... Rel (k+k')] to [Rel 1 ... Rel k'] *)
+
+let permut_rels k k' = 
+  let rec permut n = function
+    | MLrel i as a ->
+	let i' = i-n in
+	if i'<1 || i'>k+k' then a 
+	else if i'<=k then MLrel (i+k')
+	else MLrel (i-k)
+    | a -> ast_map_lift permut n a
+  in permut 0  
+
+(*s Substitution. [ml_subst e t] substitutes [e] for [Rel 1] in [t]. 
+    Lifting (of one binder) is done at the same time. *)
+
+let ast_subst e =
+  let rec subst n = function
+    | MLrel i as a ->
+	let i' = i-n in 
+	if i'=1 then ast_lift n e
+	else if i'<1 then a 
+	else MLrel (i-1)
+    | a -> ast_map_lift subst n a
+  in subst 0
+
+(*s Generalized substitution. 
+   [gen_subst v d t] applies to [t] the substitution coded in the 
+   [v] array: [(Rel i)] becomes [v.(i-1)]. [d] is the correction applies 
+   to [Rel] greater than [Array.length v]. *)
+
+let gen_subst v d t = 
+  let rec subst n = function
+    | MLrel i as a -> 
+	let i'= i-n in 
+	if i' < 1 then a 
+	else if i' <= Array.length v then 
+	  ast_lift n v.(i'-1) 
+	else MLrel (i+d) 
+    | a -> ast_map_lift subst n a
+  in subst 0 t
+
+(*S Operations concerning lambdas. *)
+
+(*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns
+    [[idn;...;id1]] and the term [t]. *)
+
+let collect_lams = 
+  let rec collect acc = function
+    | MLlam(id,t) -> collect (id::acc) t
+    | x           -> acc,x
+  in collect []
+
+(*s [collect_n_lams] does the same for a precise number of [MLlam]. *)
+
+let collect_n_lams = 
+  let rec collect acc n t = 
+    if n = 0 then acc,t 
+    else match t with 
+      | MLlam(id,t) -> collect (id::acc) (n-1) t
+      | _ -> assert false
+  in collect [] 
+
+(*s [remove_n_lams] just removes some [MLlam]. *)
+
+let rec remove_n_lams n t = 
+  if n = 0 then t  
+  else match t with 
+      | MLlam(_,t) -> remove_n_lams (n-1) t
+      | _ -> assert false
+
+(*s [nb_lams] gives the number of head [MLlam]. *)
+
+let rec nb_lams = function 
+  | MLlam(_,t) -> succ (nb_lams t)
+  | _ -> 0 
+
+(*s [named_lams] does the converse of [collect_lams]. *)
+
+let rec named_lams ids a = match ids with 
+  | [] -> a 
+  | id :: ids -> named_lams ids (MLlam (id,a))
+
+(*s The same in anonymous version. *)
+
+let rec anonym_lams a = function 
+  | 0 -> a 
+  | n -> anonym_lams (MLlam (anonymous,a)) (pred n)
+
+(*s Idem for [dummy_name]. *)
+
+let rec dummy_lams a = function 
+  | 0 -> a 
+  | n -> dummy_lams (MLlam (dummy_name,a)) (pred n)
+
+(*s mixed according to a signature. *)
+
+let rec anonym_or_dummy_lams a = function 
+  | [] -> a 
+  | true :: s -> MLlam(anonymous, anonym_or_dummy_lams a s)
+  | false :: s -> MLlam(dummy_name, anonym_or_dummy_lams a s)
+
+(*S Operations concerning eta. *)
+
+(*s The following function creates [MLrel n;...;MLrel 1] *)
+
+let rec eta_args n = 
+  if n = 0 then [] else (MLrel n)::(eta_args (pred n))
+
+(*s Same, but filtered by a signature. *)
+
+let rec eta_args_sign n = function 
+  | [] -> [] 
+  | true :: s -> (MLrel n) :: (eta_args_sign (n-1) s) 
+  | false :: s -> eta_args_sign (n-1) s
+
+(*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *)
+
+let rec test_eta_args_lift k n = function 
+  | [] -> n=0
+  | a :: q -> (a = (MLrel (k+n))) && (test_eta_args_lift k (pred n) q)
+
+(*s Computes an eta-reduction. *)
+
+let eta_red e = 
+  let ids,t = collect_lams e in 
+  let n = List.length ids in
+  if n = 0 then e 
+  else match t with 
+    | MLapp (f,a) -> 
+	let m = (List.length a) - n in 
+	if m < 0 then e 
+	else
+	  let a1,a2 = list_chop m a in 
+	  let f = if m = 0 then f else MLapp (f,a1) in 
+	  if test_eta_args_lift 0 n a2 && not (ast_occurs_itvl 1 n f)
+	  then ast_lift (-n) f
+	  else e 
+    | _ -> e
+
+(*s Computes all head linear beta-reductions possible in [(t a)].
+  Non-linear head beta-redex become let-in. *)
+
+let rec linear_beta_red a t = match a,t with  
+  | [], _ -> t 
+  | a0::a, MLlam (id,t) ->
+      (match nb_occur_match t with
+	 | 0 -> linear_beta_red a (ast_pop t)
+	 | 1 -> linear_beta_red a (ast_subst a0 t)
+	 | _ -> 
+	     let a = List.map (ast_lift 1) a in 
+	     MLletin (id, a0, linear_beta_red a t))
+  | _ -> MLapp (t, a)
+
+(*s Applies a substitution [s] of constants by their body, plus 
+  linear beta reductions at modified positions. *)  
+
+let rec ast_glob_subst s t = match t with 
+  | MLapp ((MLglob (ConstRef kn)) as f, a) -> 
+      let a = List.map (ast_glob_subst s) a in 
+      (try linear_beta_red a (KNmap.find kn s) 
+       with Not_found -> MLapp (f, a))
+  | MLglob (ConstRef kn) -> (try KNmap.find kn s with Not_found -> t)
+  | _ -> ast_map (ast_glob_subst s) t
+
+
+(*S Auxiliary functions used in simplification of ML cases. *)
+
+(*s [check_and_generalize (r0,l,c)] transforms any [MLcons(r0,l)] in [MLrel 1]
+  and raises [Impossible] if any variable in [l] occurs outside such a 
+  [MLcons] *)
+
+let check_and_generalize (r0,l,c) = 
+  let nargs = List.length l in 
+  let rec genrec n = function 
+    | MLrel i as c -> 
+	let i' = i-n in 
+	if i'<1 then c 
+	else if i'>nargs then MLrel (i-nargs+1) 
+	else raise Impossible
+    | MLcons(r,args) when r=r0 && (test_eta_args_lift n nargs args) -> 
+	MLrel (n+1) 
+    | a -> ast_map_lift genrec n a
+  in genrec 0 c  
+
+(*s [check_generalizable_case] checks if all branches can be seen as the 
+  same function [f] applied to the term matched. It is a generalized version 
+  of the identity case optimization. *)
+
+(* CAVEAT: this optimization breaks typing in some special case. example: 
+   [type 'x a = A]. Then [let f = function A -> A] has type ['x a -> 'y a],
+   which is incompatible with the type of [let f x = x].
+   By default, we brutally disable this optim except for some known types: 
+   [bool], [sumbool], [sumor] *)
+
+let generalizable_list = 
+  let datatypes = MPfile (dirpath_of_string "Coq.Init.Datatypes")
+  and specif = MPfile (dirpath_of_string "Coq.Init.Specif")
+  in 
+  [ make_kn datatypes empty_dirpath (mk_label "bool"); 
+    make_kn specif empty_dirpath (mk_label "sumbool");
+    make_kn specif empty_dirpath (mk_label "sumor") ]
+
+let check_generalizable_case unsafe br = 
+  if not unsafe then 
+    (match br.(0) with 
+     | ConstructRef ((kn,_),_), _, _ ->
+	 if not (List.mem kn generalizable_list) then raise Impossible
+     | _ -> assert false); 
+  let f = check_and_generalize br.(0) in 
+  for i = 1 to Array.length br - 1 do 
+    if check_and_generalize br.(i) <> f then raise Impossible 
+  done; f
+
+(*s Do all branches correspond to the same thing? *)
+
+let check_constant_case br = 
+  if br = [||] then raise Impossible; 
+  let (r,l,t) = br.(0) in
+  let n = List.length l in 
+  if ast_occurs_itvl 1 n t then raise Impossible; 
+  let cst = ast_lift (-n) t in 
+  for i = 1 to Array.length br - 1 do 
+    let (r,l,t) = br.(i) in
+    let n = List.length l in
+    if (ast_occurs_itvl 1 n t) || (cst <> (ast_lift (-n) t)) 
+    then raise Impossible
+  done; cst
+
+(*s If all branches are functions, try to permut the case and the functions. *)
+
+let rec merge_ids ids ids' = match ids,ids' with 
+  | [],l -> l 
+  | l,[] -> l
+  | i::ids, i'::ids' -> 
+      (if i = dummy_name then i' else i) :: (merge_ids ids ids')
+
+let is_exn = function MLexn _ -> true | _ -> false
+
+let rec permut_case_fun br acc = 
+  let nb = ref max_int in 
+  Array.iter (fun (_,_,t) -> 
+		let ids, c = collect_lams t in 
+		let n = List.length ids in 
+		if (n < !nb) && (not (is_exn c)) then nb := n) br; 
+  if !nb = max_int || !nb = 0 then ([],br) 
+  else begin
+    let br = Array.copy br in 
+    let ids = ref [] in  
+    for i = 0 to Array.length br - 1 do 
+      let (r,l,t) = br.(i) in 
+      let local_nb = nb_lams t in 
+      if local_nb < !nb then (* t = MLexn ... *)
+	br.(i) <- (r,l,remove_n_lams local_nb t)
+      else begin
+	let local_ids,t = collect_n_lams !nb t in 
+	ids := merge_ids !ids local_ids; 
+	br.(i) <- (r,l,permut_rels !nb (List.length l) t)
+      end
+    done; 
+    (!ids,br)
+  end
+  
+(*S Generalized iota-reduction. *)
+
+(* Definition of a generalized iota-redex: it's a [MLcase(e,_)] 
+   with [(is_iota_gen e)=true]. Any generalized iota-redex is 
+   transformed into beta-redexes. *)
+
+let rec is_iota_gen = function 
+  | MLcons _ -> true
+  | MLcase(_,br)-> array_for_all (fun (_,_,t)->is_iota_gen t) br
+  | _ -> false
+
+let constructor_index = function
+  | ConstructRef (_,j) -> pred j
+  | _ -> assert false
+
+let iota_gen br = 
+  let rec iota k = function 
+    | MLcons (r,a) ->
+	let (_,ids,c) = br.(constructor_index r) in
+	let c = List.fold_right (fun id t -> MLlam (id,t)) ids c in
+	let c = ast_lift k c in 
+	MLapp (c,a)
+    | MLcase(e,br') -> 
+	let new_br = 
+	  Array.map (fun (n,i,c)->(n,i,iota (k+(List.length i)) c)) br'
+	in MLcase(e, new_br)
+    | _ -> assert false
+  in iota 0 
+
+let is_atomic = function 
+  | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true
+  | _ -> false
+
+(*S The main simplification function. *)
+
+(* Some beta-iota reductions + simplifications. *)
+
+let rec simpl o = function
+  | MLapp (f, []) ->
+      simpl o f
+  | MLapp (f, a) -> 
+      simpl_app o (List.map (simpl o) a) (simpl o f)
+  | MLcase (e,br) ->
+      let br = Array.map (fun (n,l,t) -> (n,l,simpl o t)) br in 
+      simpl_case o br (simpl o e) 
+  | MLletin(id,c,e) when 
+      (id = dummy_name) || (is_atomic c) || (is_atomic e) ||
+      (let n = nb_occur_match e in n = 0 || (n=1 && o.opt_lin_let)) -> 
+	simpl o (ast_subst c e)
+  | MLfix(i,ids,c) -> 
+      let n = Array.length ids in 
+      if ast_occurs_itvl 1 n c.(i) then 
+	MLfix (i, ids, Array.map (simpl o) c)
+      else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *)
+  | a -> ast_map (simpl o) a 
+
+and simpl_app o a = function  
+  | MLapp (f',a') -> simpl_app o (a'@a) f'
+  | MLlam (id,t) when id = dummy_name -> 
+      simpl o (MLapp (ast_pop t, List.tl a))
+  | MLlam (id,t) -> (* Beta redex *)
+      (match nb_occur_match t with
+	 | 0 -> simpl o (MLapp (ast_pop t, List.tl a))
+	 | 1 when o.opt_lin_beta -> 
+	     simpl o (MLapp (ast_subst (List.hd a) t, List.tl a))
+	 | _ -> 
+	     let a' = List.map (ast_lift 1) (List.tl a) in
+	     simpl o (MLletin (id, List.hd a, MLapp (t, a'))))
+  | MLletin (id,e1,e2) when o.opt_let_app -> 
+      (* Application of a letin: we push arguments inside *)
+      MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a)))
+  | MLcase (e,br) when o.opt_case_app -> 
+      (* Application of a case: we push arguments inside *)
+      let br' = 
+	Array.map 
+      	  (fun (n,l,t) -> 
+	     let k = List.length l in
+	     let a' = List.map (ast_lift k) a in
+      	     (n, l, simpl o (MLapp (t,a')))) br 
+      in simpl o (MLcase (e,br')) 
+  | (MLdummy | MLexn _) as e -> e 
+	(* We just discard arguments in those cases. *)
+  | f -> MLapp (f,a)
+
+and simpl_case o br e = 
+  if o.opt_case_iot && (is_iota_gen e) then (* Generalized iota-redex *)
+    simpl o (iota_gen br e)
+  else 
+    try (* Does a term [f] exist such as each branch is [(f e)] ? *)
+      if not o.opt_case_idr then raise Impossible;
+      let f = check_generalizable_case o.opt_case_idg br in 
+      simpl o (MLapp (MLlam (anonymous,f),[e]))
+    with Impossible -> 
+      try (* Is each branch independant of [e] ? *) 
+	if not o.opt_case_cst then raise Impossible;
+	check_constant_case br 
+      with Impossible ->
+	(* Swap the case and the lam if possible *)
+	if o.opt_case_fun 
+	then 
+	  let ids,br = permut_case_fun br [] in 
+	  let n = List.length ids in 
+	  if n <> 0 then named_lams ids (MLcase (ast_lift n e, br))
+	  else MLcase (e, br) 
+	else MLcase (e,br)
+
+let rec post_simpl = function 
+  | MLletin(_,c,e) when (is_atomic (eta_red c)) -> 
+      post_simpl (ast_subst (eta_red c) e)
+  | a -> ast_map post_simpl a 
+
+(*S Local prop elimination. *) 
+(* We try to eliminate as many [prop] as possible inside an [ml_ast]. *)
+
+(*s In a list, it selects only the elements corresponding to a [true] 
+   in the boolean list [l]. *)
+
+let rec select_via_bl l args = match l,args with 
+  | [],_ -> args
+  | true::l,a::args -> a :: (select_via_bl l args)
+  | false::l,a::args -> select_via_bl l args
+  | _ -> assert false 
+
+(*s [kill_some_lams] removes some head lambdas according to the bool list [bl].
+   This list is build on the identifier list model: outermost lambda
+   is on the right. [true] means "to keep" and [false] means "to eliminate". 
+   [Rels] corresponding to removed lambdas are supposed not to occur, and 
+   the other [Rels] are made correct via a [gen_subst].
+   Output is not directly a [ml_ast], compose with [named_lams] if needed. *)
+
+let kill_some_lams bl (ids,c) =
+  let n = List.length bl in
+  let n' = List.fold_left (fun n b -> if b then (n+1) else n) 0 bl in 
+  if n = n' then ids,c
+  else if n' = 0 then [],ast_lift (-n) c 
+  else begin
+    let v = Array.make n MLdummy in 
+    let rec parse_ids i j = function 
+      | [] -> ()
+      | true :: l -> v.(i) <- MLrel j; parse_ids (i+1) (j+1) l
+      | false :: l -> parse_ids (i+1) j l
+    in parse_ids 0 1 bl ; 
+    select_via_bl bl ids, gen_subst v (n'-n) c
+  end
+
+(*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding 
+  to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or 
+  if there is no lambda left at all. *)
+
+let kill_dummy_lams c = 
+  let ids,c = collect_lams c in 
+  let bl = List.map ((<>) dummy_name) ids in 
+  if (List.mem true bl) && (List.mem false bl) then 
+    let ids',c = kill_some_lams bl (ids,c) in 
+    ids, named_lams ids' c
+  else raise Impossible
+
+(*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] 
+   and a signature [s] and builds a eta-long version. *)
+
+(* For example, if [s = [true;true;false;true]] then the output is :
+   [fun idn ... id1 x x _ x -> (c' 4 3 __ 1)]  with [c' = lift 4 c] *)
+
+let eta_expansion_sign s (ids,c) =
+  let rec abs ids rels i = function
+    | [] -> 
+	let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels
+	in ids, MLapp (ast_lift (i-1) c, a) 
+    | true :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l 
+    | false :: l -> abs (dummy_name :: ids) (MLdummy :: rels) (i+1) l
+  in abs ids [] 1 s
+
+(*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] 
+  in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas 
+  corresponding to [false] in [s]. *)
+
+let case_expunge s e = 
+  let m = List.length s in 
+  let n = nb_lams e in 
+  let p = if m <= n then collect_n_lams m e 
+  else eta_expansion_sign (list_skipn n s) (collect_lams e) in 
+  kill_some_lams (List.rev s) p
+
+(*s [term_expunge] takes a function [fun idn ... id1 -> c] 
+  and a signature [s] and remove dummy lams. The difference 
+  with [case_expunge] is that we here leave one dummy lambda 
+  if all lambdas are dummy. *)
+
+let term_expunge s (ids,c) =
+  if s = [] then c 
+  else 
+    let ids,c = kill_some_lams (List.rev s) (ids,c) in 
+    if ids = [] then MLlam (dummy_name, ast_lift 1 c)
+    else named_lams ids c
+
+(*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and 
+  purge the args of [t0] corresponding to a [dummy_name]. 
+  It makes eta-expansion if needed. *) 
+
+let kill_dummy_args ids t0 t =
+  let m = List.length ids in 
+  let bl = List.rev_map ((<>) dummy_name) ids in
+  let rec killrec n = function 
+    | MLapp(e, a) when e = ast_lift n t0 -> 
+	let k = max 0 (m - (List.length a)) in 
+	let a = List.map (killrec n) a in  
+	let a = List.map (ast_lift k) a in 
+	let a = select_via_bl bl (a @ (eta_args k)) in 
+	named_lams (list_firstn k ids) (MLapp (ast_lift k e, a)) 
+    | e when e = ast_lift n t0 -> 
+	let a = select_via_bl bl (eta_args m) in 
+	named_lams ids (MLapp (ast_lift m e, a))
+    | e -> ast_map_lift killrec n e 
+  in killrec 0 t 
+
+(*s The main function for local [dummy] elimination. *)
+
+let rec kill_dummy = function 
+  | MLfix(i,fi,c) -> 
+      (try 
+	 let ids,c = kill_dummy_fix i fi c in 
+	 ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids (MLrel 1) (MLrel 1))
+       with Impossible -> MLfix (i,fi,Array.map kill_dummy c))
+  | MLapp (MLfix (i,fi,c),a) -> 
+      (try 
+	 let ids,c = kill_dummy_fix i fi c in 
+	 let a = List.map (fun t -> ast_lift 1 (kill_dummy t)) a in 
+	 let e = kill_dummy_args ids (MLrel 1) (MLapp (MLrel 1,a)) in
+	 ast_subst (MLfix (i,fi,c)) e  
+       with Impossible -> 
+	 MLapp(MLfix(i,fi,Array.map kill_dummy c),List.map kill_dummy a))
+  | MLletin(id, MLfix (i,fi,c),e) -> 
+      (try 
+	 let ids,c = kill_dummy_fix i fi c in
+	 let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in 
+	 MLletin(id, MLfix(i,fi,c),e)
+      with Impossible -> 
+	MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e))
+  | MLletin(id,c,e) -> 
+      (try 
+	 let ids,c = kill_dummy_lams c in 
+	 let e = kill_dummy_args ids (MLrel 1) e in 
+	 MLletin (id, kill_dummy c,kill_dummy e) 
+       with Impossible -> MLletin(id,kill_dummy c,kill_dummy e))
+  | a -> ast_map kill_dummy a
+
+and kill_dummy_fix i fi c = 
+  let n = Array.length fi in 
+  let ids,ci = kill_dummy_lams c.(i) in 
+  let c = Array.copy c in c.(i) <- ci; 
+  for j = 0 to (n-1) do 
+    c.(j) <- kill_dummy (kill_dummy_args ids (MLrel (n-i)) c.(j)) 
+  done;
+  ids,c
+
+(*s Putting things together. *)
+
+let normalize a = 
+  let o = optims () in 
+  let a = simpl o a in 
+  if o.opt_kill_dum then post_simpl (kill_dummy a) else a
+
+(*S Special treatment of fixpoint for pretty-printing purpose. *)
+
+let general_optimize_fix f ids n args m c = 
+  let v = Array.make n 0 in 
+  for i=0 to (n-1) do v.(i)<-i done;
+  let aux i = function 
+    | MLrel j when v.(j-1)>=0 -> v.(j-1)<-(-i-1)
+    | _ -> raise Impossible
+  in list_iter_i aux args; 
+  let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in
+  let new_f = anonym_lams (MLapp (MLrel (n+m+1),args_f)) m in  
+  let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in
+  MLfix(0,[|f|],[|new_c|])
+
+let optimize_fix a = 
+  if not (optims()).opt_fix_fun then a 
+  else
+    let ids,a' = collect_lams a in 
+    let n = List.length ids in 
+    if n = 0 then a 
+    else match a' with 
+      | MLfix(_,[|f|],[|c|]) ->
+	  let new_f = MLapp (MLrel (n+1),eta_args n) in 
+	  let new_c = named_lams ids (normalize (ast_subst new_f c))
+	  in MLfix(0,[|f|],[|new_c|])
+      | MLapp(a',args) ->
+	  let m = List.length args in 
+	  (match a' with 
+	     | MLfix(_,_,_) when 
+		 (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a') 
+		 -> a'
+	     | MLfix(_,[|f|],[|c|]) -> 
+		 (try general_optimize_fix f ids n args m c
+		  with Impossible -> 
+		    named_lams ids (MLapp (MLfix (0,[|f|],[|c|]),args))) 
+	     | _ -> a)
+      | _ -> a
+
+(*S Inlining. *)
+
+(* Utility functions used in the decision of inlining. *)
+
+let rec ml_size = function
+  | MLapp(t,l) -> List.length l + ml_size t + ml_size_list l
+  | MLlam(_,t) -> 1 + ml_size t
+  | MLcons(_,l) -> ml_size_list l
+  | MLcase(t,pv) -> 
+      1 + ml_size t + (Array.fold_right (fun (_,_,t) a -> a + ml_size t) pv 0)
+  | MLfix(_,_,f) -> ml_size_array f
+  | MLletin (_,_,t) -> ml_size t
+  | MLmagic t -> ml_size t
+  | _ -> 0
+
+and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l
+
+and ml_size_array l = Array.fold_left (fun a t -> a + ml_size t) 0 l
+
+let is_fix = function MLfix _ -> true | _ -> false
+
+let rec is_constr = function
+  | MLcons _   -> true
+  | MLlam(_,t) -> is_constr t
+  | _          -> false
+
+(*s Strictness *)
+
+(* A variable is strict if the evaluation of the whole term implies
+   the evaluation of this variable. Non-strict variables can be found 
+   behind Match, for example. Expanding a term [t] is a good idea when 
+   it begins by at least one non-strict lambda, since the corresponding 
+   argument to [t] might be unevaluated in the expanded code. *)
+
+exception Toplevel
+
+let lift n l = List.map ((+) n) l
+
+let pop n l = List.map (fun x -> if x<=n then raise Toplevel else x-n) l 
+
+(* This function returns a list of de Bruijn indices of non-strict variables,
+   or raises [Toplevel] if it has an internal non-strict variable. 
+   In fact, not all variables are checked for strictness, only the ones which 
+   de Bruijn index is in the candidates list [cand]. The flag [add] controls 
+   the behaviour when going through a lambda: should we add the corresponding 
+   variable to the candidates?  We use this flag to check only the external 
+   lambdas, those that will correspond to arguments. *)
+
+let rec non_stricts add cand = function 
+  | MLlam (id,t) -> 
+      let cand = lift 1 cand in
+      let cand = if add then 1::cand else cand in
+      pop 1 (non_stricts add cand t)
+  | MLrel n -> 
+      List.filter ((<>) n) cand  
+  | MLapp (MLrel n, _) -> 
+      List.filter ((<>) n) cand
+	(* In [(x y)] we say that only x is strict. Cf [sig_rec]. We may *)
+	(* gain something if x is replaced by a function like a projection *)
+  | MLapp (t,l)-> 
+      let cand = non_stricts false cand t in 
+      List.fold_left (non_stricts false) cand l 
+  | MLcons (_,l) -> 
+      List.fold_left (non_stricts false) cand l
+  | MLletin (_,t1,t2) -> 
+      let cand = non_stricts false cand t1 in 
+      pop 1 (non_stricts add (lift 1 cand) t2)
+  | MLfix (_,i,f)-> 
+      let n = Array.length i in
+      let cand = lift n cand in 
+      let cand = Array.fold_left (non_stricts false) cand f in 
+      pop n cand
+  | MLcase (t,v) -> 
+      (* The only interesting case: for a variable to be non-strict, *)
+      (* it is sufficient that it appears non-strict in at least one branch, *)
+      (* so we make an union (in fact a merge). *)
+      let cand = non_stricts false cand t in 
+      Array.fold_left 
+	(fun c (_,i,t)-> 
+	   let n = List.length i in 
+	   let cand = lift n cand in 
+	   let cand = pop n (non_stricts add cand t) in
+	   Sort.merge (<=) cand c) [] v
+	(* [merge] may duplicates some indices, but I don't mind. *)
+  | MLmagic t -> 
+      non_stricts add cand t
+  | _ -> 
+      cand
+
+(* The real test: we are looking for internal non-strict variables, so we start
+   with no candidates, and the only positive answer is via the [Toplevel] 
+   exception. *)
+
+let is_not_strict t = 
+  try let _ = non_stricts true [] t in false
+  with Toplevel -> true
+
+(*s Inlining decision *)
+
+(* [inline_test] answers the following question: 
+   If we could inline [t] (the user said nothing special), 
+   should we inline ? 
+   
+   We expand small terms with at least one non-strict 
+   variable (i.e. a variable that may not be evaluated).
+   
+   Futhermore we don't expand fixpoints. *)
+
+let inline_test t = 
+  not (is_fix (eta_red t)) && (ml_size t < 12 && is_not_strict t)
+
+let manual_inline_list = 
+  let mp = MPfile (dirpath_of_string "Coq.Init.Wf") in 
+  List.map (fun s -> (make_kn mp empty_dirpath (mk_label s)))
+    [ "well_founded_induction_type"; "well_founded_induction"; 
+      "Acc_rect"; "Acc_rec" ; "Acc_iter" ]
+
+let manual_inline = function 
+  | ConstRef c -> List.mem c manual_inline_list
+  | _ -> false 
+
+(* If the user doesn't say he wants to keep [t], we inline in two cases:
+   \begin{itemize}
+   \item the user explicitly requests it 
+   \item [expansion_test] answers that the inlining is a good idea, and 
+   we are free to act (AutoInline is set)
+   \end{itemize} *)
+
+let inline r t = 
+  not (to_keep r) (* The user DOES want to keep it *)
+  && not (is_inline_custom r) 
+  && (to_inline r (* The user DOES want to inline it *) 
+     || (auto_inline () && lang () <> Haskell && not (is_projection r)
+         && (is_recursor r || manual_inline r || inline_test t)))
+
diff --git a/contrib/extraction/mlutil.mli b/contrib/extraction/mlutil.mli
new file mode 100644
index 00000000..eaf38778
--- /dev/null
+++ b/contrib/extraction/mlutil.mli
@@ -0,0 +1,111 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: mlutil.mli,v 1.47.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+open Util
+open Names
+open Term
+open Libnames
+open Miniml
+
+(*s Utility functions over ML types with meta. *)
+
+val reset_meta_count : unit -> unit
+val new_meta : 'a -> ml_type
+
+val type_subst : int -> ml_type -> ml_type -> ml_type
+val type_subst_list : ml_type list -> ml_type -> ml_type
+val type_subst_vect : ml_type array -> ml_type -> ml_type
+
+val instantiation : ml_schema -> ml_type
+
+val needs_magic : ml_type * ml_type -> bool
+val put_magic_if : bool -> ml_ast -> ml_ast
+val put_magic : ml_type * ml_type -> ml_ast -> ml_ast
+
+(*s ML type environment. *)
+
+module Mlenv : sig 
+  type t 
+  val empty : t
+    
+  (* get the n-th more recently entered schema and instantiate it. *) 
+  val get : t -> int -> ml_type
+
+  (* Adding a type in an environment, after generalizing free meta *)
+  val push_gen : t -> ml_type -> t
+
+  (* Adding a type with no [Tvar] *)
+  val push_type : t -> ml_type -> t
+     
+  (* Adding a type with no [Tvar] nor [Tmeta] *)
+  val push_std_type : t -> ml_type -> t
+end
+
+(*s Utility functions over ML types without meta *)
+
+val type_mem_kn : kernel_name -> ml_type -> bool
+
+val type_maxvar : ml_type -> int
+
+val type_decomp : ml_type -> ml_type list * ml_type
+val type_recomp : ml_type list * ml_type -> ml_type
+
+val var2var' : ml_type -> ml_type 
+
+type abbrev_map = global_reference -> ml_type option
+
+val type_expand : abbrev_map -> ml_type -> ml_type 
+val type_eq : abbrev_map -> ml_type -> ml_type -> bool
+val type_neq : abbrev_map -> ml_type -> ml_type -> bool
+val type_to_sign : abbrev_map -> ml_type -> bool list
+val type_expunge : abbrev_map -> ml_type -> ml_type
+
+val case_expunge : bool list -> ml_ast -> identifier list * ml_ast
+val term_expunge : bool list -> identifier list * ml_ast -> ml_ast
+
+
+(*s Special identifiers. [dummy_name] is to be used for dead code
+    and will be printed as [_] in concrete (Caml) code. *)
+
+val anonymous : identifier
+val dummy_name : identifier
+val id_of_name : name -> identifier
+
+(*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns
+    the list [idn;...;id1] and the term [t]. *)
+
+val collect_lams : ml_ast -> identifier list * ml_ast
+val collect_n_lams : int -> ml_ast -> identifier list * ml_ast
+val nb_lams : ml_ast -> int
+
+val dummy_lams : ml_ast -> int -> ml_ast
+val anonym_or_dummy_lams : ml_ast -> bool list -> ml_ast
+
+val eta_args_sign : int -> bool list -> ml_ast list 
+
+(*s Utility functions over ML terms. *)
+
+val ast_map : (ml_ast -> ml_ast) -> ml_ast -> ml_ast
+val ast_map_lift : (int -> ml_ast -> ml_ast) -> int -> ml_ast -> ml_ast
+val ast_iter : (ml_ast -> unit) -> ml_ast -> unit
+val ast_occurs : int -> ml_ast -> bool
+val ast_occurs_itvl : int -> int -> ml_ast -> bool
+val ast_lift : int -> ml_ast -> ml_ast
+val ast_pop : ml_ast -> ml_ast
+val ast_subst : ml_ast -> ml_ast -> ml_ast
+
+val ast_glob_subst : ml_ast KNmap.t -> ml_ast -> ml_ast
+
+val normalize : ml_ast -> ml_ast 
+val optimize_fix : ml_ast -> ml_ast
+val inline : global_reference -> ml_ast -> bool
+
+
+
diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml
new file mode 100644
index 00000000..feb9e54e
--- /dev/null
+++ b/contrib/extraction/modutil.ml
@@ -0,0 +1,405 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: modutil.ml,v 1.7.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+open Names
+open Declarations
+open Environ
+open Libnames
+open Util
+open Miniml
+open Table
+open Mlutil
+
+(*S Functions upon modules missing in [Modops]. *) 
+
+(*s Add _all_ direct subobjects of a module, not only those exported. 
+   Build on the [Modops.add_signature] model. *)
+
+let add_structure mp msb env = 
+  let add_one env (l,elem) = 
+    let kn = make_kn mp empty_dirpath l in 
+    match elem with 
+      | SEBconst cb -> Environ.add_constant kn cb env 
+      | SEBmind mib -> Environ.add_mind kn mib env 
+      | SEBmodule mb -> Modops.add_module (MPdot (mp,l)) mb env 
+      | SEBmodtype mtb -> Environ.add_modtype kn mtb env  
+  in List.fold_left add_one env msb
+
+(*s Apply a module path substitution on a module.
+   Build on the [Modops.subst_modtype] model. *)
+
+let rec subst_module sub mb =
+  let mtb' = Modops.subst_modtype sub mb.mod_type
+  and meb' = option_smartmap (subst_meb sub) mb.mod_expr
+  and mtb'' = option_smartmap (Modops.subst_modtype sub) mb.mod_user_type
+  and mpo' = option_smartmap (subst_mp sub) mb.mod_equiv in
+  if (mtb'==mb.mod_type) && (meb'==mb.mod_expr) && 
+    (mtb''==mb.mod_user_type) && (mpo'==mb.mod_equiv)
+  then mb
+  else { mod_expr= meb'; 
+	 mod_type=mtb'; 
+	 mod_user_type=mtb''; 
+	 mod_equiv=mpo'; 
+	 mod_constraints=mb.mod_constraints }
+
+and subst_meb sub = function 
+  | MEBident mp -> MEBident (subst_mp sub mp) 
+  | MEBfunctor (mbid, mtb, meb) -> 
+      assert (not (occur_mbid mbid sub)); 
+      MEBfunctor (mbid, Modops.subst_modtype sub mtb, subst_meb sub meb)
+  | MEBstruct (msid, msb) -> 
+      assert (not (occur_msid msid sub));
+      MEBstruct (msid, subst_msb sub msb)
+  | MEBapply (meb, meb', c) -> 
+      MEBapply (subst_meb sub meb, subst_meb sub meb', c)
+
+and subst_msb sub msb = 
+  let subst_body = function
+    | SEBconst cb -> SEBconst (subst_const_body sub cb)
+    | SEBmind mib -> SEBmind (subst_mind sub mib)
+    | SEBmodule mb -> SEBmodule (subst_module sub mb)
+    | SEBmodtype mtb -> SEBmodtype (Modops.subst_modtype sub mtb)
+  in List.map (fun (l,b) -> (l,subst_body b)) msb
+
+(*s Change a msid in a module type, to follow a module expr. 
+  Because of the "with" construct, the module type of a module can be a 
+  [MTBsig] with a msid different from the one of the module. *)
+
+let rec replicate_msid meb mtb = match meb,mtb with 
+  | MEBfunctor (_, _, meb), MTBfunsig (mbid, mtb1, mtb2) -> 
+      let mtb' = replicate_msid meb mtb2 in 
+      if mtb' == mtb2 then mtb else MTBfunsig (mbid, mtb1, mtb')
+  | MEBstruct (msid, _), MTBsig (msid1, msig) when msid <> msid1 -> 
+      let msig' = Modops.subst_signature_msid msid1 (MPself msid) msig in
+      if msig' == msig then MTBsig (msid, msig) else MTBsig (msid, msig')
+  | _ -> mtb
+
+
+(*S More functions concerning [module_path]. *)
+
+let rec mp_length = function
+  | MPdot (mp, _) -> 1 + (mp_length mp)
+  | _ -> 1
+
+let rec prefixes_mp mp = match mp with 
+  | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp')
+  | _ -> MPset.singleton mp 
+
+let rec common_prefix prefixes_mp1 mp2 = 
+  if MPset.mem mp2 prefixes_mp1 then mp2 
+  else match mp2 with 
+    | MPdot (mp,_) -> common_prefix prefixes_mp1 mp 
+    | _ -> raise Not_found
+
+let common_prefix_from_list mp0 mpl = 
+  let prefixes_mp0 = prefixes_mp mp0 in 
+  let rec f = function 
+    | [] -> raise Not_found
+    | mp1 :: l -> try common_prefix prefixes_mp0 mp1 with Not_found -> f l
+  in f mpl
+
+let rec modfile_of_mp mp = match mp with 
+  | MPfile _ -> mp
+  | MPdot (mp,_) -> modfile_of_mp mp 
+  | _ -> raise Not_found
+
+let rec parse_labels ll = function 
+  | MPdot (mp,l) -> parse_labels (l::ll) mp 
+  | mp -> mp,ll
+
+let labels_of_mp mp = parse_labels [] mp 
+
+let labels_of_kn kn = 
+  let mp,_,l = repr_kn kn in parse_labels [l] mp
+
+let rec add_labels_mp mp = function 
+  | [] -> mp 
+  | l :: ll -> add_labels_mp (MPdot (mp,l)) ll
+
+
+(*S Functions upon ML modules. *)
+
+(*s Apply some functions upon all [ml_decl] and [ml_spec] found in a 
+   [ml_structure]. *) 
+
+let struct_iter do_decl do_spec s = 
+  let rec mt_iter = function 
+    | MTident _ -> () 
+    | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt'
+    | MTsig (_, sign) -> List.iter spec_iter sign
+  and spec_iter = function 
+    | (_,Spec s) -> do_spec s
+    | (_,Smodule mt) -> mt_iter mt
+    | (_,Smodtype mt) -> mt_iter mt
+  in
+  let rec se_iter = function 
+    | (_,SEdecl d) -> do_decl d
+    | (_,SEmodule m) -> 
+	me_iter m.ml_mod_expr; mt_iter m.ml_mod_type
+    | (_,SEmodtype m) -> mt_iter m
+  and me_iter = function 
+    | MEident _ -> () 
+    | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt
+    | MEapply (me,me') -> me_iter me; me_iter me'
+    | MEstruct (msid, sel) -> List.iter se_iter sel
+  in 
+  List.iter (function (_,sel) -> List.iter se_iter sel) s
+
+(*s Apply some fonctions upon all references in [ml_type], [ml_ast], 
+  [ml_decl], [ml_spec] and [ml_structure]. *)
+
+type do_ref = global_reference -> unit
+
+let type_iter_references do_type t = 
+  let rec iter = function 
+    | Tglob (r,l) -> do_type r; List.iter iter l 
+    | Tarr (a,b) -> iter a; iter b 
+    | _ -> () 
+  in iter t
+
+let ast_iter_references do_term do_cons do_type a = 
+  let rec iter a = 
+    ast_iter iter a;
+    match a with 
+      | MLglob r -> do_term r
+      | MLcons (r,_) -> do_cons r
+      | MLcase (_,v) as a -> Array.iter (fun (r,_,_) -> do_cons r) v
+      | _ -> ()
+  in iter a
+
+let ind_iter_references do_term do_cons do_type kn ind = 
+  let type_iter = type_iter_references do_type in
+  let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in 
+  let packet_iter ip p = 
+    do_type (IndRef ip); Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types 
+  in
+  if ind.ind_info = Record then List.iter do_term (find_projections kn); 
+  Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets
+  
+let decl_iter_references do_term do_cons do_type = 
+  let type_iter = type_iter_references do_type 
+  and ast_iter = ast_iter_references do_term do_cons do_type in
+  function 
+    | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind 
+    | Dtype (r,_,t) -> do_type r; type_iter t 
+    | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t
+    | Dfix(rv,c,t) -> 	
+	Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t
+
+let spec_iter_references do_term do_cons do_type = function 
+  | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind
+  | Stype (r,_,ot) -> do_type r; option_iter (type_iter_references do_type) ot
+  | Sval (r,t) -> do_term r; type_iter_references do_type t
+
+let struct_iter_references do_term do_cons do_type = 
+  struct_iter 
+    (decl_iter_references do_term do_cons do_type) 
+    (spec_iter_references do_term do_cons do_type) 
+
+(*s Get all references used in one [ml_structure], either in [list] or [set]. *)
+
+type 'a updown = { mutable up : 'a ; mutable down : 'a }
+
+let struct_get_references empty add struc = 
+  let o = { up = empty ; down = empty } in 
+  let do_term r = o.down <- add r o.down in
+  let do_cons r = o.up <- add r o.up in 
+  let do_type = if lang () = Haskell then do_cons else do_term in 
+  struct_iter_references do_term do_cons do_type struc; o
+
+let struct_get_references_set = struct_get_references Refset.empty Refset.add
+
+module Orefset = struct 
+  type t = { set : Refset.t ; list : global_reference list }
+  let empty = { set = Refset.empty ; list = [] }
+  let add r o = 
+    if Refset.mem r o.set then o 
+    else { set = Refset.add r o.set ; list = r :: o.list }
+  let set o = o.set
+  let list o = o.list
+end
+
+let struct_get_references_list struc = 
+  let o = struct_get_references Orefset.empty Orefset.add struc in 
+  { up = Orefset.list o.up; down = Orefset.list o.down }
+
+
+(*s Searching occurrences of a particular term (no lifting done). *)
+
+exception Found
+
+let rec ast_search t a = 
+  if t = a then raise Found else ast_iter (ast_search t) a
+
+let decl_ast_search t = function 
+  | Dterm (_,a,_) -> ast_search t a
+  | Dfix (_,c,_) -> Array.iter (ast_search t) c
+  | _ -> () 
+
+let struct_ast_search t s = 
+  try struct_iter (decl_ast_search t) (fun _ -> ()) s; false
+  with Found -> true
+
+let rec type_search t = function  
+  | Tarr (a,b) -> type_search t a; type_search t b 
+  | Tglob (r,l) -> List.iter (type_search t) l
+  | u -> if t = u then raise Found
+
+let decl_type_search t = function 
+  | Dind (_,{ind_packets=p})  -> 
+      Array.iter 
+	(fun {ip_types=v} -> Array.iter (List.iter (type_search t)) v) p
+  | Dterm (_,_,u) -> type_search t u
+  | Dfix (_,_,v) -> Array.iter (type_search t) v
+  | Dtype (_,_,u) -> type_search t u
+
+let spec_type_search t = function 
+  | Sind (_,{ind_packets=p}) -> 
+      Array.iter 
+	(fun {ip_types=v} -> Array.iter (List.iter (type_search t)) v) p
+  | Stype (_,_,ot) -> option_iter (type_search t) ot
+  | Sval (_,u) -> type_search t u
+
+let struct_type_search t s = 
+  try struct_iter (decl_type_search t) (spec_type_search t) s; false
+  with Found -> true
+
+
+(*s Generating the signature. *)
+
+let rec msig_of_ms = function 
+  | [] -> [] 
+  | (l,SEdecl (Dind (kn,i))) :: ms -> 
+      (l,Spec (Sind (kn,i))) :: (msig_of_ms ms)
+  | (l,SEdecl (Dterm (r,_,t))) :: ms -> 
+      (l,Spec (Sval (r,t))) :: (msig_of_ms ms)
+  | (l,SEdecl (Dtype (r,v,t))) :: ms -> 
+      (l,Spec (Stype (r,v,Some t))) :: (msig_of_ms ms) 
+  | (l,SEdecl (Dfix (rv,_,tv))) :: ms -> 
+      let msig = ref (msig_of_ms ms) in 
+      for i = Array.length rv - 1 downto 0 do 
+	msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig
+      done; 
+      !msig
+  | (l,SEmodule m) :: ms -> (l,Smodule m.ml_mod_type) :: (msig_of_ms ms)
+  | (l,SEmodtype m) :: ms -> (l,Smodtype m) :: (msig_of_ms ms)
+
+let signature_of_structure s = 
+  List.map (fun (mp,ms) -> mp,msig_of_ms ms) s 
+
+
+(*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *)
+
+let get_decl_in_structure r struc = 
+  try 
+    let kn = kn_of_r r in 
+    let base_mp,ll = labels_of_kn kn in 
+    if not (at_toplevel base_mp) then error_not_visible r;
+    let sel = List.assoc base_mp struc in
+    let rec go ll sel = match ll with 
+      | [] -> assert false
+      | l :: ll -> 
+	  match List.assoc l sel with 
+	    | SEdecl d -> d 
+	    | SEmodtype m -> assert false
+	    | SEmodule m ->
+		match m.ml_mod_expr with 
+		  | MEstruct (_,sel) -> go ll sel 
+		  | _ -> error_not_visible r 
+    in go ll sel
+  with Not_found -> assert false
+
+
+(*s Optimization of a [ml_structure]. *)
+
+(* Some transformations of ML terms. [optimize_struct] simplify
+   all beta redexes (when the argument does not occur, it is just
+   thrown away; when it occurs exactly once it is substituted; otherwise
+   a let-in redex is created for clarity) and iota redexes, plus some other
+   optimizations. *)
+
+let dfix_to_mlfix rv av i = 
+  let rec make_subst n s = 
+    if n < 0 then s 
+    else make_subst (n-1) (KNmap.add (kn_of_r rv.(n)) (n+1) s)
+  in 
+  let s = make_subst (Array.length rv - 1) KNmap.empty 
+  in 
+  let rec subst n t = match t with 
+    | MLglob (ConstRef kn) -> 
+	(try MLrel (n + (KNmap.find kn s)) with Not_found -> t)
+    | _ -> ast_map_lift subst n t 
+  in 
+  let ids = Array.map (fun r -> id_of_label (label (kn_of_r r))) rv in 
+  let c = Array.map (subst 0) av 
+  in MLfix(i, ids, c)
+
+let rec optim prm s = function
+  | [] -> []
+  | (Dtype (r,_,Tdummy) | Dterm(r,MLdummy,_)) as d :: l ->
+      if List.mem r prm.to_appear then d :: (optim prm s l) else optim prm s l
+  | Dterm (r,t,typ) :: l ->
+      let t = normalize (ast_glob_subst !s t) in 
+      let i = inline r t in 
+      if i then s := KNmap.add (kn_of_r r) t !s; 
+      if not i || prm.modular || List.mem r prm.to_appear 
+      then 
+	let d = match optimize_fix t with 
+	  | MLfix (0, _, [|c|]) -> 
+	      Dfix ([|r|], [|ast_subst (MLglob r) c|], [|typ|])
+	  | t -> Dterm (r, t, typ)
+	in d :: (optim prm s l)
+      else optim prm s l
+  | d :: l -> d :: (optim prm s l)
+
+let rec optim_se top prm s = function 
+  | [] -> [] 
+  | (l,SEdecl (Dterm (r,a,t))) :: lse -> 
+      let kn = kn_of_r r in 
+      let a = normalize (ast_glob_subst !s a) in 
+      let i = inline r a in 
+      if i then s := KNmap.add kn a !s; 
+      if top && i && not prm.modular && not (List.mem r prm.to_appear)
+      then optim_se top prm s lse
+      else 
+	let d = match optimize_fix a with 
+	  | MLfix (0, _, [|c|]) -> 
+	      Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|])
+	  | a -> Dterm (r, a, t)
+	in (l,SEdecl d) :: (optim_se top prm s lse)
+  | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> 
+      let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in 
+      let all = ref true in 
+      (* This fake body ensures that no fixpoint will be auto-inlined. *)
+      let fake_body = MLfix (0,[||],[||]) in 
+      for i = 0 to Array.length rv - 1 do 
+	if inline rv.(i) fake_body
+	then s := KNmap.add (kn_of_r rv.(i)) (dfix_to_mlfix rv av i) !s
+	else all := false
+      done; 
+      if !all && top && not prm.modular 
+	&& (array_for_all (fun r -> not (List.mem r prm.to_appear)) rv)  
+      then optim_se top prm s lse
+      else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top prm s lse)
+  | (l,SEmodule m) :: lse -> 
+      let m = { m with ml_mod_expr = optim_me prm s m.ml_mod_expr}
+      in (l,SEmodule m) :: (optim_se top prm s lse)
+  | se :: lse -> se :: (optim_se top prm s lse) 
+
+and optim_me prm s = function 
+  | MEstruct (msid, lse) -> MEstruct (msid, optim_se false prm s lse)
+  | MEident mp as me -> me
+  | MEapply (me, me') -> MEapply (optim_me prm s me, optim_me prm s me')
+  | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me prm s me)
+
+let optimize_struct prm before struc = 
+  let subst = ref (KNmap.empty : ml_ast KNmap.t) in 
+  option_iter (fun l -> ignore (optim prm subst l)) before; 
+  List.map (fun (mp,lse) -> (mp, optim_se true prm subst lse)) struc
diff --git a/contrib/extraction/modutil.mli b/contrib/extraction/modutil.mli
new file mode 100644
index 00000000..f73e18f7
--- /dev/null
+++ b/contrib/extraction/modutil.mli
@@ -0,0 +1,70 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: modutil.mli,v 1.2.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+open Names
+open Declarations
+open Environ
+open Libnames
+open Miniml
+
+(*s Functions upon modules missing in [Modops]. *) 
+
+(* Add _all_ direct subobjects of a module, not only those exported. 
+   Build on the [Modops.add_signature] model. *)
+
+val add_structure : module_path -> module_structure_body -> env -> env 
+
+(* Apply a module path substitution on a module.
+   Build on the [Modops.subst_modtype] model. *)
+
+val subst_module : substitution -> module_body -> module_body 
+val subst_meb : substitution -> module_expr_body -> module_expr_body
+val subst_msb : substitution -> module_structure_body -> module_structure_body
+
+(* Change a msid in a module type, to follow a module expr. *)
+
+val replicate_msid : module_expr_body -> module_type_body -> module_type_body
+
+(*s More utilities concerning [module_path]. *)
+
+val mp_length : module_path -> int
+val prefixes_mp : module_path -> MPset.t
+val modfile_of_mp : module_path -> module_path
+val common_prefix_from_list : module_path -> module_path list -> module_path
+val add_labels_mp : module_path -> label list -> module_path
+
+(*s Functions upon ML modules. *)
+
+val struct_ast_search : ml_ast -> ml_structure -> bool
+val struct_type_search : ml_type -> ml_structure -> bool
+
+type do_ref = global_reference -> unit 
+
+val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit
+val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit
+val struct_iter_references : do_ref -> do_ref -> do_ref -> ml_structure -> unit
+
+type 'a updown = { mutable up : 'a ; mutable down : 'a }
+
+val struct_get_references_set : ml_structure -> Refset.t updown
+val struct_get_references_list : ml_structure -> global_reference list updown
+
+val signature_of_structure : ml_structure -> ml_signature
+
+val get_decl_in_structure : global_reference -> ml_structure -> ml_decl
+
+(* Some transformations of ML terms. [optimize_struct] simplify
+   all beta redexes (when the argument does not occur, it is just
+   thrown away; when it occurs exactly once it is substituted; otherwise
+   a let-in redex is created for clarity) and iota redexes, plus some other
+   optimizations. *)
+
+val optimize_struct : 
+  extraction_params -> ml_decl list option -> ml_structure -> ml_structure
diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml
new file mode 100644
index 00000000..707ef94f
--- /dev/null
+++ b/contrib/extraction/ocaml.ml
@@ -0,0 +1,627 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: ocaml.ml,v 1.100.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Production of Ocaml syntax. *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Libnames
+open Table
+open Miniml
+open Mlutil
+open Modutil
+
+let cons_cofix = ref Refset.empty
+
+(*s Some utility functions. *)
+
+let pp_par par st = if par then str "(" ++ st ++ str ")" else st
+
+let pp_tvar id = 
+  let s = string_of_id id in 
+  if String.length s < 2 || s.[1]<>'\'' 
+  then str ("'"^s)
+  else str ("' "^s)
+
+let pp_tuple_light f = function
+  | [] -> mt ()
+  | [x] -> f true x
+  | l -> 
+      pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l)
+
+let pp_tuple f = function
+  | [] -> mt ()
+  | [x] -> f x
+  | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l)
+
+let pp_boxed_tuple f = function
+  | [] -> mt ()
+  | [x] -> f x
+  | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l))
+
+let pp_abst = function
+  | [] -> mt ()
+  | l  -> 
+      str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++ 
+      str " ->" ++ spc ()
+
+let pp_apply st par args = match args with
+  | [] -> st
+  | _  -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args))
+
+let pr_binding = function
+  | [] -> mt ()
+  | l  -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l
+
+let space_if = function true -> str " " | false -> mt ()
+
+let sec_space_if = function true -> spc () | false -> mt ()
+
+let fnl2 () = fnl () ++ fnl () 
+
+(*s Generic renaming issues. *)
+
+let rec rename_id id avoid = 
+  if Idset.mem id avoid then rename_id (lift_ident id) avoid else id
+
+let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id))
+let uppercase_id id = id_of_string (String.capitalize (string_of_id id))
+
+(* [pr_upper_id id] makes 2 String.copy lesser than [pr_id (uppercase_id id)] *)
+let pr_upper_id id = str (String.capitalize (string_of_id id))
+
+(*s de Bruijn environments for programs *)
+
+type env = identifier list * Idset.t
+
+let rec rename_vars avoid = function
+  | [] -> 
+      [], avoid
+  | id :: idl when id == dummy_name ->
+      (* we don't rename dummy binders *)
+      let (idl', avoid') = rename_vars avoid idl in
+      (id :: idl', avoid')
+  | id :: idl ->
+      let (idl, avoid) = rename_vars avoid idl in
+      let id = rename_id (lowercase_id id) avoid in
+      (id :: idl, Idset.add id avoid)
+
+let rename_tvars avoid l = 
+  let rec rename avoid = function 
+    | [] -> [],avoid 
+    | id :: idl -> 
+	let id = rename_id (lowercase_id id) avoid in 
+	let idl, avoid = rename (Idset.add id avoid) idl in 
+	(id :: idl, avoid) in
+  fst (rename avoid l)
+
+let push_vars ids (db,avoid) =
+  let ids',avoid' = rename_vars avoid ids in
+  ids', (ids' @ db, avoid')
+
+let get_db_name n (db,_) = 
+  let id = List.nth db (pred n) in 
+  if id = dummy_name then id_of_string "__" else id
+
+(*s Ocaml renaming issues. *)
+
+let keywords =     
+  List.fold_right (fun s -> Idset.add (id_of_string s))
+  [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
+    "done"; "downto"; "else"; "end"; "exception"; "external"; "false";
+    "for"; "fun"; "function"; "functor"; "if"; "in"; "include";
+    "inherit"; "initializer"; "lazy"; "let"; "match"; "method";
+    "module"; "mutable"; "new"; "object"; "of"; "open"; "or";
+    "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true";
+    "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod";
+    "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] 
+  Idset.empty
+
+let preamble _ used_modules (mldummy,tdummy,tunknown) = 
+  let pp_mp = function 
+    | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
+    | _ -> assert false 
+  in 
+  prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules
+  ++ 
+  (if used_modules = [] then mt () else fnl ())
+  ++
+  (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() else mt()) 
+  ++
+  (if mldummy then 
+     str "let __ = let rec f _ = Obj.repr f in Obj.repr f" ++ fnl ()
+   else mt ()) 
+  ++ 
+  (if tdummy || tunknown || mldummy then fnl () else mt ())
+
+let preamble_sig _ used_modules (_,tdummy,tunknown) = 
+  let pp_mp = function 
+    | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
+    | _ -> assert false 
+  in 
+  prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules
+  ++ 
+  (if used_modules = [] then mt () else fnl ())
+  ++
+  (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() ++ fnl () 
+   else mt()) 
+
+(*s The pretty-printing functor. *)
+
+module Make = functor(P : Mlpp_param) -> struct
+
+let local_mpl = ref ([] : module_path list)
+
+let pp_global r = 
+  if is_inline_custom r then str (find_custom r) 
+  else P.pp_global !local_mpl  r
+
+let empty_env () = [], P.globals ()
+
+(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
+    are needed or not. *)
+
+let rec pp_type par vl t =
+  let rec pp_rec par = function
+    | Tmeta _ | Tvar' _ | Taxiom -> assert false
+    | Tvar i -> (try pp_tvar (List.nth vl (pred i)) 
+		 with _ -> (str "'a" ++ int i))
+    | Tglob (r,[]) -> pp_global r
+    | Tglob (r,l) -> pp_tuple_light pp_rec l ++ spc () ++ pp_global r
+    | Tarr (t1,t2) ->
+	pp_par par 
+	  (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
+    | Tdummy -> str "__"
+    | Tunknown -> str "__"
+    | Tcustom s -> str s
+  in 
+  hov 0 (pp_rec par t)
+
+(*s Pretty-printing of expressions. [par] indicates whether
+    parentheses are needed or not. [env] is the list of names for the
+    de Bruijn variables. [args] is the list of collected arguments
+    (already pretty-printed). *)
+
+let expr_needs_par = function
+  | MLlam _  -> true
+  | MLcase (_,[|_|]) -> false 
+  | MLcase _ -> true
+  | _        -> false 
+
+
+let rec pp_expr par env args = 
+  let par' = args <> [] || par
+  and apply st = pp_apply st par args in 
+  function
+    | MLrel n -> 
+	let id = get_db_name n env in apply (pr_id id)
+    | MLapp (f,args') ->
+	let stl = List.map (pp_expr true env []) args' in
+        pp_expr par env (stl @ args) f
+    | MLlam _ as a -> 
+      	let fl,a' = collect_lams a in
+	let fl,env' = push_vars fl env in
+	let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in
+	apply (pp_par par' st)
+    | MLletin (id,a1,a2) ->
+	let i,env' = push_vars [id] env in
+	let pp_id = pr_id (List.hd i)
+	and pp_a1 = pp_expr false env [] a1
+	and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in 
+	hv 0 
+	  (apply 
+	     (pp_par par' 
+		(hv 0 
+		   (hov 2 
+		      (str "let " ++ pp_id ++ str " =" ++ spc () ++ pp_a1) ++ 
+		    spc () ++ str "in") ++ 
+		 spc () ++ hov 0 pp_a2)))
+    | MLglob r -> 
+	(try 
+	   let args = list_skipn (projection_arity r) args in 
+	   let record = List.hd args in 
+	   pp_apply (record ++ str "." ++ pp_global r) par (List.tl args)
+	 with _ -> apply (pp_global r))
+    | MLcons (r,[]) ->
+	assert (args=[]);
+	if Refset.mem r !cons_cofix then 
+	  pp_par par (str "lazy " ++ pp_global r)
+	else pp_global r
+    | MLcons (r,args') -> 
+	(try 
+	   let projs = find_projections (kn_of_r r) in 
+	   pp_record_pat (projs, List.map (pp_expr true env []) args')
+	 with Not_found ->
+	   assert (args=[]);
+	   let tuple = pp_tuple (pp_expr true env []) args' in 
+	   if Refset.mem r !cons_cofix then 
+	     pp_par par (str "lazy (" ++ pp_global r ++ spc() ++ tuple ++str ")")
+	   else pp_par par (pp_global r ++ spc () ++ tuple))
+    | MLcase (t, pv) ->
+	let r,_,_ = pv.(0) in 
+	let expr = if Refset.mem r !cons_cofix then 
+	  (str "Lazy.force" ++ spc () ++ pp_expr true env [] t)
+	else 
+	  (pp_expr false env [] t) 
+	in 
+	(try 
+	   let projs = find_projections (kn_of_r r) in 
+	   let (_, ids, c) = pv.(0) in 
+	   let n = List.length ids in 
+	   match c with 
+	     | MLrel i when i <= n -> 
+		 apply (pp_par par' (pp_expr true env [] t ++ str "." ++ 
+				     pp_global (List.nth projs (n-i)))) 
+	     | MLapp (MLrel i, a) when i <= n -> 
+		 if List.exists (ast_occurs_itvl 1 n) a 
+		 then raise Not_found
+		 else
+		   let ids,env' = push_vars (List.rev ids) env in
+		   (pp_apply 
+		      (pp_expr true env [] t ++ str "." ++ 
+		       pp_global (List.nth projs (n-i)))
+		      par ((List.map (pp_expr true env' []) a) @ args))
+	     | _ -> raise Not_found
+	 with Not_found -> 
+	   if Array.length pv = 1 then 
+	     let s1,s2 = pp_one_pat env pv.(0) in 
+	     apply 
+	       (hv 0 
+		  (pp_par par' 
+		     (hv 0 
+			(hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr) 
+			 ++ spc () ++ str "in") ++ 
+		      spc () ++ hov 0 s2)))
+	   else
+	     apply
+      	       (pp_par par' 
+      		  (v 0 (str "match " ++ expr ++ str " with" ++
+			fnl () ++ str "  | " ++ pp_pat env pv))))
+    | MLfix (i,ids,defs) ->
+	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
+      	pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
+    | MLexn s -> 
+	(* An [MLexn] may be applied, but I don't really care. *)
+	pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)"))
+    | MLdummy ->
+	str "__" (* An [MLdummy] may be applied, but I don't really care. *)
+    | MLmagic a ->
+	pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args)
+    | MLaxiom -> 
+	pp_par par (str "failwith \"AXIOM TO BE REALIZED\"")
+
+	  
+and pp_record_pat (projs, args) =
+   str "{ " ++
+   prlist_with_sep (fun () -> str ";" ++ spc ()) 
+     (fun (r,a) -> pp_global r ++ str " =" ++ spc () ++ a)
+     (List.combine projs args) ++
+   str " }"
+
+and pp_one_pat env (r,ids,t) = 
+  let ids,env' = push_vars (List.rev ids) env in
+  let expr = pp_expr (expr_needs_par t) env' [] t in 
+  try 
+    let projs = find_projections (kn_of_r r) in 
+    pp_record_pat (projs, List.rev_map pr_id ids), expr
+  with Not_found -> 
+    let args = 
+      if ids = [] then (mt ()) 
+      else str " " ++ pp_boxed_tuple pr_id (List.rev ids) in 
+    pp_global r ++ args, expr
+  
+and pp_pat env pv = 
+  prvect_with_sep (fun () -> (fnl () ++ str "  | ")) 
+    (fun x -> let s1,s2 = pp_one_pat env x in 
+     hov 2 (s1 ++ str " ->" ++ spc () ++ s2)) pv
+
+and pp_function env f t =
+  let bl,t' = collect_lams t in
+  let bl,env' = push_vars bl env in
+  let is_function pv =
+    let ktl = array_map_to_list (fun (_,l,t0) -> (List.length l,t0)) pv in
+    not (List.exists (fun (k,t0) -> ast_occurs (k+1) t0) ktl)
+  in
+  let is_not_cofix pv = 
+    let (r,_,_) = pv.(0) in not (Refset.mem r !cons_cofix) 
+  in					  
+  match t' with 
+    | MLcase(MLrel 1,pv) when is_not_cofix pv ->
+	if is_function pv then
+	  (f ++ pr_binding (List.rev (List.tl bl)) ++
+       	     str " = function" ++ fnl () ++
+	     v 0 (str "  | " ++ pp_pat env' pv))
+	else
+          (f ++ pr_binding (List.rev bl) ++ 
+             str " = match " ++
+	     pr_id (List.hd bl) ++ str " with" ++ fnl () ++
+	     v 0 (str "  | " ++ pp_pat env' pv))
+	  
+    | _ -> (f ++ pr_binding (List.rev bl) ++
+	      str " =" ++ fnl () ++ str "  " ++
+	      hov 2 (pp_expr false env' [] t'))
+
+(*s names of the functions ([ids]) are already pushed in [env],
+    and passed here just for convenience. *)
+
+and pp_fix par env i (ids,bl) args =
+  pp_par par 
+    (v 0 (str "let rec " ++
+	  prvect_with_sep
+      	    (fun () -> fnl () ++ str "and ")
+	    (fun (fi,ti) -> pp_function env (pr_id fi) ti)
+	    (array_map2 (fun id b -> (id,b)) ids bl) ++
+	  fnl () ++
+	  hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
+
+let pp_val e typ = 
+  str "(** val " ++ e ++ str " : " ++ pp_type false [] typ ++ 
+  str " **)"  ++ fnl2 ()
+
+(*s Pretty-printing of [Dfix] *)
+
+let rec pp_Dfix init i ((rv,c,t) as fix) = 
+  if i >= Array.length rv then mt () 
+  else 
+    if is_inline_custom rv.(i) then pp_Dfix init (i+1) fix
+    else 
+      let e = pp_global rv.(i) in
+      (if init then mt () else fnl2 ()) ++
+      pp_val e t.(i) ++
+      str (if init then "let rec " else "and ") ++
+      (if is_custom rv.(i) then e ++ str " = " ++ str (find_custom rv.(i))
+       else pp_function (empty_env ()) e c.(i)) ++
+      pp_Dfix false (i+1) fix 
+	
+(*s Pretty-printing of inductive types declaration. *)
+
+let pp_parameters l = 
+  (pp_boxed_tuple pp_tvar l ++ space_if (l<>[]))
+
+let pp_string_parameters l = 
+  (pp_boxed_tuple str l ++ space_if (l<>[])) 
+
+let pp_one_ind prefix ip pl cv =
+  let pl = rename_tvars keywords pl in
+  let pp_constructor (r,l) =
+    hov 2 (str "  | " ++ pp_global r ++
+	   match l with
+	     | [] -> mt () 
+	     | _  -> (str " of " ++ 
+		      prlist_with_sep 
+			(fun () -> spc () ++ str "* ") (pp_type true pl) l))
+  in
+  pp_parameters pl ++ str prefix ++ pp_global (IndRef ip) ++ str " =" ++ 
+  if cv = [||] then str " unit (* empty inductive *)" 
+  else fnl () ++ v 0 (prvect_with_sep fnl pp_constructor
+			(Array.mapi (fun i c -> ConstructRef (ip,i+1), c) cv))
+
+let pp_comment s = str "(* " ++ s ++ str " *)"
+
+let pp_logical_ind packet = 
+  pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ 
+  fnl () ++ pp_comment (str "with constructors : " ++ 
+			prvect_with_sep spc pr_id packet.ip_consnames)
+
+let pp_singleton kn packet = 
+  let l = rename_tvars keywords packet.ip_vars in 
+  hov 2 (str "type " ++ pp_parameters l ++
+	 pp_global (IndRef (kn,0)) ++ str " =" ++ spc () ++
+	 pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++
+	 pp_comment (str "singleton inductive, whose constructor was " ++ 
+		     pr_id packet.ip_consnames.(0)))
+
+let pp_record kn packet = 
+  let l = List.combine (find_projections kn) packet.ip_types.(0) in 
+  let projs = find_projections kn in
+  let pl = rename_tvars keywords packet.ip_vars in 
+  str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ str " = { "++
+  hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) 
+	   (fun (r,t) -> pp_global r ++ str " : " ++ pp_type true pl t) l) 
+  ++ str " }"
+
+let pp_coind ip pl = 
+  let r = IndRef ip in 
+  let pl = rename_tvars keywords pl in
+  pp_parameters pl ++ pp_global r ++ str " = " ++ 
+  pp_parameters pl ++ str "__" ++ pp_global r ++ str " Lazy.t"
+
+let pp_ind co kn ind =
+  let some = ref false in 
+  let init= ref (str "type ") in 
+  let rec pp i =  
+    if i >= Array.length ind.ind_packets then mt () 
+    else 
+      let ip = (kn,i) in 
+      let p = ind.ind_packets.(i) in 
+      if is_custom (IndRef (kn,i)) then pp (i+1)
+      else begin 
+	some := true; 
+	if p.ip_logical then pp_logical_ind p ++ pp (i+1)
+	else 
+	  let s = !init in 
+	  begin 
+	    init := (fnl () ++ str "and "); 
+	    s ++
+	    (if co then pp_coind ip p.ip_vars ++ fnl () ++ str "and " else mt ())
+	    ++ pp_one_ind (if co then "__" else "") ip p.ip_vars p.ip_types ++
+	    pp (i+1)
+	  end
+      end
+  in 
+  let st = pp 0 in if !some then st else failwith "empty phrase"
+	     
+
+(*s Pretty-printing of a declaration. *)
+
+let pp_mind kn i = 
+  match i.ind_info with 
+    | Singleton -> pp_singleton kn i.ind_packets.(0)
+    | Coinductive -> 
+	let nop _ = () 
+	and add r = cons_cofix := Refset.add r !cons_cofix in 
+	decl_iter_references nop add nop (Dind (kn,i)); 
+	pp_ind true kn i
+    | Record -> pp_record kn i.ind_packets.(0)
+    | _ -> pp_ind false kn i
+
+let pp_decl mpl = 
+  local_mpl := mpl; 
+  function
+    | Dind (kn,i) as d -> pp_mind kn i
+    | Dtype (r, l, t) ->
+	if is_inline_custom r then failwith "empty phrase"
+	else 
+	  let l = rename_tvars keywords l in 
+	  let ids, def = try 
+	    let ids,s = find_type_custom r in 
+	    pp_string_parameters ids, str "=" ++ spc () ++ str s 
+	  with not_found -> 
+	    pp_parameters l, 
+	    if t = Taxiom then str "(* AXIOM TO BE REALIZED *)"
+	    else str "=" ++ spc () ++ pp_type false l t
+	  in 
+	  hov 2 (str "type" ++ spc () ++ ids ++ pp_global r ++ 
+		 spc () ++ def)
+    | Dterm (r, a, t) -> 
+	if is_inline_custom r then failwith "empty phrase"
+	else 
+	  let e = pp_global r in 
+	  pp_val e t ++
+	  hov 0 
+	    (str "let " ++ 
+	     if is_custom r then 
+	       e ++ str " = " ++ str (find_custom r)
+	     else if is_projection r then 
+	       let s = prvecti (fun _ -> str) 
+			 (Array.make (projection_arity r) " _") in 
+	       e ++ s ++ str " x = x." ++ e
+	     else pp_function (empty_env ()) e a)
+    | Dfix (rv,defs,typs) ->
+	pp_Dfix true 0 (rv,defs,typs)
+
+let pp_spec mpl = 
+  local_mpl := mpl; 
+  function 
+    | Sind (kn,i) -> pp_mind kn i
+    | Sval (r,t) -> 
+	if is_inline_custom r then failwith "empty phrase"
+	else 
+	  hov 2 (str "val" ++ spc () ++ pp_global r ++ str " :" ++ spc () ++
+		 pp_type false [] t)
+    | Stype (r,vl,ot) -> 
+	if is_inline_custom r then failwith "empty phrase"
+	else 
+	  let l = rename_tvars keywords vl in 
+	  let ids, def = 
+	    try 
+	      let ids, s = find_type_custom r in 
+	      pp_string_parameters ids,  str "= " ++ str s 
+	    with not_found -> 
+	      let ids = pp_parameters l in 
+	      match ot with 
+		| None -> ids, mt ()
+		| Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" 
+		| Some t -> ids, str "=" ++ spc () ++ pp_type false l t 
+	  in 
+	  hov 2 (str "type" ++ spc () ++ ids ++ pp_global r ++ spc () ++ def)
+
+let rec pp_specif mpl = function 
+  | (_,Spec s) -> pp_spec mpl s 
+  | (l,Smodule mt) -> 
+      hov 1 
+	(str "module " ++ 
+	 P.pp_module mpl (MPdot (List.hd mpl, l)) ++
+	 str " : " ++ fnl () ++ pp_module_type mpl None (* (Some l) *) mt)
+  | (l,Smodtype mt) -> 
+      hov 1
+	(str "module type " ++
+	 P.pp_module mpl (MPdot (List.hd mpl, l)) ++
+	 str " = " ++ fnl () ++ pp_module_type mpl None mt)
+
+and pp_module_type mpl ol = function 
+  | MTident kn -> 
+      let mp,_,l = repr_kn kn in P.pp_module mpl (MPdot (mp,l)) 
+  | MTfunsig (mbid, mt, mt') -> 
+      str "functor (" ++ 
+      P.pp_module mpl (MPbound mbid) ++
+      str ":" ++
+      pp_module_type mpl None mt ++
+      str ") ->" ++ fnl () ++
+      pp_module_type mpl None mt'
+  | MTsig (msid, sign) ->
+      let mpl = match ol, mpl with 
+	| None, _ -> (MPself msid) :: mpl
+	| Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl
+	| _ -> assert false 
+      in
+      let l = map_succeed (pp_specif mpl) sign in 
+      str "sig " ++ fnl () ++ 
+      v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++
+      fnl () ++ str "end"
+
+let is_short = function MEident _ | MEapply _ -> true | _ -> false
+
+let rec pp_structure_elem mpl = function 
+  | (_,SEdecl d) -> pp_decl mpl d
+  | (l,SEmodule m) ->
+      hov 1 
+	(str "module " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++ 
+	 (* if you want signatures everywhere: *)
+	 (*i str " :" ++ fnl () ++ i*)
+	 (*i pp_module_type mpl None m.ml_mod_type ++ fnl () ++ i*)
+	 str " = " ++
+	 (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++
+	 pp_module_expr mpl (Some l) m.ml_mod_expr)
+  | (l,SEmodtype m) -> 
+      hov 1 
+	(str "module type " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++
+	 str " = " ++ fnl () ++ pp_module_type mpl None m)
+
+and pp_module_expr mpl ol = function 
+  | MEident mp' -> P.pp_module mpl mp'
+  | MEfunctor (mbid, mt, me) -> 
+      str "functor (" ++ 
+      P.pp_module mpl (MPbound mbid) ++
+      str ":" ++
+      pp_module_type mpl None mt ++
+      str ") ->" ++ fnl () ++
+      pp_module_expr mpl None me
+  | MEapply (me, me') -> 
+      pp_module_expr mpl None me ++ str "(" ++ 
+      pp_module_expr mpl None me' ++ str ")"
+  | MEstruct (msid, sel) -> 
+      let mpl = match ol, mpl with 
+	| None, _ -> (MPself msid) :: mpl
+	| Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl
+	| _ -> assert false
+      in
+      let l = map_succeed (pp_structure_elem mpl) sel in 
+      str "struct " ++ fnl () ++
+      v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ 
+      fnl () ++ str "end" 
+
+let pp_struct s =
+  let pp mp s = pp_structure_elem [mp] s ++ fnl2 () in 
+  prlist (fun (mp,sel) -> prlist identity (map_succeed (pp mp) sel)) s
+
+let pp_signature s = 
+  let pp mp s = pp_specif [mp] s ++ fnl2 () in 
+  prlist (fun (mp,sign) -> prlist identity (map_succeed (pp mp) sign)) s
+
+let pp_decl mpl d = 
+  try pp_decl mpl d with Failure "empty phrase" -> mt () 
+
+end
+
+
+
diff --git a/contrib/extraction/ocaml.mli b/contrib/extraction/ocaml.mli
new file mode 100644
index 00000000..711c15da
--- /dev/null
+++ b/contrib/extraction/ocaml.mli
@@ -0,0 +1,56 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: ocaml.mli,v 1.26.6.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Some utility functions to be reused in module [Haskell]. *)
+
+open Pp
+open Names
+open Libnames
+open Miniml
+
+val cons_cofix : Refset.t ref
+
+val pp_par : bool -> std_ppcmds -> std_ppcmds
+val pp_abst : identifier list -> std_ppcmds
+val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds 
+val pr_binding : identifier list -> std_ppcmds
+
+val rename_id : identifier -> Idset.t -> identifier
+
+val lowercase_id : identifier -> identifier
+val uppercase_id : identifier -> identifier
+
+val pr_upper_id : identifier -> std_ppcmds
+
+type env = identifier list * Idset.t
+
+val rename_vars: Idset.t -> identifier list -> env
+val rename_tvars: Idset.t -> identifier list -> identifier list 
+val push_vars : identifier list -> env -> identifier list * env
+val get_db_name : int -> env -> identifier
+
+val keywords : Idset.t
+
+val preamble : 
+  extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds
+
+val preamble_sig : 
+  extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds
+
+(*s Production of Ocaml syntax. We export both a functor to be used for 
+    extraction in the Coq toplevel and a function to extract some 
+    declarations to a file. *)
+
+module Make : functor(P : Mlpp_param) -> Mlpp
+
+
+
+
+
diff --git a/contrib/extraction/scheme.ml b/contrib/extraction/scheme.ml
new file mode 100644
index 00000000..61045304
--- /dev/null
+++ b/contrib/extraction/scheme.ml
@@ -0,0 +1,175 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: scheme.ml,v 1.9.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Production of Scheme syntax. *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Libnames
+open Miniml
+open Mlutil
+open Table
+open Ocaml
+
+(*s Scheme renaming issues. *)
+
+let keywords =     
+  List.fold_right (fun s -> Idset.add (id_of_string s))
+    [ "define"; "let"; "lambda"; "lambdas"; "match-case"; 
+      "apply"; "car"; "cdr"; 
+      "error"; "delay"; "force"; "_"; "__"] 
+    Idset.empty
+
+let preamble _ _ (mldummy,_,_) = 
+  (if mldummy then 
+     str "(define __ (lambda (_) __))" 
+     ++ fnl () ++ fnl()
+   else mt ())
+
+let paren = pp_par true
+
+let pp_abst st = function 
+  | [] -> assert false
+  | [id] -> paren (str "lambda " ++ paren (pr_id id) ++ spc () ++ st)
+  | l -> paren 
+	(str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st)
+
+(*s The pretty-printing functor. *)
+
+module Make = functor(P : Mlpp_param) -> struct
+
+let pp_global r = P.pp_global [initial_path] r
+let empty_env () = [], P.globals()
+
+(*s Pretty-printing of expressions.  *)
+
+let rec pp_expr env args = 
+  let apply st = pp_apply st true args in 
+  function
+    | MLrel n -> 
+	let id = get_db_name n env in apply (pr_id id)
+    | MLapp (f,args') ->
+	let stl = List.map (pp_expr env []) args' in
+        pp_expr env (stl @ args) f
+    | MLlam _ as a -> 
+      	let fl,a' = collect_lams a in
+	let fl,env' = push_vars fl env in
+	pp_abst (pp_expr env' [] a') (List.rev fl)
+    | MLletin (id,a1,a2) ->
+	let i,env' = push_vars [id] env in
+	apply 
+	  (hv 0 
+	     (hov 2 
+		(paren 
+		   (str "let " ++ 
+		    paren 
+		      (paren 
+			 (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) 
+		    ++ spc () ++ hov 0 (pp_expr env' [] a2)))))
+    | MLglob r -> 
+	apply (pp_global r)
+    | MLcons (r,args') ->
+	assert (args=[]);
+	let st = 
+	  str "`" ++ 
+	  paren (pp_global r ++ 
+		 (if args' = [] then mt () else (spc () ++ str ",")) ++
+		 prlist_with_sep 
+		   (fun () -> spc () ++ str ",") 
+		   (pp_expr env []) args')
+	in 
+	if Refset.mem r !cons_cofix then 
+	  paren (str "delay " ++ st)
+        else st 
+    | MLcase (t, pv) ->
+	let r,_,_ = pv.(0) in 
+	let e = if Refset.mem r !cons_cofix then 
+	  paren (str "force" ++ spc () ++ pp_expr env [] t)
+	else 
+	  pp_expr env [] t 	
+	in apply (v 3 (paren 
+			 (str "match-case " ++ e ++ fnl () ++ pp_pat env pv)))
+    | MLfix (i,ids,defs) ->
+	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
+      	pp_fix env' i (Array.of_list (List.rev ids'),defs) args
+    | MLexn s -> 
+	(* An [MLexn] may be applied, but I don't really care. *)
+	paren (str "absurd")
+    | MLdummy ->
+	str "__" (* An [MLdummy] may be applied, but I don't really care. *)
+    | MLmagic a ->
+	pp_expr env args a
+    | MLaxiom -> paren (str "absurd ;;AXIOM TO BE REALIZED\n")
+	
+
+and pp_one_pat env (r,ids,t) = 
+  let pp_arg id = str "?" ++ pr_id id in 
+  let ids,env' = push_vars (List.rev ids) env in
+  let args = 
+    if ids = [] then mt () 
+    else (str " " ++ prlist_with_sep spc pp_arg (List.rev ids))
+  in 
+  (pp_global r ++ args), (pp_expr env' [] t)
+  
+and pp_pat env pv = 
+  prvect_with_sep fnl  
+    (fun x -> let s1,s2 = pp_one_pat env x in 
+     hov 2 (str "((" ++ s1 ++ str ")" ++ spc () ++ s2 ++ str ")")) pv
+
+(*s names of the functions ([ids]) are already pushed in [env],
+    and passed here just for convenience. *)
+
+and pp_fix env j (ids,bl) args =
+    paren 
+      (str "letrec " ++
+       (v 0 (paren 
+	       (prvect_with_sep fnl
+		  (fun (fi,ti) -> paren ((pr_id fi) ++ (pp_expr env [] ti)))
+		  (array_map2 (fun id b -> (id,b)) ids bl)) ++
+	     fnl () ++
+      	     hov 2 (pp_apply (pr_id (ids.(j))) true args))))
+
+(*s Pretty-printing of a declaration. *)
+
+let pp_decl _ = function
+  | Dind _ -> mt ()
+  | Dtype _ -> mt () 
+  | Dfix (rv, defs,_) ->
+      let ppv = Array.map pp_global rv in 
+      prvect_with_sep fnl 
+	(fun (pi,ti) -> 
+	   hov 2 
+	     (paren (str "define " ++ pi ++ spc () ++ 
+		     (pp_expr (empty_env ()) [] ti)) 
+	      ++ fnl ()))
+	(array_map2 (fun p b -> (p,b)) ppv defs) ++
+      fnl ()
+  | Dterm (r, a, _) ->
+      if is_inline_custom r then mt () 
+      else 
+	hov 2 (paren (str "define " ++ pp_global r ++ spc () ++
+		      pp_expr (empty_env ()) [] a)) ++ fnl ()  ++ fnl ()
+
+let pp_structure_elem mp = function 
+  | (l,SEdecl d) -> pp_decl mp d
+  | (l,SEmodule m) -> 
+      failwith "TODO: Scheme extraction of modules not implemented yet"
+  | (l,SEmodtype m) -> 
+      failwith "TODO: Scheme extraction of modules not implemented yet"
+
+let pp_struct = 
+  prlist (fun (mp,sel) -> prlist (pp_structure_elem mp) sel)
+
+let pp_signature s = assert false
+
+end
+
diff --git a/contrib/extraction/scheme.mli b/contrib/extraction/scheme.mli
new file mode 100644
index 00000000..6e689a47
--- /dev/null
+++ b/contrib/extraction/scheme.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: scheme.mli,v 1.6.6.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Some utility functions to be reused in module [Haskell]. *)
+
+open Pp
+open Miniml
+open Names
+
+val keywords : Idset.t
+
+val preamble : 
+  extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds
+
+module Make : functor(P : Mlpp_param) -> Mlpp
+
+
+
+
+
diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml
new file mode 100644
index 00000000..a65c51a4
--- /dev/null
+++ b/contrib/extraction/table.ml
@@ -0,0 +1,446 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: table.ml,v 1.35.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+open Names
+open Term
+open Declarations
+open Nameops
+open Summary
+open Libobject
+open Goptions
+open Libnames
+open Util
+open Pp
+open Miniml
+
+(*S Utilities concerning [module_path] and [kernel_names] *)
+
+let kn_of_r r = match r with 
+    | ConstRef kn -> kn
+    | IndRef (kn,_) -> kn
+    | ConstructRef ((kn,_),_) -> kn
+    | VarRef _ -> assert false
+
+let current_toplevel () = fst (Lib.current_prefix ())
+
+let rec base_mp = function 
+  | MPdot (mp,l) -> base_mp mp 
+  | mp -> mp 
+
+let is_modfile = function 
+  | MPfile _ -> true 
+  | _ -> false
+
+let is_toplevel mp = 
+  mp = initial_path || mp = current_toplevel ()
+
+let at_toplevel mp = 
+  is_modfile mp || is_toplevel mp
+
+let visible_kn kn = at_toplevel (base_mp (modpath kn))
+
+
+(*S The main tables: constants, inductives, records, ... *)
+
+(*s Constants tables. *) 
+
+let terms = ref (KNmap.empty : ml_decl KNmap.t)
+let init_terms () = terms := KNmap.empty
+let add_term kn d = terms := KNmap.add kn d !terms
+let lookup_term kn = KNmap.find kn !terms
+
+let types = ref (KNmap.empty : ml_schema KNmap.t)
+let init_types () = types := KNmap.empty
+let add_type kn s = types := KNmap.add kn s !types
+let lookup_type kn = KNmap.find kn !types 
+
+(*s Inductives table. *)
+
+let inductives = ref (KNmap.empty : ml_ind KNmap.t)
+let init_inductives () = inductives := KNmap.empty
+let add_ind kn m = inductives := KNmap.add kn m !inductives
+let lookup_ind kn = KNmap.find kn !inductives
+
+(*s Recursors table. *)
+
+let recursors = ref KNset.empty
+let init_recursors () = recursors := KNset.empty
+
+let add_recursors env kn = 
+  let make_kn id = make_kn (modpath kn) empty_dirpath (label_of_id id) in 
+  let mib = Environ.lookup_mind kn env in 
+  Array.iter 
+    (fun mip -> 
+       let id = mip.mind_typename in 
+       let kn_rec = make_kn (Nameops.add_suffix id "_rec")
+       and kn_rect = make_kn (Nameops.add_suffix id "_rect") in 
+       recursors := KNset.add kn_rec (KNset.add kn_rect !recursors))
+    mib.mind_packets
+
+let is_recursor = function 
+  | ConstRef kn -> KNset.mem kn !recursors
+  | _ -> false
+
+(*s Record tables. *)
+
+let records = ref (KNmap.empty : global_reference list KNmap.t)
+let init_records () = records := KNmap.empty
+
+let projs = ref (Refmap.empty : int Refmap.t)
+let init_projs () = projs := Refmap.empty
+
+let add_record kn n (l1,l2) = 
+  records := KNmap.add kn l1 !records; 
+  projs := List.fold_right (fun r -> Refmap.add r n) l2 !projs
+
+let find_projections kn = KNmap.find kn !records
+let is_projection r = Refmap.mem r !projs
+let projection_arity r = Refmap.find r !projs
+
+(*s Tables synchronization. *)
+
+let reset_tables () = 
+  init_terms (); init_types (); init_inductives (); init_recursors (); 
+  init_records (); init_projs ()
+
+(*s Printing. *)
+
+(* The following functions work even on objects not in [Global.env ()].
+   WARNING: for inductive objects, an extract_inductive must have been 
+   done before. *)
+
+let id_of_global = function 
+  | ConstRef kn -> let _,_,l = repr_kn kn in id_of_label l
+  | IndRef (kn,i) -> (lookup_ind kn).ind_packets.(i).ip_typename
+  | ConstructRef ((kn,i),j) -> (lookup_ind kn).ind_packets.(i).ip_consnames.(j-1)
+  | _ -> assert false
+
+let pr_global r = pr_id (id_of_global r)
+
+(*S Warning and Error messages. *)
+
+let err s = errorlabstrm "Extraction" s
+
+let error_axiom_scheme r i = 
+  err (str "The type scheme axiom " ++ spc () ++
+       pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ 
+       str " type variable(s).") 
+
+let warning_info_ax r =
+  Options.if_verbose msg_warning
+    (str "You must realize axiom " ++
+     pr_global r ++ str " in the extracted code.")
+
+let warning_log_ax r = 
+  Options.if_verbose msg_warning
+    (str "This extraction depends on logical axiom" ++ spc () ++ 
+     pr_global r ++ str "." ++ spc() ++ 
+     str "Having false logical axiom in the environment when extracting" ++ 
+     spc () ++ str "may lead to incorrect or non-terminating ML terms.")
+
+let check_inside_module () = 
+  try 
+    ignore (Lib.what_is_opened ()); 
+    Options.if_verbose warning
+      ("Extraction inside an opened module is experimental.\n"^
+       "In case of problem, close it first.\n"); 
+    Pp.flush_all ()
+  with Not_found -> ()
+
+let check_inside_section () = 
+  if Lib.sections_are_opened () then 
+    err (str "You can't do that within a section." ++ fnl () ++
+	 str "Close it and try again.")
+
+let error_constant r = 
+  err (Printer.pr_global r ++ str " is not a constant.") 
+
+let error_inductive r = 
+  err (Printer.pr_global r ++ spc () ++ str "is not an inductive type.")
+
+let error_nb_cons () = 
+  err (str "Not the right number of constructors.")
+
+let error_module_clash s = 
+  err (str ("There are two Coq modules with ML name " ^ s ^".\n") ++ 
+       str "This is not allowed in ML. Please do some renaming first.")
+
+let error_unknown_module m = 
+  err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.") 
+
+let error_toplevel () = 
+  err (str "Toplevel pseudo-ML language can be used only at Coq toplevel.\n" ++
+       str "You should use Extraction Language Ocaml or Haskell before.") 
+
+let error_scheme () = 
+  err (str "No Scheme modular extraction available yet.")
+
+let error_not_visible r = 
+  err (Printer.pr_global r ++ str " is not directly visible.\n" ++
+       str "For example, it may be inside an applied functor." ++
+       str "Use Recursive Extraction to get the whole environment.")
+
+let error_unqualified_name s1 s2 = 
+  err (str (s1 ^ " is used in " ^ s2 ^ " where it cannot be disambiguated\n" ^
+	    "in ML from another name sharing the same basename.\n"  ^
+	    "Please do some renaming.\n"))
+
+let error_MPfile_as_mod d = 
+  err (str ("The whole file "^(string_of_dirpath d)^".v is used somewhere as a module.\n"^
+	    "Extraction cannot currently deal with this situation.\n"))
+
+(*S The Extraction auxiliary commands *)
+
+(*s Extraction AutoInline *)
+
+let auto_inline_ref = ref true
+
+let auto_inline () = !auto_inline_ref
+
+let _ = declare_bool_option 
+	  {optsync = true;
+	   optname = "Extraction AutoInline";
+	   optkey = SecondaryTable ("Extraction", "AutoInline");
+	   optread = auto_inline; 
+	   optwrite = (:=) auto_inline_ref}
+
+
+(*s Extraction Optimize *)
+
+type opt_flag = 
+    { opt_kill_dum : bool; (* 1 *) 
+      opt_fix_fun : bool;   (* 2 *)
+      opt_case_iot : bool;  (* 4 *)
+      opt_case_idr : bool;  (* 8 *)
+      opt_case_idg : bool;  (* 16 *)
+      opt_case_cst : bool;  (* 32 *)
+      opt_case_fun : bool;  (* 64 *)
+      opt_case_app : bool;  (* 128 *)
+      opt_let_app : bool;   (* 256 *)
+      opt_lin_let : bool;   (* 512 *)
+      opt_lin_beta : bool } (* 1024 *)
+
+let kth_digit n k = (n land (1 lsl k) <> 0)
+
+let flag_of_int n = 
+    { opt_kill_dum = kth_digit n 0;
+      opt_fix_fun = kth_digit n 1;
+      opt_case_iot = kth_digit n 2;
+      opt_case_idr = kth_digit n 3;
+      opt_case_idg = kth_digit n 4; 
+      opt_case_cst = kth_digit n 5;
+      opt_case_fun = kth_digit n 6;
+      opt_case_app = kth_digit n 7;
+      opt_let_app = kth_digit n 8;
+      opt_lin_let = kth_digit n 9;
+      opt_lin_beta = kth_digit n 10 }
+
+(* For the moment, we allow by default everything except the type-unsafe 
+   optimization [opt_case_idg]. *)
+
+let int_flag_init = 1 + 2 + 4 + 8 + 32 + 64 + 128 + 256 + 512 + 1024
+
+let int_flag_ref = ref int_flag_init
+let opt_flag_ref = ref (flag_of_int int_flag_init)
+
+let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n
+
+let optims () = !opt_flag_ref
+
+let _ = declare_bool_option 
+	  {optsync = true; 
+	   optname = "Extraction Optimize";
+	   optkey = SecondaryTable ("Extraction", "Optimize");
+	   optread = (fun () -> !int_flag_ref <> 0); 
+	   optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))}
+
+let _ = declare_int_option
+          { optsync = true;
+            optname = "Extraction Flag";
+            optkey = SecondaryTable("Extraction","Flag"); 
+            optread = (fun _ -> Some !int_flag_ref); 
+            optwrite = (function 
+                          | None -> chg_flag 0
+                          | Some i -> chg_flag (max i 0))}
+
+
+(*s Extraction Lang *)
+
+type lang = Ocaml | Haskell | Scheme | Toplevel
+
+let lang_ref = ref Ocaml
+
+let lang () = !lang_ref
+
+let (extr_lang,_) = 
+  declare_object 
+    {(default_object "Extraction Lang") with  
+       cache_function = (fun (_,l) -> lang_ref := l);
+       load_function = (fun _ (_,l) -> lang_ref := l);
+       export_function = (fun x -> Some x)}
+
+let _ = declare_summary "Extraction Lang" 
+	  { freeze_function = (fun () -> !lang_ref);
+	    unfreeze_function = ((:=) lang_ref);
+	    init_function = (fun () -> lang_ref := Ocaml);
+	    survive_module = false;
+	    survive_section = true }  
+	  
+let extraction_language x = Lib.add_anonymous_leaf (extr_lang x)
+
+
+(*s Extraction Inline/NoInline *)
+
+let empty_inline_table = (Refset.empty,Refset.empty)
+
+let inline_table = ref empty_inline_table
+
+let to_inline r = Refset.mem r (fst !inline_table)
+
+let to_keep r = Refset.mem r (snd !inline_table)
+
+let add_inline_entries b l = 
+  let f b = if b then Refset.add else Refset.remove in 
+  let i,k = !inline_table in 
+  inline_table := 
+  (List.fold_right (f b) l i), 
+  (List.fold_right (f (not b)) l k)
+
+(* Registration of operations for rollback. *)
+
+let (inline_extraction,_) = 
+  declare_object 
+    {(default_object "Extraction Inline") with 
+       cache_function = (fun (_,(b,l)) -> add_inline_entries b l);
+       load_function = (fun _ (_,(b,l)) -> add_inline_entries b l);
+       export_function = (fun x -> Some x); 
+       classify_function = (fun (_,o) -> Substitute o); 
+       subst_function = (fun (_,s,(b,l)) -> (b,(List.map (subst_global s) l))) }
+
+let _ = declare_summary "Extraction Inline"
+	  { freeze_function = (fun () -> !inline_table);
+	    unfreeze_function = ((:=) inline_table);
+	    init_function = (fun () -> inline_table := empty_inline_table);
+	    survive_module = false;
+	    survive_section = true }
+
+(* Grammar entries. *)
+
+let extraction_inline b l =
+  check_inside_section (); 
+  check_inside_module ();
+  let refs = List.map Nametab.global l in 
+  List.iter 
+    (fun r -> match r with 
+       | ConstRef _ -> ()
+       | _ -> error_constant r) refs; 
+  Lib.add_anonymous_leaf (inline_extraction (b,refs))
+
+(* Printing part *)
+
+let print_extraction_inline () = 
+  let (i,n)= !inline_table in 
+  let i'= Refset.filter (function ConstRef _ -> true | _ -> false) i in 
+  msg 
+    (str "Extraction Inline:" ++ fnl () ++ 
+     Refset.fold
+       (fun r p -> 
+	  (p ++ str "   " ++ Printer.pr_global r ++ fnl ())) i' (mt ()) ++
+     str "Extraction NoInline:" ++ fnl () ++ 
+     Refset.fold
+       (fun r p -> 
+	  (p ++ str "   " ++ Printer.pr_global r ++ fnl ())) n (mt ()))
+
+(* Reset part *)
+
+let (reset_inline,_) = 
+  declare_object
+    {(default_object "Reset Extraction Inline") with  
+       cache_function = (fun (_,_)-> inline_table :=  empty_inline_table);
+       load_function = (fun _ (_,_)-> inline_table :=  empty_inline_table); 
+       export_function = (fun x -> Some x)}
+
+let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ())
+
+
+(*s Extract Constant/Inductive. *)
+
+(* UGLY HACK: to be defined in [extraction.ml] *)
+let use_type_scheme_nb_args, register_type_scheme_nb_args = 
+  let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r 
+
+let customs = ref Refmap.empty
+
+let add_custom r ids s = customs := Refmap.add r (ids,s) !customs
+
+let is_custom r = Refmap.mem r !customs
+
+let is_inline_custom r = (is_custom r) && (to_inline r) 
+
+let find_custom r = snd (Refmap.find r !customs)
+
+let find_type_custom r = Refmap.find r !customs
+
+(* Registration of operations for rollback. *)
+
+let (in_customs,_) = 
+  declare_object 
+    {(default_object "ML extractions") with 
+       cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s);
+       load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s);
+       export_function = (fun x -> Some x)}
+
+let _ = declare_summary "ML extractions"
+	  { freeze_function = (fun () -> !customs);
+	    unfreeze_function = ((:=) customs);
+	    init_function = (fun () -> customs := Refmap.empty);
+	    survive_module = false;
+	    survive_section = true }
+
+(* Grammar entries. *)
+
+let extract_constant_inline inline r ids s =
+  check_inside_section ();
+  check_inside_module ();
+  let g = Nametab.global r in 
+  match g with 
+    | ConstRef kn -> 
+	let env = Global.env () in 
+	let typ = Environ.constant_type env kn in 
+	let typ = Reduction.whd_betadeltaiota env typ in
+	if Reduction.is_arity env typ 
+	  then begin 
+	    let nargs = use_type_scheme_nb_args env typ in 
+	    if List.length ids <> nargs then error_axiom_scheme g nargs
+	  end; 
+	Lib.add_anonymous_leaf (inline_extraction (inline,[g]));
+	Lib.add_anonymous_leaf (in_customs (g,ids,s))
+    | _ -> error_constant g
+
+
+let extract_inductive r (s,l) =
+  check_inside_section ();
+  check_inside_module ();
+  let g = Nametab.global r in 
+  match g with
+    | IndRef ((kn,i) as ip) ->
+	let mib = Global.lookup_mind kn in
+	let n = Array.length mib.mind_packets.(i).mind_consnames in
+	if n <> List.length l then error_nb_cons (); 
+	Lib.add_anonymous_leaf (inline_extraction (true,[g]));
+	Lib.add_anonymous_leaf (in_customs (g,[],s));
+	list_iter_i
+	  (fun j s -> 
+	     let g = ConstructRef (ip,succ j) in 
+	     Lib.add_anonymous_leaf (inline_extraction (true,[g]));
+	     Lib.add_anonymous_leaf (in_customs (g,[],s))) l
+    | _ -> error_inductive g 
+
+
diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli
new file mode 100644
index 00000000..680638e5
--- /dev/null
+++ b/contrib/extraction/table.mli
@@ -0,0 +1,122 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: table.mli,v 1.25.2.1 2004/07/16 19:30:09 herbelin Exp $ i*)
+
+open Names
+open Libnames
+open Miniml
+
+val id_of_global : global_reference -> identifier
+
+(*s Warning and Error messages. *)
+
+val error_axiom_scheme : global_reference -> int -> 'a
+val warning_info_ax : global_reference -> unit
+val warning_log_ax : global_reference -> unit
+val error_constant : global_reference -> 'a
+val error_inductive : global_reference -> 'a
+val error_nb_cons : unit -> 'a
+val error_module_clash : string -> 'a 
+val error_unknown_module : qualid -> 'a
+val error_toplevel : unit -> 'a
+val error_scheme : unit -> 'a
+val error_not_visible : global_reference -> 'a
+val error_unqualified_name : string -> string -> 'a 
+val error_MPfile_as_mod : dir_path -> 'a
+
+val check_inside_module : unit -> unit
+val check_inside_section : unit -> unit
+
+(*s utilities concerning [module_path]. *)
+
+val kn_of_r : global_reference -> kernel_name
+
+val current_toplevel : unit -> module_path
+val base_mp : module_path -> module_path
+val is_modfile : module_path -> bool 
+val is_toplevel : module_path -> bool
+val at_toplevel : module_path -> bool 
+val visible_kn : kernel_name -> bool
+
+(*s Some table-related operations *)
+
+val add_term : kernel_name -> ml_decl -> unit
+val lookup_term : kernel_name -> ml_decl
+
+val add_type : kernel_name -> ml_schema -> unit
+val lookup_type : kernel_name -> ml_schema
+
+val add_ind : kernel_name -> ml_ind -> unit
+val lookup_ind : kernel_name -> ml_ind
+
+val add_recursors : Environ.env -> kernel_name -> unit
+val is_recursor : global_reference -> bool 
+
+val add_record : 
+  kernel_name -> int -> global_reference list * global_reference list -> unit
+val find_projections : kernel_name -> global_reference list
+val is_projection : global_reference -> bool 
+val projection_arity : global_reference -> int
+
+val reset_tables : unit -> unit
+
+(*s AutoInline parameter *) 
+
+val auto_inline : unit -> bool
+
+(*s Optimize parameter *) 
+
+type opt_flag = 
+    { opt_kill_dum : bool; (* 1 *) 
+      opt_fix_fun : bool;   (* 2 *)
+      opt_case_iot : bool;  (* 4 *)
+      opt_case_idr : bool;  (* 8 *)
+      opt_case_idg : bool;  (* 16 *)
+      opt_case_cst : bool;  (* 32 *)
+      opt_case_fun : bool;  (* 64 *)
+      opt_case_app : bool;  (* 128 *)
+      opt_let_app : bool;   (* 256 *)
+      opt_lin_let : bool;   (* 512 *)
+      opt_lin_beta : bool } (* 1024 *)
+
+val optims :  unit -> opt_flag
+
+(*s Target language. *)
+
+type lang = Ocaml | Haskell | Scheme | Toplevel
+val lang : unit -> lang 
+
+(*s Table for custom inlining *) 
+
+val to_inline : global_reference -> bool
+val to_keep : global_reference -> bool
+
+(*s Table for user-given custom ML extractions. *)
+
+(* UGLY HACK: registration of a function defined in [extraction.ml] *)
+val register_type_scheme_nb_args : (Environ.env -> Term.constr -> int) -> unit
+
+val is_custom : global_reference -> bool
+val is_inline_custom : global_reference -> bool
+val find_custom : global_reference -> string
+val find_type_custom : global_reference -> string list * string
+
+(*s Extraction commands. *)
+
+val extraction_language : lang -> unit
+val extraction_inline : bool -> reference list -> unit
+val print_extraction_inline : unit -> unit
+val reset_extraction_inline : unit -> unit
+val extract_constant_inline : 
+  bool -> reference -> string list -> string -> unit
+val extract_inductive : reference -> string * string list -> unit
+
+
+
+
diff --git a/contrib/extraction/test/.depend b/contrib/extraction/test/.depend
new file mode 100644
index 00000000..641b50a7
--- /dev/null
+++ b/contrib/extraction/test/.depend
@@ -0,0 +1,713 @@
+theories/Arith/arith.cmo: theories/Arith/arith.cmi 
+theories/Arith/arith.cmx: theories/Arith/arith.cmi 
+theories/Arith/between.cmo: theories/Arith/between.cmi 
+theories/Arith/between.cmx: theories/Arith/between.cmi 
+theories/Arith/bool_nat.cmo: theories/Arith/compare_dec.cmi \
+    theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi \
+    theories/Init/specif.cmi theories/Bool/sumbool.cmi \
+    theories/Arith/bool_nat.cmi 
+theories/Arith/bool_nat.cmx: theories/Arith/compare_dec.cmx \
+    theories/Init/datatypes.cmx theories/Arith/peano_dec.cmx \
+    theories/Init/specif.cmx theories/Bool/sumbool.cmx \
+    theories/Arith/bool_nat.cmi 
+theories/Arith/compare_dec.cmo: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/Arith/compare_dec.cmi 
+theories/Arith/compare_dec.cmx: theories/Init/datatypes.cmx \
+    theories/Init/specif.cmx theories/Arith/compare_dec.cmi 
+theories/Arith/compare.cmo: theories/Arith/compare_dec.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Arith/compare.cmi 
+theories/Arith/compare.cmx: theories/Arith/compare_dec.cmx \
+    theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Arith/compare.cmi 
+theories/Arith/div2.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi \
+    theories/Init/specif.cmi theories/Arith/div2.cmi 
+theories/Arith/div2.cmx: theories/Init/datatypes.cmx theories/Init/peano.cmx \
+    theories/Init/specif.cmx theories/Arith/div2.cmi 
+theories/Arith/eqNat.cmo: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/Arith/eqNat.cmi 
+theories/Arith/eqNat.cmx: theories/Init/datatypes.cmx \
+    theories/Init/specif.cmx theories/Arith/eqNat.cmi 
+theories/Arith/euclid.cmo: theories/Arith/compare_dec.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Arith/euclid.cmi 
+theories/Arith/euclid.cmx: theories/Arith/compare_dec.cmx \
+    theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Arith/euclid.cmi 
+theories/Arith/even.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Arith/even.cmi 
+theories/Arith/even.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Arith/even.cmi 
+theories/Arith/factorial.cmo: theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi theories/Arith/factorial.cmi 
+theories/Arith/factorial.cmx: theories/Init/datatypes.cmx \
+    theories/Init/peano.cmx theories/Arith/factorial.cmi 
+theories/Arith/gt.cmo: theories/Arith/gt.cmi 
+theories/Arith/gt.cmx: theories/Arith/gt.cmi 
+theories/Arith/le.cmo: theories/Arith/le.cmi 
+theories/Arith/le.cmx: theories/Arith/le.cmi 
+theories/Arith/lt.cmo: theories/Arith/lt.cmi 
+theories/Arith/lt.cmx: theories/Arith/lt.cmi 
+theories/Arith/max.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Arith/max.cmi 
+theories/Arith/max.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Arith/max.cmi 
+theories/Arith/min.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Arith/min.cmi 
+theories/Arith/min.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Arith/min.cmi 
+theories/Arith/minus.cmo: theories/Arith/minus.cmi 
+theories/Arith/minus.cmx: theories/Arith/minus.cmi 
+theories/Arith/mult.cmo: theories/Init/datatypes.cmi theories/Arith/plus.cmi \
+    theories/Arith/mult.cmi 
+theories/Arith/mult.cmx: theories/Init/datatypes.cmx theories/Arith/plus.cmx \
+    theories/Arith/mult.cmi 
+theories/Arith/peano_dec.cmo: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/Arith/peano_dec.cmi 
+theories/Arith/peano_dec.cmx: theories/Init/datatypes.cmx \
+    theories/Init/specif.cmx theories/Arith/peano_dec.cmi 
+theories/Arith/plus.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Arith/plus.cmi 
+theories/Arith/plus.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Arith/plus.cmi 
+theories/Arith/wf_nat.cmo: theories/Init/datatypes.cmi \
+    theories/Arith/wf_nat.cmi 
+theories/Arith/wf_nat.cmx: theories/Init/datatypes.cmx \
+    theories/Arith/wf_nat.cmi 
+theories/Bool/boolEq.cmo: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/Bool/boolEq.cmi 
+theories/Bool/boolEq.cmx: theories/Init/datatypes.cmx \
+    theories/Init/specif.cmx theories/Bool/boolEq.cmi 
+theories/Bool/bool.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Bool/bool.cmi 
+theories/Bool/bool.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Bool/bool.cmi 
+theories/Bool/bvector.cmo: theories/Bool/bool.cmi theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi theories/Bool/bvector.cmi 
+theories/Bool/bvector.cmx: theories/Bool/bool.cmx theories/Init/datatypes.cmx \
+    theories/Init/peano.cmx theories/Bool/bvector.cmi 
+theories/Bool/decBool.cmo: theories/Init/specif.cmi theories/Bool/decBool.cmi 
+theories/Bool/decBool.cmx: theories/Init/specif.cmx theories/Bool/decBool.cmi 
+theories/Bool/ifProp.cmo: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/Bool/ifProp.cmi 
+theories/Bool/ifProp.cmx: theories/Init/datatypes.cmx \
+    theories/Init/specif.cmx theories/Bool/ifProp.cmi 
+theories/Bool/sumbool.cmo: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
+theories/Bool/sumbool.cmx: theories/Init/datatypes.cmx \
+    theories/Init/specif.cmx theories/Bool/sumbool.cmi 
+theories/Bool/zerob.cmo: theories/Init/datatypes.cmi theories/Bool/zerob.cmi 
+theories/Bool/zerob.cmx: theories/Init/datatypes.cmx theories/Bool/zerob.cmi 
+theories/Init/datatypes.cmo: theories/Init/datatypes.cmi 
+theories/Init/datatypes.cmx: theories/Init/datatypes.cmi 
+theories/Init/logic.cmo: theories/Init/logic.cmi 
+theories/Init/logic.cmx: theories/Init/logic.cmi 
+theories/Init/logic_Type.cmo: theories/Init/datatypes.cmi \
+    theories/Init/logic_Type.cmi 
+theories/Init/logic_Type.cmx: theories/Init/datatypes.cmx \
+    theories/Init/logic_Type.cmi 
+theories/Init/notations.cmo: theories/Init/notations.cmi 
+theories/Init/notations.cmx: theories/Init/notations.cmi 
+theories/Init/peano.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi 
+theories/Init/peano.cmx: theories/Init/datatypes.cmx theories/Init/peano.cmi 
+theories/Init/prelude.cmo: theories/Init/prelude.cmi 
+theories/Init/prelude.cmx: theories/Init/prelude.cmi 
+theories/Init/specif.cmo: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi 
+theories/Init/specif.cmx: theories/Init/datatypes.cmx \
+    theories/Init/specif.cmi 
+theories/Init/wf.cmo: theories/Init/wf.cmi 
+theories/Init/wf.cmx: theories/Init/wf.cmi 
+theories/IntMap/adalloc.cmo: theories/IntMap/addec.cmi \
+    theories/IntMap/addr.cmi theories/NArith/binPos.cmi \
+    theories/Init/datatypes.cmi theories/IntMap/map.cmi \
+    theories/Init/specif.cmi theories/Bool/sumbool.cmi \
+    theories/IntMap/adalloc.cmi 
+theories/IntMap/adalloc.cmx: theories/IntMap/addec.cmx \
+    theories/IntMap/addr.cmx theories/NArith/binPos.cmx \
+    theories/Init/datatypes.cmx theories/IntMap/map.cmx \
+    theories/Init/specif.cmx theories/Bool/sumbool.cmx \
+    theories/IntMap/adalloc.cmi 
+theories/IntMap/addec.cmo: theories/IntMap/addr.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/Bool/sumbool.cmi \
+    theories/IntMap/addec.cmi 
+theories/IntMap/addec.cmx: theories/IntMap/addr.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+    theories/Init/specif.cmx theories/Bool/sumbool.cmx \
+    theories/IntMap/addec.cmi 
+theories/IntMap/addr.cmo: theories/NArith/binPos.cmi theories/Bool/bool.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/IntMap/addr.cmi 
+theories/IntMap/addr.cmx: theories/NArith/binPos.cmx theories/Bool/bool.cmx \
+    theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/IntMap/addr.cmi 
+theories/IntMap/adist.cmo: theories/IntMap/addr.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/IntMap/adist.cmi 
+theories/IntMap/adist.cmx: theories/IntMap/addr.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+    theories/IntMap/adist.cmi 
+theories/IntMap/allmaps.cmo: theories/IntMap/allmaps.cmi 
+theories/IntMap/allmaps.cmx: theories/IntMap/allmaps.cmi 
+theories/IntMap/fset.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
+    theories/Init/datatypes.cmi theories/IntMap/map.cmi \
+    theories/Init/specif.cmi theories/IntMap/fset.cmi 
+theories/IntMap/fset.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \
+    theories/Init/datatypes.cmx theories/IntMap/map.cmx \
+    theories/Init/specif.cmx theories/IntMap/fset.cmi 
+theories/IntMap/lsort.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
+    theories/NArith/binPos.cmi theories/Bool/bool.cmi \
+    theories/Init/datatypes.cmi theories/Lists/list.cmi \
+    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \
+    theories/Init/specif.cmi theories/Bool/sumbool.cmi \
+    theories/IntMap/lsort.cmi 
+theories/IntMap/lsort.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \
+    theories/NArith/binPos.cmx theories/Bool/bool.cmx \
+    theories/Init/datatypes.cmx theories/Lists/list.cmx \
+    theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \
+    theories/Init/specif.cmx theories/Bool/sumbool.cmx \
+    theories/IntMap/lsort.cmi 
+theories/IntMap/mapaxioms.cmo: theories/IntMap/mapaxioms.cmi 
+theories/IntMap/mapaxioms.cmx: theories/IntMap/mapaxioms.cmi 
+theories/IntMap/mapcanon.cmo: theories/IntMap/map.cmi \
+    theories/Init/specif.cmi theories/IntMap/mapcanon.cmi 
+theories/IntMap/mapcanon.cmx: theories/IntMap/map.cmx \
+    theories/Init/specif.cmx theories/IntMap/mapcanon.cmi 
+theories/IntMap/mapcard.cmo: theories/IntMap/addec.cmi \
+    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
+    theories/IntMap/map.cmi theories/Init/peano.cmi \
+    theories/Arith/peano_dec.cmi theories/Arith/plus.cmi \
+    theories/Init/specif.cmi theories/Bool/sumbool.cmi \
+    theories/IntMap/mapcard.cmi 
+theories/IntMap/mapcard.cmx: theories/IntMap/addec.cmx \
+    theories/IntMap/addr.cmx theories/Init/datatypes.cmx \
+    theories/IntMap/map.cmx theories/Init/peano.cmx \
+    theories/Arith/peano_dec.cmx theories/Arith/plus.cmx \
+    theories/Init/specif.cmx theories/Bool/sumbool.cmx \
+    theories/IntMap/mapcard.cmi 
+theories/IntMap/mapc.cmo: theories/IntMap/mapc.cmi 
+theories/IntMap/mapc.cmx: theories/IntMap/mapc.cmi 
+theories/IntMap/mapfold.cmo: theories/IntMap/addr.cmi \
+    theories/Init/datatypes.cmi theories/IntMap/fset.cmi \
+    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \
+    theories/Init/specif.cmi theories/IntMap/mapfold.cmi 
+theories/IntMap/mapfold.cmx: theories/IntMap/addr.cmx \
+    theories/Init/datatypes.cmx theories/IntMap/fset.cmx \
+    theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \
+    theories/Init/specif.cmx theories/IntMap/mapfold.cmi 
+theories/IntMap/mapiter.cmo: theories/IntMap/addec.cmi \
+    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/IntMap/map.cmi theories/Init/specif.cmi \
+    theories/Bool/sumbool.cmi theories/IntMap/mapiter.cmi 
+theories/IntMap/mapiter.cmx: theories/IntMap/addec.cmx \
+    theories/IntMap/addr.cmx theories/Init/datatypes.cmx \
+    theories/Lists/list.cmx theories/IntMap/map.cmx theories/Init/specif.cmx \
+    theories/Bool/sumbool.cmx theories/IntMap/mapiter.cmi 
+theories/IntMap/maplists.cmo: theories/IntMap/addec.cmi \
+    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
+    theories/IntMap/fset.cmi theories/Lists/list.cmi theories/IntMap/map.cmi \
+    theories/IntMap/mapiter.cmi theories/Init/specif.cmi \
+    theories/Bool/sumbool.cmi theories/IntMap/maplists.cmi 
+theories/IntMap/maplists.cmx: theories/IntMap/addec.cmx \
+    theories/IntMap/addr.cmx theories/Init/datatypes.cmx \
+    theories/IntMap/fset.cmx theories/Lists/list.cmx theories/IntMap/map.cmx \
+    theories/IntMap/mapiter.cmx theories/Init/specif.cmx \
+    theories/Bool/sumbool.cmx theories/IntMap/maplists.cmi 
+theories/IntMap/map.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi theories/Init/specif.cmi theories/IntMap/map.cmi 
+theories/IntMap/map.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+    theories/Init/peano.cmx theories/Init/specif.cmx theories/IntMap/map.cmi 
+theories/IntMap/mapsubset.cmo: theories/Bool/bool.cmi \
+    theories/Init/datatypes.cmi theories/IntMap/fset.cmi \
+    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \
+    theories/IntMap/mapsubset.cmi 
+theories/IntMap/mapsubset.cmx: theories/Bool/bool.cmx \
+    theories/Init/datatypes.cmx theories/IntMap/fset.cmx \
+    theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \
+    theories/IntMap/mapsubset.cmi 
+theories/Lists/list.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Lists/list.cmi 
+theories/Lists/list.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Lists/list.cmi 
+theories/Lists/listSet.cmo: theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/Init/specif.cmi \
+    theories/Lists/listSet.cmi 
+theories/Lists/listSet.cmx: theories/Init/datatypes.cmx \
+    theories/Lists/list.cmx theories/Init/specif.cmx \
+    theories/Lists/listSet.cmi 
+theories/Lists/monoList.cmo: theories/Init/datatypes.cmi \
+    theories/Lists/monoList.cmi 
+theories/Lists/monoList.cmx: theories/Init/datatypes.cmx \
+    theories/Lists/monoList.cmi 
+theories/Lists/streams.cmo: theories/Init/datatypes.cmi \
+    theories/Lists/streams.cmi 
+theories/Lists/streams.cmx: theories/Init/datatypes.cmx \
+    theories/Lists/streams.cmi 
+theories/Lists/theoryList.cmo: theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/Init/specif.cmi \
+    theories/Lists/theoryList.cmi 
+theories/Lists/theoryList.cmx: theories/Init/datatypes.cmx \
+    theories/Lists/list.cmx theories/Init/specif.cmx \
+    theories/Lists/theoryList.cmi 
+theories/Logic/berardi.cmo: theories/Logic/berardi.cmi 
+theories/Logic/berardi.cmx: theories/Logic/berardi.cmi 
+theories/Logic/choiceFacts.cmo: theories/Logic/choiceFacts.cmi 
+theories/Logic/choiceFacts.cmx: theories/Logic/choiceFacts.cmi 
+theories/Logic/classicalChoice.cmo: theories/Logic/classicalChoice.cmi 
+theories/Logic/classicalChoice.cmx: theories/Logic/classicalChoice.cmi 
+theories/Logic/classicalDescription.cmo: \
+    theories/Logic/classicalDescription.cmi 
+theories/Logic/classicalDescription.cmx: \
+    theories/Logic/classicalDescription.cmi 
+theories/Logic/classicalFacts.cmo: theories/Logic/classicalFacts.cmi 
+theories/Logic/classicalFacts.cmx: theories/Logic/classicalFacts.cmi 
+theories/Logic/classical.cmo: theories/Logic/classical.cmi 
+theories/Logic/classical.cmx: theories/Logic/classical.cmi 
+theories/Logic/classical_Pred_Set.cmo: theories/Logic/classical_Pred_Set.cmi 
+theories/Logic/classical_Pred_Set.cmx: theories/Logic/classical_Pred_Set.cmi 
+theories/Logic/classical_Pred_Type.cmo: \
+    theories/Logic/classical_Pred_Type.cmi 
+theories/Logic/classical_Pred_Type.cmx: \
+    theories/Logic/classical_Pred_Type.cmi 
+theories/Logic/classical_Prop.cmo: theories/Logic/classical_Prop.cmi 
+theories/Logic/classical_Prop.cmx: theories/Logic/classical_Prop.cmi 
+theories/Logic/classical_Type.cmo: theories/Logic/classical_Type.cmi 
+theories/Logic/classical_Type.cmx: theories/Logic/classical_Type.cmi 
+theories/Logic/decidable.cmo: theories/Logic/decidable.cmi 
+theories/Logic/decidable.cmx: theories/Logic/decidable.cmi 
+theories/Logic/diaconescu.cmo: theories/Logic/diaconescu.cmi 
+theories/Logic/diaconescu.cmx: theories/Logic/diaconescu.cmi 
+theories/Logic/eqdep_dec.cmo: theories/Logic/eqdep_dec.cmi 
+theories/Logic/eqdep_dec.cmx: theories/Logic/eqdep_dec.cmi 
+theories/Logic/eqdep.cmo: theories/Logic/eqdep.cmi 
+theories/Logic/eqdep.cmx: theories/Logic/eqdep.cmi 
+theories/Logic/hurkens.cmo: theories/Logic/hurkens.cmi 
+theories/Logic/hurkens.cmx: theories/Logic/hurkens.cmi 
+theories/Logic/jMeq.cmo: theories/Logic/jMeq.cmi 
+theories/Logic/jMeq.cmx: theories/Logic/jMeq.cmi 
+theories/Logic/proofIrrelevance.cmo: theories/Logic/proofIrrelevance.cmi 
+theories/Logic/proofIrrelevance.cmx: theories/Logic/proofIrrelevance.cmi 
+theories/Logic/relationalChoice.cmo: theories/Logic/relationalChoice.cmi 
+theories/Logic/relationalChoice.cmx: theories/Logic/relationalChoice.cmi 
+theories/NArith/binNat.cmo: theories/NArith/binPos.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binNat.cmi 
+theories/NArith/binNat.cmx: theories/NArith/binPos.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binNat.cmi 
+theories/NArith/binPos.cmo: theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi theories/NArith/binPos.cmi 
+theories/NArith/binPos.cmx: theories/Init/datatypes.cmx \
+    theories/Init/peano.cmx theories/NArith/binPos.cmi 
+theories/NArith/nArith.cmo: theories/NArith/nArith.cmi 
+theories/NArith/nArith.cmx: theories/NArith/nArith.cmi 
+theories/NArith/pnat.cmo: theories/NArith/pnat.cmi 
+theories/NArith/pnat.cmx: theories/NArith/pnat.cmi 
+theories/Relations/newman.cmo: theories/Relations/newman.cmi 
+theories/Relations/newman.cmx: theories/Relations/newman.cmi 
+theories/Relations/operators_Properties.cmo: \
+    theories/Relations/operators_Properties.cmi 
+theories/Relations/operators_Properties.cmx: \
+    theories/Relations/operators_Properties.cmi 
+theories/Relations/relation_Definitions.cmo: \
+    theories/Relations/relation_Definitions.cmi 
+theories/Relations/relation_Definitions.cmx: \
+    theories/Relations/relation_Definitions.cmi 
+theories/Relations/relation_Operators.cmo: theories/Lists/list.cmi \
+    theories/Init/specif.cmi theories/Relations/relation_Operators.cmi 
+theories/Relations/relation_Operators.cmx: theories/Lists/list.cmx \
+    theories/Init/specif.cmx theories/Relations/relation_Operators.cmi 
+theories/Relations/relations.cmo: theories/Relations/relations.cmi 
+theories/Relations/relations.cmx: theories/Relations/relations.cmi 
+theories/Relations/rstar.cmo: theories/Relations/rstar.cmi 
+theories/Relations/rstar.cmx: theories/Relations/rstar.cmi 
+theories/Setoids/setoid.cmo: theories/Setoids/setoid.cmi 
+theories/Setoids/setoid.cmx: theories/Setoids/setoid.cmi 
+theories/Sets/classical_sets.cmo: theories/Sets/classical_sets.cmi 
+theories/Sets/classical_sets.cmx: theories/Sets/classical_sets.cmi 
+theories/Sets/constructive_sets.cmo: theories/Sets/constructive_sets.cmi 
+theories/Sets/constructive_sets.cmx: theories/Sets/constructive_sets.cmi 
+theories/Sets/cpo.cmo: theories/Sets/partial_Order.cmi theories/Sets/cpo.cmi 
+theories/Sets/cpo.cmx: theories/Sets/partial_Order.cmx theories/Sets/cpo.cmi 
+theories/Sets/ensembles.cmo: theories/Sets/ensembles.cmi 
+theories/Sets/ensembles.cmx: theories/Sets/ensembles.cmi 
+theories/Sets/finite_sets_facts.cmo: theories/Sets/finite_sets_facts.cmi 
+theories/Sets/finite_sets_facts.cmx: theories/Sets/finite_sets_facts.cmi 
+theories/Sets/finite_sets.cmo: theories/Sets/finite_sets.cmi 
+theories/Sets/finite_sets.cmx: theories/Sets/finite_sets.cmi 
+theories/Sets/image.cmo: theories/Sets/image.cmi 
+theories/Sets/image.cmx: theories/Sets/image.cmi 
+theories/Sets/infinite_sets.cmo: theories/Sets/infinite_sets.cmi 
+theories/Sets/infinite_sets.cmx: theories/Sets/infinite_sets.cmi 
+theories/Sets/integers.cmo: theories/Init/datatypes.cmi \
+    theories/Sets/partial_Order.cmi theories/Sets/integers.cmi 
+theories/Sets/integers.cmx: theories/Init/datatypes.cmx \
+    theories/Sets/partial_Order.cmx theories/Sets/integers.cmi 
+theories/Sets/multiset.cmo: theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi theories/Init/specif.cmi \
+    theories/Sets/multiset.cmi 
+theories/Sets/multiset.cmx: theories/Init/datatypes.cmx \
+    theories/Init/peano.cmx theories/Init/specif.cmx \
+    theories/Sets/multiset.cmi 
+theories/Sets/partial_Order.cmo: theories/Sets/ensembles.cmi \
+    theories/Sets/relations_1.cmi theories/Sets/partial_Order.cmi 
+theories/Sets/partial_Order.cmx: theories/Sets/ensembles.cmx \
+    theories/Sets/relations_1.cmx theories/Sets/partial_Order.cmi 
+theories/Sets/permut.cmo: theories/Sets/permut.cmi 
+theories/Sets/permut.cmx: theories/Sets/permut.cmi 
+theories/Sets/powerset_Classical_facts.cmo: \
+    theories/Sets/powerset_Classical_facts.cmi 
+theories/Sets/powerset_Classical_facts.cmx: \
+    theories/Sets/powerset_Classical_facts.cmi 
+theories/Sets/powerset_facts.cmo: theories/Sets/powerset_facts.cmi 
+theories/Sets/powerset_facts.cmx: theories/Sets/powerset_facts.cmi 
+theories/Sets/powerset.cmo: theories/Sets/ensembles.cmi \
+    theories/Sets/partial_Order.cmi theories/Sets/powerset.cmi 
+theories/Sets/powerset.cmx: theories/Sets/ensembles.cmx \
+    theories/Sets/partial_Order.cmx theories/Sets/powerset.cmi 
+theories/Sets/relations_1_facts.cmo: theories/Sets/relations_1_facts.cmi 
+theories/Sets/relations_1_facts.cmx: theories/Sets/relations_1_facts.cmi 
+theories/Sets/relations_1.cmo: theories/Sets/relations_1.cmi 
+theories/Sets/relations_1.cmx: theories/Sets/relations_1.cmi 
+theories/Sets/relations_2_facts.cmo: theories/Sets/relations_2_facts.cmi 
+theories/Sets/relations_2_facts.cmx: theories/Sets/relations_2_facts.cmi 
+theories/Sets/relations_2.cmo: theories/Sets/relations_2.cmi 
+theories/Sets/relations_2.cmx: theories/Sets/relations_2.cmi 
+theories/Sets/relations_3_facts.cmo: theories/Sets/relations_3_facts.cmi 
+theories/Sets/relations_3_facts.cmx: theories/Sets/relations_3_facts.cmi 
+theories/Sets/relations_3.cmo: theories/Sets/relations_3.cmi 
+theories/Sets/relations_3.cmx: theories/Sets/relations_3.cmi 
+theories/Sets/uniset.cmo: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/Sets/uniset.cmi 
+theories/Sets/uniset.cmx: theories/Init/datatypes.cmx \
+    theories/Init/specif.cmx theories/Sets/uniset.cmi 
+theories/Sorting/heap.cmo: theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/Sets/multiset.cmi \
+    theories/Init/peano.cmi theories/Sorting/sorting.cmi \
+    theories/Init/specif.cmi theories/Sorting/heap.cmi 
+theories/Sorting/heap.cmx: theories/Init/datatypes.cmx \
+    theories/Lists/list.cmx theories/Sets/multiset.cmx \
+    theories/Init/peano.cmx theories/Sorting/sorting.cmx \
+    theories/Init/specif.cmx theories/Sorting/heap.cmi 
+theories/Sorting/permutation.cmo: theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/Sets/multiset.cmi \
+    theories/Init/peano.cmi theories/Init/specif.cmi \
+    theories/Sorting/permutation.cmi 
+theories/Sorting/permutation.cmx: theories/Init/datatypes.cmx \
+    theories/Lists/list.cmx theories/Sets/multiset.cmx \
+    theories/Init/peano.cmx theories/Init/specif.cmx \
+    theories/Sorting/permutation.cmi 
+theories/Sorting/sorting.cmo: theories/Lists/list.cmi \
+    theories/Init/specif.cmi theories/Sorting/sorting.cmi 
+theories/Sorting/sorting.cmx: theories/Lists/list.cmx \
+    theories/Init/specif.cmx theories/Sorting/sorting.cmi 
+theories/Wellfounded/disjoint_Union.cmo: \
+    theories/Wellfounded/disjoint_Union.cmi 
+theories/Wellfounded/disjoint_Union.cmx: \
+    theories/Wellfounded/disjoint_Union.cmi 
+theories/Wellfounded/inclusion.cmo: theories/Wellfounded/inclusion.cmi 
+theories/Wellfounded/inclusion.cmx: theories/Wellfounded/inclusion.cmi 
+theories/Wellfounded/inverse_Image.cmo: \
+    theories/Wellfounded/inverse_Image.cmi 
+theories/Wellfounded/inverse_Image.cmx: \
+    theories/Wellfounded/inverse_Image.cmi 
+theories/Wellfounded/lexicographic_Exponentiation.cmo: \
+    theories/Wellfounded/lexicographic_Exponentiation.cmi 
+theories/Wellfounded/lexicographic_Exponentiation.cmx: \
+    theories/Wellfounded/lexicographic_Exponentiation.cmi 
+theories/Wellfounded/lexicographic_Product.cmo: \
+    theories/Wellfounded/lexicographic_Product.cmi 
+theories/Wellfounded/lexicographic_Product.cmx: \
+    theories/Wellfounded/lexicographic_Product.cmi 
+theories/Wellfounded/transitive_Closure.cmo: \
+    theories/Wellfounded/transitive_Closure.cmi 
+theories/Wellfounded/transitive_Closure.cmx: \
+    theories/Wellfounded/transitive_Closure.cmi 
+theories/Wellfounded/union.cmo: theories/Wellfounded/union.cmi 
+theories/Wellfounded/union.cmx: theories/Wellfounded/union.cmi 
+theories/Wellfounded/wellfounded.cmo: theories/Wellfounded/wellfounded.cmi 
+theories/Wellfounded/wellfounded.cmx: theories/Wellfounded/wellfounded.cmi 
+theories/Wellfounded/well_Ordering.cmo: theories/Init/specif.cmi \
+    theories/Wellfounded/well_Ordering.cmi 
+theories/Wellfounded/well_Ordering.cmx: theories/Init/specif.cmx \
+    theories/Wellfounded/well_Ordering.cmi 
+theories/ZArith/auxiliary.cmo: theories/ZArith/auxiliary.cmi 
+theories/ZArith/auxiliary.cmx: theories/ZArith/auxiliary.cmi 
+theories/ZArith/binInt.cmo: theories/NArith/binNat.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/binInt.cmx: theories/NArith/binNat.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/wf_Z.cmo: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi 
+theories/ZArith/wf_Z.cmx: theories/ZArith/binInt.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+    theories/Init/peano.cmx theories/Init/specif.cmx theories/ZArith/wf_Z.cmi 
+theories/ZArith/zabs.cmo: theories/ZArith/binInt.cmi theories/Init/specif.cmi \
+    theories/Bool/sumbool.cmi theories/ZArith/zabs.cmi 
+theories/ZArith/zabs.cmx: theories/ZArith/binInt.cmx theories/Init/specif.cmx \
+    theories/Bool/sumbool.cmx theories/ZArith/zabs.cmi 
+theories/ZArith/zArith_base.cmo: theories/ZArith/zArith_base.cmi 
+theories/ZArith/zArith_base.cmx: theories/ZArith/zArith_base.cmi 
+theories/ZArith/zArith_dec.cmo: theories/ZArith/binInt.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi 
+theories/ZArith/zArith_dec.cmx: theories/ZArith/binInt.cmx \
+    theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Bool/sumbool.cmx theories/ZArith/zArith_dec.cmi 
+theories/ZArith/zArith.cmo: theories/ZArith/zArith.cmi 
+theories/ZArith/zArith.cmx: theories/ZArith/zArith.cmi 
+theories/ZArith/zbinary.cmo: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Bool/bvector.cmi \
+    theories/Init/datatypes.cmi theories/ZArith/zeven.cmi \
+    theories/ZArith/zbinary.cmi 
+theories/ZArith/zbinary.cmx: theories/ZArith/binInt.cmx \
+    theories/NArith/binPos.cmx theories/Bool/bvector.cmx \
+    theories/Init/datatypes.cmx theories/ZArith/zeven.cmx \
+    theories/ZArith/zbinary.cmi 
+theories/ZArith/zbool.cmo: theories/ZArith/binInt.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi \
+    theories/ZArith/zeven.cmi theories/ZArith/zbool.cmi 
+theories/ZArith/zbool.cmx: theories/ZArith/binInt.cmx \
+    theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Bool/sumbool.cmx theories/ZArith/zArith_dec.cmx \
+    theories/ZArith/zeven.cmx theories/ZArith/zbool.cmi 
+theories/ZArith/zcompare.cmo: theories/ZArith/zcompare.cmi 
+theories/ZArith/zcompare.cmx: theories/ZArith/zcompare.cmi 
+theories/ZArith/zcomplements.cmo: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \
+    theories/ZArith/zabs.cmi theories/ZArith/zcomplements.cmi 
+theories/ZArith/zcomplements.cmx: theories/ZArith/binInt.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+    theories/Lists/list.cmx theories/Init/specif.cmx theories/ZArith/wf_Z.cmx \
+    theories/ZArith/zabs.cmx theories/ZArith/zcomplements.cmi 
+theories/ZArith/zdiv.cmo: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/ZArith/zArith_dec.cmi \
+    theories/ZArith/zbool.cmi theories/ZArith/zdiv.cmi 
+theories/ZArith/zdiv.cmx: theories/ZArith/binInt.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+    theories/Init/specif.cmx theories/ZArith/zArith_dec.cmx \
+    theories/ZArith/zbool.cmx theories/ZArith/zdiv.cmi 
+theories/ZArith/zeven.cmo: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/ZArith/zeven.cmi 
+theories/ZArith/zeven.cmx: theories/ZArith/binInt.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+    theories/Init/specif.cmx theories/ZArith/zeven.cmi 
+theories/ZArith/zhints.cmo: theories/ZArith/zhints.cmi 
+theories/ZArith/zhints.cmx: theories/ZArith/zhints.cmi 
+theories/ZArith/zlogarithm.cmo: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/ZArith/zlogarithm.cmi 
+theories/ZArith/zlogarithm.cmx: theories/ZArith/binInt.cmx \
+    theories/NArith/binPos.cmx theories/ZArith/zlogarithm.cmi 
+theories/ZArith/zmin.cmo: theories/ZArith/binInt.cmi \
+    theories/Init/datatypes.cmi theories/ZArith/zmin.cmi 
+theories/ZArith/zmin.cmx: theories/ZArith/binInt.cmx \
+    theories/Init/datatypes.cmx theories/ZArith/zmin.cmi 
+theories/ZArith/zmisc.cmo: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/ZArith/zmisc.cmi 
+theories/ZArith/zmisc.cmx: theories/ZArith/binInt.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+    theories/ZArith/zmisc.cmi 
+theories/ZArith/znat.cmo: theories/ZArith/znat.cmi 
+theories/ZArith/znat.cmx: theories/ZArith/znat.cmi 
+theories/ZArith/znumtheory.cmo: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \
+    theories/ZArith/zArith_dec.cmi theories/ZArith/zdiv.cmi \
+    theories/ZArith/zorder.cmi theories/ZArith/znumtheory.cmi 
+theories/ZArith/znumtheory.cmx: theories/ZArith/binInt.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+    theories/Init/specif.cmx theories/ZArith/wf_Z.cmx \
+    theories/ZArith/zArith_dec.cmx theories/ZArith/zdiv.cmx \
+    theories/ZArith/zorder.cmx theories/ZArith/znumtheory.cmi 
+theories/ZArith/zorder.cmo: theories/ZArith/binInt.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/ZArith/zorder.cmi 
+theories/ZArith/zorder.cmx: theories/ZArith/binInt.cmx \
+    theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/ZArith/zorder.cmi 
+theories/ZArith/zpower.cmo: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/ZArith/zmisc.cmi theories/ZArith/zpower.cmi 
+theories/ZArith/zpower.cmx: theories/ZArith/binInt.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+    theories/ZArith/zmisc.cmx theories/ZArith/zpower.cmi 
+theories/ZArith/zsqrt.cmo: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/specif.cmi \
+    theories/ZArith/zArith_dec.cmi theories/ZArith/zsqrt.cmi 
+theories/ZArith/zsqrt.cmx: theories/ZArith/binInt.cmx \
+    theories/NArith/binPos.cmx theories/Init/specif.cmx \
+    theories/ZArith/zArith_dec.cmx theories/ZArith/zsqrt.cmi 
+theories/ZArith/zwf.cmo: theories/ZArith/zwf.cmi 
+theories/ZArith/zwf.cmx: theories/ZArith/zwf.cmi 
+theories/Arith/bool_nat.cmi: theories/Arith/compare_dec.cmi \
+    theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi \
+    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
+theories/Arith/compare_dec.cmi: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi 
+theories/Arith/compare.cmi: theories/Arith/compare_dec.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi 
+theories/Arith/div2.cmi: theories/Init/datatypes.cmi theories/Init/peano.cmi \
+    theories/Init/specif.cmi 
+theories/Arith/eqNat.cmi: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi 
+theories/Arith/euclid.cmi: theories/Arith/compare_dec.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi 
+theories/Arith/even.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
+theories/Arith/factorial.cmi: theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi 
+theories/Arith/max.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
+theories/Arith/min.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
+theories/Arith/mult.cmi: theories/Init/datatypes.cmi theories/Arith/plus.cmi 
+theories/Arith/peano_dec.cmi: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi 
+theories/Arith/plus.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
+theories/Arith/wf_nat.cmi: theories/Init/datatypes.cmi 
+theories/Bool/boolEq.cmi: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi 
+theories/Bool/bool.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
+theories/Bool/bvector.cmi: theories/Bool/bool.cmi theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi 
+theories/Bool/decBool.cmi: theories/Init/specif.cmi 
+theories/Bool/ifProp.cmi: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi 
+theories/Bool/sumbool.cmi: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi 
+theories/Bool/zerob.cmi: theories/Init/datatypes.cmi 
+theories/Init/logic_Type.cmi: theories/Init/datatypes.cmi 
+theories/Init/peano.cmi: theories/Init/datatypes.cmi 
+theories/Init/specif.cmi: theories/Init/datatypes.cmi 
+theories/IntMap/adalloc.cmi: theories/IntMap/addec.cmi \
+    theories/IntMap/addr.cmi theories/NArith/binPos.cmi \
+    theories/Init/datatypes.cmi theories/IntMap/map.cmi \
+    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
+theories/IntMap/addec.cmi: theories/IntMap/addr.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
+theories/IntMap/addr.cmi: theories/NArith/binPos.cmi theories/Bool/bool.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi 
+theories/IntMap/adist.cmi: theories/IntMap/addr.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi 
+theories/IntMap/fset.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
+    theories/Init/datatypes.cmi theories/IntMap/map.cmi \
+    theories/Init/specif.cmi 
+theories/IntMap/lsort.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
+    theories/NArith/binPos.cmi theories/Bool/bool.cmi \
+    theories/Init/datatypes.cmi theories/Lists/list.cmi \
+    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \
+    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
+theories/IntMap/mapcanon.cmi: theories/IntMap/map.cmi \
+    theories/Init/specif.cmi 
+theories/IntMap/mapcard.cmi: theories/IntMap/addec.cmi \
+    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
+    theories/IntMap/map.cmi theories/Init/peano.cmi \
+    theories/Arith/peano_dec.cmi theories/Arith/plus.cmi \
+    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
+theories/IntMap/mapfold.cmi: theories/IntMap/addr.cmi \
+    theories/Init/datatypes.cmi theories/IntMap/fset.cmi \
+    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \
+    theories/Init/specif.cmi 
+theories/IntMap/mapiter.cmi: theories/IntMap/addec.cmi \
+    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/IntMap/map.cmi theories/Init/specif.cmi \
+    theories/Bool/sumbool.cmi 
+theories/IntMap/maplists.cmi: theories/IntMap/addec.cmi \
+    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
+    theories/IntMap/fset.cmi theories/Lists/list.cmi theories/IntMap/map.cmi \
+    theories/IntMap/mapiter.cmi theories/Init/specif.cmi \
+    theories/Bool/sumbool.cmi 
+theories/IntMap/map.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi theories/Init/specif.cmi 
+theories/IntMap/mapsubset.cmi: theories/Bool/bool.cmi \
+    theories/Init/datatypes.cmi theories/IntMap/fset.cmi \
+    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi 
+theories/Lists/list.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
+theories/Lists/listSet.cmi: theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/Init/specif.cmi 
+theories/Lists/monoList.cmi: theories/Init/datatypes.cmi 
+theories/Lists/streams.cmi: theories/Init/datatypes.cmi 
+theories/Lists/theoryList.cmi: theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/Init/specif.cmi 
+theories/NArith/binNat.cmi: theories/NArith/binPos.cmi \
+    theories/Init/datatypes.cmi 
+theories/NArith/binPos.cmi: theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi 
+theories/Relations/relation_Operators.cmi: theories/Lists/list.cmi \
+    theories/Init/specif.cmi 
+theories/Sets/cpo.cmi: theories/Sets/partial_Order.cmi 
+theories/Sets/integers.cmi: theories/Init/datatypes.cmi \
+    theories/Sets/partial_Order.cmi 
+theories/Sets/multiset.cmi: theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi theories/Init/specif.cmi 
+theories/Sets/partial_Order.cmi: theories/Sets/ensembles.cmi \
+    theories/Sets/relations_1.cmi 
+theories/Sets/powerset.cmi: theories/Sets/ensembles.cmi \
+    theories/Sets/partial_Order.cmi 
+theories/Sets/uniset.cmi: theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi 
+theories/Sorting/heap.cmi: theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/Sets/multiset.cmi \
+    theories/Init/peano.cmi theories/Sorting/sorting.cmi \
+    theories/Init/specif.cmi 
+theories/Sorting/permutation.cmi: theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/Sets/multiset.cmi \
+    theories/Init/peano.cmi theories/Init/specif.cmi 
+theories/Sorting/sorting.cmi: theories/Lists/list.cmi \
+    theories/Init/specif.cmi 
+theories/Wellfounded/well_Ordering.cmi: theories/Init/specif.cmi 
+theories/ZArith/binInt.cmi: theories/NArith/binNat.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi 
+theories/ZArith/wf_Z.cmi: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/peano.cmi theories/Init/specif.cmi 
+theories/ZArith/zabs.cmi: theories/ZArith/binInt.cmi theories/Init/specif.cmi \
+    theories/Bool/sumbool.cmi 
+theories/ZArith/zArith_dec.cmi: theories/ZArith/binInt.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Bool/sumbool.cmi 
+theories/ZArith/zbinary.cmi: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Bool/bvector.cmi \
+    theories/Init/datatypes.cmi theories/ZArith/zeven.cmi 
+theories/ZArith/zbool.cmi: theories/ZArith/binInt.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi \
+    theories/ZArith/zeven.cmi 
+theories/ZArith/zcomplements.cmi: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Lists/list.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \
+    theories/ZArith/zabs.cmi 
+theories/ZArith/zdiv.cmi: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/ZArith/zArith_dec.cmi \
+    theories/ZArith/zbool.cmi 
+theories/ZArith/zeven.cmi: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi 
+theories/ZArith/zlogarithm.cmi: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi 
+theories/ZArith/zmin.cmi: theories/ZArith/binInt.cmi \
+    theories/Init/datatypes.cmi 
+theories/ZArith/zmisc.cmi: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi 
+theories/ZArith/znumtheory.cmi: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \
+    theories/ZArith/zArith_dec.cmi theories/ZArith/zdiv.cmi \
+    theories/ZArith/zorder.cmi 
+theories/ZArith/zorder.cmi: theories/ZArith/binInt.cmi \
+    theories/Init/datatypes.cmi theories/Init/specif.cmi 
+theories/ZArith/zpower.cmi: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+    theories/ZArith/zmisc.cmi 
+theories/ZArith/zsqrt.cmi: theories/ZArith/binInt.cmi \
+    theories/NArith/binPos.cmi theories/Init/specif.cmi \
+    theories/ZArith/zArith_dec.cmi 
diff --git a/contrib/extraction/test/Makefile b/contrib/extraction/test/Makefile
new file mode 100644
index 00000000..c9bb5623
--- /dev/null
+++ b/contrib/extraction/test/Makefile
@@ -0,0 +1,109 @@
+# 
+#	General variables
+#
+
+TOPDIR=../../..
+
+# Files with axioms to be realized: can't be extracted directly
+
+AXIOMSVO:= \
+theories/Reals/% \
+theories/Num/%
+
+DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS))
+
+INCL:= $(patsubst %,-I %,$(DIRS))
+
+VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo))
+
+VO:= $(filter-out $(AXIOMSVO),$(VO))
+
+ML:= $(shell test -x v2ml && ./v2ml $(VO))
+
+MLI:= $(patsubst %.ml,%.mli,$(ML))
+
+CMO:= $(patsubst %.ml,%.cmo,$(ML))
+
+OSTDLIB:=$(shell (ocamlc -where))
+
+#
+#	General rules 
+#
+
+all: v2ml ml $(MLI) $(CMO)
+
+ml: $(ML)
+
+depend: $(ML)
+	rm -f .depend; ocamldep $(INCL) theories/*/*.ml theories/*/*.mli > .depend
+
+tree:
+	mkdir -p $(DIRS)
+	cp $(OSTDLIB)/pervasives.cmi $(OSTDLIB)/obj.cmi $(OSTDLIB)/lazy.cmi theories
+
+#%.mli:%.ml
+#	./make_mli $< > $@
+
+%.cmi:%.mli
+	ocamlc -c $(INCL) -nostdlib $<
+
+%.cmo:%.ml
+	ocamlc -c $(INCL) -nostdlib $<
+
+$(ML): ml2v
+	./extract $@
+
+clean: 
+	rm -f theories/*/*.ml* theories/*/*.cm*
+
+
+#
+#	Utilities
+#
+
+open: 
+	find theories -name "*".ml -exec ./qualify2open \{\} \;
+
+undo_open: 
+	find theories -name "*".ml -exec mv \{\}.orig \{\} \;
+
+ml2v: ml2v.ml
+	ocamlopt -o $@ $<
+
+v2ml: v2ml.ml
+	ocamlopt -o $@ $< 
+	$(MAKE)
+
+#
+#	Extraction of Reals
+#
+
+
+REALSAXIOMSVO:=theories/Reals/Rsyntax.vo
+
+REALSALLVO:=$(shell cd $(TOPDIR); ls -tr theories/Reals/*.vo)
+REALSVO:=$(filter-out $(REALSAXIOMSVO),$(REALSALLVO))
+REALSML:=$(shell test -x v2ml && ./v2ml $(REALSVO))
+REALSCMO:= $(patsubst %.ml,%.cmo,$(REALSML))
+
+reals: all realsml theories/Reals/addReals.cmo $(REALSCMO)
+
+realsml: $(REALSML)
+
+theories/Reals/addReals.ml: 
+	cp -f addReals theories/Reals/addReals.ml
+
+$(REALSML): 
+	./extract $@
+
+
+#
+#	The End
+#
+
+.PHONY: all tree clean reals realsml depend
+
+include .depend
+
+
+
diff --git a/contrib/extraction/test/Makefile.haskell b/contrib/extraction/test/Makefile.haskell
new file mode 100644
index 00000000..6e1e15d1
--- /dev/null
+++ b/contrib/extraction/test/Makefile.haskell
@@ -0,0 +1,416 @@
+# 
+#	General variables
+#
+
+TOPDIR=../../..
+
+# Files with axioms to be realized: can't be extracted directly
+
+AXIOMSVO:= \
+theories/Init/Prelude.vo \
+theories/Reals/% \
+theories/Num/%
+
+DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS))
+
+INCL:= $(patsubst %,-i%,$(DIRS))
+
+VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo))
+
+VO:= $(filter-out $(AXIOMSVO),$(VO))
+
+HS:= $(shell test -x v2hs && ./v2hs $(VO))
+
+O:= $(patsubst %.hs,%.o,$(HS))
+
+#
+#	General rules 
+#
+
+all: v2hs hs $(O)
+
+hs: $(HS)
+
+tree:
+	mkdir -p $(DIRS)
+
+%.o:%.hs
+	ghc $(INCL) -c $<
+
+$(HS): hs2v
+	./extract.haskell $@
+
+clean: 
+	rm -f theories/*/*.h* theories/*/*.o
+
+
+#
+#	Utilities
+#
+
+hs2v: hs2v.ml
+	ocamlc -o $@ $<
+
+v2hs: v2hs.ml
+	ocamlc -o $@ $< 
+	$(MAKE) -f Makefile.haskell
+
+
+#
+#	The End
+#
+
+.PHONY: all tree clean depend
+
+# DO NOT DELETE: Beginning of Haskell dependencies
+theories/Arith/Between.o : theories/Arith/Between.hs
+theories/Arith/Bool_nat.o : theories/Arith/Bool_nat.hs
+theories/Arith/Bool_nat.o : theories/Bool/Sumbool.o
+theories/Arith/Bool_nat.o : theories/Init/Specif.o
+theories/Arith/Bool_nat.o : theories/Arith/Peano_dec.o
+theories/Arith/Bool_nat.o : theories/Init/Datatypes.o
+theories/Arith/Bool_nat.o : theories/Arith/Compare_dec.o
+theories/Arith/Compare_dec.o : theories/Arith/Compare_dec.hs
+theories/Arith/Compare_dec.o : theories/Init/Specif.o
+theories/Arith/Compare_dec.o : theories/Init/Logic.o
+theories/Arith/Compare_dec.o : theories/Init/Datatypes.o
+theories/Arith/Compare.o : theories/Arith/Compare.hs
+theories/Arith/Compare.o : theories/Init/Specif.o
+theories/Arith/Compare.o : theories/Init/Datatypes.o
+theories/Arith/Compare.o : theories/Arith/Compare_dec.o
+theories/Arith/Div2.o : theories/Arith/Div2.hs
+theories/Arith/Div2.o : theories/Init/Specif.o
+theories/Arith/Div2.o : theories/Init/Peano.o
+theories/Arith/Div2.o : theories/Init/Datatypes.o
+theories/Arith/EqNat.o : theories/Arith/EqNat.hs
+theories/Arith/EqNat.o : theories/Init/Specif.o
+theories/Arith/EqNat.o : theories/Init/Datatypes.o
+theories/Arith/Euclid.o : theories/Arith/Euclid.hs
+theories/Arith/Euclid.o : theories/Arith/Wf_nat.o
+theories/Arith/Euclid.o : theories/Init/Specif.o
+theories/Arith/Euclid.o : theories/Arith/Minus.o
+theories/Arith/Euclid.o : theories/Init/Datatypes.o
+theories/Arith/Euclid.o : theories/Arith/Compare_dec.o
+theories/Arith/Even.o : theories/Arith/Even.hs
+theories/Arith/Even.o : theories/Init/Specif.o
+theories/Arith/Even.o : theories/Init/Datatypes.o
+theories/Arith/Gt.o : theories/Arith/Gt.hs
+theories/Arith/Le.o : theories/Arith/Le.hs
+theories/Arith/Lt.o : theories/Arith/Lt.hs
+theories/Arith/Max.o : theories/Arith/Max.hs
+theories/Arith/Max.o : theories/Init/Specif.o
+theories/Arith/Max.o : theories/Init/Logic.o
+theories/Arith/Max.o : theories/Init/Datatypes.o
+theories/Arith/Min.o : theories/Arith/Min.hs
+theories/Arith/Min.o : theories/Init/Specif.o
+theories/Arith/Min.o : theories/Init/Logic.o
+theories/Arith/Min.o : theories/Init/Datatypes.o
+theories/Arith/Minus.o : theories/Arith/Minus.hs
+theories/Arith/Minus.o : theories/Init/Datatypes.o
+theories/Arith/Mult.o : theories/Arith/Mult.hs
+theories/Arith/Mult.o : theories/Arith/Plus.o
+theories/Arith/Mult.o : theories/Init/Datatypes.o
+theories/Arith/Peano_dec.o : theories/Arith/Peano_dec.hs
+theories/Arith/Peano_dec.o : theories/Init/Specif.o
+theories/Arith/Peano_dec.o : theories/Init/Datatypes.o
+theories/Arith/Plus.o : theories/Arith/Plus.hs
+theories/Arith/Plus.o : theories/Init/Specif.o
+theories/Arith/Plus.o : theories/Init/Logic.o
+theories/Arith/Plus.o : theories/Init/Datatypes.o
+theories/Arith/Wf_nat.o : theories/Arith/Wf_nat.hs
+theories/Arith/Wf_nat.o : theories/Init/Wf.o
+theories/Arith/Wf_nat.o : theories/Init/Logic.o
+theories/Arith/Wf_nat.o : theories/Init/Datatypes.o
+theories/Bool/BoolEq.o : theories/Bool/BoolEq.hs
+theories/Bool/BoolEq.o : theories/Init/Specif.o
+theories/Bool/BoolEq.o : theories/Init/Datatypes.o
+theories/Bool/Bool.o : theories/Bool/Bool.hs
+theories/Bool/Bool.o : theories/Init/Specif.o
+theories/Bool/Bool.o : theories/Init/Datatypes.o
+theories/Bool/DecBool.o : theories/Bool/DecBool.hs
+theories/Bool/DecBool.o : theories/Init/Specif.o
+theories/Bool/IfProp.o : theories/Bool/IfProp.hs
+theories/Bool/IfProp.o : theories/Init/Specif.o
+theories/Bool/IfProp.o : theories/Init/Datatypes.o
+theories/Bool/Sumbool.o : theories/Bool/Sumbool.hs
+theories/Bool/Sumbool.o : theories/Init/Specif.o
+theories/Bool/Sumbool.o : theories/Init/Datatypes.o
+theories/Bool/Zerob.o : theories/Bool/Zerob.hs
+theories/Bool/Zerob.o : theories/Init/Datatypes.o
+theories/Init/Datatypes.o : theories/Init/Datatypes.hs
+theories/Init/DatatypesSyntax.o : theories/Init/DatatypesSyntax.hs
+theories/Init/Logic.o : theories/Init/Logic.hs
+theories/Init/LogicSyntax.o : theories/Init/LogicSyntax.hs
+theories/Init/Logic_Type.o : theories/Init/Logic_Type.hs
+theories/Init/Logic_TypeSyntax.o : theories/Init/Logic_TypeSyntax.hs
+theories/Init/Peano.o : theories/Init/Peano.hs
+theories/Init/Peano.o : theories/Init/Datatypes.o
+theories/Init/Specif.o : theories/Init/Specif.hs
+theories/Init/Specif.o : theories/Init/Logic.o
+theories/Init/Specif.o : theories/Init/Datatypes.o
+theories/Init/SpecifSyntax.o : theories/Init/SpecifSyntax.hs
+theories/Init/Wf.o : theories/Init/Wf.hs
+theories/IntMap/Adalloc.o : theories/IntMap/Adalloc.hs
+theories/IntMap/Adalloc.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Adalloc.o : theories/Bool/Sumbool.o
+theories/IntMap/Adalloc.o : theories/Init/Specif.o
+theories/IntMap/Adalloc.o : theories/IntMap/Map.o
+theories/IntMap/Adalloc.o : theories/Init/Logic.o
+theories/IntMap/Adalloc.o : theories/Init/Datatypes.o
+theories/IntMap/Adalloc.o : theories/IntMap/Addr.o
+theories/IntMap/Adalloc.o : theories/IntMap/Addec.o
+theories/IntMap/Addec.o : theories/IntMap/Addec.hs
+theories/IntMap/Addec.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Addec.o : theories/Bool/Sumbool.o
+theories/IntMap/Addec.o : theories/Init/Specif.o
+theories/IntMap/Addec.o : theories/Init/Datatypes.o
+theories/IntMap/Addec.o : theories/IntMap/Addr.o
+theories/IntMap/Addr.o : theories/IntMap/Addr.hs
+theories/IntMap/Addr.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Addr.o : theories/Init/Specif.o
+theories/IntMap/Addr.o : theories/Init/Datatypes.o
+theories/IntMap/Addr.o : theories/Bool/Bool.o
+theories/IntMap/Adist.o : theories/IntMap/Adist.hs
+theories/IntMap/Adist.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Adist.o : theories/Arith/Min.o
+theories/IntMap/Adist.o : theories/Init/Datatypes.o
+theories/IntMap/Adist.o : theories/IntMap/Addr.o
+theories/IntMap/Allmaps.o : theories/IntMap/Allmaps.hs
+theories/IntMap/Fset.o : theories/IntMap/Fset.hs
+theories/IntMap/Fset.o : theories/Init/Specif.o
+theories/IntMap/Fset.o : theories/IntMap/Map.o
+theories/IntMap/Fset.o : theories/Init/Logic.o
+theories/IntMap/Fset.o : theories/Init/Datatypes.o
+theories/IntMap/Fset.o : theories/IntMap/Addr.o
+theories/IntMap/Fset.o : theories/IntMap/Addec.o
+theories/IntMap/Lsort.o : theories/IntMap/Lsort.hs
+theories/IntMap/Lsort.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Lsort.o : theories/Bool/Sumbool.o
+theories/IntMap/Lsort.o : theories/Init/Specif.o
+theories/IntMap/Lsort.o : theories/Lists/PolyList.o
+theories/IntMap/Lsort.o : theories/IntMap/Mapiter.o
+theories/IntMap/Lsort.o : theories/IntMap/Map.o
+theories/IntMap/Lsort.o : theories/Init/Logic.o
+theories/IntMap/Lsort.o : theories/Init/Datatypes.o
+theories/IntMap/Lsort.o : theories/Bool/Bool.o
+theories/IntMap/Lsort.o : theories/IntMap/Addr.o
+theories/IntMap/Lsort.o : theories/IntMap/Addec.o
+theories/IntMap/Mapaxioms.o : theories/IntMap/Mapaxioms.hs
+theories/IntMap/Mapcanon.o : theories/IntMap/Mapcanon.hs
+theories/IntMap/Mapcanon.o : theories/Init/Specif.o
+theories/IntMap/Mapcanon.o : theories/IntMap/Map.o
+theories/IntMap/Mapcard.o : theories/IntMap/Mapcard.hs
+theories/IntMap/Mapcard.o : theories/Bool/Sumbool.o
+theories/IntMap/Mapcard.o : theories/Init/Specif.o
+theories/IntMap/Mapcard.o : theories/Arith/Plus.o
+theories/IntMap/Mapcard.o : theories/Arith/Peano_dec.o
+theories/IntMap/Mapcard.o : theories/Init/Peano.o
+theories/IntMap/Mapcard.o : theories/IntMap/Map.o
+theories/IntMap/Mapcard.o : theories/Init/Logic.o
+theories/IntMap/Mapcard.o : theories/Init/Datatypes.o
+theories/IntMap/Mapcard.o : theories/IntMap/Addr.o
+theories/IntMap/Mapcard.o : theories/IntMap/Addec.o
+theories/IntMap/Mapc.o : theories/IntMap/Mapc.hs
+theories/IntMap/Mapfold.o : theories/IntMap/Mapfold.hs
+theories/IntMap/Mapfold.o : theories/Init/Specif.o
+theories/IntMap/Mapfold.o : theories/IntMap/Mapiter.o
+theories/IntMap/Mapfold.o : theories/IntMap/Map.o
+theories/IntMap/Mapfold.o : theories/Init/Logic.o
+theories/IntMap/Mapfold.o : theories/IntMap/Fset.o
+theories/IntMap/Mapfold.o : theories/Init/Datatypes.o
+theories/IntMap/Mapfold.o : theories/IntMap/Addr.o
+theories/IntMap/Map.o : theories/IntMap/Map.hs
+theories/IntMap/Map.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Map.o : theories/Init/Specif.o
+theories/IntMap/Map.o : theories/Init/Peano.o
+theories/IntMap/Map.o : theories/Init/Datatypes.o
+theories/IntMap/Map.o : theories/IntMap/Addr.o
+theories/IntMap/Map.o : theories/IntMap/Addec.o
+theories/IntMap/Mapiter.o : theories/IntMap/Mapiter.hs
+theories/IntMap/Mapiter.o : theories/Bool/Sumbool.o
+theories/IntMap/Mapiter.o : theories/Init/Specif.o
+theories/IntMap/Mapiter.o : theories/Lists/PolyList.o
+theories/IntMap/Mapiter.o : theories/IntMap/Map.o
+theories/IntMap/Mapiter.o : theories/Init/Logic.o
+theories/IntMap/Mapiter.o : theories/Init/Datatypes.o
+theories/IntMap/Mapiter.o : theories/IntMap/Addr.o
+theories/IntMap/Mapiter.o : theories/IntMap/Addec.o
+theories/IntMap/Maplists.o : theories/IntMap/Maplists.hs
+theories/IntMap/Maplists.o : theories/Bool/Sumbool.o
+theories/IntMap/Maplists.o : theories/Init/Specif.o
+theories/IntMap/Maplists.o : theories/Lists/PolyList.o
+theories/IntMap/Maplists.o : theories/IntMap/Mapiter.o
+theories/IntMap/Maplists.o : theories/IntMap/Map.o
+theories/IntMap/Maplists.o : theories/Init/Logic.o
+theories/IntMap/Maplists.o : theories/IntMap/Fset.o
+theories/IntMap/Maplists.o : theories/Init/Datatypes.o
+theories/IntMap/Maplists.o : theories/Bool/Bool.o
+theories/IntMap/Maplists.o : theories/IntMap/Addr.o
+theories/IntMap/Maplists.o : theories/IntMap/Addec.o
+theories/IntMap/Mapsubset.o : theories/IntMap/Mapsubset.hs
+theories/IntMap/Mapsubset.o : theories/IntMap/Mapiter.o
+theories/IntMap/Mapsubset.o : theories/IntMap/Map.o
+theories/IntMap/Mapsubset.o : theories/IntMap/Fset.o
+theories/IntMap/Mapsubset.o : theories/Init/Datatypes.o
+theories/IntMap/Mapsubset.o : theories/Bool/Bool.o
+theories/Lists/ListSet.o : theories/Lists/ListSet.hs
+theories/Lists/ListSet.o : theories/Init/Specif.o
+theories/Lists/ListSet.o : theories/Lists/PolyList.o
+theories/Lists/ListSet.o : theories/Init/Logic.o
+theories/Lists/ListSet.o : theories/Init/Datatypes.o
+theories/Lists/PolyList.o : theories/Lists/PolyList.hs
+theories/Lists/PolyList.o : theories/Init/Specif.o
+theories/Lists/PolyList.o : theories/Init/Datatypes.o
+theories/Lists/PolyListSyntax.o : theories/Lists/PolyListSyntax.hs
+theories/Lists/Streams.o : theories/Lists/Streams.hs
+theories/Lists/Streams.o : theories/Init/Datatypes.o
+theories/Lists/TheoryList.o : theories/Lists/TheoryList.hs
+theories/Lists/TheoryList.o : theories/Init/Specif.o
+theories/Lists/TheoryList.o : theories/Lists/PolyList.o
+theories/Lists/TheoryList.o : theories/Bool/DecBool.o
+theories/Lists/TheoryList.o : theories/Init/Datatypes.o
+theories/Logic/Berardi.o : theories/Logic/Berardi.hs
+theories/Logic/ClassicalFacts.o : theories/Logic/ClassicalFacts.hs
+theories/Logic/Classical.o : theories/Logic/Classical.hs
+theories/Logic/Classical_Pred_Set.o : theories/Logic/Classical_Pred_Set.hs
+theories/Logic/Classical_Pred_Type.o : theories/Logic/Classical_Pred_Type.hs
+theories/Logic/Classical_Prop.o : theories/Logic/Classical_Prop.hs
+theories/Logic/Classical_Type.o : theories/Logic/Classical_Type.hs
+theories/Logic/Decidable.o : theories/Logic/Decidable.hs
+theories/Logic/Eqdep_dec.o : theories/Logic/Eqdep_dec.hs
+theories/Logic/Eqdep.o : theories/Logic/Eqdep.hs
+theories/Logic/Hurkens.o : theories/Logic/Hurkens.hs
+theories/Logic/JMeq.o : theories/Logic/JMeq.hs
+theories/Logic/ProofIrrelevance.o : theories/Logic/ProofIrrelevance.hs
+theories/Relations/Newman.o : theories/Relations/Newman.hs
+theories/Relations/Operators_Properties.o : theories/Relations/Operators_Properties.hs
+theories/Relations/Relation_Definitions.o : theories/Relations/Relation_Definitions.hs
+theories/Relations/Relation_Operators.o : theories/Relations/Relation_Operators.hs
+theories/Relations/Relation_Operators.o : theories/Init/Specif.o
+theories/Relations/Relation_Operators.o : theories/Lists/PolyList.o
+theories/Relations/Relations.o : theories/Relations/Relations.hs
+theories/Relations/Rstar.o : theories/Relations/Rstar.hs
+theories/Setoids/Setoid.o : theories/Setoids/Setoid.hs
+theories/Sets/Classical_sets.o : theories/Sets/Classical_sets.hs
+theories/Sets/Constructive_sets.o : theories/Sets/Constructive_sets.hs
+theories/Sets/Cpo.o : theories/Sets/Cpo.hs
+theories/Sets/Cpo.o : theories/Sets/Partial_Order.o
+theories/Sets/Ensembles.o : theories/Sets/Ensembles.hs
+theories/Sets/Finite_sets_facts.o : theories/Sets/Finite_sets_facts.hs
+theories/Sets/Finite_sets.o : theories/Sets/Finite_sets.hs
+theories/Sets/Image.o : theories/Sets/Image.hs
+theories/Sets/Infinite_sets.o : theories/Sets/Infinite_sets.hs
+theories/Sets/Integers.o : theories/Sets/Integers.hs
+theories/Sets/Integers.o : theories/Sets/Partial_Order.o
+theories/Sets/Integers.o : theories/Init/Datatypes.o
+theories/Sets/Multiset.o : theories/Sets/Multiset.hs
+theories/Sets/Multiset.o : theories/Init/Specif.o
+theories/Sets/Multiset.o : theories/Init/Peano.o
+theories/Sets/Multiset.o : theories/Init/Datatypes.o
+theories/Sets/Partial_Order.o : theories/Sets/Partial_Order.hs
+theories/Sets/Permut.o : theories/Sets/Permut.hs
+theories/Sets/Powerset_Classical_facts.o : theories/Sets/Powerset_Classical_facts.hs
+theories/Sets/Powerset_facts.o : theories/Sets/Powerset_facts.hs
+theories/Sets/Powerset.o : theories/Sets/Powerset.hs
+theories/Sets/Powerset.o : theories/Sets/Partial_Order.o
+theories/Sets/Relations_1_facts.o : theories/Sets/Relations_1_facts.hs
+theories/Sets/Relations_1.o : theories/Sets/Relations_1.hs
+theories/Sets/Relations_2_facts.o : theories/Sets/Relations_2_facts.hs
+theories/Sets/Relations_2.o : theories/Sets/Relations_2.hs
+theories/Sets/Relations_3_facts.o : theories/Sets/Relations_3_facts.hs
+theories/Sets/Relations_3.o : theories/Sets/Relations_3.hs
+theories/Sets/Uniset.o : theories/Sets/Uniset.hs
+theories/Sets/Uniset.o : theories/Init/Specif.o
+theories/Sets/Uniset.o : theories/Init/Datatypes.o
+theories/Sets/Uniset.o : theories/Bool/Bool.o
+theories/Sorting/Heap.o : theories/Sorting/Heap.hs
+theories/Sorting/Heap.o : theories/Init/Specif.o
+theories/Sorting/Heap.o : theories/Sorting/Sorting.o
+theories/Sorting/Heap.o : theories/Lists/PolyList.o
+theories/Sorting/Heap.o : theories/Sets/Multiset.o
+theories/Sorting/Heap.o : theories/Init/Logic.o
+theories/Sorting/Permutation.o : theories/Sorting/Permutation.hs
+theories/Sorting/Permutation.o : theories/Init/Specif.o
+theories/Sorting/Permutation.o : theories/Lists/PolyList.o
+theories/Sorting/Permutation.o : theories/Sets/Multiset.o
+theories/Sorting/Sorting.o : theories/Sorting/Sorting.hs
+theories/Sorting/Sorting.o : theories/Init/Specif.o
+theories/Sorting/Sorting.o : theories/Lists/PolyList.o
+theories/Sorting/Sorting.o : theories/Init/Logic.o
+theories/Wellfounded/Disjoint_Union.o : theories/Wellfounded/Disjoint_Union.hs
+theories/Wellfounded/Inclusion.o : theories/Wellfounded/Inclusion.hs
+theories/Wellfounded/Inverse_Image.o : theories/Wellfounded/Inverse_Image.hs
+theories/Wellfounded/Lexicographic_Exponentiation.o : theories/Wellfounded/Lexicographic_Exponentiation.hs
+theories/Wellfounded/Lexicographic_Product.o : theories/Wellfounded/Lexicographic_Product.hs
+theories/Wellfounded/Transitive_Closure.o : theories/Wellfounded/Transitive_Closure.hs
+theories/Wellfounded/Union.o : theories/Wellfounded/Union.hs
+theories/Wellfounded/Wellfounded.o : theories/Wellfounded/Wellfounded.hs
+theories/Wellfounded/Well_Ordering.o : theories/Wellfounded/Well_Ordering.hs
+theories/Wellfounded/Well_Ordering.o : theories/Init/Wf.o
+theories/Wellfounded/Well_Ordering.o : theories/Init/Specif.o
+theories/ZArith/Auxiliary.o : theories/ZArith/Auxiliary.hs
+theories/ZArith/Fast_integer.o : theories/ZArith/Fast_integer.hs
+theories/ZArith/Fast_integer.o : theories/Init/Peano.o
+theories/ZArith/Fast_integer.o : theories/Init/Datatypes.o
+theories/ZArith/Wf_Z.o : theories/ZArith/Wf_Z.hs
+theories/ZArith/Wf_Z.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Wf_Z.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Wf_Z.o : theories/Init/Specif.o
+theories/ZArith/Wf_Z.o : theories/Init/Peano.o
+theories/ZArith/Wf_Z.o : theories/Init/Logic.o
+theories/ZArith/Wf_Z.o : theories/Init/Datatypes.o
+theories/ZArith/Zarith_aux.o : theories/ZArith/Zarith_aux.hs
+theories/ZArith/Zarith_aux.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zarith_aux.o : theories/Init/Specif.o
+theories/ZArith/Zarith_aux.o : theories/Init/Datatypes.o
+theories/ZArith/ZArith_base.o : theories/ZArith/ZArith_base.hs
+theories/ZArith/ZArith_dec.o : theories/ZArith/ZArith_dec.hs
+theories/ZArith/ZArith_dec.o : theories/ZArith/Fast_integer.o
+theories/ZArith/ZArith_dec.o : theories/Bool/Sumbool.o
+theories/ZArith/ZArith_dec.o : theories/Init/Specif.o
+theories/ZArith/ZArith_dec.o : theories/Init/Logic.o
+theories/ZArith/ZArith.o : theories/ZArith/ZArith.hs
+theories/ZArith/Zbool.o : theories/ZArith/Zbool.hs
+theories/ZArith/Zbool.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zbool.o : theories/ZArith/Zmisc.o
+theories/ZArith/Zbool.o : theories/ZArith/ZArith_dec.o
+theories/ZArith/Zbool.o : theories/Bool/Sumbool.o
+theories/ZArith/Zbool.o : theories/Init/Specif.o
+theories/ZArith/Zbool.o : theories/Init/Datatypes.o
+theories/ZArith/Zcomplements.o : theories/ZArith/Zcomplements.hs
+theories/ZArith/Zcomplements.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Zcomplements.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zcomplements.o : theories/ZArith/Wf_Z.o
+theories/ZArith/Zcomplements.o : theories/Init/Specif.o
+theories/ZArith/Zcomplements.o : theories/Init/Logic.o
+theories/ZArith/Zcomplements.o : theories/Init/Datatypes.o
+theories/ZArith/Zdiv.o : theories/ZArith/Zdiv.hs
+theories/ZArith/Zdiv.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Zdiv.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zdiv.o : theories/ZArith/Zmisc.o
+theories/ZArith/Zdiv.o : theories/ZArith/ZArith_dec.o
+theories/ZArith/Zdiv.o : theories/Init/Specif.o
+theories/ZArith/Zdiv.o : theories/Init/Logic.o
+theories/ZArith/Zdiv.o : theories/Init/Datatypes.o
+theories/ZArith/Zhints.o : theories/ZArith/Zhints.hs
+theories/ZArith/Zlogarithm.o : theories/ZArith/Zlogarithm.hs
+theories/ZArith/Zlogarithm.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Zlogarithm.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zmisc.o : theories/ZArith/Zmisc.hs
+theories/ZArith/Zmisc.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zmisc.o : theories/Init/Specif.o
+theories/ZArith/Zmisc.o : theories/Init/Datatypes.o
+theories/ZArith/Zpower.o : theories/ZArith/Zpower.hs
+theories/ZArith/Zpower.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Zpower.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zpower.o : theories/ZArith/Zmisc.o
+theories/ZArith/Zpower.o : theories/Init/Logic.o
+theories/ZArith/Zpower.o : theories/Init/Datatypes.o
+theories/ZArith/Zsqrt.o : theories/ZArith/Zsqrt.hs
+theories/ZArith/Zsqrt.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Zsqrt.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zsqrt.o : theories/ZArith/ZArith_dec.o
+theories/ZArith/Zsqrt.o : theories/Init/Specif.o
+theories/ZArith/Zsqrt.o : theories/Init/Logic.o
+theories/ZArith/Zwf.o : theories/ZArith/Zwf.hs
+# DO NOT DELETE: End of Haskell dependencies
diff --git a/contrib/extraction/test/addReals b/contrib/extraction/test/addReals
new file mode 100644
index 00000000..fb73d47b
--- /dev/null
+++ b/contrib/extraction/test/addReals
@@ -0,0 +1,21 @@
+open TypeSyntax
+open Fast_integer
+
+
+let total_order_T x y = 
+if x = y then InleftT RightT
+else if x < y then InleftT LeftT
+else InrightT 
+
+let rec int_to_positive i = 
+	if i = 1 then XH
+	else
+	  if (i mod 2) = 0 then XO (int_to_positive (i/2))
+	  else XI (int_to_positive (i/2))
+
+let rec int_to_Z i = 
+	if i = 0 then ZERO
+	else if i > 0 then POS (int_to_positive i)
+	else NEG (int_to_positive (-i))
+
+let my_ceil x = int_to_Z (succ (int_of_float (floor x)))
diff --git a/contrib/extraction/test/custom/Adalloc b/contrib/extraction/test/custom/Adalloc
new file mode 100644
index 00000000..0fb556aa
--- /dev/null
+++ b/contrib/extraction/test/custom/Adalloc
@@ -0,0 +1,2 @@
+Require Import Addr.
+Extraction NoInline ad_double ad_double_plus_un.
diff --git a/contrib/extraction/test/custom/Euclid b/contrib/extraction/test/custom/Euclid
new file mode 100644
index 00000000..a58e3940
--- /dev/null
+++ b/contrib/extraction/test/custom/Euclid
@@ -0,0 +1 @@
+Extraction Inline Wf_nat.gt_wf_rec Wf_nat.lt_wf_rec.
diff --git a/contrib/extraction/test/custom/List b/contrib/extraction/test/custom/List
new file mode 100644
index 00000000..ffee7dc9
--- /dev/null
+++ b/contrib/extraction/test/custom/List
@@ -0,0 +1 @@
+Extraction NoInline map.
diff --git a/contrib/extraction/test/custom/ListSet b/contrib/extraction/test/custom/ListSet
new file mode 100644
index 00000000..c9bea52a
--- /dev/null
+++ b/contrib/extraction/test/custom/ListSet
@@ -0,0 +1 @@
+Extraction NoInline set_add set_mem.
diff --git a/contrib/extraction/test/custom/Lsort b/contrib/extraction/test/custom/Lsort
new file mode 100644
index 00000000..6a185683
--- /dev/null
+++ b/contrib/extraction/test/custom/Lsort
@@ -0,0 +1,2 @@
+Require Import Addr. 
+Extraction NoInline ad_double ad_double_plus_un.
diff --git a/contrib/extraction/test/custom/Map b/contrib/extraction/test/custom/Map
new file mode 100644
index 00000000..3e464e39
--- /dev/null
+++ b/contrib/extraction/test/custom/Map
@@ -0,0 +1,3 @@
+Require Import Addr.
+Extraction NoInline ad_double ad_double_plus_un.
+
diff --git a/contrib/extraction/test/custom/Mapcard b/contrib/extraction/test/custom/Mapcard
new file mode 100644
index 00000000..ca555aa3
--- /dev/null
+++ b/contrib/extraction/test/custom/Mapcard
@@ -0,0 +1,4 @@
+Require Import Plus.
+Extraction NoInline plus_is_one.
+Require Import Addr.
+Extraction NoInline ad_double ad_double_plus_un.
diff --git a/contrib/extraction/test/custom/Mapiter b/contrib/extraction/test/custom/Mapiter
new file mode 100644
index 00000000..6a185683
--- /dev/null
+++ b/contrib/extraction/test/custom/Mapiter
@@ -0,0 +1,2 @@
+Require Import Addr. 
+Extraction NoInline ad_double ad_double_plus_un.
diff --git a/contrib/extraction/test/custom/R_Ifp b/contrib/extraction/test/custom/R_Ifp
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/R_Ifp
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/R_sqr b/contrib/extraction/test/custom/R_sqr
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/R_sqr
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Ranalysis b/contrib/extraction/test/custom/Ranalysis
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Ranalysis
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Raxioms b/contrib/extraction/test/custom/Raxioms
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Raxioms
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rbase b/contrib/extraction/test/custom/Rbase
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rbase
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rbasic_fun b/contrib/extraction/test/custom/Rbasic_fun
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rbasic_fun
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rdefinitions b/contrib/extraction/test/custom/Rdefinitions
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rdefinitions
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Reals.v b/contrib/extraction/test/custom/Reals.v
new file mode 100644
index 00000000..45d0a224
--- /dev/null
+++ b/contrib/extraction/test/custom/Reals.v
@@ -0,0 +1,17 @@
+Require Import Reals. 
+Extract Inlined Constant R => float.
+Extract Inlined Constant R0 => "0.0".
+Extract Inlined Constant R1 => "1.0".
+Extract Inlined Constant Rplus => "(+.)".
+Extract Inlined Constant Rmult => "( *.)".
+Extract Inlined Constant Ropp => "(~-.)".
+Extract Inlined Constant Rinv => "(fun x -> 1.0 /. x)".
+Extract Inlined Constant Rlt => "(<)".
+Extract Inlined Constant up => "AddReals.my_ceil".
+Extract Inlined Constant total_order_T => "AddReals.total_order_T".
+Extract Inlined Constant sqrt => "sqrt".
+Extract Inlined Constant sigma => "(fun l h -> sigma_aux l h (Minus.minus h l))".
+Extract Inlined Constant PI => "3.141593".
+Extract Inlined Constant cos => cos.
+Extract Inlined Constant sin => sin.
+Extract Inlined Constant derive_pt => "(fun f x -> ((f (x+.1E-5))-.(f x))*.1E5)".
diff --git a/contrib/extraction/test/custom/Rfunctions b/contrib/extraction/test/custom/Rfunctions
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rfunctions
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rgeom b/contrib/extraction/test/custom/Rgeom
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rgeom
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rlimit b/contrib/extraction/test/custom/Rlimit
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rlimit
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rseries b/contrib/extraction/test/custom/Rseries
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rseries
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rsigma b/contrib/extraction/test/custom/Rsigma
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rsigma
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rtrigo b/contrib/extraction/test/custom/Rtrigo
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rtrigo
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/ZArith_dec b/contrib/extraction/test/custom/ZArith_dec
new file mode 100644
index 00000000..2201419e
--- /dev/null
+++ b/contrib/extraction/test/custom/ZArith_dec
@@ -0,0 +1 @@
+Extraction Inline Dcompare_inf Zcompare_rec.
diff --git a/contrib/extraction/test/custom/fast_integer b/contrib/extraction/test/custom/fast_integer
new file mode 100644
index 00000000..e2b24953
--- /dev/null
+++ b/contrib/extraction/test/custom/fast_integer
@@ -0,0 +1 @@
+Extraction NoInline Zero_suivi_de Un_suivi_de.
diff --git a/contrib/extraction/test/e b/contrib/extraction/test/e
new file mode 100644
index 00000000..88b6c90b
--- /dev/null
+++ b/contrib/extraction/test/e
@@ -0,0 +1,17 @@
+
+(* To trace Extraction, you can use this file via:  *)
+(*               Drop. #use "e";;                   *) 
+(*                                                  *)
+
+#use "include";;
+open Extraction;;
+open Miniml;;
+#trace extract_declaration;;
+go();;
+
+
+
+
+
+
+
diff --git a/contrib/extraction/test/extract b/contrib/extraction/test/extract
new file mode 100755
index 00000000..83444be3
--- /dev/null
+++ b/contrib/extraction/test/extract
@@ -0,0 +1,12 @@
+#!/bin/sh
+rm -f /tmp/extr$$.v 
+vfile=`./ml2v $1`
+d=`dirname $vfile`
+n=`basename $vfile .v`
+if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi  
+echo "Cd \"$d\". Extraction Library $n. " >> /tmp/extr$$.v
+../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v 
+out=$?
+rm -f /tmp/extr$$.v
+exit $out
+
diff --git a/contrib/extraction/test/extract.haskell b/contrib/extraction/test/extract.haskell
new file mode 100755
index 00000000..d11bc706
--- /dev/null
+++ b/contrib/extraction/test/extract.haskell
@@ -0,0 +1,12 @@
+#!/bin/sh
+rm -f /tmp/extr$$.v 
+vfile=`./hs2v $1`
+d=`dirname $vfile`
+n=`basename $vfile .v`
+if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi  
+echo "Cd \"$d\". Extraction Language Haskell. Extraction Library $n. " >> /tmp/extr$$.v
+../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v 
+out=$?
+rm -f /tmp/extr$$.v
+exit $out
+
diff --git a/contrib/extraction/test/hs2v.ml b/contrib/extraction/test/hs2v.ml
new file mode 100644
index 00000000..fd8b9b26
--- /dev/null
+++ b/contrib/extraction/test/hs2v.ml
@@ -0,0 +1,14 @@
+let _ =
+  for j = 1 to ((Array.length Sys.argv)-1) do
+    let fml = Sys.argv.(j) in
+    let f = Filename.chop_extension fml in 
+    let fv = f ^ ".v" in
+    if Sys.file_exists ("../../../" ^ fv) then
+      print_string (fv^" ") 
+    else
+      let d = Filename.dirname f in
+      let b = String.uncapitalize (Filename.basename f) in
+      let fv = Filename.concat d (b ^ ".v ") in
+      print_string fv
+  done;
+  print_newline()
diff --git a/contrib/extraction/test/make_mli b/contrib/extraction/test/make_mli
new file mode 100755
index 00000000..40ee496e
--- /dev/null
+++ b/contrib/extraction/test/make_mli
@@ -0,0 +1,17 @@
+#!/usr/bin/awk -We $0
+
+{ match($0,"^open") 
+  if (RLENGTH>0) state=1
+  match($0,"^type") 
+  if (RLENGTH>0) state=1 
+  match($0,"^\(\*\* ")
+  if (RLENGTH>0) state=2
+  match($0,"^let")
+  if (RLENGTH>0) state=0
+  match($0,"^and")
+  if ((RLENGTH>0) && (state==2)) state=0
+  if ((RLENGTH>0) && (state==1)) state=1		     
+  gsub("\(\*\* ","")
+  gsub("\*\*\)","")
+  if (state>0) print
+}  
diff --git a/contrib/extraction/test/ml2v.ml b/contrib/extraction/test/ml2v.ml
new file mode 100644
index 00000000..363ea642
--- /dev/null
+++ b/contrib/extraction/test/ml2v.ml
@@ -0,0 +1,14 @@
+let _ =
+  for j = 1 to ((Array.length Sys.argv)-1) do
+    let fml = Sys.argv.(j) in
+    let f = Filename.chop_extension fml in 
+    let fv = f ^ ".v" in
+    if Sys.file_exists ("../../../" ^ fv) then
+      print_string (fv^" ") 
+    else
+      let d = Filename.dirname f in
+      let b = String.capitalize (Filename.basename f) in
+      let fv = Filename.concat d (b ^ ".v ") in
+      print_string fv
+  done;
+  print_newline()
diff --git a/contrib/extraction/test/v2hs.ml b/contrib/extraction/test/v2hs.ml
new file mode 100644
index 00000000..88632875
--- /dev/null
+++ b/contrib/extraction/test/v2hs.ml
@@ -0,0 +1,9 @@
+let _ = 
+  for j = 1 to ((Array.length Sys.argv) -1) do 
+    let s = Sys.argv.(j) in
+    let b = Filename.chop_extension (Filename.basename s) in 
+    let b = String.capitalize b in
+    let d = Filename.dirname s in 
+    print_string (Filename.concat d (b ^ ".hs "))
+  done;	
+  print_newline()
diff --git a/contrib/extraction/test/v2ml.ml b/contrib/extraction/test/v2ml.ml
new file mode 100644
index 00000000..245a1b1e
--- /dev/null
+++ b/contrib/extraction/test/v2ml.ml
@@ -0,0 +1,9 @@
+let _ = 
+  for j = 1 to ((Array.length Sys.argv) -1) do 
+    let s = Sys.argv.(j) in
+    let b = Filename.chop_extension (Filename.basename s) in 
+    let b = String.uncapitalize b in
+    let d = Filename.dirname s in 
+    print_string (Filename.concat d (b ^ ".ml "))
+  done;	
+  print_newline()
diff --git a/contrib/extraction/test_extraction.v b/contrib/extraction/test_extraction.v
new file mode 100644
index 00000000..0745f62d
--- /dev/null
+++ b/contrib/extraction/test_extraction.v
@@ -0,0 +1,552 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Arith.
+Require Import List.
+
+(*** STANDARD EXAMPLES *)
+
+(** Functions. *)
+
+Definition idnat (x:nat) := x.
+Extraction idnat.
+(* let idnat x = x *)
+
+Definition id (X:Type) (x:X) := x.      
+Extraction id. (* let id x = x *)
+Definition id' := id Set nat.
+Extraction id'. (* type id' = nat *)
+
+Definition test2 (f:nat -> nat) (x:nat) := f x.
+Extraction test2.
+(* let test2 f x = f x *)
+
+Definition test3 (f:nat -> Set -> nat) (x:nat) := f x nat.
+Extraction test3.
+(* let test3 f x = f x __ *)
+
+Definition test4 (f:(nat -> nat) -> nat) (x:nat) (g:nat -> nat) := f g.
+Extraction test4.
+(* let test4 f x g = f g *)
+
+Definition test5 := (1, 0).
+Extraction test5.
+(* let test5 = Pair ((S O), O) *)
+
+Definition cf (x:nat) (_:x <= 0) := S x.
+Extraction NoInline cf.
+Definition test6 := cf 0 (le_n 0).
+Extraction test6.  
+(* let test6 = cf O *)
+
+Definition test7 := (fun (X:Set) (x:X) => x) nat.
+Extraction test7.
+(* let test7 x = x *)
+
+Definition d (X:Type) := X.
+Extraction d. (* type 'x d = 'x *)
+Definition d2 := d Set.
+Extraction d2. (* type d2 = __ d *)
+Definition d3 (x:d Set) := 0.
+Extraction d3. (* let d3 _ = O *)
+Definition d4 := d nat. 
+Extraction d4. (* type d4 = nat d *)
+Definition d5 := (fun x:d Type => 0) Type.  
+Extraction d5.  (* let d5 = O *)
+Definition d6 (x:d Type) := x.
+Extraction d6.  (* type 'x d6 = 'x *)
+
+Definition test8 := (fun (X:Type) (x:X) => x) Set nat.
+Extraction test8. (* type test8 = nat *)
+
+Definition test9 := let t := nat in id Set t.
+Extraction test9.  (* type test9 = nat *)
+
+Definition test10 := (fun (X:Type) (x:X) => 0) Type Type.
+Extraction test10. (* let test10 = O *)
+
+Definition test11 := let n := 0 in let p := S n in S p.
+Extraction test11. (* let test11 = S (S O) *)
+
+Definition test12 := forall x:forall X:Type, X -> X, x Type Type.
+Extraction test12. 
+(* type test12 = (__ -> __ -> __) -> __ *)
+
+
+Definition test13 := match left True I with
+                     | left x => 1
+                     | right x => 0
+                     end.
+Extraction test13. (* let test13 = S O *)
+
+
+(** example with more arguments that given by the type *)
+
+Definition test19 :=
+  nat_rec (fun n:nat => nat -> nat) (fun n:nat => 0)
+    (fun (n:nat) (f:nat -> nat) => f) 0 0.
+Extraction test19.
+(* let test19 =
+  let rec f = function
+    | O -> (fun n0 -> O)
+    | S n0 -> f n0
+  in f O O
+*)
+
+
+(** casts *)
+
+Definition test20 := True:Type.
+Extraction test20.
+(* type test20 = __ *)
+
+
+(** Simple inductive type and recursor. *)
+
+Extraction nat.
+(* 
+type nat = 
+  | O 
+  | S of nat 
+*)
+
+Extraction sumbool_rect.
+(* 
+let sumbool_rect f f0 = function
+  |  Left -> f __
+  | Right -> f0 __
+*)
+
+(** Less simple inductive type. *)
+
+Inductive c (x:nat) : nat -> Set :=
+  | refl : c x x
+  | trans : forall y z:nat, c x y -> y <= z -> c x z.
+Extraction c.
+(* 
+type c =
+  | Refl
+  | Trans of nat * nat * c
+*)
+
+Definition Ensemble (U:Type) := U -> Prop.
+Definition Empty_set (U:Type) (x:U) := False.
+Definition Add (U:Type) (A:Ensemble U) (x y:U) := A y \/ x = y.
+
+Inductive Finite (U:Type) : Ensemble U -> Set :=
+  | Empty_is_finite : Finite U (Empty_set U)
+  | Union_is_finite :
+      forall A:Ensemble U,
+        Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x).
+Extraction Finite.
+(* 
+type 'u finite =
+  | Empty_is_finite
+  | Union_is_finite of 'u finite * 'u
+*)
+
+
+(** Mutual Inductive *)
+
+Inductive tree : Set :=
+    Node : nat -> forest -> tree
+with forest : Set :=
+  | Leaf : nat -> forest
+  | Cons : tree -> forest -> forest.
+
+Extraction tree.
+(* 
+type tree =
+  | Node of nat * forest
+and forest =
+  | Leaf of nat
+  | Cons of tree * forest
+*)
+
+Fixpoint tree_size (t:tree) : nat :=
+  match t with
+  | Node a f => S (forest_size f)
+  end
+ 
+ with forest_size (f:forest) : nat :=
+  match f with
+  | Leaf b => 1
+  | Cons t f' => tree_size t + forest_size f'
+  end.
+
+Extraction tree_size.
+(* 
+let rec tree_size = function
+  | Node (a, f) -> S (forest_size f)
+and forest_size = function
+  | Leaf b -> S O
+  | Cons (t, f') -> plus (tree_size t) (forest_size f')
+*)
+
+
+(** Eta-expansions of inductive constructor *)
+
+Inductive titi : Set :=
+    tata : nat -> nat -> nat -> nat -> titi.
+Definition test14 := tata 0.
+Extraction test14.
+(* let test14 x x0 x1 = Tata (O, x, x0, x1) *)
+Definition test15 := tata 0 1.
+Extraction test15. 
+(* let test15 x x0 = Tata (O, (S O), x, x0) *)
+
+Inductive eta : Set :=
+    eta_c : nat -> Prop -> nat -> Prop -> eta.
+Extraction eta_c.
+(* 
+type eta =
+  | Eta_c of nat * nat
+*)
+Definition test16 := eta_c 0.
+Extraction test16.
+(* let test16 x = Eta_c (O, x) *)
+Definition test17 := eta_c 0 True.
+Extraction test17.
+(* let test17 x = Eta_c (O, x) *)
+Definition test18 := eta_c 0 True 0.
+Extraction test18. 
+(* let test18 _ = Eta_c (O, O) *)
+
+
+(** Example of singleton inductive type *)
+
+Inductive bidon (A:Prop) (B:Type) : Set :=
+    tb : forall (x:A) (y:B), bidon A B. 
+Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) 
+  (x:A) (y:B) := f x y.
+Extraction bidon.
+(* type 'b bidon = 'b *)
+Extraction tb.
+(* tb : singleton inductive constructor *)
+Extraction fbidon.
+(* let fbidon f x y =
+  f x y
+*)
+
+Definition fbidon2 := fbidon True nat (tb True nat).
+Extraction fbidon2. (* let fbidon2 y = y *)
+Extraction NoInline fbidon.
+Extraction fbidon2.
+(* let fbidon2 y = fbidon (fun _ x -> x) __ y *)
+
+(* NB: first argument of fbidon2 has type [True], so it disappears. *)
+
+(** mutual inductive on many sorts *)
+
+Inductive test_0 : Prop :=
+    ctest0 : test_0
+with test_1 : Set :=
+    ctest1 : test_0 -> test_1.  
+Extraction test_0.
+(* test0 : logical inductive *)
+Extraction test_1. 
+(* 
+type test1 =
+  | Ctest1
+*)
+
+(** logical singleton *)
+
+Extraction eq.
+(* eq : logical inductive *)
+Extraction eq_rect.
+(* let eq_rect x f y =
+  f
+*)
+
+(** No more propagation of type parameters. Obj.t instead. *)
+
+Inductive tp1 : Set :=
+    T : forall (C:Set) (c:C), tp2 -> tp1
+with tp2 : Set :=
+    T' : tp1 -> tp2.
+Extraction tp1.
+(* 
+type tp1 =
+  | T of __ * tp2
+and tp2 =
+  | T' of tp1
+*) 
+
+Inductive tp1bis : Set :=
+    Tbis : tp2bis -> tp1bis
+with tp2bis : Set :=
+    T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis.
+Extraction tp1bis.
+(* 
+type tp1bis =
+  | Tbis of tp2bis
+and tp2bis =
+  | T'bis of __ * tp1bis
+*)
+
+
+(** Strange inductive type. *)
+
+Inductive Truc : Set -> Set :=
+  | chose : forall A:Set, Truc A
+  | machin : forall A:Set, A -> Truc bool -> Truc A.
+Extraction Truc.
+(*
+type 'x truc =
+  | Chose
+  | Machin of 'x * bool truc
+*)
+
+
+(** Dependant type over Type *)
+
+Definition test24 := sigT (fun a:Set => option a).
+Extraction test24.
+(* type test24 = (__, __ option) sigT *)
+
+
+(** Coq term non strongly-normalizable after extraction *)
+
+Require Import Gt.
+Definition loop (Ax:Acc gt 0) :=
+  (fix F (a:nat) (b:Acc gt a) {struct b} : nat :=
+     F (S a) (Acc_inv b (S a) (gt_Sn_n a))) 0 Ax.
+Extraction loop.
+(* let loop _ =
+  let rec f a =
+    f (S a)
+  in f O
+*)
+
+(*** EXAMPLES NEEDING OBJ.MAGIC *)
+
+(** False conversion of type: *)
+
+Lemma oups : forall H:nat = list nat, nat -> nat.
+intros.
+generalize H0; intros.
+rewrite H in H1.
+case H1.
+exact H0.
+intros.
+exact n.
+Qed.
+Extraction oups.
+(* 
+let oups h0 = 
+  match Obj.magic h0 with
+    | Nil -> h0
+    | Cons0 (n, l) -> n
+*)
+
+
+(** hybrids *)
+
+Definition horibilis (b:bool) :=
+  if b as b return (if b then Type else nat) then Set else 0.
+Extraction horibilis.
+(* 
+let horibilis = function
+  | True -> Obj.magic __
+  | False -> Obj.magic O
+*)
+
+Definition PropSet (b:bool) := if b then Prop else Set.
+Extraction PropSet. (* type propSet = __ *)
+
+Definition natbool (b:bool) := if b then nat else bool.
+Extraction natbool. (* type natbool = __ *)
+
+Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true.
+Extraction zerotrue. 
+(* 
+let zerotrue = function
+  | True -> Obj.magic O
+  | False -> Obj.magic True
+*)
+
+Definition natProp (b:bool) := if b return Type then nat else Prop.
+
+Definition natTrue (b:bool) := if b return Type then nat else True.
+
+Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True.
+Extraction zeroTrue.
+(* 
+let zeroTrue = function
+  | True -> Obj.magic O
+  | False -> Obj.magic __
+*)
+
+Definition natTrue2 (b:bool) := if b return Type then nat else True.
+
+Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I.
+Extraction zeroprop.
+(* 
+let zeroprop = function
+  | True -> Obj.magic O
+  | False -> Obj.magic __
+*)
+
+(** polymorphic f applied several times *)
+
+Definition test21 := (id nat 0, id bool true).
+Extraction test21.
+(* let test21 = Pair ((id O), (id True)) *)
+
+(** ok *)
+
+Definition test22 :=
+  (fun f:forall X:Type, X -> X => (f nat 0, f bool true))
+    (fun (X:Type) (x:X) => x).
+Extraction test22. 
+(* let test22 = 
+  let f = fun x -> x in Pair ((f O), (f True)) *)
+
+(* still ok via optim beta -> let *)
+
+Definition test23 (f:forall X:Type, X -> X) := (f nat 0, f bool true).
+Extraction test23.
+(* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *)
+
+(* problem: fun f -> (f 0, f true) not legal in ocaml *)
+(* solution: magic ... *)
+
+
+(** Dummy constant __ can be applied.... *)
+
+Definition f (X:Type) (x:nat -> X) (y:X -> bool) : bool := y (x 0).
+Extraction f.
+(* let f x y =
+  y (x O)
+*)
+
+Definition f_prop := f (0 = 0) (fun _ => refl_equal 0) (fun _ => true).
+Extraction NoInline f.
+Extraction f_prop.
+(* let f_prop =
+  f (Obj.magic __) (fun _ -> True)
+*)
+
+Definition f_arity := f Set (fun _:nat => nat) (fun _:Set => true).
+Extraction f_arity.
+(* let f_arity =
+  f (Obj.magic __) (fun _ -> True)
+*)
+
+Definition f_normal :=
+  f nat (fun x => x) (fun x => match x with
+                               | O => true
+                               | _ => false
+                               end).
+Extraction f_normal.
+(* let f_normal =
+  f (fun x -> x) (fun x -> match x with
+                             | O -> True
+                             | S n -> False)
+*)
+
+
+(* inductive with magic needed *)
+
+Inductive Boite : Set :=
+    boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. 
+Extraction Boite. 
+(*
+type boite =
+  | Boite of bool * __
+*)
+
+
+Definition boite1 := boite true 0.
+Extraction boite1.
+(* let boite1 = Boite (True, (Obj.magic O)) *)
+
+Definition boite2 := boite false (0, 0).
+Extraction boite2.
+(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *)
+
+Definition test_boite (B:Boite) :=
+  match B return nat with
+  | boite true n => n
+  | boite false n => fst n + snd n
+  end.
+Extraction test_boite. 
+(* 
+let test_boite = function
+  | Boite (b0, n) ->
+      (match b0 with
+         | True -> Obj.magic n
+         | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n)))
+*)
+
+(* singleton inductive with magic needed *)
+
+Inductive Box : Set :=
+    box : forall A:Set, A -> Box. 
+Extraction Box.
+(* type box = __ *)
+
+Definition box1 := box nat 0. 
+Extraction box1. (* let box1 = Obj.magic O *)
+
+(* applied constant, magic needed *)
+
+Definition idzarb (b:bool) (x:if b then nat else bool) := x.
+Definition zarb := idzarb true 0.
+Extraction NoInline idzarb. 
+Extraction zarb. 
+(* let zarb = Obj.magic idzarb True (Obj.magic O) *)
+
+(** function of variable arity. *)
+(** Fun n = nat -> nat -> ... -> nat *)  
+
+Fixpoint Fun (n:nat) : Set :=
+  match n with
+  | O => nat
+  | S n => nat -> Fun n
+  end.
+
+Fixpoint Const (k n:nat) {struct n} : Fun n :=
+  match n as x return Fun x with
+  | O => k
+  | S n => fun p:nat => Const k n
+  end.
+
+Fixpoint proj (k n:nat) {struct n} : Fun n :=
+  match n as x return Fun x with
+  | O => 0 (* ou assert false ....*)
+  | S n =>
+      match k with
+      | O => fun x => Const x n
+      | S k => fun x => proj k n
+      end
+  end. 
+
+Definition test_proj := proj 2 4 0 1 2 3.
+
+Eval compute in test_proj. 
+
+Recursive Extraction test_proj. 
+
+
+
+(*** TO SUM UP: ***) 
+
+
+Extraction
+ "test_extraction.ml" idnat id id' test2 test3 test4 test5 test6 test7 d d2
+                     d3 d4 d5 d6 test8 id id' test9 test10 test11 test12
+                     test13 test19 test20 nat sumbool_rect c Finite tree
+                     tree_size test14 test15 eta_c test16 test17 test18 bidon
+                     tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1
+                     tp1bis Truc oups test24 loop horibilis PropSet natbool
+                     zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop
+                     f_arity f_normal Boite boite1 boite2 test_boite Box box1
+                     zarb test_proj.
+