Ltac check_witness_type' ts A witness :=
(unify A (rmaps.ConstType Ridiculous); (* because [is_evar A] doesn't seem to work *)
elimtype False)
||
let TA := constr:(functors.MixVariantFunctor._functor
(rmaps.dependent_type_functor_rec ts A) mpred) in
let TA' := eval cbv
[functors.MixVariantFunctor._functor
functors.MixVariantFunctorGenerator.fpair
functors.MixVariantFunctorGenerator.fconst
functors.MixVariantFunctorGenerator.fidentity
rmaps.dependent_type_functor_rec
functors.GeneralFunctorGenerator.CovariantBiFunctor_MixVariantFunctor_compose
functors.CovariantFunctorGenerator.fconst
functors.CovariantFunctorGenerator.fidentity
functors.CovariantBiFunctor._functor
functors.CovariantBiFunctorGenerator.Fpair
functors.GeneralFunctorGenerator.CovariantFunctor_MixVariantFunctor
functors.CovariantFunctor._functor
functors.MixVariantFunctor.fmap
] in TA
in let TA'' := eval simpl in TA'
in match type of witness with ?T =>
unify T TA''
+ (fail "Type of witness does not match type required by funspec WITH clause.
Witness value: " witness "
Witness type: " T "
Funspec type: " TA'')
end.
Ltac prove_call_setup' ts witness :=
prove_call_setup1 subsume_funspec_refl;
[ .. |
match goal with |- call_setup1  _ _ _ _ _ _ _ _ _ _ _ _ _ _ ?A _ _ _ _ _ _ _ -> _ =>
check_witness_type' ts A witness
end;
let H := fresh in
intro H;
match goal with | |- @semax ?CS _ _ _ _ _ =>
let Frame := fresh "Frame" in evar (Frame: list mpred);
exploit (call_setup2'_i _ _ _ _ _ _ _ _ _ _ _ _ _ _ ts _ _ _ _ _ _ _ _ H witness Frame); clear H;
simpl functors.MixVariantFunctor._functor;
[ reflexivity
| check_prove_local2ptree
| Forall_pTree_from_elements
| unfold check_gvars_spec; solve [exact I | reflexivity]
| try change_compspecs CS; cancel_for_forward_call
|
]
end].

Lemma semax_call_aux55:
forall (cs: compspecs) (Qtemp: PTree.t val) (Qvar: PTree.t (type * val)) GV (a: expr)
Delta P Q R fs argsig retty (*cc ts A Pre Post NEPre NEPost  *)
ts (A : rmaps.TypeTree)
(Pre
Post : forall ts : list Type,
functors.MixVariantFunctor._functor
(rmaps.dependent_type_functor_rec
ts (AssertTT A)) mpred)
witness Frame bl Ppre Qpre Rpre Qactuals Qpre_temp GV' vl
(PTREE : local2ptree Q = (Qtemp, Qvar, nil, GV))
(TC0 : ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |-- tc_expr Delta a)
(TC1 : ENTAIL Delta, PROPx P (LOCALx Q (SEPx R))
|-- tc_exprlist Delta (argtypes argsig) bl)
(MSUBST : force_list (map (msubst_eval_expr Delta Qtemp Qvar GV)
(explicit_cast_exprlist (argtypes argsig) bl)) = Some vl)
(PTREE'' : pTree_from_elements (combine (var_names argsig) vl) = Qactuals)
(PRE1 : Pre ts witness = PROPx Ppre (LOCALx Qpre (SEPx Rpre)))
(PTREE' : local2ptree Qpre = (Qpre_temp, PTree.empty _, nil, GV'))
(CHECKTEMP : Forall (check_one_temp_spec Qactuals) (PTree.elements Qpre_temp))
(CHECKG: check_gvars_spec GV GV' )
(FRAME : fold_right_sepcon R
|-- fold_right_sepcon Rpre * fold_right_sepcon Frame)
(PPRE : fold_right_and True Ppre)
(LEN : length (argtypes argsig) = length bl),
ENTAIL Delta,
(EX v : val,
lift0 (func_ptr fs v) &&
local (` (eq v) (eval_expr a))) && |>PROPx P (LOCALx Q (SEPx R))
|-- |> (tc_expr Delta a && tc_exprlist Delta (argtypes argsig) bl) &&
(|> @liftx (Tarrow environ (LiftEnviron mpred)) (Pre ts witness)
(make_args' (argsig, retty) (eval_exprlist (argtypes argsig) bl)) *
` (func_ptr' fs)
(eval_expr a) * |>PROPx P (LOCALx Q (SEPx Frame))).