Commit a6263aae authored by charguer's avatar charguer

inprogress

parent f37ac489
......@@ -31,10 +31,11 @@ coqlib:
coqlib_quick:
$(MAKE) -C lib/coq quick
# quick_cf builds what is needed for compiling characteristic formulae files (CFHeader)
coqlib_quick_cf:
$(MAKE) -C lib/coq quick_cf
#------ TODO: ocamllib is deprecated
#------ TODO: ocamllib is deprecated
ocamllib: tools
$(MAKE) -C lib/ocaml
......
This diff is collapsed.
open Mytools
(*#########################################################################*)
(* ** Helper function to decompose Coq paths *)
(*#########################################################################*)
(* TEMPORARILY DEPRECATED
(** List of special modules whose [open] should not lead to the
generation of an [Require Import] statement. *)
let is_primitive_module n =
List.mem n [ "NullPointers"; "StrongPointers" ]
(* ; "Okasaki"; "OkaStream" *)
(** [is_primitive_module] Recognizes builtin modules that have a special treatment,
namely "NullPointers" and "StrongPointers" *)
val is_primitive_module : string -> bool
*)
(* TEMPORARILY DEPRECATED
(** List of special top-level definitions that should not lead
to the generation of a characteristic formula. The definition
of [!$] as a keyword for forcing lazy expressions is one such
exception. *)
let hack_recognize_okasaki_lazy = function
| "!$" -> true
| _ -> false
(** Below is a HACK for the [!$] symbol used in Okasaki's code to mean "lazy" *)
val hack_recognize_okasaki_lazy : string -> bool
*)
(** DEPRECATED test only base on the last part of the name
let rec split_at_dots s pos =
try
let dot = String.index_from s pos '.' in
String.sub s pos (dot - pos) :: split_at_dots s (dot + 1)
with Not_found ->
[String.sub s pos (String.length s - pos)]
let name_of_mlpath s =
List.hd (List.rev (split_at_dots s 0))
(* HACK! Same as above, but only checks base on the tail of the name,
e.g. considering only "+" instead of "Pervasives.+"
This hack is only correct if we forbit the rebinding of
these special primitive names, however this check is not
yet implemented. *)
val is_inlined_primitive_hack : string -> int -> bool
let is_inlined_primitive_hack p arity =
let p = add_pervasives_prefix_if_needed p in
match list_assoc_option p Renaming.inlined_primitives_table with
| None -> false
| Some (n,y) -> (arity = n)
(* old: let inlined_primitives_table = List.map (fun (x,(n,y)) -> name_of_mlpath x, (n,y)) inlined_primitives_table in *)
*)
\ No newline at end of file
(** This module contains information for properly handling
OCaml builtin functions and Coq builtin functions and
data types. *)
Require Import List.
Lemma test: True.
let x := eval compute in (List.length (3::4::nil)) in
pose x.
admit.
......@@ -164,6 +164,11 @@ let test_partial_app_arities () =
let f3 = func4 1 2 3 in
f1 2 3 4 + f2 3 4 + f3 4
let app_partial_builtin () =
let f = (+) 1 in
f 2
(********************************************************************)
(* ** Over applications *)
......
......@@ -64,7 +64,8 @@ OCAMLBUILD := \
##############################################################
# Targets
all: code cf proof
all: cf proof
# code => excluded cause does not work yet
nocode: cf proof
......
......@@ -18,3 +18,7 @@ clean:
# Note: to generate mli files, run the following command from ./_build:
# ocamlc -I typing -I utils -I tools -I parsing -I lex -I /usr/local/lib/ocaml/4.01.0/pprint/ -i normalize.ml > ../normalize.mli
# TODO: understand if myocamldeb is needed or not.
\ No newline at end of file
......@@ -8,7 +8,6 @@ open Print_tast
open Print_type
open Formula
open Coq
open Primitives
open Path
open Renaming
open Printf
......@@ -122,19 +121,9 @@ let rec lift_btyp t =
val_type
| Btyp_arrow (t1,t2) ->
val_type
| Btyp_constr (id,[t]) when Path.name id = "ref" || Path.name id = "Pervasives.ref"
|| Path.name id = "mlist" -> (* --todo: not needed anymore *)
| Btyp_constr (id,[t]) when Path.name id = "array" ->
(* || Path.name id = "Pervasives.array" *)
loc_type
| Btyp_constr (id,[t]) when Path.name id = "array" || Path.name id = "Pervasives.array" ->
loc_type
| Btyp_constr (id,[t]) when Path.name id = "heap" || Path.name id = "Heap.heap" -> (* todo generalize *)
loc_type
| Btyp_constr (id,[t]) when Path.same id Predef.path_lazy_t || Path.name id = "Lazy.t" ->
aux t (* todo: les Lazy provenant des patterns ne sont pas identique Predef.path_lazy_t *)
| Btyp_constr (id,[t]) when Path.name id = "Stream.stream" || Path.name id = "stream" ->
Coq_app (Coq_var "list", aux t)
| Btyp_constr (id,[t]) when Path.name id = "Stream.stream_cell" || Path.name id = "stream_cell" ->
Coq_app (Coq_var "list", aux t)
| Btyp_constr (id,ts) ->
coq_apps (Coq_var (type_constr_name (lift_path_name id))) (List.map aux ts)
| Btyp_tuple ts ->
......@@ -150,6 +139,24 @@ let rec lift_btyp t =
then unsupported ("found a recursive type that is not erased by an arrow:" ^ (print_out_type t));
aux t1
(* TEMPORARILY DEPRECATED
| Btyp_constr (id,[t]) when Path.name id = "ref" || Path.name id = "Pervasives.ref" ->
loc_type
| Btyp_constr (id,[t]) when Path.name id = "heap" || Path.name id = "Heap.heap" ->
loc_type
| Btyp_constr (id,[t]) when Path.same id Predef.path_lazy_t || Path.name id = "Lazy.t" ->
aux t
| Btyp_constr (id,[t]) when Path.name id = "Stream.stream" || Path.name id = "stream" ->
Coq_app (Coq_var "list", aux t)
| Btyp_constr (id,[t]) when Path.name id = "Stream.stream_cell" || Path.name id = "stream_cell" ->
Coq_app (Coq_var "list", aux t)
*)
(* REMARK: les Lazy provenant des patterns ne sont pas identique Predef.path_lazy_t *)
(** Translates a Caml type into a Coq type *)
let lift_typ_exp ty =
......@@ -783,7 +790,8 @@ let rec cfg_structure_item s : cftops =
end else if (List.length pat_expr_list = 1) then begin (* later: check it is not a function *)
let (pat,bod) = List.hd pat_expr_list in
let x = pattern_name_protect_infix pat in
if (hack_recognize_okasaki_lazy x) then [] else begin
(* DEPRECATED if (hack_recognize_okasaki_lazy x) then [] else *)
begin
let fvs_typ, typ = lift_typ_sch pat.pat_type in
let fvs = List.map name_of_type fvs in
let fvs_strict = list_intersect fvs fvs_typ in
......@@ -852,7 +860,7 @@ let rec cfg_structure_item s : cftops =
| Tstr_modtype(id, decl) -> cfg_modtype id decl
| Tstr_open path ->
if is_primitive_module (Path.name path) then [] else
(* TEMPORARILY DEPRECATED if is_primitive_module (Path.name path) then [] else *)
[ Cftop_coqs [ Coqtop_require_import [ lift_full_path_name path ] ] ]
| Tstr_primitive(id, descr) ->
......@@ -1372,6 +1380,7 @@ let cfg_file str =
Coqtop_set_implicit_args;
Coqtop_require [ "Coq.ZArith.BinInt"; "LibLogic"; "LibRelation"; "LibInt"; "Shared"; "CFHeaps"; "CFApp" ];
Coqtop_require_import ["CFHeader"];
Coqtop_require ["CFPrint"];
Coqtop_custom "Open Scope list_scope.";
Coqtop_custom "Local Notation \"'int'\" := (Coq.ZArith.BinInt.Z).";
Coqtop_custom "Delimit Scope Z_scope with Z."
......
......@@ -36,7 +36,7 @@ and coq =
| Coq_type
| Coq_tuple of coqs
| Coq_record of (var * coq) list
| Coq_tag of string * string option * coq
| Coq_tag of string * coq list * string option * coq
| Coq_annot of coq * coq
and coqs = coq list
......@@ -116,31 +116,31 @@ and implicit =
(** Several Coq constants *)
let coq_false =
Coq_var "False"
Coq_var "Coq.Init.Logic.False"
let coq_true =
Coq_var "True"
Coq_var "Coq.Init.Logic.True"
let coq_bool_false =
Coq_var "false"
Coq_var "Coq.Init.Datatypes.false"
let coq_bool_true =
Coq_var "true"
Coq_var "Coq.Init.Datatypes.true"
let coq_tt =
Coq_var "tt"
Coq_var "Coq.Init.Datatypes.tt"
let coq_unit =
Coq_var "unit"
Coq_var "Coq.Init.Datatypes.unit"
let coq_int =
Coq_var "int"
Coq_var "Coq.ZArith.BinInt.Z"
let coq_list xs =
Coq_list xs
let coq_bool =
Coq_var "bool"
Coq_var "Coq.Init.Datatypes.bool"
(** Identifier [x] *)
......@@ -228,27 +228,27 @@ let coq_prod cs =
match cs with
| [] -> coq_unit
| [c] -> c
| c0::cs' -> List.fold_left (fun acc c -> coq_apps (Coq_var "prod") [acc;c]) c0 cs'
| c0::cs' -> List.fold_left (fun acc c -> coq_apps (Coq_var "Coq.Init.Datatypes.prod") [acc;c]) c0 cs'
(** Logic combinators *)
let coq_eq c1 c2 =
coq_apps (Coq_var "Logic.eq") [ c1; c2 ]
coq_apps (Coq_var "Coq.Init.Logic.eq") [ c1; c2 ]
let coq_neq c1 c2 =
coq_apps (Coq_var "Logic.not") [coq_eq c1 c2]
coq_apps (Coq_var "Coq.Init.Logic.not") [coq_eq c1 c2]
let coq_disj c1 c2 =
coq_apps (Coq_var "Logic.or") [c1; c2]
coq_apps (Coq_var "Coq.Init.Logic.or") [c1; c2]
let coq_conj c1 c2 =
coq_apps (Coq_var "Logic.and") [c1; c2]
coq_apps (Coq_var "Coq.Init.Logic.and") [c1; c2]
let coq_neg c =
Coq_app (Coq_var "LibBool.neg", c)
Coq_app (Coq_var "TLC.LibBool.neg", c)
let coq_exist x c1 c2 =
coq_apps (Coq_var "Logic.ex") [Coq_fun ((x, c1), c2)]
coq_apps (Coq_var "Coq.Init.Logic.ex") [Coq_fun ((x, c1), c2)]
(** Iterated logic combinators *)
......@@ -263,10 +263,10 @@ let coq_exists xcs c2 =
(** Arithmetic operations *)
let coq_le c1 c2 =
coq_apps (Coq_var "LibOrder.le") [ c1; c2 ]
coq_apps (Coq_var "TLC.LibOrder.le") [ c1; c2 ]
let coq_gt c1 c2 =
coq_apps (Coq_var "LibOrder.gt") [ c1; c2 ]
coq_apps (Coq_var "TLC.LibOrder.gt") [ c1; c2 ]
let coq_plus c1 c2 =
coq_apps (Coq_var "Coq.ZArith.BinInt.Zplus") [ c1; c2 ]
......@@ -302,8 +302,9 @@ let string_of_var_bits vb =
let value_variable n =
string_of_var_bits (var_bits_of_int n)
let coq_tag (tag : string) ?label (term : coq) =
Coq_tag (tag, label, term)
let coq_tag (tag : string) ?args ?label (term : coq) =
let args = match args with | None -> [] | Some args -> args in
Coq_tag ("CFML.CFPrint." ^ tag, args, label, term)
let coq_annot (term : coq) (term_type : coq) =
Coq_annot (term, term_type)
......
......@@ -45,41 +45,41 @@ and cftops = cftop list
(** Abstract datatype for dynamic values *)
let coq_dyn_at = coq_var_at "CFHeaps.dyn"
let coq_dyn_at = coq_var_at "CFML.CFHeaps.dyn"
(** Abstract datatype for functions *)
let val_type = Coq_var "CFApp.func"
let val_type = Coq_var "CFML.CFApp.func"
(** Abstract data type for locations *)
let loc_type =
Coq_var "CFHeaps.loc"
Coq_var "CFML.CFHeaps.loc"
(** Abstract data type for heaps *)
let heap =
Coq_var "CFHeaps.heap"
Coq_var "CFML.CFHeaps.heap"
(** Type of proposition on heaps, [hprop], a shorthand for [heap->Prop] *)
let hprop =
Coq_var "CFHeaps.hprop"
Coq_var "CFML.CFHeaps.hprop"
(** Type of representation predicates *)
let htype c_abstract c_concrete =
coq_apps (Coq_var "CFHeaps.htype") [c_abstract; c_concrete]
coq_apps (Coq_var "CFML.CFHeaps.htype") [c_abstract; c_concrete]
(** The identity representation predicate *)
let id_repr =
Coq_var "CFHeaps.Id"
Coq_var "CFML.CFHeaps.Id"
(** Representation predicate tag *)
let hdata c_concrete c_abstract =
coq_apps (Coq_var "CFHeaps.hdata") [c_abstract; c_concrete]
coq_apps (Coq_var "CFML.CFHeaps.hdata") [c_abstract; c_concrete]
(** Type of pure post-conditions [_ -> Prop] *)
......@@ -104,7 +104,7 @@ let formula_type =
(** Hprop entailment [H1 ==> H2] *)
let heap_impl h1 h2 =
coq_apps (Coq_var "LibLogic.pred_le") [h1;h2]
coq_apps (Coq_var "TLC.LibLogic.pred_le") [h1;h2]
(** Specialized Hprop entailment [H1 ==> Q2 tt] *)
......@@ -114,7 +114,7 @@ let heap_impl_unit h1 q2 =
(** Postcondition entailment [Q1 ===> Q2] *)
let post_impl q1 q2 =
coq_apps (Coq_var "LibRelation.rel_le") [q1;q2]
coq_apps (Coq_var "TLC.LibRelation.rel_le") [q1;q2]
(** Specialized post-conditions [fun (_:unit) => H], i.e. [# H] *)
......@@ -124,17 +124,17 @@ let post_unit h =
(** Separating conjunction [H1 * H2] *)
let heap_star h1 h2 =
coq_apps (Coq_var "CFHeaps.heap_is_star") [h1;h2]
coq_apps (Coq_var "CFML.CFHeaps.heap_is_star") [h1;h2]
(** Base data [heap_is_single c1 c2] *)
let heap_is_single c1 c2 =
coq_apps (coq_var_at "CFHeaps.heap_is_single") [c1;Coq_wild;c2]
coq_apps (coq_var_at "CFML.CFHeaps.heap_is_single") [c1;Coq_wild;c2]
(** Empty heap predicate [[]] *)
let heap_empty =
Coq_var "CFHeaps.heap_is_empty"
Coq_var "CFML.CFHeaps.heap_is_empty"
(** Iterated separating conjunction [H1 * .. * HN] *)
......@@ -146,7 +146,7 @@ let heap_stars hs =
(** Lifted existentials [Hexists x, H] *)
let heap_exists xname xtype h =
Coq_app (Coq_var "CFHeaps.heap_is_pack", Coq_fun ((xname, xtype), h))
Coq_app (Coq_var "CFML.CFHeaps.heap_is_pack", Coq_fun ((xname, xtype), h))
(** Lifted existentials [Hexists x, H], alternative *)
......@@ -161,4 +161,4 @@ let heap_existss x_names_types h =
(** Lifted propositions [ [P] ] *)
let heap_pred c =
Coq_app (Coq_var "CFHeaps.heap_is_empty_st", c)
Coq_app (Coq_var "CFML.CFHeaps.heap_is_empty_st", c)
......@@ -7,6 +7,7 @@ open Renaming
(*#########################################################################*)
(* ** Conversion of IMPERATIVE characteristic formulae to Coq *)
(* TODO: extract hard coded constants*)
let rec coqtops_of_imp_cf cf =
let coq_of_cf = coqtops_of_imp_cf in
......@@ -18,7 +19,7 @@ let rec coqtops_of_imp_cf cf =
| Some t -> t
in
let f_core = coq_funs [("H", hprop);("Q", Coq_impl(typ,hprop))] c in
let f = Coq_app (Coq_var "CFHeaps.local", f_core) in
let f = Coq_app (Coq_var "CFML.CFHeaps.local", f_core) in
match label with
| None -> coq_tag tag f
| Some x -> (*todo:remove this hack*) if x = "_c" then coq_tag tag f else
......@@ -50,7 +51,7 @@ let rec coqtops_of_imp_cf cf =
assert (List.length ts = List.length vs);
let tvs = List.combine ts vs in
let args = List.map (fun (t,v) -> coq_apps coq_dyn_at [t;v]) tvs in
coq_tag "tag_apply" (coq_apps (coq_var_at "app_def") [f; coq_list args; tret])
coq_tag "tag_apply" (coq_apps (coq_var_at "CFML.CFApp.app_def") [f; coq_list args; tret])
(* (!Apply: (app_def f [(@dyn t1 v1) (@dyn t2 v2)])) *)
(* DEPRECATED
......@@ -124,8 +125,8 @@ let rec coqtops_of_imp_cf cf =
*)
| Cf_caseif (v,cf1,cf2) ->
let c1 = Coq_impl (coq_eq v (Coq_var "true"), coq_apps (coq_of_cf cf1) [h;q]) in
let c2 = Coq_impl (coq_eq v (Coq_var "false"), coq_apps (coq_of_cf cf2) [h;q]) in
let c1 = Coq_impl (coq_eq v coq_bool_true, coq_apps (coq_of_cf cf1) [h;q]) in
let c2 = Coq_impl (coq_eq v coq_bool_false, coq_apps (coq_of_cf cf2) [h;q]) in
funhq "tag_if" (coq_conj c1 c2)
(* (!I a: (fun H Q => (x = true -> Q1 H Q) /\ (x = false -> Q2 H Q))) *)
......@@ -148,7 +149,7 @@ let rec coqtops_of_imp_cf cf =
where trueb are implicit by coercions *)
| Cf_match (label, n,cf1) ->
coq_tag (Printf.sprintf "(tag_match %d%snat)" n "%") (*~label:label*) (coq_of_cf cf1)
coq_tag "tag_match" ~args:[Coq_var (Printf.sprintf "%d%s" n "%nat")] (*~label:label*) (coq_of_cf cf1)
| Cf_seq (cf1,cf2) ->
let q' = Coq_var "Q'" in
......@@ -168,7 +169,7 @@ let rec coqtops_of_imp_cf cf =
let ple = Coq_impl (coq_le i v2, coq_apps body_le [h; q]) in
let body_gt = funhq "tag_ret" ~rettype:coq_unit (heap_impl_unit h q) in
let pgt = Coq_impl (coq_gt i v2, coq_apps body_gt [h; q]) in
let locals = Coq_app (Coq_var "CFHeaps.is_local_pred", s) in
let locals = Coq_app (Coq_var "CFML.CFHeaps.is_local_pred", s) in
let bodys = coq_conj ple pgt in
let hypr = coq_foralls [(i_name, coq_int); ("H", hprop); ("Q", Coq_impl (coq_unit, hprop))] (Coq_impl (bodys,(coq_apps s [i;h;q]))) in
funhq "tag_for" (Coq_forall (("S",typs), coq_impls [locals; hypr] (coq_apps s [v1;h;q])))
......@@ -188,7 +189,7 @@ let rec coqtops_of_imp_cf cf =
let cfif = Cf_caseif (Coq_var "_c", cfseq, cfret) in
let bodyr = coq_of_cf (Cf_let (("_c",coq_bool), cf1, cfif)) in
let hypr = coq_foralls [("H", hprop); ("Q", Coq_impl (coq_unit, hprop))] (Coq_impl (coq_apps bodyr [h;q],(coq_apps r [h;q]))) in
let localr = Coq_app (Coq_var "CFHeaps.is_local", r) in
let localr = Coq_app (Coq_var "CFML.CFHeaps.is_local", r) in
funhq "tag_while" (Coq_forall (("R",typr), coq_impls [localr; hypr] (coq_apps r [h;q])))
(* (!While: (fun H Q => forall R:~~unit, is_local R ->
(forall H Q,
......@@ -198,7 +199,7 @@ let rec coqtops_of_imp_cf cf =
| Cf_pay (cf1) ->
let h' = Coq_var "H'" in
let c1 = coq_apps (Coq_var "pay_one") [h;h'] in
let c1 = coq_apps (Coq_var "CFML.CFHeaps.pay_one") [h;h'] in
let c2 = coq_apps (coq_of_cf cf1) [h'; Coq_var "Q"] in
funhq "tag_pay" (coq_exist "H'" hprop (coq_conj c1 c2))
(* (!Pay: fun H Q => exists H', pay_one H H' /\ F1 H' Q *)
......
......@@ -5,7 +5,6 @@ open Parsetree
open Mytools
open Longident
open Location
open Primitives
open Renaming
(** This file takes as input an abstract syntax tree and produces
......@@ -37,9 +36,9 @@ let is_inlined_primitive e largs =
| Pexp_ident f, [n; {pexp_desc = Pexp_constant (Const_int m)}]
(* TODO: check that mod and "/" are actually coming from pervasives *)
when m > 0 && let x = name_of_lident f in x = "mod" || x = "/" ->
is_inlined_primitive_hack (fullname_of_lident f) primitive_special
is_inlined_primitive (fullname_of_lident f) primitive_special
| Pexp_ident f,_ ->
is_inlined_primitive_hack (fullname_of_lident f) (List.length args)
is_inlined_primitive (fullname_of_lident f) (List.length args)
| _ -> false
let is_failwith_function e =
......
open Mytools
(*#########################################################################*)
(* ** Helper function to decompose Coq paths *)
let rec split_at_dots s pos =
try
let dot = String.index_from s pos '.' in
String.sub s pos (dot - pos) :: split_at_dots s (dot + 1)
with Not_found ->
[String.sub s pos (String.length s - pos)]
let name_of_mlpath s =
List.hd (List.rev (split_at_dots s 0))
(*#########################################################################*)
(* ** List of inlined primitives *)
(** Fully-applied "inlined primitive" are translated directly as a
Coq application, and does not involve the "AppReturns" predicate. *)
let primitive_special = -1
let inlined_primitives_table =
["Pervasives.+", (2, "Coq.ZArith.BinInt.Zplus");
"Pervasives.-", (2, "Coq.ZArith.BinInt.Zminus");
"Pervasives.*", (2, "Coq.ZArith.BinInt.Zmult");
"Pervasives.~-", (1, "Coq.ZArith.BinInt.Zopp");
"Pervasives.&&", (2, "LibBool.and");
"Pervasives.||", (2, "LibBool.or");
(*
"Pervasives./", (primitive_special, "Coq.ZArith.Zdiv.Zdiv");
"Pervasives.mod", (primitive_special, "Coq.ZArith.Zdiv.Zmod");
*)
(*
"Pervasives.=", (2, "(fun _y _z => isTrue (_y = _z))");
"Pervasives.<>", (2, "(fun _y _z => isTrue (_y <> _z))");
"Pervasives.<", (2, "(fun _y _z => isTrue (_y < _z))");
"Pervasives.<=", (2, "(fun _y _z => isTrue (_y <= _z))");
"Pervasives.>", (2, "(fun _y _z => isTrue (_y > _z))");
"Pervasives.>=", (2, "(fun _y _z => isTrue (_y >= _z))");
"Pervasives.max", (2, "(fun _y _z => Zmin (_y >= _z))");
"Pervasives.min", (2, "(fun _y _z => isTrue (_y >= _z))");
"Pervasives.not", (1, "LibBool.neg");
"Pervasives.fst", (1, "(@fst _ _)");
"Pervasives.snd", (1, "(@snd _ _)");
"Pervasives.@", (2, "LibList.append");
"List.rev", (1, "LibList.rev");
"List.length", (1, "LibList.length");
"List.append", (2, "LibList.append");
"OkaStream.++", (2, "LibList.append");
"OkaStream.reverse", (1, "LibList.rev");
"StrongPointers.cast", (1, "")
"Lazy.force", (1, "");
"Okasaki.!$", (1, ""); (* i.e., @LibLogic.id _*)
*)
]
(*#########################################################################*)
(* ** List of all primitives *)
(** Primitive functions from the following list are mapped to special
Coq constants whose specification is axiomatized. *)
let all_primitives_table =
[
(* "Pervasives.=", "ml_eqb";
"Pervasives.<>", "ml_neq";
"Pervasives.==", "ml_phy_eq";
"Pervasives.!=", "ml_phy_neq";
"Pervasives.+", "ml_plus";
"Pervasives.-", "ml_minus";
"Pervasives.~-", "ml_opp";
"Pervasives.*", "ml_mul";
"Pervasives./", "ml_div";
"Pervasives.mod", "ml_mod";
"Pervasives.<=", "ml_leq";
"Pervasives.<", "ml_lt";
"Pervasives.>", "ml_gt";
"Pervasives.>=", "ml_geq";
"Pervasives.&&", "ml_and";
"Pervasives.||", "ml_or";
"Pervasives.@", "ml_append";
"Pervasives.raise", "ml_raise";
"Pervasives.asr", "ml_asr";
"Pervasives.ref", "ml_ref";
"Pervasives.!", "ml_get";
"Pervasives.:=", "ml_set";
"Pervasives.incr", "ml_incr";
"Pervasives.decr", "ml_decr";
"Pervasives.fst", "ml_fst";
"Pervasives.snd", "ml_snd";
"Pervasives.max_int", "ml_max_int";
"Pervasives.min_int", "ml_min_int";
"Pervasives.read_int", "ml_read_int";
"Pervasives.print_int", "ml_print_int";
"Array.make", "ml_array_make";
"Array.get", "ml_array_get";
"Array.set", "ml_array_set";
"Array.init", "ml_array_init";
"Array.length", "ml_array_length";
"Random.int", "ml_rand_int";
"List.nth", "ml_list_nth";
"List.hd", "ml_list_hd";
"List.tl", "ml_list_tl";
"List.iter", "ml_list_iter";
"List.fold_left", "ml_list_fold_left";
"List.fold_right", "ml_list_fold_right";
"List.rev", "ml_rev";
"List.append", "ml_append";
"Stack.create", "ml_stack_create";
"Stack.is_empty", "ml_stack_is_empty";
"Stack.push", "ml_stack_push";
"Stack.pop", "ml_stack_pop";
"OkaStream.append", "ml_append";
"OkaStream.take", "ml_take";
"OkaStream.drop", "ml_drop";
"NullPointers.null", "null";
"NullPointers.is_null", "ml_is_null";
"NullPointers.free", "ml_free";
"StrongPointers.sref", "ml_ref";
"StrongPointers.sget", "ml_get";
"StrongPointers.sset", "ml_sset";
*)
]
(* ---todo: add not, fst, snd *)
(*#########################################################################*)
(* ** List of primitive data constructors *)
(** Data constructors from the following lists are mapped to particular
inductive data constructors in Coq. *)
let builtin_constructors_table =
[ "[]", ("Coq.Lists.List.nil", 1);
"::", ("Coq.Lists.List.cons", 1);
"()", ("Coq.Init.Datatypes.tt", 0);
"true", ("Coq.Init.Datatypes.true", 0);
"false", ("Coq.Init.Datatypes.false", 0);
]
(* --todo: add [Pervasives] as prefix *)
(*#########################################################################*)
(* ** Accessor functions *)
(** Auxiliary function for the special case of compiling pervasives *)
let add_pervasives_prefix_if_needed p =
if !Clflags.nopervasives then "Pervasives." ^ p else p
(** Find the inlined primitive associated with [p] of arity [arity] *)
let find_inlined_primitive p arity =
(* Printf.printf "find_inlined_primitive: %s %d\n" p arity; *)
let p = add_pervasives_prefix_if_needed p in
match list_assoc_option p inlined_primitives_table with
| None -> None
| Some (n,y) -> if n = arity then Some y else None
(** Test whether [p] is an inlined primitive of arity [arity] *)
let is_inlined_primitive p arity =
find_inlined_primitive p arity <> None