@@ -447,6 +447,150 @@ let t_ecall_hoare_bwd ((cttpt, _) : proofterm * form) (tc : tcenv1) =
447447 EcPhlAuto. t_auto ?conv:None ; (* Kill the conseq from the call rule *)
448448 ] tc
449449
450+ (* -------------------------------------------------------------------- *)
451+ (* Backward ecall on bdHoare/phoare goals (ecall without ->>).
452+ *
453+ * Mirrors t_ecall_hoare_bwd but for a bdHoare goal and a bdHoare/phoare
454+ * contract. We abstract program-variable arguments of the contract pterm
455+ * into fresh local idents, dispatch to [t_call None ctt] (which routes
456+ * via [t_call]'s (FbdHoareF, FbdHoareS) arm to [t_bdhoare_call]), then
457+ * re-generalize over the abstracted idents in the residual goals.
458+ *
459+ * Unlike the hoare bwd variant, we do not elaborate a [t_hoare_seq]
460+ * splitting the prefix from the call: the bdhoare seq variant requires
461+ * an additional probability split which we cannot infer here. As a
462+ * result the user gets the same shape of subgoals that plain
463+ * [call (lemma)] would produce, but with program-variable arguments
464+ * handled by ecall's abstraction machinery.
465+ *)
466+ let t_ecall_bdhoare_bwd ((cttpt , _ ) : proofterm * form ) (tc : tcenv1 ) =
467+ let hyps = FApi. tc1_hyps tc in
468+ let env = EcEnv.LDecl. toenv hyps in
469+ let concl = destr_bdHoareS (FApi. tc1_goal tc) in
470+ let m = fst (concl.bhs_m) in
471+ let call, _ = pf_last_call !! tc concl.bhs_s in
472+
473+ let pvs = PT. collect_pvars_from_pt cttpt in
474+ let ids, _, pvs_as_inv, subst = abstract_pvs hyps [m] pvs in
475+
476+ let cttpt =
477+ let pt_head, pt_args =
478+ match cttpt with
479+ | PTApply { pt_head; pt_args } -> (pt_head, pt_args)
480+ | _ -> assert false in
481+ let pt_args = List. map (PT. subst_pv_pt_arg env subst) pt_args in
482+ PTApply { pt_head; pt_args } in
483+
484+ let cttpt, ctt = EcLowGoal.LowApply. check `Elim cttpt (`Hyps (hyps, !! tc)) in
485+
486+ let ctt =
487+ EcReduction. h_red_opt EcReduction. full_red hyps ctt
488+ |> odfl ctt in
489+
490+ let ids_subst =
491+ List. fold_left2
492+ (fun s (id , _ ) pv -> EcSubst. add_flocal s id (inv_of_inv pv))
493+ EcSubst. empty ids pvs_as_inv in
494+
495+ let fpre, fpost =
496+ let hf = destr_bdHoareF ctt in
497+ (ss_inv_rebind (bhf_pr hf) m).inv, (ss_inv_rebind (bhf_po hf) m).inv
498+ in
499+
500+ let post =
501+ EcPhlCall. compute_hoare_call_post
502+ hyps m (fpre, POE. empty fpost) call
503+ (POE. empty (bhs_po concl).inv) in
504+ let post = EcSubst. subst_form ids_subst post in
505+
506+ (* Trivial probability split for FHeq with bound 1%r (lossless body):
507+ pR = true, f1=f2=1%r, g1=g2=0%r. Yields:
508+ - cond_phi : f_hoareS pre s1 post (user-level prefix, as hoare)
509+ - condf1 : pre s1 true 1%r (lossless prefix, trivial for det. code)
510+ - condf2 : phi s2 bhs_po 1%r (suffix bdhoare, target of t_call)
511+ - condg1 : pre s1 false 0%r (trivial)
512+ - condbd : 1*1+0*0 = bd (trivial when bd=1%r)
513+ - condnm : forall r1 r2 ... (trivial) *)
514+ let seq_info =
515+ let phi = { m; inv = post } in
516+ let pR = { m; inv = f_true } in
517+ let f1 = { m; inv = f_r1 } in
518+ let f2 = { m; inv = f_r1 } in
519+ let g1 = { m; inv = f_r0 } in
520+ let g2 = { m; inv = f_r0 } in
521+ (phi, pR, f1, f2, g1, g2)
522+ in
523+
524+ let tc = EcPhlSeq. t_bdhoare_seq (GapBefore cpos1_last) seq_info tc in
525+ (* Subgoal order from t_bdhoare_seq (with f1≠0, f2≠0, g1=0):
526+ [cond_phi; condf1; condf2; condg1; condbd; condnm]
527+ We apply the exists+intros+t_call pipeline to condf2 (the suffix).
528+ The intros chain leaves a single bdhoare goal on which t_call produces
529+ two subgoals (contract obligation + conseq); we then dispatch via
530+ t_seqsub. *)
531+ let condf2_tactic =
532+ FApi. t_seqs [
533+ t_hr_exists_intro_r pvs_as_inv;
534+ t_hr_exists_elim_r ~bound: (List. length ids);
535+ t_intros_i (List. fst ids);
536+ FApi. t_seqsub
537+ (EcPhlCall. t_call None ctt)
538+ [ EcLowGoal.Apply. t_apply_bwd_hi ~dpe: true cttpt;
539+ EcPhlAuto. t_auto ?conv:None ; ];
540+ ]
541+ in
542+
543+ (* t_bdhoare_seq_r auto-closes condnm via t_try, so the count is 5 (or 6 if
544+ that auto fails). Use t_onalli with an index-based dispatcher to be
545+ robust to either count. Order (0-indexed):
546+ 0 -> cond_phi (HOARE prefix): lift to BDHOARE [pre ==> phi] FHeq 1%r
547+ via t_hoareS_conseq_bdhoare. This is sound under losslessness of
548+ the prefix — which the user proves as part of the residual goal.
549+ Subsequent ecalls then dispatch through our bdhoare arm and accept
550+ phoare contracts.
551+ 2 -> condf2 (suffix call dance)
552+ others -> auto (trivial bound conditions). *)
553+ let tc =
554+ FApi. t_onalli
555+ (fun i ->
556+ if i = 0 then EcPhlConseq. t_hoareS_conseq_bdhoare
557+ else if i = 2 then condf2_tactic
558+ else EcPhlAuto. t_auto ?conv:None )
559+ tc
560+ in
561+
562+ tc
563+
564+ (* -------------------------------------------------------------------- *)
565+ let process_ecall_bdhoare
566+ (dir : APT.pdirection )
567+ (pterm : APT.pecall )
568+ (tc : tcenv1 )
569+ =
570+ if dir <> `Backward then
571+ tc_error !! tc " forward ecall on bdHoare/phoare goals is not supported" ;
572+
573+ let (ctt_path, ctt_tvi, ctt_args) = pterm in
574+ let hyps = FApi. tc1_hyps tc in
575+ let concl = destr_bdHoareS (FApi. tc1_goal tc) in
576+
577+ (* Type-check contract (lemma) - apply it fully to find the bdHoare contract *)
578+ let ptenv = PT. ptenv_of_penv (LDecl. push_active_ss concl.bhs_m hyps) !! tc in
579+ let contract = PT. process_pterm ptenv (APT. FPNamed (ctt_path, ctt_tvi)) in
580+ let contract, _ = PT. process_pterm_args_app contract ctt_args in
581+ let contract = PT. apply_pterm_to_max_holes hyps contract in
582+
583+ assert (PT. can_concretize contract.PT. ptev_env);
584+ let contract = PT. concretize contract in
585+
586+ let call, _ = pf_last_call !! tc concl.bhs_s in
587+
588+ check_contract_type
589+ ~phoare: true ~noexn: false ~loc: (L. loc ctt_path) ~name: (L. unloc ctt_path)
590+ !! tc hyps (`Single call) (snd contract);
591+
592+ t_ecall_bdhoare_bwd contract tc
593+
450594(* -------------------------------------------------------------------- *)
451595let process_ecall_hoare
452596 (dir : APT.pdirection )
@@ -624,7 +768,12 @@ let process_ecall
624768 tc_error !! tc " cannot provide a side for Hoare goals" ;
625769 process_ecall_hoare dir pterm tc
626770
771+ | FbdHoareS _ ->
772+ if Option. is_some oside then
773+ tc_error !! tc " cannot provide a side for bdHoare/phoare goals" ;
774+ process_ecall_bdhoare dir pterm tc
775+
627776 | FequivS _ ->
628777 process_ecall_equiv dir oside pterm tc
629778
630- | _ -> tc_error_noXhl ~kinds: [`Hoare `Stmt ; `Equiv `Stmt ] !! tc
779+ | _ -> tc_error_noXhl ~kinds: [`Hoare `Stmt ; `PHoare `Stmt ; ` Equiv `Stmt ] !! tc
0 commit comments