Commit 7b337aef authored by charguer's avatar charguer

Merge branch 'cfml2' of git+ssh://scm.gforge.inria.fr//gitroot/cfml/cfml into cfml2

parents fc40fc7d ec836ce2
xwhile: error reporting when arguments don't have the right types.
notation "# H" uniquement lorsque H est au type hprop.
xwhile: error reporting when arguments don't have the right types.
rename xextract to xpull; and xgen to xpush.
todo: model K/E -> list V
infix_eq_
comparable_type A || comparable_value x || comparable_value y
x = y : A
comparable_value x || comparable_value y
comparable_value x || comparable_value y
x = y : A
forall x : int, comparable_value x
mettre trop de let pour les fonctions builtin;
xuntag_goal. => dans xcf.
CFPrint.tag
app_def
infix_eq_
assume
MAJOR TODAY
......@@ -40,8 +23,12 @@ MAJOR TODAY
- for downto
- inline CFHeader.pred as -1
MAJOR NEXT
- xchanges
- record with
- when clauses
......@@ -50,55 +37,38 @@ MAJOR NEXT
- xabstract => reimplement and rename as xgen
- open no scope in CF.
- add support for pure records
MAJOR NEXT NEXT
- record single field and array single cell notation
Notation "x `. f '~>' S" :=
Notation "x `[ i ] '~>' S" :=
Notation "x `. f '~>' S" :=
Notation "x `[ i ] '~>' S" :=
- realize array specification using single-cell array specifications
- see if we can get rid of make_cmj
MAJOR POSTPONED
- support float
- add support for pure records
=> need type information for normalization
=> how to shared typed/untyped AST
- implement the work around for type abbreviations:
type typerecb1 = | Typerecb_1 of typerecb2
and typerecb2 = typerecb1 list
SANITY
- discuss the naming scheme
=> type t --> t_ || x'
=> var fresh x --> x12__
=> var x' --> x_prime_
=> var (++) --> plus_plus_infix_ || infix_plus_plus_
=> PB: plus_plus_infix' !
=> var x_ --> forbidden
- reject programs with constructor names ending with "_"
(e.g. "A_" is already used for type variables *)
type typerecb1 = | Typerecb_1 of typerecb2
and typerecb2 = typerecb1 list
- reject variable names and type definition that belongs to the list
builtin_type_constructors
- would it be better to perform all renaming during normalization phase?
- rename on the fly coq keyword such as exists, forall, etc..
=> requires a list of all coq keywords: see
else if name = "exists" then "exists__"
else if name = "forall" then "forall__"
- have a flag to control whether functions such as "min", "max", "abs", etc..
should be systematically let-bound; this would allow binding these names.
- prevent rebinding of List
- restriction on not binding "min" and "max" might be a bit restrictive..
- need to prevent double-underscore in the names?
##################################################################
# FUTURE WORK
OTHER LANGUAGES
......@@ -130,7 +100,31 @@ MAKEFILE BEAUTIFY
- make systematic use of || (rm -f $@; exit 1) in cfml calls
- In the makefile.Coq, when building the .vq and obtaining
"Error: /home/charguer/tlc/src/LibPer.vio: premature end of file. Try to rebuild it."
"Error: /home/charguer/tlc/src/LibPer.vio: premature end of file. Try to rebuild it."
=> then delete the .vio file
(useful for compilations interrupted using CTRL+C)
=> even better, wrap "coqc -quick" with an atomic commit of its result.
##################################################################
# PROPOSAL FOR DEFENSIVE CODE
- VStack.ml contains a verified stack implemementation using CFML.
(not polluted by any runtime checks).
- SStack.ml is a wrapper for VStack which adds asserts;
e.g. let pop s = assert (!s <> nil); VStack.pop s
- The file SStack.ml is processed using a special mode of CFML,
in which "assert t" is interpreted as "t needs to run safely
and produce some boolean; and the rest of the code may
assume this boolean to be true". Formally:
(Assert F) H Q :=
exists (P:Prop),
(F H (fun (b:bool) => [b = true <-> P] \* H))
/\ (H \* [P] ==> Q tt)
During the proof, the user needs to provide the proposition
[P] that is tested by the assertion. This proposition can
be assumed to be true after the assert is executed.
......@@ -24,9 +24,31 @@ let f () : 'a list =
*)
(********************************************************************)
(* ** Encoding of names *)
(* type renaming_t_ = int --rejected *)
(* type renaming_t__ = int --rejected *)
(* type renaming_t1 = C_ --rejected *)
type renaming_t' = int
type renaming_t2 = C'
type 'a renaming_t3 = int
type 'a_ renaming_t4 = int
let renaming_demo () =
(* let x_ = 3 in --rejected *)
(* let x__ = 3 in --rejected *)
let x = 3 in
let x' = 3 in
let x_' = 3 in
let exists = 3 in
let array = 3 in
()
(********************************************************************)
(* ** Return *)
(* ** Return *)
let ret_unit x =
()
......
This diff is collapsed.
......@@ -21,4 +21,13 @@ clean:
# TODO: understand if myocamldeb is needed or not.
\ No newline at end of file
# TODO: understand if myocamldeb is needed or not.
#####################################################################
doc: README.html
README.html: README.md
pandoc -o $@ $<
#####################################################################
# Binaries
`main`
: for building `*_ml.v` files from `*.ml` files. The `*_ml.v` files contain the characteristic formulae.
`makecmj`
: for building `*.cmj` files from `*.ml` and `*.mli` files, which are like `*.cmi` files, but named differently to avoid conflicts. The `*.cmj` files are required for the separate compilation performed by the `main` tool.
#####################################################################
# Compilation of the binaries
Execute:
```
make
```
#####################################################################
# Options for `main` and `makecmj`
`-I` *folder*
: Add an include directory where to look for `*.cmj` files.
`-rectypes`
: Allow type-checking with recursive types.
`-nostdlib`
: Use this file to compile `*.ml` files from the standard library.
`-nopervasives`
: Use this file to compile Pervasives.ml.
#####################################################################
# Options for `main`
`-o` *FILENAME*
: Set the output file name. By default, `*_ml.v` for `*.ml`
`-rectypes`
: Allow type-checking with recursive types.
`-left2right`
: Assume that side-effects are performed in the left subexpressions first, unlike OCaml's convention.
`-only_normalize`
: Normalize the code, but do not attempt building the characteristic formula file.
`-debug`
: Trace the various steps performed by the tool.
`-width`
: Set the pretty-printing width for the output file.
`-credits`
: [FUTURE USE] Generate characteristic formulae with time credits.
#####################################################################
# Organization of the code
`main.ml`
: Drives the operations.
`renaming.ml`
: Contains the convention for mapping names of variables, types, constructors and modules. It includes the list of builtin types and operators that are treated specially.
`normalize.ml`
: Describes a source-to-source translation at the level of the parse tree. This translation implements a form of A-normalization: it pulls out all side-effectful sub-expressions, and all function definitions, into seperate let bindings. This translation also rejects programs using features that are not supported by CFML.
`formula.ml`
: Describes a data type called `formula`, which serves as an intermediate representation for characteristic formulae before they get dumped as Coq syntax.
`coq.ml`
: Describes a data type called `coq`, which serves as a structured representation for Coq terms.
`characteristic.ml`
: Converts a typed abstract syntax tree into a structure of type `formula`.
`formula_to_coq.ml`
: Converts a structure of type `formula` into a structured `coq` term.
`print_coq.ml`
: Converts a structured `coq` term into a pretty-printed string.
`print_past.ml`
: Prints an AST, obtained from the parser.
`print_tast.ml`
: Prints a typed AST, obtained from type-checker.
#####################################################################
# Debugging
For debugging purposes, when compiling a `*.ml` file, the `main` tool
generates three files:
* `output/*_original.ml`
* `output/*_normalized.ml`
* `output/*_normalized_types.ml`
These files are not in valid syntax, and are not pretty-printed,
but they allow debugging the normalization process.
......@@ -233,7 +233,7 @@ let rec pattern_variables p : typed_vars = (* ignores aliases *)
let aux = pattern_variables in
match p.pat_desc with
| Tpat_any -> not_in_normal_form loc "wildcard patterns remain after normalization"
| Tpat_var s -> [Ident.name s, coq_typ_pat p]
| Tpat_var s -> [var_name (Ident.name s), coq_typ_pat p]
| Tpat_alias (p, s) -> aux p
| Tpat_constant c -> []
| Tpat_tuple l -> list_concat_map aux l
......@@ -252,7 +252,7 @@ let rec lift_pat ?(through_aliases=true) p : coq =
let aux = lift_pat ~through_aliases:through_aliases in
match p.pat_desc with
| Tpat_var s ->
Coq_var (Ident.name s)
Coq_var (var_name (Ident.name s))
| Tpat_constant (Const_int n) ->
Coq_int n
| Tpat_tuple l ->
......@@ -262,7 +262,7 @@ let rec lift_pat ?(through_aliases=true) p : coq =
| Tpat_alias (p, ak) ->
begin match ak with
| TPat_alias id ->
if through_aliases then aux p else Coq_var (Ident.name id)
if through_aliases then aux p else Coq_var (var_name (Ident.name id))
| TPat_constraint ty ->
let typ = lift_typ_exp ty.ctyp_type in
Coq_annot (aux p, typ)
......@@ -430,7 +430,7 @@ let exp_is_inlined_primitive e oargs =
let lift_exp_path env p =
match find_primitive (Path.name p) with
| None ->
let x = lift_path_name (protect_infix_path p) in
let x = lift_path_name (var_path p) in
coq_app_var_wilds x (typ_arity_var env p)
| Some y ->
Coq_var y
......@@ -570,8 +570,7 @@ let pattern_name p =
(** Takes a function name and encodes its name in case of an infix operator *)
let pattern_name_protect_infix p =
protect_infix (pattern_name p)
var_name (pattern_name p)
(** An alternative version of function extract_label_names, for obtaining record labels *)
......@@ -960,7 +959,7 @@ let rec cfg_structure_item s : cftops =
[ Cftop_coqs [ Coqtop_require_import [ lift_full_path_name path ] ] ]
| Tstr_primitive(id, descr) ->
let id = protect_infix (Ident.name id) in
let id = var_name (Ident.name id) in
let fvs, typ = lift_typ_sch descr.val_desc.ctyp_type in
let typ = coq_fun_types fvs typ in
[ Cftop_val (id, typ) ]
......@@ -980,20 +979,25 @@ let rec cfg_structure_item s : cftops =
a type abbreviation. *)
and cfg_type_abbrev (name,dec) =
let x = type_constr_name (Ident.name name) in
let loc = dec.typ_loc in
let x = Ident.name name in
check_type_constr_name loc x;
let name = type_constr_name x in
let args = List.map name_of_type dec.typ_type.type_params in
let sort = coq_impl_types (List.length args) in
let coqs = match dec.typ_type.type_manifest with
| None -> [Coqtop_param (x, sort)]
| Some t -> [Coqtop_def ((x, sort), coq_fun_types args (lift_typ_exp t));
Coqtop_hint_unfold ([x],"typeclass_instances") ] in
| None -> [Coqtop_param (name, sort)]
| Some t -> [Coqtop_def ((name, sort), coq_fun_types args (lift_typ_exp t));
Coqtop_hint_unfold ([name],"typeclass_instances") ] in
coqs
(** Generate the top-level Coq declarations associated with
a record definition. *)
and cfg_type_record (name,dec) =
let loc = dec.typ_loc in
let x = Ident.name name in
check_type_constr_name loc x;
let name_of_field lbl =
record_field_name lbl in
let fields = match dec.typ_type.type_kind with Type_record (l,_) -> l | _ -> assert false in
......@@ -1241,22 +1245,25 @@ and cfg_algebraics decls =
(* -- todo: Caml types often clash with Caml program variables, since in Coq
they get put in the same namespace *)
let trans_ind (name,dec) =
let loc = dec.typ_loc in
let x = Ident.name name in
check_type_constr_name loc x;
let branches = match dec.typ_type.type_kind with Type_variant l -> l | _ -> assert false in
let params = List.map name_of_type dec.typ_type.type_params in
let ret_typ = coq_apps (Coq_var (type_constr_name x)) (coq_vars params) in
let get_typed_constructor (c,ts) =
check_constr_name loc c;
(c, coq_impls (List.map lift_typ_exp ts) ret_typ) in
let coqind_decl =
if List.length decls = 1 then
{ coqind_name = type_constr_name x;
coqind_constructor_name = record_constructor_name x;
coqind_constructor_name = algebraic_constructor_name x;
coqind_targs = coq_types params;
coqind_ret = Coq_type;
coqind_branches = List.map get_typed_constructor branches; }
else
{ coqind_name = type_constr_name x;
coqind_constructor_name = record_constructor_name x;
coqind_constructor_name = algebraic_constructor_name x;
coqind_targs = [];
coqind_ret = coq_impl_types (List.length params);
coqind_branches = List.map
......
......@@ -79,7 +79,7 @@ let rec coqtops_of_imp_cf cf =
let h_curried = coq_apps (Coq_var "curried") [narity; coq_var f] in
let h_body_hyp = coq_apps (coq_of_cf cf1) [h; q] in
let args = List.map (fun (x,t) -> coq_apps coq_dyn_at [t; coq_var x]) targs in
let h_body_conc = coq_apps (Coq_var "app_def") [coq_var f; coq_list args; h; q] in
let h_body_conc = coq_apps (Coq_var "CFML.CFApp.app_def") [coq_var f; coq_list args; h; q] in
let h_body_2 = Coq_impl (h_body_hyp, h_body_conc) in
let h_body_1 = coq_foralls [("H", hprop); ("Q", Coq_impl (typ, hprop))] h_body_2 in
let h_body = coq_forall_types fvs (coq_foralls targs h_body_1) in
......@@ -177,7 +177,30 @@ let rec coqtops_of_imp_cf cf =
funhq "tag_seq" (coq_exist "Q'" wild_to_hprop (coq_conj c1 c2))
(* (!S: fun H Q => exists Q', F1 H Q /\ F2 (Q' tt) Q *)
| Cf_for (i_name,v1,v2,cf) ->
| Cf_for (i_name,v1,v2,cf) ->
let s = Coq_var "S" in
let i = Coq_var i_name in
let typs = Coq_impl (coq_int,formula_type) in
let locals = Coq_app (Coq_var "CFML.CFHeaps.is_local_pred", s) in
let snext = coq_apps s [ coq_plus i (Coq_int 1) ] in
let cf_step = Cf_seq (cf, Cf_manual snext) in
let cf_ret = Cf_ret coq_tt in
let cond = coq_apps (Coq_var "TLC.LibReflect.isTrue") [ coq_le i v2 ] in
let cf_if = Cf_caseif (cond, cf_step, cf_ret) in
let bodys = coq_of_cf cf_if in
let hypr = coq_foralls [(i_name, coq_int); ("H", hprop); ("Q", Coq_impl (coq_unit, hprop))] (Coq_impl (coq_apps bodys [h;q], (coq_apps s [i;h;q]))) in
funhq "tag_for" (Coq_forall (("S",typs), coq_impls [locals; hypr] (coq_apps s [v1;h;q])))
(* (!For (fun H Q => forall S:int->~~unit, is_local_pred S ->
(forall i H Q,
(If_ i <= v2
Then Seq (F1 ;; S (i+1)) H Q))
Else Ret tt) H Q
-> S i H Q)
-> S v1 H Q) *)
(*--todo:optimize using rec calls *)
(* DEPRECATED
let s = Coq_var "S" in
let i = Coq_var i_name in
let typs = Coq_impl (coq_int,formula_type) in
......@@ -192,20 +215,14 @@ let rec coqtops_of_imp_cf cf =
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])))
(* (!For (fun H Q => forall S:int->~~unit, is_local_pred S ->
(forall i H Q,
((i <= v2 -> !Seq (fun H Q => exists Q', Q1 H Q' /\ S (i+1) (Q' tt) Q) H Q))
/\ (i > v2 -> !Ret: (fun H Q => H ==> Q tt) H Q) ))
-> S i H Q)
-> S v1 H Q) *)
(*--todo:optimize using rec calls *)
*)
| Cf_while (cf1,cf2) ->
let r = Coq_var "R" in
let typr = formula_type in
let cfseq = Cf_seq (cf2, Cf_manual r) in
let cfret = Cf_ret coq_tt in
let cfif = Cf_caseif (Coq_var "_c", cfseq, cfret) in
let cf_step = Cf_seq (cf2, Cf_manual r) in
let cf_ret = Cf_ret coq_tt in
let cfif = Cf_caseif (Coq_var "_c", cf_step, cf_ret) 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 "CFML.CFHeaps.is_local", r) in
......
......@@ -13,7 +13,7 @@ let trace s =
let ppf = Format.std_formatter
let onlycmj = ref false
let only_normalize = ref false
let no_mystd_include = ref false
......@@ -34,7 +34,7 @@ let spec =
("-nostdlib", Arg.Set no_mystd_include, " do not include standard library");
("-nopervasives", Arg.Set Clflags.nopervasives, " do not include standard pervasives file");
("-o", Arg.String (fun s -> outputfile := Some s), " set the output file name");
("-onlycmj", Arg.Set onlycmj, " only generate the .cmj file, not the .v file");
("-only_normalize", Arg.Set only_normalize, " only generate the .cmj file, not the .v file");
("-debug", Arg.Set is_tracing, " trace the various steps");
("-width", Arg.Set_int Print_coq.width, " set pretty-printing width for the .v file");
]
......@@ -121,12 +121,12 @@ let _ =
in
(*---------------------------------------------------*)
trace "5) dumping .cmj file";
trace "5) dumping normalized file";
file_put_contents (debugdirBase ^ "_normalized_typed.ml") (Print_tast.string_of_structure typedtree2);
(* ignore (typedtree2); *)
if !onlycmj then begin
trace "6) exiting since -onlycmj";
if !only_normalize then begin
trace "6) exiting since -only_normalize";
exit 0;
end;
......
......@@ -24,7 +24,7 @@ let fullname_of_lident idt =
String.concat "." words
let check_lident loc idt = (* DEPRECATED *)
check_var loc (name_of_lident idt)
check_var_name loc (name_of_lident idt)
(*#########################################################################*)
......@@ -120,9 +120,9 @@ let normalize_pattern p =
| Ppat_any -> Ppat_var (next_name())
| Ppat_var s ->
(* hack to handle generated vars *)
if loc <> Location.none then check_var loc s;
if loc <> Location.none then check_var_name loc s;
Ppat_var s
| Ppat_alias (p, s) -> check_var loc s; Ppat_alias (aux p, s)
| Ppat_alias (p, s) -> check_var_name loc s; Ppat_alias (aux p, s)
| Ppat_constant c -> Ppat_constant c
| Ppat_tuple l -> Ppat_tuple (List.map aux l)
| Ppat_construct (li, po, b) -> Ppat_construct (li, option_map aux po, b)
......
......@@ -172,7 +172,7 @@ and expr1 = function
else parens (apps ((string tag)::(List.map expr0 args)))
in
apps [
string "CFPrint.tag"; (* @ *)
string "CFML.CFPrint.tag"; (* @ *)
stag;
(* FUTURE USE: label l;*)
(* string "_"; *)
......
This diff is collapsed.
......@@ -577,7 +577,7 @@ Notation "Q \*+ H" :=
(fun x => heap_is_star (Q x) H)
(at level 40) : heap_scope.
Notation "# H" := (fun _:unit => H)
Notation "# H" := (fun (_:unit) => (H:hprop))
(at level 39, H at level 99) : heap_scope.
Notation "\[= v ]" := (fun x => \[x = v])
......@@ -585,12 +585,14 @@ Notation "\[= v ]" := (fun x => \[x = v])
Notation "P ==+> Q" := (pred_le P%h (heap_is_star P Q))
(at level 55, only parsing) : heap_scope.
(* TODO: notation PRE P '/' ==> KEEP '/' POST Q *)
(* DEPRECATED
Notation "'hkeep' P '==>' Q" := (pred_le P%h (Q \* P))
(at level 55, P at level 0, right associativity) : heap_scope.
*)
(*------------------------------------------------------------------*)
(* ** Properties of heap empty *)
......
......@@ -631,10 +631,11 @@ Notation "'LetIf' F0 'Then' F1 'Else' F2" :=
(Let x := F0 in If_ x Then F1 Else F2)
(at level 69, only parsing) : charac.
(* DEPRECATED
Notation "'IfProp' P 'Then' F1 'Else' F2" :=
(!If (fun H Q => (P -> F1 H Q) /\ (~ P -> F2 H Q)))
(at level 69, P at level 0) : charac.
*)
(********************************************************************)
(** Case *)
......@@ -786,8 +787,7 @@ Notation "'While' F1 'Do' F2 'Done_'" :=
Notation "'For' i '=' a 'To' b 'Do' F1 'Done_'" :=
(!For (fun H Q => forall S:int->~~unit, CFHeaps.is_local_pred S ->
(forall i H Q,
(i <= (b)%Z -> (F1 ;; S (i+1)) H Q)
/\ (i > b%Z -> (Ret tt) H Q)
(If_ isTrue (i <= (b)%Z) Then (F1 ;; S (i+1)) Else (Ret tt)) H Q
-> S i H Q)
-> S a H Q))
(at level 69, i ident, a at level 0, b at level 0) : charac.
......@@ -875,13 +875,14 @@ Notation "'RegisterSpecCredits' T" := (Register database_spec_credits T)
(** The focus and unfocus databases are used to register specifications
for accessors to record fields, combined with focus/unfocus operations *)
Definition database_spec_focus := True.
Notation "'focus'" := database_spec_focus.
Definition database_spec_unfocus := True.
Notation "'unfocus'" := database_spec_unfocus.
Definition database_xopen := True.
Definition database_xclose := True.
Notation "'RegisterOpen' T" := (Register database_xopen T)
(at level 69) : charac.
Notation "'RegisterClose' T" := (Register database_xclose T)
(at level 69) : charac.
......
This diff is collapsed.
......@@ -39,3 +39,11 @@ COQINCLUDE := -R $(CFML)/lib/tlc TLC -R . CFML
include $(CFML)/lib/make/Makefile.coq
quick_cf: CFHeader.vio
#####################################################################
doc: README.html
README.html: README.md
pandoc -o $@ $<
#####################################################################
# Packaged libraries and compilation
`CFHeader.v`
: This file packages the scripts needed for compiling a `*_ml.v` file. Execute `make quick_cf` to build `CFHeader.vio` and be ready to compile a `*_ml.v` file.
`CFLib.v`
: This file packages the scripts needed for compiling a `*_proof.v` file, using the CFML tactics. Execute `make quick` to be ready to compile a `*_proof.v` file.
#####################################################################
# Organization of the code
`Shared.v`
: Contains general-purpose definition and tactics used in CFML.
`CFHeaps.v`
: Contains the formalization of heaps and heap predicates. It also includes the definition of `local` and of tactics such as `hsimpl`.
`CFApp.v`
: Contains an axiomatization of the behavior of ML function applications, as well as record operations.
`CFPrint.v`
: Describes notation for pretty-printing characteristic formulae.
`CFHeader.v`
: Packages the libraries used for compiling a `*_ml.v` file.
`CFTactics.v`
: Contains the implementation of CFML tactics.
`CFLib.v`
: Packages the libraries used for compiling a `*_proof.v` file.
#####################################################################
# For debugging
`CFDemos.v`
: This file contains a bunch of unit tests.
......@@ -129,7 +129,8 @@ endif
# Only the %.cmj target is known to "make".
%.cmj: %.ml $(CFML_MLV)