Commit 11e082f4 authored by charguer's avatar charguer

progress_tactics

parent 3d98a723
This diff is collapsed.
......@@ -8,47 +8,6 @@ open Pervasives
*)
(********************************************************************)
(* ** Top-level values *)
let top_val_int = 5
let top_val_int_list : int list = []
let top_val_poly_list = []
let top_val_poly_list_pair = ([],[])
(********************************************************************)
(* ** Polymorphic functions *)
let top_fun_poly_id x =
x
let top_fun_poly_proj1 (x,y) =
x
let top_fun_poly_pair_homogeneous (x:'a) (y:'a) =
(x,y)
(********************************************************************)
(* ** Infix functions *)
let (+++) x y = x + y
let infix_aux x y = x + y
let (---) = infix_aux
(********************************************************************)
(* ** Inlined total functions *)
let f () =
1 - 1/(-1) + (2 / 2) mod 3
(********************************************************************)
(* ** Return *)
......@@ -169,7 +128,6 @@ let app_partial_builtin () =
f 2
(********************************************************************)
(* ** Over applications *)
......@@ -178,6 +136,48 @@ let app_over_id () =
f f 3
(********************************************************************)
(* ** Infix functions *)
let (+++) x y = x + y
let infix_aux x y = x + y
let (---) = infix_aux
(********************************************************************)
(* ** Inlined total functions *)
let f () =
1 - 1/(-1) + (2 / 2) mod 3
(********************************************************************)
(* ** Polymorphic functions *)
let top_fun_poly_id x =
x
let top_fun_poly_proj1 (x,y) =
x
let top_fun_poly_pair_homogeneous (x:'a) (y:'a) =
(x,y)
(********************************************************************)
(* ** Top-level values *)
let top_val_int = 5
let top_val_int_list : int list = []
let top_val_poly_list = []
let top_val_poly_list_pair = ([],[])
(********************************************************************)
(* ** Polymorphic let bindings *)
......@@ -330,6 +330,9 @@ let for_incr () =
done;
!n
(* "for .. down to" not yet supported *)
(********************************************************************)
(* ** Recursive function *)
......
This diff is collapsed.
......@@ -95,7 +95,8 @@ cf: $(ML)
# Make sure TLC and CFML itself are up-to-date.
# Needed only when developing TLC and CFML. Ideally, should be removed.
@$(MAKE) -C $(CFML)/lib/tlc --no-print-directory quick
@$(MAKE) -C $(CFML) --no-print-directory tools coqlib_quick_cf
# @$(MAKE) -C $(CFML) --no-print-directory tools coqlib_quick_cf
@$(MAKE) -C $(CFML) --no-print-directory tools coqlib_quick
@$(MAKE) -C $(CFML)/lib/stdlib --no-print-directory quick
@$(MAKE) CFML=$(CFML) OCAML_FLAGS=$(OCAML_FLAGS) COQINCLUDE="$(COQINCLUDE)" ML="$(ML)" --no-print-directory -f $(CFML)/lib/make/Makefile.cf all
......
......@@ -5,7 +5,7 @@ open Renaming
(*#########################################################################*)
(* ** Conversion of IMPERATIVE characteristic formulae to Coq *)
(* ** Conversion of characteristic formulae to Coq *)
(* TODO: extract hard coded constants*)
......
......@@ -61,9 +61,8 @@ Ltac cfml_get_tag tt :=
(** [cfml_check_not_tagged tt] fails if the head of the goal contains a tag *)
Ltac cfml_check_not_tagged tt :=
match goal with |- @tag ?t _ _ => fail 1 end.
Ltac cfml_check_not_tagged tt ::=
match goal with |- @tag ?t _ _ => fail 1 | _ => idtac end.
(** [xuntag T] removes the tag [T] at the head of the goal,
and fails if it is not there. *)
......
......@@ -2082,18 +2082,54 @@ Tactic Notation "xspec" :=
- [xapps_spec] is not supported, use [xapp_spec], then [subst]. *)
(** Debugging for [xapp]:
- [xapp1] sets the goal in the right form for [xapp],
by calling [xseq] or [xlet], or [xgc] if applicable
- [xapp2] looks up the specification for the function and pushes
it into the goal.
[xapp2_spec H] can be used to provide a custom specification.
- [xapp3] exploits the last hypothesis in the goal as a specification
and instantiates it using the tactic [forward].
[xapp3 args] can be used to provide arguments.
At this point, sides conditions should be discarded.
//TODO: [xapp3_skip] can be used to skip all side conditions.
- [xapp4] applies the frame rule, exploiting lemma [local_wframe].
- [xapp5] applies the last hypothesis in the goal to the goal.
From there, [xsimpl] should be called on the other two goals
produced by [xapp4].
- [xapp12] is short for [xapp1; xapp2].
- [xapp45] is short for [xapp4; xapp5].
*)
(* TODO: xapp_spec_no_simpl *)
(* Retreives only the "app" part of the spec *)
(* Retreives only the "app" part of the spec, from the head of the goal,
into an hypothesis named [Sf]. *)
Ltac xapp_extract_app_from_spec H :=
Ltac xapp_extract_app_from_spec_as Sf :=
match goal with
| |- (spec _ _ _) -> _ => intros [_ H] (* drops the curried part *)
| |- (_) -> _ => intros H
| |- (spec _ _ _) -> _ => intros [_ Sf] (* drops the curried part *)
| |- (_) -> _ => intros Sf
end.
Ltac xspec_for_xapp H :=
xspec; xapp_extract_app_from_spec H.
(* [xapp_use_of_find H Sf] creates an hypothesis [Sf]
that is equal to [H] if [H] is not [___], else
finds a spec for the current function, and names it [Sf]. *)
Ltac xapp_use_of_find H Sf :=
match H with
| ___ => xspec
| _ => generalize H
end;
xapp_extract_app_from_spec_as Sf.
(* [xapp_prepare_goal] tactic for settings things up *)
......@@ -2109,9 +2145,21 @@ Ltac xapp_prepare_goal cont :=
| tag_seq => xseq; [ xuntag tag_apply; cont tt | instantiate; xextract ]
end.
Ltac xapp_instantiate H args :=
Ltac xapp_instantiate Sf args :=
let args := list_boxer_of args in
constr:((boxer H)::args).
constr:((boxer Sf)::args).
(* [xapp_instantiate_and_apply Sf args xapp_core cont]
instantiate the spec [Sf] on the arguments [args],
then calls [xapp_core] on the resulting lemma,
then calls the continuation on subgoals
then clears [Sf]. *)
Ltac xapp_instantiate_and_apply Sf args xapp_core cont :=
let K := xapp_instantiate Sf args in
xapp_core K;
cont tt;
clear Sf.
(* [xapp_common] executes [xapp] given
[H] as specification (or [___]),
......@@ -2122,8 +2170,9 @@ Ltac xapp_instantiate H args :=
Ltac xapp_common H E xapp_core cont :=
xapp_prepare_goal ltac:(fun _ =>
let K := xapp_instantiate H E in
xapp_core K; cont tt).
let Sf := fresh "Spec" in
xapp_use_of_find H Sf;
xapp_instantiate_and_apply Sf E xapp_core cont).
(* helper for [xapp] internal implementation *)
......@@ -2170,6 +2219,73 @@ Ltac xapp_as_core E X :=
[ xapp_core ___ (>>) ltac:(fun _ => idtac) (* = xapp *)
| instantiate; try xextract ].
(* Implementation for [xapp] debugging versions *)
Ltac xapp1_core tt :=
xapp_prepare_goal ltac:(fun _ => idtac).
Ltac xapp2_core tt :=
let Sf := fresh "Spec" in
xapp_use_of_find ___ Sf.
Ltac xapp2_spec_core H :=
let Sf := fresh "Spec" in
xapp_use_of_find H Sf.
Ltac xapp3_core args :=
let Sf := get_last_hyp tt in
let Sfi := fresh "SpecI" in
let K := xapp_instantiate Sf args in
generalize K; intros Sfi. (* ; clear Sf. *)
Ltac xapp4_core tt :=
eapply local_wframe; [ xlocal | | | ].
Ltac xapp5_core tt :=
let K := get_last_hyp tt in
sapply K.
Ltac xapp45_core tt :=
let K := get_last_hyp tt in
xapp_xapply_generic K ltac:(fun _ => idtac) ltac:(fun _ => idtac).
(* Notation for [xapp] debugging versions *)
Tactic Notation "xapp1" := xapp1_core tt.
Tactic Notation "xapp2" := xapp2_core tt.
Tactic Notation "xapp2_spec" constr(H) := xapp2_spec_core H.
Tactic Notation "xapp12" := xapp1; xapp2_core tt.
Tactic Notation "xapp12_spec" constr(H) := xapp1; xapp2_spec_core H.
Tactic Notation "xapp3" := xapp3_core (>>).
Tactic Notation "xapp3" constr(args) := xapp3_core args.
Tactic Notation "xapp4" := xapp4_core tt.
Tactic Notation "xapp5" := xapp5_core tt.
Tactic Notation "xapp45" := xapp45_core tt.
(* FUTURE
- [xapp_1] is like [xapp1]
- [xapp_2] is like [xapp1; xapp2]
- [xapp_3] is like [xapp1; xapp2; xapp3]
- [xapp_4] is like [xapp1; xapp2; xapp3; xapp4]
- [xapp_5] is like [xapp1; xapp2; xapp3; xapp4; xapp5]
Tactic Notation "xapp_1" := xapp1.
Tactic Notation "xapp_2" := xapp1; xapp2.
Tactic Notation "xapp_2_spec" constr(H) := xapp_1; xapp2_spec H.
Tactic Notation "xapp_3" := xapp_2; xapp3.
Tactic Notation "xapp_3" constr(args) := xapp_2; xapp3 args.
Tactic Notation "xapp_3_spec" constr(H) := xapp_2_spec H; xapp3.
Tactic Notation "xapp_3_spec" constr(H) constr(args) := xapp_2_spec H; xapp3 args.
Tactic Notation "xapp_4" := xapp_3; xapp4.
Tactic Notation "xapp_4" constr(args) := xapp_3 args; xapp4.
Tactic Notation "xapp_4_spec" constr(H) := xapp_spec H; xapp4.
Tactic Notation "xapp_4_spec" constr(H) constr(args) := xapp_3_spec H args; xapp4.
*)
(* Notation for [xapp] with automation and with hints *)
Tactic Notation "xapp" :=
......@@ -2485,8 +2601,12 @@ Tactic Notation "xapp" "*" constr(E) "as" simple_intropattern(X) :=
Variants:
- [xcf f] brings to the front of the goal the specification for [f].
- [xcf_show] will only display the CF lemma found in the database,
putting it in a fresh hypothesis.
- [xcf_show f] is similar, only [f] is provided explicitly.
*)
(* TODO: extend to support partial application *)
......@@ -2526,20 +2646,56 @@ Ltac xcf_core_app f :=
intros [_ H]; (* curried part not needed *)
xcf_core_app_exploit H. (* todo: might need sapply here *)
Ltac xcf_top_value f :=
xcf_find f;
let Sf := fresh "Spec" in
intros Sf;
try (rewrite Sf; clear Sf).
Ltac xcf_core tt :=
intros;
match goal with
| |- spec ?f ?n ?P => xcf_core_spec f
| |- app ?f ?xs ?H ?Q => xcf_core_app f
| |- tag tag_apply (app ?f ?xs ?H ?Q) => xuntag tag_apply; xcf_core_app f
end .
| |- ?f = _ => xcf_top_value f
| _ => fail 1 "need to call [xcf f; => H], where [f] is the name of the definition"
end.
Tactic Notation "xcf" :=
xcf_core tt.
Tactic Notation "xcf" constr(f) :=
xcf_find f;
try match goal with |- tag tag_top_val _ -> _ =>
let H := fresh in intros H; hnf in H; revert H end.
Ltac xcf_show_name f :=
let H := fresh "S" (*f*) in intros H;
try match type of H with tag tag_top_val _ => hnf in H end.
(* TODO: can't we make a name based on f? *)
Ltac xcf_show_core tt :=
intros;
let f :=
match goal with
| |- spec ?f ?n ?P => constr:(f)
| |- app ?f ?xs ?H ?Q => constr:(f)
| |- tag tag_apply (app ?f ?xs ?H ?Q) => constr:(f)
| |- ?f = _ => constr:(f)
| _ => fail 1 "need to call [xcf_show f], where [f] is the name of the definition"
end in
xcf_find f; xcf_show_name f.
Tactic Notation "xcf_show" :=
let f := cfml_get_goal_fun tt in xcf_find f;
let H := fresh "S" f in intros H.
xcf_show_core tt.
Tactic Notation "xcf_show" constr(f) :=
xcf_find f; xcf_show_name f.
Tactic Notation "xcf" "~" := xcf; xauto_tilde.
Tactic Notation "xcf" "*" := xcf; xauto_star.
(********************************************************************)
......
......@@ -19,11 +19,11 @@ SRC :=\
CFPrint \
CFHeader \
CFTactics \
CFRep \
CFLib
# CFLibCredits \
# CFLibCreditsNat
# CFRep \
V := $(SRC:=.v)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment