Commit 11e082f4 authored by charguer's avatar charguer

progress_tactics

parent 3d98a723
This diff is collapsed.
...@@ -8,47 +8,6 @@ open Pervasives ...@@ -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 *) (* ** Return *)
...@@ -169,7 +128,6 @@ let app_partial_builtin () = ...@@ -169,7 +128,6 @@ let app_partial_builtin () =
f 2 f 2
(********************************************************************) (********************************************************************)
(* ** Over applications *) (* ** Over applications *)
...@@ -178,6 +136,48 @@ let app_over_id () = ...@@ -178,6 +136,48 @@ let app_over_id () =
f f 3 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 *) (* ** Polymorphic let bindings *)
...@@ -330,6 +330,9 @@ let for_incr () = ...@@ -330,6 +330,9 @@ let for_incr () =
done; done;
!n !n
(* "for .. down to" not yet supported *)
(********************************************************************) (********************************************************************)
(* ** Recursive function *) (* ** Recursive function *)
......
This diff is collapsed.
...@@ -95,7 +95,8 @@ cf: $(ML) ...@@ -95,7 +95,8 @@ cf: $(ML)
# Make sure TLC and CFML itself are up-to-date. # Make sure TLC and CFML itself are up-to-date.
# Needed only when developing TLC and CFML. Ideally, should be removed. # Needed only when developing TLC and CFML. Ideally, should be removed.
@$(MAKE) -C $(CFML)/lib/tlc --no-print-directory quick @$(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) -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 @$(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 ...@@ -5,7 +5,7 @@ open Renaming
(*#########################################################################*) (*#########################################################################*)
(* ** Conversion of IMPERATIVE characteristic formulae to Coq *) (* ** Conversion of characteristic formulae to Coq *)
(* TODO: extract hard coded constants*) (* TODO: extract hard coded constants*)
......
...@@ -61,9 +61,8 @@ Ltac cfml_get_tag tt := ...@@ -61,9 +61,8 @@ Ltac cfml_get_tag tt :=
(** [cfml_check_not_tagged tt] fails if the head of the goal contains a tag *) (** [cfml_check_not_tagged tt] fails if the head of the goal contains a tag *)
Ltac cfml_check_not_tagged tt := Ltac cfml_check_not_tagged tt ::=
match goal with |- @tag ?t _ _ => fail 1 end. match goal with |- @tag ?t _ _ => fail 1 | _ => idtac end.
(** [xuntag T] removes the tag [T] at the head of the goal, (** [xuntag T] removes the tag [T] at the head of the goal,
and fails if it is not there. *) and fails if it is not there. *)
......
...@@ -2082,18 +2082,54 @@ Tactic Notation "xspec" := ...@@ -2082,18 +2082,54 @@ Tactic Notation "xspec" :=
- [xapps_spec] is not supported, use [xapp_spec], then [subst]. *) - [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 *) (* 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 match goal with
| |- (spec _ _ _) -> _ => intros [_ H] (* drops the curried part *) | |- (spec _ _ _) -> _ => intros [_ Sf] (* drops the curried part *)
| |- (_) -> _ => intros H | |- (_) -> _ => intros Sf
end. end.
Ltac xspec_for_xapp H := (* [xapp_use_of_find H Sf] creates an hypothesis [Sf]
xspec; xapp_extract_app_from_spec H. 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 *) (* [xapp_prepare_goal] tactic for settings things up *)
...@@ -2109,9 +2145,21 @@ Ltac xapp_prepare_goal cont := ...@@ -2109,9 +2145,21 @@ Ltac xapp_prepare_goal cont :=
| tag_seq => xseq; [ xuntag tag_apply; cont tt | instantiate; xextract ] | tag_seq => xseq; [ xuntag tag_apply; cont tt | instantiate; xextract ]
end. end.
Ltac xapp_instantiate H args := Ltac xapp_instantiate Sf args :=
let args := list_boxer_of args in 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 (* [xapp_common] executes [xapp] given
[H] as specification (or [___]), [H] as specification (or [___]),
...@@ -2122,8 +2170,9 @@ Ltac xapp_instantiate H args := ...@@ -2122,8 +2170,9 @@ Ltac xapp_instantiate H args :=
Ltac xapp_common H E xapp_core cont := Ltac xapp_common H E xapp_core cont :=
xapp_prepare_goal ltac:(fun _ => xapp_prepare_goal ltac:(fun _ =>
let K := xapp_instantiate H E in let Sf := fresh "Spec" in
xapp_core K; cont tt). xapp_use_of_find H Sf;
xapp_instantiate_and_apply Sf E xapp_core cont).
(* helper for [xapp] internal implementation *) (* helper for [xapp] internal implementation *)
...@@ -2170,6 +2219,73 @@ Ltac xapp_as_core E X := ...@@ -2170,6 +2219,73 @@ Ltac xapp_as_core E X :=
[ xapp_core ___ (>>) ltac:(fun _ => idtac) (* = xapp *) [ xapp_core ___ (>>) ltac:(fun _ => idtac) (* = xapp *)
| instantiate; try xextract ]. | 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 *) (* Notation for [xapp] with automation and with hints *)
Tactic Notation "xapp" := Tactic Notation "xapp" :=
...@@ -2485,8 +2601,12 @@ Tactic Notation "xapp" "*" constr(E) "as" simple_intropattern(X) := ...@@ -2485,8 +2601,12 @@ Tactic Notation "xapp" "*" constr(E) "as" simple_intropattern(X) :=
Variants: 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, - [xcf_show] will only display the CF lemma found in the database,
putting it in a fresh hypothesis. putting it in a fresh hypothesis.
- [xcf_show f] is similar, only [f] is provided explicitly.
*) *)
(* TODO: extend to support partial application *) (* TODO: extend to support partial application *)
...@@ -2526,20 +2646,56 @@ Ltac xcf_core_app f := ...@@ -2526,20 +2646,56 @@ Ltac xcf_core_app f :=
intros [_ H]; (* curried part not needed *) intros [_ H]; (* curried part not needed *)
xcf_core_app_exploit H. (* todo: might need sapply here *) 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 := Ltac xcf_core tt :=
intros;
match goal with match goal with
| |- spec ?f ?n ?P => xcf_core_spec f | |- spec ?f ?n ?P => xcf_core_spec f
| |- app ?f ?xs ?H ?Q => xcf_core_app 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 | |- 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" := Tactic Notation "xcf" :=
xcf_core tt. 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" := Tactic Notation "xcf_show" :=
let f := cfml_get_goal_fun tt in xcf_find f; xcf_show_core tt.
let H := fresh "S" f in intros H.
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 :=\ ...@@ -19,11 +19,11 @@ SRC :=\
CFPrint \ CFPrint \
CFHeader \ CFHeader \
CFTactics \ CFTactics \
CFRep \
CFLib CFLib
# CFLibCredits \ # CFLibCredits \
# CFLibCreditsNat # CFLibCreditsNat
# CFRep \
V := $(SRC:=.v) 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