diff options
Diffstat (limited to 'contrib/extraction')
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. + |