------------------------------------------------------------------------------
--                                                                          --
--                            GNAT2WHY COMPONENTS                           --
--                                                                          --
--                   G N A T 2 W H Y - S U B P R O G R A M S                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2010-2023, AdaCore                     --
--                                                                          --
-- gnat2why is  free  software;  you can redistribute  it and/or  modify it --
-- under terms of the  GNU General Public License as published  by the Free --
-- Software  Foundation;  either version 3,  or (at your option)  any later --
-- version.  gnat2why is distributed  in the hope that  it will be  useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of  MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
-- License for  more details.  You should have  received  a copy of the GNU --
-- General  Public License  distributed with  gnat2why;  see file COPYING3. --
-- If not,  go to  http://www.gnu.org/licenses  for a complete  copy of the --
-- license.                                                                 --
--                                                                          --
-- gnat2why is maintained by AdaCore (http://www.adacore.com)               --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Containers.Doubly_Linked_Lists;
with Ada.Strings.Unbounded;          use Ada.Strings.Unbounded;
with Atree;
with Debug;
with Errout;                         use Errout;
with Exp_Util;
with Flow_Dependency_Maps;           use Flow_Dependency_Maps;
with Flow_Generated_Globals;         use Flow_Generated_Globals;
with Flow_Generated_Globals.Phase_2; use Flow_Generated_Globals.Phase_2;
with Flow_Refinement;                use Flow_Refinement;
with Flow_Utility;                   use Flow_Utility;
with GNAT.Source_Info;
with Gnat2Why.Data_Decomposition; use Gnat2Why.Data_Decomposition;
with Gnat2Why.Error_Messages;        use Gnat2Why.Error_Messages;
with Gnat2Why.Expr;                  use Gnat2Why.Expr;
with Gnat2Why.Tables;                use Gnat2Why.Tables;
with Gnat2Why_Args;
with Namet;                          use Namet;
with Nlists;                         use Nlists;
with Opt;                            use type Opt.Warning_Mode_Type;
with Rtsfind;                        use Rtsfind;
with Sinput;                         use Sinput;
with Snames;                         use Snames;
with SPARK_Definition;               use SPARK_Definition;
with SPARK_Util;                     use SPARK_Util;
with SPARK_Util.Subprograms;         use SPARK_Util.Subprograms;
with SPARK_Util.Types;               use SPARK_Util.Types;
with Stand;                          use Stand;
with Uintp;                          use Uintp;
with VC_Kinds;                       use VC_Kinds;
with Why;                            use Why;
with Why.Atree.Accessors;            use Why.Atree.Accessors;
with Why.Atree.Builders;             use Why.Atree.Builders;
with Why.Atree.Modules;              use Why.Atree.Modules;
with Why.Atree.Mutators;             use Why.Atree.Mutators;
with Why.Gen.Arrays;                 use Why.Gen.Arrays;
with Why.Gen.Decl;                   use Why.Gen.Decl;
with Why.Gen.Init;                   use Why.Gen.Init;
with Why.Gen.Names;                  use Why.Gen.Names;
with Why.Gen.Pointers;               use Why.Gen.Pointers;
with Why.Gen.Progs;                  use Why.Gen.Progs;
with Why.Gen.Records;                use Why.Gen.Records;
with Why.Inter;                      use Why.Inter;
with Why.Types;                      use Why.Types;

package body Gnat2Why.Subprograms is

   Subprogram_Exceptions : Why_Node_Sets.Set;
   --  Set of exception declarations

   -----------------------
   -- Local Subprograms --
   -----------------------

   function Add_Logic_Binders
     (E           : Entity_Id;
      Raw_Binders : Item_Array;
      More_Reads  : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
      return Item_Array;
   --  Return Why binders for the parameters and read effects of function E.
   --  The array is a singleton of unit type if E has no parameters and no
   --  effects. More_Reads is a set of globals that should be considered as
   --  read by the subprogram in addition to its actual inputs. It is used to
   --  handle calls with higher order specialization.

   function Assume_Initial_Condition_Of_Withed_Units
     (Main   : Entity_Id;
      Params : Transformation_Params) return W_Prog_Id
   with Pre => Ekind (Main) in Subprogram_Kind | E_Package | E_Package_Body
     and then Is_Compilation_Unit (Main);
   --  Assume the Initial_Condition of every unit withed by a compilation unit.
   --  @param Main entity for a compilation unit
   --  @param Params the transformation parameters
   --  @result a sequence of assumptions, one for each withed unit which has an
   --          Initial_Condition.

   function Check_Ceiling_Protocol
     (Params : Transformation_Params;
      E      : Entity_Id) return W_Prog_Id
     with Pre => Ekind (E) in E_Task_Type | E_Entry | E_Function | E_Procedure;
   --  @param Params the transformation params
   --  @param E a task type, entry, main-like or protected subprogram entity
   --  @return an assertion or sequence of assertion that expresses that the
   --    ceiling protocol is respected in the call graph starting from this
   --    entity, i.e. that external calls to protected operations are made with
   --    a priority lower or equal to the priority of the object in question.

   function Check_Type_Invariants_For_Package
     (E      : Entity_Id;
      Params : Transformation_Params) return W_Prog_Id
   with
     Pre => Ekind (E) = E_Package;
   --  @param E Entity of a package
   --  @param Params the transformation parameters
   --  @result program peforming an invariant check after E's elaboration

   procedure Clear_Exceptions;
   --  Initialization procedure to call before start of subprogram/package
   --  handling.

   function Compute_Args
     (E          : Entity_Id;
      Binders    : Binder_Array;
      More_Reads : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
      return W_Expr_Array;
   --  Given a function entity, and an array of program binders,
   --  compute a call of the logical Why function corresponding to E.
   --  In general, the resulting expression array has *more* arguments than the
   --  Ada entity, because of effects. Note that these effect variables are not
   --  bound here, they refer to the global variables.
   --  More_Reads is a set of globals that should be considered as read by
   --  the subprogram in addition to its actual inputs. It is used to handle
   --  calls with higher order specialization.

   function Compute_Attach_Handler_Check
     (Ty     : Entity_Id;
      Params : Transformation_Params) return W_Prog_Id
     with Pre => Is_Protected_Type (Ty);
   --  @param Ty a protected type
   --  @return an assertion (if necessary) that checks if any of the
   --    Attach_Handler pragmas of the procedures of the type is reserved
   --    see also Ada RM C.3.1(10/3)

   function Compute_Binders
     (E          : Entity_Id;
      Domain     : EW_Domain;
      More_Reads : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
      return Item_Array;
   --  Return Why binders for the parameters of subprogram E.
   --  More_Reads is a set of globals that should be considered as read by
   --  the subprogram in addition to its actual inputs. It is used to handle
   --  calls with higher order specialization.
   --  If Domain is EW_Term also generates binders for E's read effects.
   --  The array is a singleton of unit type if the array is empty.

   function Compute_Contract_Cases_Entry_Checks
     (E         : Entity_Id;
      Guard_Map : Ada_To_Why_Ident.Map) return W_Prog_Id;
   --  Returns the Why program for checking that the guards of the
   --  Contract_Cases pragma attached to subprogram E (if any) are disjoint,
   --  and that they cover all cases prescribed by the precondition. The checks
   --  that evaluating guards do not raise run-time errors are done separately,
   --  based on the result of Compute_Contract_Cases_Guard_Map. Guard_Map
   --  stores a mapping from guard AST nodes to temporary Why names, so that
   --  the caller can compute the Why expression for these in the pre-state,
   --  and bind them appropriately.

   function Compute_Contract_Cases_Exit_Checks
     (Params             : Transformation_Params;
      E                  : Entity_Id;
      Guard_Map          : Ada_To_Why_Ident.Map;
      Others_Guard_Ident : W_Identifier_Id) return W_Prog_Id;
   --  Returns in Result the Why program for checking that the consequence of
   --  enabled guard of the Contract_Cases pragma attached to subprogram E (if
   --  any) does not raise a run-time error, and that it holds. Guard_Map
   --  stores a mapping from guard AST nodes to temporary Why names, so that
   --  the caller can compute the Why expression for these in the pre-state,
   --  and bind them appropriately.

   procedure Compute_Contract_Cases_Guard_Map
     (E                  : Entity_Id;
      Guard_Map          : out Ada_To_Why_Ident.Map;
      Others_Guard_Ident : out W_Identifier_Id;
      Others_Guard_Expr  : out W_Term_Id);
   --  Returns the map from contracts cases nodes attached to subprogram E,
   --  if any, to Why identifiers for the value of these guards in the Why3
   --  program. If the contract cases contain an "others" case, return in
   --  Others_Guard_Ident an identifier for a Boolean value set to true when
   --  this case is enabled, and in Others_Guard_Expr the Why3 expression
   --  to define this identifier. If there is no "others" case, return with
   --  Others_Guard_Ident set to Why_Empty.

   function Compute_Exceptional_Cases_Postcondition
     (Params : Transformation_Params;
      E      : Callable_Kind_Id;
      Exc_Id : W_Identifier_Id)
      return W_Pred_Id;
   --  Returns the postcondition corresponding to the Exceptional_Cases pragma
   --  for subprogram E (if any), to be used in the raises effect of the
   --  program function.

   function Compute_Dynamic_Property_For_Effects
     (E           : Entity_Id;
      Params      : Transformation_Params;
      Exceptional : Boolean := False) return W_Pred_Id;
   --  Returns an assumption including the dynamic property of every object
   --  modified by a subprogram. If Exceptional is True, only consider
   --  parameters passed by reference and no not assume top-level
   --  initialization of by reference formals with Relaxed_Initialization.

   function Compute_Effects
     (E             : Entity_Id;
      Global_Params : Boolean := False;
      More_Reads    : Flow_Types.Flow_Id_Sets.Set :=
        Flow_Types.Flow_Id_Sets.Empty_Set)
      return W_Effects_Id;
   --  Compute the effects of the generated Why function. If Global_Params is
   --  True, then the global version of the parameters is used.
   --  More_Reads is a set of globals that should be considered as read by
   --  the subprogram in addition to its actual inputs. It is used to handle
   --  calls with higher order specialization.

   function Compute_Guard_Formula
     (Binders : Item_Array;
      Params  : Transformation_Params) return W_Pred_Id;
   --  For every object in the binder array, build a predicate for the dynamic
   --  invariant of the object and join everything together with a conjunction.

   function Compute_Guard_For_Dispatch
     (Subp    : Entity_Id;
      Binders : Item_Array;
      W_Tag   : W_Term_Id;
      Params  : Transformation_Params) return W_Pred_Id;
   --  For every object in the binder array whose type matches the dispatching
   --  type of Subp, state that the tag of the object is equal to W_Tag.

   function Compute_Inlined_Expr
     (Function_Entity    : Entity_Id;
      Logic_Func_Binders : Item_Array;
      W_Return_Type      : W_Type_Id;
      Params             : Transformation_Params)
      return W_Term_Id;
   --  @param Function_Entity entity of a function
   --  @param Logic_Func_Binders binders for Function_Entity's declaration if
   --     local names should be used for these binders
   --  @param W_Return_Type Why3 type for Function_Entity's return type
   --  @param Params parameters for the translation
   --  @return if Function_Entity is non recursive and has a pragma
   --     Annotate (GNATprove, Inline_For_Proof), return the Why3 expression
   --     for its value; if Function_Entity has a pragma Annotate (GNATprove,
   --     Logic_Equal), return a call to the builtin equality of Why3;
   --     otherwise return Why_Empty.

   function Compute_Moved_Property_For_Deep_Outputs
     (E      : Entity_Id;
      Params : Transformation_Params) return W_Prog_Id
   with
     Pre => Ekind (E) in E_Procedure      |
                         E_Function       |
                         E_Package        |
                         E_Task_Type      |
                         E_Entry          |
                         E_Subprogram_Type;
   --  Compute the program assuming that deep outputs of E have all pointers
   --  moved at subprogram entry.

   function Compute_Raw_Binders (E : Entity_Id) return Item_Array;
   --  Return Why binders for the parameters of subprogram E. The array is
   --  empty if E has no parameters.

   function Compute_Type_Invariants_For_Subprogram
     (E           : Entity_Id;
      Params      : Transformation_Params;
      For_Input   : Boolean;
      Exceptional : Boolean := False) return W_Pred_Id
   with
     Pre  => (Is_Subprogram_Or_Entry (E) or Ekind (E) = E_Subprogram_Type)
       and then (if Exceptional then not For_Input),
     Post => (if For_Input then
                Is_True_Boolean
                  (+Compute_Type_Invariants_For_Subprogram'Result)
                /= Subp_Needs_Invariant_Checks (E));
   --  @param E Entity of a subprogram or entry.
   --  @param Params the transformation parameters
   --  @param For_Input True if we are interested in inputs of E, False if we
   --         are interested in its outputs.
   --  @param Exceptional True if we are interested in outputs of E on
   --         exceptional paths.
   --  @result a predicate including the type invariants that should be checked
   --          on entry/exit of E.

   procedure Declare_Exceptions (Th : Theory_UC);
   --  Declare exceptions needed for translation of the current unit. Those
   --  are introduced when translating loop exit statements and goto
   --  statements.

   procedure Generate_Dispatch_Compatibility_Axioms
     (Th : Theory_UC;
      E  : Entity_Id)
   with Pre => Is_Dispatching_Operation (E)
     and then not Is_Hidden_Dispatching_Operation (E);
   --  @param E a dispatching subprogram
   --  Emit compatibility axioms between the dispatching version of E and each
   --  visible overriding / inherited versions of E.

   function Get_Location_For_Aspect
     (E         : Entity_Id;
      Kind      : Pragma_Id;
      Classwide : Boolean := False;
      Inherited : Boolean := False) return Node_Id
   with Pre => Kind in Pragma_Precondition
                     | Pragma_Postcondition
                     | Pragma_Refined_Post;
   --  Return a node with a proper location for the pre- or postcondition of E,
   --  if any.

   function Include_Non_Local_Type_Inv_For_Subp
     (E : Entity_Id) return W_Term_Id
   is
     (if not Is_Globally_Visible (E)
      and then not Is_Declared_In_Main_Unit_Or_Parent (E)
      then False_Term
      else True_Term);
   --  If E is a private subprogram, type invariants of its enclosing units may
   --  be broken for its parameters and result. Ignore type invariants for
   --  private subprograms declared in other library units (for those declared
   --  in the current unit, it is OK, as local subprograms are already not part
   --  of the dynamic invariant).

   function Insert_Bindings_For_Variants
     (E      : Entity_Id;
      Prog   : W_Prog_Id;
      Domain : EW_Domain;
      Params : Transformation_Params) return W_Prog_Id;
   --  Add binding for the initial value of variants

   function Number_Of_Func_Args (E : Entity_Id) return Natural is
     (Number_Formals (E)
       + (if Need_Self_Binder (E) then 1 else 0));

   function Preservation_Of_Access_Parameters
     (E      : Entity_Id;
      Params : Transformation_Params) return W_Pred_Id;
   --  Access parameters are mutable, but the bounds or discriminants of their
   --  designated value cannot be modified. Generate an assumption saying they
   --  are preserved.

   function Procedure_Logic_Binders (E : Entity_Id) return Binder_Array;
   --  Return binders that should be used for specific_post of a procedure E

   function Tag_Binder return Binder_Type is
      (Binder_Type'(Ada_Node => Empty,
                    B_Name   =>
                       New_Identifier
                      (Name   => To_String (WNE_Attr_Tag),
                       Typ    => EW_Int_Type),
                    B_Ent    => Null_Entity_Name,
                    Mutable  => False,
                    Labels   => <>));
   --  Binder to be used as additional tag argument for dispatching functions

   function Wrap_Post_Of_Traversal
     (E      : Entity_Id;
      Post   : W_Pred_Id;
      Args   : W_Expr_Array;
      Params : Transformation_Params) return W_Pred_Id
   with Pre => Is_Borrowing_Traversal_Function (E);
   --  The postcondition of traversal functions might refer to the value of the
   --  result of the function and the borrowed parameter at the end of the
   --  borrow (if it contains a call to a pledge function). Introduce bindings
   --  for them.

   ----------------------------------------------
   -- Assume_Initial_Condition_Of_Withed_Units --
   ----------------------------------------------

   function Assume_Initial_Condition_Of_Withed_Units
     (Main   : Entity_Id;
      Params : Transformation_Params) return W_Prog_Id
   is
      CU           : constant Node_Id := Enclosing_Comp_Unit_Node (Main);
      Context_Item : Node_Id;
      Assumption   : W_Prog_Id := +Void;
      Withed_Unit  : Node_Id;
      Withed       : Entity_Id;

   begin
      pragma Assert (Present (CU));

      --  For each withed unit which is a package declaration, assume its
      --  Initial_Condition if the elaboration of the withed unit is known
      --  to precede the elaboration of E.

      Context_Item := First (Context_Items (CU));
      while Present (Context_Item) loop
         if Nkind (Context_Item) = N_With_Clause
           and then not Limited_Present (Context_Item)
         then
            Withed_Unit := Unit (Library_Unit (Context_Item));
            Withed := (if Present (Withed_Unit) then
                         Unique_Defining_Entity (Withed_Unit)
                       else Empty);

            if Nkind (Withed_Unit) = N_Package_Declaration
              and then Known_To_Precede (Withed => Withed, Main => Main)
            then
               declare
                  Init_Cond : constant Node_Id :=
                    Get_Pragma (Withed, Pragma_Initial_Condition);
               begin
                  if Present (Init_Cond) then
                     declare
                        Expr : constant Node_Id :=
                          Expression
                            (First (Pragma_Argument_Associations (Init_Cond)));
                     begin
                        Append
                          (Assumption,
                           New_Assume_Statement
                             (Pred => Transform_Pred
                                  (Expr, EW_Bool_Type, Params)));
                     end;
                  end if;
               end;

            --  Otherwise raise a warning if --info is given and there is an
            --  Initial_Condition.

            elsif Debug.Debug_Flag_Underscore_F
              and then Nkind (Withed_Unit) = N_Package_Declaration
            then
               declare
                  Init_Cond : constant Node_Id :=
                    Get_Pragma (Withed, Pragma_Initial_Condition);
               begin
                  if Present (Init_Cond)
                    and then (Ekind (Main) /= E_Package_Body
                              or else Withed /= Unique_Entity (Main))
                  then
                     Error_Msg_NE
                       ("info: ?"
                        & "Initial_Condition of package & is ignored",
                        Main, Withed);
                     Error_Msg_NE
                       ("\the elaboration of & is not known to precede the"
                        & " elaboration of the current unit",
                        Main, Withed);
                     Error_Msg_NE
                       ("\use pragma Elaborate_Body in & or pragma Elaborate"
                        & " in the current unit",
                        Main, Withed);
                  end if;
               end;
            end if;
         end if;

         Next (Context_Item);
      end loop;

      return Assumption;
   end Assume_Initial_Condition_Of_Withed_Units;

   ----------------------------
   -- Check_Ceiling_Protocol --
   ----------------------------

   function Check_Ceiling_Protocol
     (Params : Transformation_Params;
      E      : Entity_Id) return W_Prog_Id is

      function Self_Priority return W_Term_Id;
      --  @return expression for the priority of entity E

      -------------------
      -- Self_Priority --
      -------------------

      function Self_Priority return W_Term_Id is
         --  If the priority is not explicitly specified then assume:
         --    * for main-like subprograms -> System.Default_Priority,
         --    * for tasks                 -> System.Priority'Last
         --    * for protected subprograms ->
         --        System.Priority'Last or System.Interrupt_Priority'Last
         --  which are worst-cases for tasks and protected subprograms
         --  and exact value for main-like subprograms.

         --  To know the exact value for tasks we would have to know the
         --  priority inherited from the enviromental task; the exact value
         --  for protected subprograms with Interrupt_Handler or Attach_Handler
         --  present is implementation-specific (but in GNAT it is
         --  System.Interrupt_Priority'Last, so we are exact).
         --
         --  For details on default priorities see RM D.1 (19) and D.3 (10,11).

         Pragma_Entity : constant Entity_Id :=
           (if Ekind (E) = E_Task_Type
              then E
            elsif Ekind (E) in Subprogram_Kind and then Might_Be_Main (E)
              then E
            elsif Is_Protected_Operation (E) then Enclosing_Type (E)
            else raise Program_Error);
         --  Entity where Priority or Interrupt_Priority pragma is attached

         Prio_Expr     : constant Node_Id :=
           Get_Priority_Or_Interrupt_Priority (Pragma_Entity);
         --  Priority expression

      begin

         if Present (Prio_Expr) then
            return Transform_Term (Prio_Expr, EW_Int_Type, Params);
         end if;

         --  No explicit priority was given

         if Ekind (E) = E_Task_Type then
            --  If pragma Interrupt_Priority is present then build expression
            --  for System.Interrupt_Priority'Last; otherwise for
            --  System.Priority'Last.
            return
              +New_Attribute_Expr
                (Domain => EW_Term,
                 Ty     =>
                   RTE (if Present
                            (Get_Rep_Item (E, Name_Interrupt_Priority))
                        then RE_Interrupt_Priority
                        else RE_Priority),
                 Attr   => Attribute_Last,
                 Params => Params);

         elsif Ekind (E) in Subprogram_Kind and then Might_Be_Main (E) then
            --  Return expression used that defined System.Default_Priority
            return
              Transform_Term
                (Expr   =>
                   Expression
                     (Enclosing_Declaration (RTE (RE_Default_Priority))),
                 Params => Params);

         else
            pragma Assert (Is_Protected_Operation (E));
            declare
               PT : constant Entity_Id := Enclosing_Type (E);

               Type_Id : RE_Id;
               Attr_Id : Supported_Attribute_Id;
               --  Type and attribute for priority expression
            begin
               if Present (Get_Rep_Item (PT, Name_Interrupt_Priority))
               then
                  --  Pragma Interrupt_Priority without expression defaults to
                  --  Interrupt_Priority'Last; RM J.15(12).
                  Type_Id := RE_Interrupt_Priority;
                  Attr_Id := Attribute_Last;

               elsif Has_Interrupt_Handler (PT)
                 or else Has_Attach_Handler (PT)
               then
                  --  Assume the worst case of implementation-defined value
                  --  within Interrupt_Priority; RM D.3(10).
                  Type_Id := RE_Interrupt_Priority;
                  Attr_Id := Attribute_First;

               else
                  --  Default priority for protected type is Priority'Last
                  Type_Id := RE_Priority;
                  Attr_Id := Attribute_Last;

               end if;

               return
                 +New_Attribute_Expr
                   (Domain => EW_Term,
                    Ty     => RTE (Type_Id),
                    Attr   => Attr_Id,
                    Params => Params);

            end;
         end if;

      end Self_Priority;

   --  Start of processing for Check_Ceiling_Protocol

   begin

      if Ekind (E) not in E_Task_Type | E_Entry
        and then not Might_Be_Main (E)
        and then not Is_Protected_Operation (E)
      then
         return +Void;
      end if;

      declare
         Prio : constant W_Term_Id := Self_Priority;
         S    : W_Prog_Id := +Void;
      begin
         --  Placeholder for a Why3 sequence that will represent the check
         for Obj_Name of Directly_Called_Protected_Objects (E) loop

            --  Create a check that compares priorities of the task and of a
            --  single protected component of an object. See ARM, D.3 (7-11)
            --  for details.

            for Obj_Prio of Component_Priorities (Obj_Name) loop

               declare
                  Obj_Prio_Expr : constant W_Term_Id :=
                    (case Obj_Prio.Kind is
                     --  ??? if type of the component is visible we should try
                     --  to transform the expression.
                        when Nonstatic =>
                           +New_Attribute_Expr
                            (Domain => EW_Term,
                             Ty     => RTE (RE_Any_Priority),
                             Attr   => Attribute_First,
                             Params => Params),

                        when Static =>
                           New_Integer_Constant
                             (Value => UI_From_Int (Obj_Prio.Value)),

                        when Default_Prio =>
                           +New_Attribute_Expr
                             (Domain => EW_Term,
                              Ty     => RTE (RE_Priority),
                              Attr   => Attribute_Last,
                              Params => Params),

                        when Default_Interrupt_Prio =>
                           +New_Attribute_Expr
                             (Domain => EW_Term,
                              Ty     => RTE (RE_Interrupt_Priority),
                              Attr   => Attribute_First,
                              Params => Params),

                        when Last_Interrupt_Prio =>
                           +New_Attribute_Expr
                             (Domain => EW_Term,
                              Ty     => RTE (RE_Interrupt_Priority),
                              Attr   => Attribute_Last,
                              Params => Params));

                  Pred         : constant W_Pred_Id :=
                    New_Comparison
                      (Symbol => (case Obj_Prio.Kind is
                                     when Nonstatic => Why_Eq,
                                     when others    => Int_Infix_Le),
                     Left   => Prio,
                     Right  => Obj_Prio_Expr);

                  Check        : constant W_Prog_Id :=
                    New_Located_Assert (Ada_Node => E,
                                        Pred     => Pred,
                                        Reason   =>
                                          VC_Ceiling_Priority_Protocol,
                                        Kind     => EW_Check);
               begin
                  Append (S, Check);
               end;
            end loop;
         end loop;

         return S;
      end;
   end Check_Ceiling_Protocol;

   ----------------------------------------
   --  Check_Type_Invariants_For_Package --
   ----------------------------------------

   function Check_Type_Invariants_For_Package
     (E      : Entity_Id;
      Params : Transformation_Params) return W_Prog_Id
   is
      Checks : W_Statement_Sequence_Id := Void_Sequence;

   begin
      --  We use the Initializes aspect to get the variables initialized during
      --  elaboration.
      --  We don't do it for wrapper packages as they do not have local
      --  variables / constants.

      if not Is_Wrapper_Package (E) then
         declare
            Init_Map   : constant Dependency_Maps.Map :=
              Parse_Initializes (E, Get_Flow_Scope (E));
            Check_Info : Check_Info_Type := New_Check_Info;

         begin
            --  The checks will be localized at the global declaration. Add a
            --  continuation to make it clear that the checks are done after
            --  the package's elaboration.

            Check_Info.Continuation.Append
              (Continuation_Type'
                 (E,
                  To_Unbounded_String
                    ("at the end of the elaboration of package")));

            for Cu in Init_Map.Iterate loop
               declare
                  K  : Flow_Id renames Dependency_Maps.Key (Cu);
                  FS : constant Flow_Id_Sets.Set :=
                    Expand_Abstract_State (K);

                  --  From the expansion of the LHS of an Initializes contract
                  --  we only get constants, variables and abstract states
                  --  (when the expansion stops at a SPARK_Mode => Off); these
                  --  are known by an Entity_Id but are wrapped in a
                  --  Direct_Mapping or Magic_String kinds of Flow_Id,
                  --  depending whether they are in SPARK.

               begin
                  for F of FS loop
                     case F.Kind is
                        when Direct_Mapping =>
                           declare
                              Obj : Entity_Id := Get_Direct_Mapping_Id (F);

                              pragma Assert (Ekind (Obj) in E_Abstract_State
                                                          | E_Constant
                                                          | E_Variable);

                           begin
                              --  Only partial views of constants are stored in
                              --  the symbol map.

                              if Ekind (Obj) = E_Constant
                                and then Is_Full_View (Obj)
                              then
                                 Obj := Partial_View (Obj);
                              end if;

                              --  Only consider objects that are in SPARK.
                              --  Other objects (and abstract states) are
                              --  translated to a private type in Why.

                              if Is_Object (Obj)
                                and then not Is_Part_Of_Concurrent_Object (Obj)
                              then
                                 declare
                                    Binder  : constant Item_Type :=
                                      Ada_Ent_To_Why.Element
                                        (Symbol_Table, Obj);
                                    Expr    : constant W_Term_Id :=
                                      Reconstruct_Item
                                        (Binder,
                                         Ref_Allowed => Params.Ref_Allowed);
                                    Dyn_Inv : constant W_Pred_Id :=
                                      Compute_Type_Invariant
                                        (Expr        => Expr,
                                         Ty          => Etype (Obj),
                                         Params      => Params,
                                         On_Internal => True);
                                 begin
                                    if not Is_True_Boolean (+Dyn_Inv) then
                                       Append
                                         (Checks,
                                          Right  => New_Assert
                                            (Pred        => New_VC_Pred
                                                 (Obj,
                                                  Dyn_Inv,
                                                  VC_Invariant_Check,
                                                  Check_Info),
                                             Assert_Kind => EW_Assert));
                                    end if;
                                 end;
                              end if;
                           end;

                        when Magic_String =>
                           pragma Assert (Is_Opaque_For_Proof (F));

                        when others =>
                           raise Program_Error;
                     end case;
                  end loop;
               end;
            end loop;
         end;
      end if;

      return +Checks;
   end Check_Type_Invariants_For_Package;

   ----------------------
   -- Clear_Exceptions --
   ----------------------

   procedure Clear_Exceptions is
   begin
      Subprogram_Exceptions.Clear;
   end Clear_Exceptions;

   --------------------------------
   -- Collect_Old_For_Subprogram --
   --------------------------------

   procedure Collect_Old_For_Subprogram
     (E                 :        Callable_Kind_Id;
      Old_Parts         : in out Node_Sets.Set;
      Exclude_Classwide :        Boolean := True;
      Exclude_CC        :        Boolean := False)
   is
      CC_Prag   : constant Node_Id :=
        (if Exclude_CC then Empty
         else Get_Pragma (E, Pragma_Contract_Cases));
      EC_Prag   : constant Node_Id :=
        Get_Pragma (E, Pragma_Exceptional_Cases);
      Post_List : constant Node_Lists.List :=
        Find_Contracts (E, Pragma_Postcondition);
   begin
      Collect_Old_Parts (Post_List, Old_Parts);

      --  If there are no post pragmas or contract cases, the post defaults to
      --  the classwide one.

      if not Exclude_Classwide
        and then Post_List.Is_Empty
        and then No (CC_Prag)
      then
         declare
            Classwide_List : constant Node_Lists.List :=
              Find_Contracts (E, Pragma_Postcondition, Classwide => True);
         begin
            Collect_Old_Parts (Classwide_List, Old_Parts);

            --  If no classwide post is specified for E, use the inherited one.

            if Classwide_List.Is_Empty then
               Collect_Old_Parts
                 (Find_Contracts (E, Pragma_Postcondition, Inherited => True),
                  Old_Parts);
            end if;
         end;
      end if;

      --  Go over contract cases to collect the old attributes. Also collect
      --  the guards which have to be evaluated in the pre-state.

      if not Exclude_CC and then Present (CC_Prag) then
         declare
            Aggr          : constant Node_Id :=
              Expression (First (Pragma_Argument_Associations (CC_Prag)));
            Contract_Case : Node_Id :=
              First (Component_Associations (Aggr));
         begin
            while Present (Contract_Case) loop
               Collect_Old_Parts (Expression (Contract_Case), Old_Parts);
               if not Is_Others_Choice (Choice_List (Contract_Case)) then
                  Old_Parts.Include (First (Choice_List (Contract_Case)));
               end if;

               Next (Contract_Case);
            end loop;
         end;
      end if;

      --  Go over exceptional cases to collect the old attributes

      if  Present (EC_Prag) then
         declare
            Aggr             : constant Node_Id :=
              Expression (First (Pragma_Argument_Associations (EC_Prag)));
            Exceptional_Case : Node_Id :=
              First (Component_Associations (Aggr));
         begin
            while Present (Exceptional_Case) loop
               Collect_Old_Parts (Expression (Exceptional_Case), Old_Parts);

               Next (Exceptional_Case);
            end loop;
         end;
      end if;
   end Collect_Old_For_Subprogram;

   ------------------
   -- Compute_Args --
   ------------------

   function Compute_Args
     (E          : Entity_Id;
      Binders    : Binder_Array;
      More_Reads : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
      return W_Expr_Array
   is
      Logic_Args  : constant W_Expr_Array :=
        Get_Logic_Args (E, True, More_Reads);
      Params      : constant W_Expr_Array :=
        (if Number_Of_Func_Args (E) = 0 then (1 .. 0 => <>)
         else Get_Args_From_Binders (Binders, True));

   begin
      if Params'Length = 0 and then Logic_Args'Length = 0 then
         return W_Expr_Array'(1 => +Void);
      end if;

      return Params & Logic_Args;
   end Compute_Args;

   ----------------------------------
   -- Compute_Attach_Handler_Check --
   ----------------------------------

   function Compute_Attach_Handler_Check
     (Ty     : Entity_Id;
      Params : Transformation_Params) return W_Prog_Id
   is
      function Single_Attach_Handler_Check (Proc : Entity_Id) return W_Prog_Id;
      --  @param Proc a procedure with an Attach_Handler pragma
      --  @return an assertion statement that expresses the attach handler
      --    check for this pragma

      procedure Process_Declarations (L : List_Id);
      --  @param L list of declarations to check for interrupt attachments

      Stat : W_Prog_Id := +Void;
      --  Why3 program with static checks

      ---------------------------------
      -- Single_Attach_Handler_Check --
      ---------------------------------

      function Single_Attach_Handler_Check (Proc : Entity_Id) return W_Prog_Id
      is

         --  The interrupt is given as the second argument of the pragma
         --  Attach_Handler.
         Att_Val : constant Node_Id :=
           Expression (Next (First (Pragma_Argument_Associations
                       (Get_Pragma (Proc, Pragma_Attach_Handler)))));

         --  To check whether the attach handler is reserved, we call the
         --  Ada.Interrupts.Is_Reserved. However, this function reads a global
         --  state, which makes it a bit difficult to generate a call in
         --  the logic (we would have to come up with the state object - not
         --  impossible but not currently proposed by frontend). Instead,
         --  we call the program function, which has only the interrupt as
         --  argument, store the result in a temp and assert that the result
         --  is false. So we are essentially asserting "not is_reserved(int)".

         Res     : constant W_Expr_Id :=
           New_Temp_For_Expr
             (New_Call
                (Name   => To_Why_Id (RTE (RE_Is_Reserved), Domain => EW_Prog),
                 Domain => EW_Prog,
                 Args   =>
                   (1 =>
                      Transform_Expr (Att_Val, EW_Int_Type, EW_Prog, Params)),
                 Typ    => EW_Bool_Type));

         Pred    : constant W_Pred_Id :=
           New_Call
             (Name => Why_Eq,
              Args => (1 => +Res,
                       2 => Bool_False (EW_Term)));
      begin
         return
           +Binding_For_Temp
             (Domain  => EW_Prog,
              Tmp     => Res,
              Context =>
                +New_Located_Assert
                  (Ada_Node => Att_Val,
                   Reason   => VC_Interrupt_Reserved,
                   Kind     => EW_Check,
                   Pred     => Pred));
      end Single_Attach_Handler_Check;

      --------------------------
      -- Process_Declarations --
      --------------------------

      procedure Process_Declarations (L : List_Id) is
         Proc : Node_Id := First (L);
      begin
         while Present (Proc) loop
            if Nkind (Proc) = N_Subprogram_Declaration then
               declare
                  Ent : constant Entity_Id := Unique_Defining_Entity (Proc);
               begin
                  if Ekind (Ent) = E_Procedure
                    and then Present (Get_Pragma (Ent, Pragma_Attach_Handler))
                  then
                     Append (Stat, Single_Attach_Handler_Check (Ent));
                  end if;
               end;
            end if;
            Next (Proc);
         end loop;
      end Process_Declarations;

   --  Start of processing for Compute_Attach_Handler_Check

   begin
      Process_Declarations (Visible_Declarations_Of_Prot_Type (Ty));

      if Private_Spec_In_SPARK (Ty) then
         Process_Declarations (Private_Declarations_Of_Prot_Type (Ty));
      end if;

      return Stat;
   end Compute_Attach_Handler_Check;

   ---------------------
   -- Compute_Binders --
   ---------------------

   function Compute_Binders
     (E          : Entity_Id;
      Domain     : EW_Domain;
      More_Reads : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
      return Item_Array
   is
      Binders : constant Item_Array :=
        Compute_Subprogram_Parameters (E, Domain, More_Reads);
   begin
      --  If E has no parameters, return a singleton of unit type.

      if Binders'Length = 0 then
         return (1 =>
                   (Regular, Local => True, Init => <>, Main => Unit_Param));
      else
         return Binders;
      end if;
   end Compute_Binders;

   --------------------------
   -- Compute_Call_Effects --
   --------------------------

   function Compute_Call_Effects
     (Params : Transformation_Params;
      E      : Callable_Kind_Id)
      return W_Prog_Id
   is
      Call_Effects : W_Prog_Id;
   begin
      Call_Effects := New_Havoc_Statement
        (Ada_Node => E,
         Effects  => +Compute_Effects (E, Global_Params => True));

      Append
        (Call_Effects,
         New_Assume_Statement
           (Ada_Node => E,
            Pred     => Compute_Dynamic_Property_For_Effects (E, Params)));

      return Call_Effects;
   end Compute_Call_Effects;

   -----------------------------------------
   -- Compute_Dynamic_Property_For_Inputs --
   -----------------------------------------

   function Compute_Dynamic_Property_For_Inputs
     (E              : Unit_Kind_Id;
      Params         : Transformation_Params;
      Pred_Fun_Param : Entity_Id := Empty)
      return W_Prog_Id
   is
      Includes : Node_Sets.Set;

      procedure Include_Entity (E : Entity_Id; Kind : Formal_Kind);
      --  Add an entity to Includes

      --------------------
      -- Include_Entity --
      --------------------

      procedure Include_Entity (E : Entity_Id; Kind : Formal_Kind) is
         pragma Unreferenced (Kind);
      begin
         Includes.Include (E);
      end Include_Entity;

      procedure Include_Referenced_Entities is
         new Process_Referenced_Entities (Include_Entity);
   begin
      --  Collect global variables read or written in E

      case Ekind (E) is
         when E_Entry
            | E_Function
            | E_Procedure
            | E_Task_Type
            | E_Package
            | E_Subprogram_Type
         =>
            Include_Referenced_Entities (E);

            --  Collect parameters of E if any

            if Is_Subprogram_Or_Entry (E) then
               Includes.Union (Get_Explicit_Formals (E));

               --  If E is a protected subprogram, add the type itself to stand
               --  for the self reference.

               if Need_Self_Binder (E)
                 and then Entity_Body_In_SPARK (E)
               then
                  Includes.Include (Containing_Protected_Type (E));
               end if;

            --  Collect discriminants of task types

            elsif Is_Task_Type (E) and then Has_Discriminants (E) then
               declare
                  Discr : Entity_Id := First_Discriminant (E);
               begin
                  while Present (Discr) loop
                     Includes.Include (Discr);
                     Next_Discriminant (Discr);
                  end loop;
               end;
            end if;

         when others =>
            raise Program_Error;
      end case;

      return Assume_Dynamic_Invariant_For_Variables
        (Vars             => Includes,
         Params           => Params,
         Scope            => E,
         Exclude_Top_Pred => Pred_Fun_Param,
         Initialized      => False);
   end Compute_Dynamic_Property_For_Inputs;

   ------------------------------------------
   -- Compute_Dynamic_Property_For_Effects --
   ------------------------------------------

   function Compute_Dynamic_Property_For_Effects
     (E           : Entity_Id;
      Params      : Transformation_Params;
      Exceptional : Boolean := False) return W_Pred_Id
   is
      Func_Why_Binders     : constant Item_Array :=
        Compute_Binders (E, EW_Prog);
      Dynamic_Prop_Effects : W_Pred_Id := True_Pred;
      Formal               : Entity_Id;
   begin

      --  Compute the dynamic property of mutable parameters

      for I in Func_Why_Binders'Range loop
         Formal := Get_Ada_Node_From_Item (Func_Why_Binders (I));

         --  Only assume dynamic property of concurrent self if the containing
         --  protected type is in SPARK. Otherwise, self will have the type
         --  EW_Private_Type and no dynamic property applies.

         if Func_Why_Binders (I).Kind = Concurrent_Self then
            declare
               Ada_Type : constant Node_Id :=
                 Func_Why_Binders (I).Main.Ada_Node;
            begin
               if Entity_In_SPARK (Ada_Type) then
                  declare
                     Self_Expr : constant W_Expr_Id :=
                       (if Self_Is_Mutable then
                           New_Deref (Right => Self_Name,
                                      Typ   => Get_Typ (Self_Name))
                        else +Self_Name);
                     Dyn_Prop  : constant W_Pred_Id :=
                       Compute_Dynamic_Inv_And_Initialization
                         (Expr             => +Self_Expr,
                          Ty               => Ada_Type,
                          Params           => Params,
                          Include_Type_Inv =>
                            Include_Non_Local_Type_Inv_For_Subp (E));
                  begin
                     Dynamic_Prop_Effects := +New_And_Expr
                       (Left   => +Dynamic_Prop_Effects,
                        Right  => +Dyn_Prop,
                        Domain => EW_Pred);
                  end;
               end if;
            end;
         elsif Item_Is_Mutable (Func_Why_Binders (I))
           and then Entity_In_SPARK (Formal)
         then
            --  On exceptional paths, formals with relaxed initialization
            --  might not be initialized at toplevel.

            if Exceptional then
               if By_Reference (Formal) then
                  declare
                     Ada_Type  : constant Node_Id :=
                       Get_Ada_Type_From_Item (Func_Why_Binders (I));
                     Init_Expr : constant W_Term_Id :=
                       (if Func_Why_Binders (I).Init.Present
                        then New_Deref
                          (Right => Func_Why_Binders (I).Init.Id,
                           Typ   => Get_Typ (Func_Why_Binders (I).Init.Id))
                        else True_Term);

                     Dyn_Prop   : constant W_Pred_Id :=
                       Compute_Dynamic_Invariant
                         (Expr             =>
                            +Transform_Identifier
                            (Params => Params,
                             Expr   => Formal,
                             Ent    => Formal,
                             Domain => EW_Term),
                          Ty               => Ada_Type,
                          Params           => Params,
                          Initialized      => Init_Expr,
                          Include_Type_Inv =>
                            Include_Non_Local_Type_Inv_For_Subp (E));
                  begin
                     Dynamic_Prop_Effects := +New_And_Expr
                       (Left   => +Dynamic_Prop_Effects,
                        Right  => +Dyn_Prop,
                        Domain => EW_Pred);
                  end;
               end if;

            --  Otherwise, Compute_Dynamic_Inv_And_Initialization can be used
            --  safely.

            else
               declare
                  Ada_Type : constant Node_Id :=
                    Get_Ada_Type_From_Item (Func_Why_Binders (I));
                  Dyn_Prop : constant W_Pred_Id :=
                    Compute_Dynamic_Inv_And_Initialization
                      (Expr             =>
                         +Transform_Identifier
                         (Params => Params,
                          Expr   => Formal,
                          Ent    => Formal,
                          Domain => EW_Term),
                       Ty               => Ada_Type,
                       Params           => Params,
                       Include_Type_Inv =>
                         Include_Non_Local_Type_Inv_For_Subp (E));
               begin
                  Dynamic_Prop_Effects := +New_And_Expr
                    (Left   => +Dynamic_Prop_Effects,
                     Right  => +Dyn_Prop,
                     Domain => EW_Pred);
               end;
            end if;
         end if;
      end loop;

      --  Compute the dynamic property of global output

      declare
         Read_Ids    : Flow_Types.Flow_Id_Sets.Set;
         Write_Ids   : Flow_Types.Flow_Id_Sets.Set;

      begin
         Flow_Utility.Get_Proof_Globals (Subprogram      => E,
                                         Reads           => Read_Ids,
                                         Writes          => Write_Ids,
                                         Erase_Constants => True);

         for Write_Id of Write_Ids loop
            if Write_Id.Kind = Direct_Mapping then
               declare
                  Entity : constant Entity_Id :=
                    Get_Direct_Mapping_Id (Write_Id);

               begin
                  if not Is_Concurrent_Type (Entity) then
                     declare
                        Init_Id  : constant W_Expr_Id :=
                          Get_Init_Id_From_Object (Entity, Params.Ref_Allowed);
                        Dyn_Prop : constant W_Pred_Id :=
                          Compute_Dynamic_Invariant
                            (Expr        =>
                               +Transform_Identifier (Params   => Params,
                                                      Expr     => Entity,
                                                      Ent      => Entity,
                                                      Domain   => EW_Term),
                             Ty          => Etype (Entity),
                             Params      => Params,
                             Initialized =>
                               (if Init_Id /= Why_Empty then +Init_Id
                                else True_Term));
                     begin
                        Dynamic_Prop_Effects := +New_And_Expr
                          (Left   => +Dynamic_Prop_Effects,
                           Right  => +Dyn_Prop,
                           Domain => EW_Pred);
                     end;
                  end if;
               end;
            end if;
         end loop;
      end;

      return Dynamic_Prop_Effects;
   end Compute_Dynamic_Property_For_Effects;

   ---------------------
   -- Compute_Effects --
   ---------------------

   function Compute_Effects
     (E             : Entity_Id;
      Global_Params : Boolean := False;
      More_Reads    : Flow_Types.Flow_Id_Sets.Set :=
        Flow_Types.Flow_Id_Sets.Empty_Set)
      return W_Effects_Id
   is
      Read_Ids  : Flow_Types.Flow_Id_Sets.Set;
      Write_Ids : Flow_Types.Flow_Id_Sets.Set;
      Eff       : constant W_Effects_Id := New_Effects;

      procedure Effects_Append_Binder_To_Reads is
         new Effects_Append_Binder (Effects_Append_To_Reads);

      procedure Effects_Append_Binder_To_Writes is
         new Effects_Append_Binder (Effects_Append_To_Writes);

   --  Start of processing for Compute_Effects

   begin
      --  Collect global variables potentially read and written

      Flow_Utility.Get_Proof_Globals (Subprogram      => E,
                                      Reads           => Read_Ids,
                                      Writes          => Write_Ids,
                                      Erase_Constants => True);

      Read_Ids.Union (More_Reads);

      for Write_Id of Write_Ids loop
         case Write_Id.Kind is
            when Direct_Mapping =>
               declare
                  Entity : constant Entity_Id :=
                    Get_Direct_Mapping_Id (Write_Id);

               begin
                  --  Effects on concurrent types are handled by other means

                  if not Is_Concurrent_Type (Entity) then
                     Effects_Append_Binder_To_Writes
                       (Eff, Ada_Ent_To_Why.Element (Symbol_Table, Entity));

                     if Is_Local_Borrower (Entity) then
                        Effects_Append_To_Writes
                          (Eff, Get_Brower_At_End (Entity));
                     end if;
                  end if;

               end;

            when Magic_String =>
               declare
                  Cu : constant Ada_Ent_To_Why.Cursor :=
                    Ada_Ent_To_Why.Find (Symbol_Table, To_Name (Write_Id));

               begin
                  --  If Write_Id is in the symbol table, use this mapping

                  if Ada_Ent_To_Why.Has_Element (Cu) then
                     Effects_Append_Binder_To_Writes
                       (Eff, Ada_Ent_To_Why.Element (Cu));

                  --  Otherwise, use the id name

                  else
                     Effects_Append_To_Writes
                       (Eff,
                        To_Why_Id (Obj => To_Name (Write_Id), Local => False));
                  end if;
               end;

            when others =>
               raise Program_Error;
         end case;
      end loop;

      --  Add all OUT and IN OUT parameters as potential writes.
      --  If Global_Params is True, use binders from the Symbol_Table;
      --  otherwise, use binders from the function declaration.

      if Global_Params then
         declare
            Formal : Entity_Id := First_Formal (E);
         begin
            while Present (Formal) loop
               declare
                  B : constant Item_Type :=
                    Ada_Ent_To_Why.Element
                      (Symbol_Table, Formal);
               begin
                  Effects_Append_Binder_To_Writes (Eff, B);
               end;
               Next_Formal (Formal);
            end loop;
         end;
      else
         declare
            Binders : constant Item_Array := Compute_Raw_Binders (E);
         begin
            for B of Binders loop
               Effects_Append_Binder_To_Writes (Eff, B);
            end loop;
         end;
      end if;

      for Read_Id of Read_Ids loop
         case Read_Id.Kind is
            when Direct_Mapping =>
               declare
                  Entity : constant Entity_Id :=
                    Get_Direct_Mapping_Id (Read_Id);

               begin
                  --  Effects on concurrent types are handled by other means

                  if not Is_Concurrent_Type (Entity) then
                     Effects_Append_Binder_To_Reads
                       (Eff, Ada_Ent_To_Why.Element (Symbol_Table, Entity));
                  end if;
               end;

            when Magic_String =>
               declare
                  Cu : constant Ada_Ent_To_Why.Cursor :=
                    Ada_Ent_To_Why.Find (Symbol_Table, To_Name (Read_Id));

               begin
                  --  If Read_Id is in the symbol table, use this mapping

                  if Ada_Ent_To_Why.Has_Element (Cu) then
                     Effects_Append_Binder_To_Reads
                       (Eff, Ada_Ent_To_Why.Element (Cu));

                  --  Otherwise, use the id name

                  else
                     Effects_Append_To_Reads
                       (Eff,
                        To_Why_Id (Obj => To_Name (Read_Id), Local => False));
                  end if;
               end;

            when others =>
               raise Program_Error;
         end case;
      end loop;

      return +Eff;
   end Compute_Effects;

   --------------------------------
   -- Compute_Guard_For_Dispatch --
   --------------------------------

   function Compute_Guard_For_Dispatch
     (Subp    : Entity_Id;
      Binders : Item_Array;
      W_Tag   : W_Term_Id;
      Params  : Transformation_Params) return W_Pred_Id
   is
      D_Ty : constant Entity_Id := Find_Dispatching_Type (Subp);
      Pred : W_Pred_Id := True_Pred;
   begin
      for B of Binders loop
         if D_Ty = Get_Ada_Type_From_Item (B) then
            case B.Kind is
               when Regular =>
                  Pred := New_And_Pred
                    (Left  => Pred,
                     Right => New_Comparison
                       (Symbol => Why_Eq,
                        Left   => W_Tag,
                        Right  => +New_Tag_Access
                          (Domain => EW_Term,
                           Name   =>
                             (if Params.Ref_Allowed
                              then New_Deref
                                (Right => B.Main.B_Name,
                                 Typ   => EW_Abstract (D_Ty))
                              else +B.Main.B_Name),
                           Ty     => D_Ty)));
               when DRecord =>
                  pragma Assert (B.Tag.Present);
                  Pred := New_And_Pred
                    (Left  => Pred,
                     Right => New_Comparison
                       (Symbol => Why_Eq,
                        Left   => W_Tag,
                        Right  => +B.Tag.Id));
               when others =>
                  raise Program_Error;
            end case;
         end if;
      end loop;
      return Pred;
   end Compute_Guard_For_Dispatch;

   ---------------------------
   -- Compute_Guard_Formula --
   ---------------------------

   function Compute_Guard_Formula
     (Binders : Item_Array;
      Params  : Transformation_Params) return W_Pred_Id is
      Pred : W_Pred_Id := True_Pred;

   begin
      --  Add to guard the dynamic property of logic parameters.

      for B of Binders loop

         declare
            Ada_Node : constant Node_Id :=
              Get_Ada_Node_From_Item (B);
            Expr     : constant W_Term_Id :=
              Reconstruct_Item (B, Params.Ref_Allowed);
            Ty_Node  : constant Entity_Id :=
              (if Present (Ada_Node)
               and then not Specialized_Call_Params.Contains (Ada_Node)
               then
                   (if Is_Type (Ada_Node) then Ada_Node
                    else Etype (Ada_Node))
               else Empty);
            --  Do not generate guards for specialized formals
            Dyn_Prop : constant W_Pred_Id :=
              (if Present (Ty_Node)
               then Compute_Dynamic_Inv_And_Initialization
                 (Expr     => +Expr,
                  Ty       => Ty_Node,
                  Params   => Params,
                  Only_Var => False_Term)
               else True_Pred);
         begin
            if No (Ada_Node) then
               declare
                  K    : constant Item_Enum := B.Kind;
                  Name : constant W_Identifier_Id :=
                    B.Main.B_Name;
                  Ty   : constant W_Type_Id := Get_Typ (Name);
               begin

                  --  If there is no Ada_Node associated to the binder then
                  --  it must be either the unit binder or a binder for
                  --  a variable referenced for effects only.

                  pragma Assert
                    (K = Regular
                     and then Ty in M_Main.Type_Of_Heap
                                  | EW_Private_Type
                                  | EW_Unit_Type);
               end;
            end if;

            Pred :=
              +New_And_Then_Expr
              (Domain => EW_Pred,
               Left   => +Pred,
               Right  => +Dyn_Prop);
         end;
      end loop;
      return Pred;
   end Compute_Guard_Formula;

   ---------------------------------------------
   -- Compute_Moved_Property_For_Deep_Outputs --
   ---------------------------------------------

   function Compute_Moved_Property_For_Deep_Outputs
     (E      : Entity_Id;
      Params : Transformation_Params) return W_Prog_Id
   is
      Assume : W_Prog_Id := +Void;
   begin
      if Ekind (E) in E_Function | E_Package | E_Task_Type then
         return +Void;
      end if;

      declare
         Outputs : constant Entity_Sets.Set :=
           Compute_Outputs_With_Allocated_Parts (E);
      begin
         for Obj of Outputs loop
            declare
               Typ : constant Entity_Id := Retysp (Etype (Obj));
            begin
               Append
                 (Assume,
                  New_Assume_Statement
                    (Pred => Compute_Is_Moved_Property
                       (+Transform_Identifier (Params => Params,
                                               Expr   => Obj,
                                               Ent    => Obj,
                                               Domain => EW_Term), Typ)));
            end;
         end loop;
      end;

      return Assume;
   end Compute_Moved_Property_For_Deep_Outputs;

   ------------------------------------------
   -- Compute_Outputs_With_Allocated_Parts --
   ------------------------------------------

   function Compute_Outputs_With_Allocated_Parts
     (E : Callable_Kind_Id)
      return Entity_Sets.Set
   is
      Outputs : Entity_Sets.Set;
   begin
      declare
         Read_Ids  : Flow_Types.Flow_Id_Sets.Set;
         Write_Ids : Flow_Types.Flow_Id_Sets.Set;
      begin
         Flow_Utility.Get_Proof_Globals (Subprogram      => E,
                                         Reads           => Read_Ids,
                                         Writes          => Write_Ids,
                                         Erase_Constants => True);

         for Write_Id of Write_Ids loop
            case Write_Id.Kind is
               when Direct_Mapping =>
                  declare
                     Entity : constant Entity_Id :=
                       Get_Direct_Mapping_Id (Write_Id);
                     Typ    : constant Entity_Id := Retysp (Etype (Entity));

                  begin
                     if not Is_Concurrent_Type (Entity)
                       and then not Read_Ids.Contains (Write_Id)
                       and then Contains_Allocated_Parts (Typ)
                       and then not Is_Anonymous_Access_Type (Typ)
                     then
                        Outputs.Insert (Entity);
                     end if;
                  end;

               when Magic_String =>
                  null;

               when others =>
                  raise Program_Error;
            end case;
         end loop;
      end;

      declare
         Formal : Entity_Id := First_Formal (E);
      begin
         while Present (Formal) loop
            declare
               Typ : constant Entity_Id := Retysp (Etype (Formal));
            begin
               if Contains_Allocated_Parts (Typ)
                 and then not Is_Anonymous_Access_Type (Typ)
                 and then Ekind (Formal) = E_Out_Parameter
               then
                  Outputs.Insert (Formal);
               end if;

               Next_Formal (Formal);
            end;
         end loop;
      end;

      return Outputs;
   end Compute_Outputs_With_Allocated_Parts;

   ------------------------------------
   -- Compute_Subprogram_Parameters  --
   ------------------------------------

   function Compute_Subprogram_Parameters
     (E          : Callable_Kind_Id;
      Domain     : EW_Domain;
      More_Reads : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
      return Item_Array
   is
      Raw_Binders : constant Item_Array := Compute_Raw_Binders (E);
   begin
      return (if Domain = EW_Prog then Raw_Binders
              else Add_Logic_Binders (E, Raw_Binders, More_Reads));
   end Compute_Subprogram_Parameters;

   --------------------------------------------
   -- Compute_Type_Invariants_For_Subprogram --
   --------------------------------------------

   function Compute_Type_Invariants_For_Subprogram
     (E           : Entity_Id;
      Params      : Transformation_Params;
      For_Input   : Boolean;
      Exceptional : Boolean := False) return W_Pred_Id
   is

      procedure Add_Type_Invariants_For_Globals
        (Ids      :        Flow_Types.Flow_Id_Sets.Set;
         Inv_Pred : in out W_Pred_Id);
      --  Add the type invariants of elements of Ids to Inv_Pred.
      --  @param Ids the set of read / write effects for the subprogram
      --  @param Inv_Pred a why predicate

      procedure Add_Type_Invariants_For_Params
        (Subp      : Entity_Id;
         For_Input : Boolean;
         Inv_Pred  : in out W_Pred_Id);
      --  Add the type invariants of Subp's parameters to Inv_Pred.
      --  @param Subp the entity of the subprogram
      --  @param For_Input True if we should consider inputs of Subp, False if
      --         we should consider outputs.
      --  @param Inv_Pred a why predicate

      function Compute_Type_Invariant_For_Entity
        (E : Entity_Id) return W_Pred_Id
      with Pre => Ada_Ent_To_Why.Has_Element (Symbol_Table, E);
      --  @param E Entity of an object stored in the Symbol_Table
      --  @return a predicate containing the invariants of all parts of E
      --          which have an external invariant.

      -------------------------------------
      -- Add_Type_Invariants_For_Globals --
      -------------------------------------

      procedure Add_Type_Invariants_For_Globals
        (Ids      :        Flow_Types.Flow_Id_Sets.Set;
         Inv_Pred : in out W_Pred_Id)
      is
      begin
         for F of Ids loop
            pragma Assert (F.Kind in Direct_Mapping | Magic_String);

            --  Magic_String are global state with no attached entities. As
            --  such state is translated as private in Why3, we do not need
            --  to consider any type invariant for it.

            if F.Kind = Direct_Mapping then
               declare
                  E : constant Entity_Id := Get_Direct_Mapping_Id (F);
               begin
                  --  Global variables accessed by the subprogram. Abstract
                  --  states and private variables are not considered here,
                  --  as they cannot have visible type invariants.

                  if Is_Object (E) then
                     Inv_Pred := +New_And_Then_Expr
                       (Left   => +Inv_Pred,
                        Right  => +Compute_Type_Invariant_For_Entity (E),
                        Domain => EW_Pred);

                  --  Self reference of protected subprograms

                  else pragma Assert (Is_Concurrent_Type (E));

                     Inv_Pred := +New_And_Then_Expr
                       (Left   => +Inv_Pred,
                        Right  => +Compute_Type_Invariant
                          (Expr        =>
                               +Concurrent_Self_Binder (E).B_Name,
                           Ty          => E,
                           Params      => Params,
                           On_Internal => True),
                        Domain => EW_Pred);
                  end if;
               end;
            end if;
         end loop;
      end Add_Type_Invariants_For_Globals;

      ------------------------------------
      -- Add_Type_Invariants_For_Params --
      ------------------------------------

      procedure Add_Type_Invariants_For_Params
        (Subp      : Entity_Id;
         For_Input : Boolean;
         Inv_Pred  : in out W_Pred_Id)
      is
         Formal : Entity_Id := First_Formal (Subp);

      begin
         while Present (Formal) loop
            if (if For_Input then Ekind (Formal) /= E_Out_Parameter
                else Ekind (Formal) /= E_In_Parameter
                  or else Is_Access_Variable (Etype (Formal)))
              and then (not Exceptional or else By_Reference (Formal))
            then
               Inv_Pred := +New_And_Then_Expr
                 (Left   => +Inv_Pred,
                  Right  => +Compute_Type_Invariant_For_Entity (Formal),
                  Domain => EW_Pred);
            end if;

            Next_Formal (Formal);
         end loop;
      end Add_Type_Invariants_For_Params;

      ---------------------------------------
      -- Compute_Type_Invariant_For_Entity --
      ---------------------------------------

      function Compute_Type_Invariant_For_Entity
        (E : Entity_Id) return W_Pred_Id
      is
         Binder : constant Item_Type :=
           Ada_Ent_To_Why.Element (Symbol_Table, E);
         Expr   : constant W_Term_Id :=
           Reconstruct_Item (Binder, Ref_Allowed => Params.Ref_Allowed);
      begin
         return Compute_Type_Invariant
           (Expr        => Expr,
            Ty          => Etype (E),
            Params      => Params,
            On_Internal => True);
      end Compute_Type_Invariant_For_Entity;

      Read_Ids    : Flow_Types.Flow_Id_Sets.Set;
      Write_Ids   : Flow_Types.Flow_Id_Sets.Set;

      Inv_Pred    : W_Pred_Id := True_Pred;

      Is_External : constant Boolean := Is_Globally_Visible (E);
      --  The subprogram is an external or a boundary subprogram if it is
      --  visible from outside the current compilation unit.

   begin
      --  If the subprogram is boundary or external, we should assume/check the
      --  type invariants of its parameters.

      if Is_External then
         Add_Type_Invariants_For_Params (E, For_Input, Inv_Pred);
      end if;

      Flow_Utility.Get_Proof_Globals (Subprogram      => E,
                                      Reads           => Read_Ids,
                                      Writes          => Write_Ids,
                                      Erase_Constants => True);

      --  If For_Input is True, add the invariants of the variables read by E,
      --  otherwise add the invariants of the variables written by E.

      if For_Input then
         Add_Type_Invariants_For_Globals (Read_Ids, Inv_Pred);
      else
         Add_Type_Invariants_For_Globals (Write_Ids, Inv_Pred);
      end if;

      --  If For_Input is false and E is a function, add the invariants of its
      --  result.

      if Is_External
        and then not For_Input
        and then Ekind (E) = E_Function
      then
         declare
            Result : constant W_Term_Id :=
              (if not Result_Is_Mutable
               then +Result_Name
               else New_Deref
                 (Right => Result_Name,
                  Typ   => Get_Typ (+Result_Name)));
         begin
            Inv_Pred := +New_And_Then_Expr
              (Left   => +Inv_Pred,
               Right  => +Compute_Type_Invariant
                 (Expr        => Result,
                  Ty          => Etype (E),
                  Params      => Params,
                  On_Internal => True),
               Domain => EW_Pred);
         end;
      end if;

      return Inv_Pred;
   end Compute_Type_Invariants_For_Subprogram;

   -----------------------
   -- Add_Logic_Binders --
   -----------------------

   function Add_Logic_Binders
     (E           : Entity_Id;
      Raw_Binders : Item_Array;
      More_Reads  : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
      return Item_Array
   is
      Effect_Binders : Item_Array :=
        Compute_Binders_For_Effects (E, More_Reads);
   begin
      Localize_Binders (Effect_Binders);
      return Raw_Binders & Effect_Binders;
   end Add_Logic_Binders;

   ---------------------------------
   -- Compute_Binders_For_Effects --
   ---------------------------------

   function Compute_Binders_For_Effects
     (E          : Callable_Kind_Id;
      More_Reads : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
      return Item_Array
   is
      Read_Ids  : Flow_Id_Sets.Set;
      Write_Ids : Flow_Id_Sets.Set;

   begin
      --  Collect global variables potentially read and written

      Flow_Utility.Get_Proof_Globals (Subprogram      => E,
                                      Reads           => Read_Ids,
                                      Writes          => Write_Ids,
                                      Erase_Constants => True);

      Read_Ids.Union (More_Reads);

      --  Do not include binder for self reference as it is already included
      --  in binders for parameters.

      return Get_Binders_From_Variables
        (Read_Ids.Union (Write_Ids), Ignore_Self => True);
   end Compute_Binders_For_Effects;

   -------------------------
   -- Compute_Raw_Binders --
   -------------------------

   function Compute_Raw_Binders (E : Entity_Id) return Item_Array is
      Binder_Len    : constant Natural :=
        Number_Formals (E) + (if Need_Self_Binder (E) then 1 else 0);
      Result        : Item_Array (1 .. Binder_Len);
      Formal        : Entity_Id;
      Count         : Positive;

   begin
      Formal := First_Formal (E);
      Count := 1;

      if Need_Self_Binder (E) then
         declare
            Prot : constant Entity_Id := Containing_Protected_Type (E);
         begin
            Result (1) :=
              (Concurrent_Self, Local => True, Init => <>,
               Main => Concurrent_Self_Binder
                 (Prot, Mutable => Ekind (E) /= E_Function));
            Count := 2;
         end;
      end if;

      while Present (Formal) loop

         --  Specialized parameters are hardcoded. No actual value is provided,
         --  we use a parameter of type unit instead. We still provide an
         --  Ada_Node for it so it will be stored in the Symbol_Table. This
         --  works as a sanity checking. If the formal is referenced, which
         --  should never happen, the generated Why3 code will be ill-typed.

         if Specialized_Call_Params.Contains (Formal) then
            Result (Count) :=
              (Regular, Local => True,
               Init           => <>,
               Main           => Unit_Param (Short_Name (Formal), Formal));
         else
            Result (Count) := Mk_Item_Of_Entity
              (E           => Formal,
               Local       => True,
               In_Fun_Decl => True);
         end if;
         Next_Formal (Formal);
         Count := Count + 1;
      end loop;

      pragma Assert (Count = Binder_Len + 1);

      return Result;
   end Compute_Raw_Binders;

   --------------------------------------
   -- Compute_Contract_Cases_Guard_Map --
   --------------------------------------

   --  Pragma/aspect Contract_Cases (Guard1 => Consequence1,
   --                                Guard2 => Consequence2,
   --                                  ...
   --                                GuardN => ConsequenceN
   --                              [,OTHERS => ConsequenceN+1]);

   --  This helper subprogram stores in Guard_Map a map from guard expressions
   --  to temporary Why names. The temporary Why name for the OTHERS case
   --  is stored in Others_Guard_Ident, and the value of this guard in
   --  Others_Guard_Expr. These results will be used to generate bindings
   --  such as:

   --    let guard1 = ... in
   --    let guard2 = ... in
   --    ...
   --    let guardN = ... in
   --    let guardOTHERS = not (guard1 or guard2 ... or guardN) in

   procedure Compute_Contract_Cases_Guard_Map
     (E                  : Entity_Id;
      Guard_Map          : out Ada_To_Why_Ident.Map;
      Others_Guard_Ident : out W_Identifier_Id;
      Others_Guard_Expr  : out W_Term_Id)
   is
      Prag          : constant Node_Id :=
        Get_Pragma (E, Pragma_Contract_Cases);
      Aggr          : Node_Id;
      Contract_Case : Node_Id;
      Case_Guard    : Node_Id;

   begin
      --  Initial values for outputs related to the "others" guard if any

      Others_Guard_Ident := Why_Empty;
      Others_Guard_Expr := False_Term;

      --  If no Contract_Cases on this subprogram, nothing to do

      if No (Prag) then
         return;
      end if;

      --  Process individual contract cases

      Aggr := Expression (First (Pragma_Argument_Associations (Prag)));
      Contract_Case := First (Component_Associations (Aggr));
      while Present (Contract_Case) loop
         declare
            --  Temporary Why name for the current guard
            Guard_Ident : constant W_Identifier_Id :=
              New_Temp_Identifier (Typ => EW_Bool_Type);

            --  Whether the current guard is enabled
            Enabled     : constant W_Term_Id := +Guard_Ident;

         begin
            Case_Guard := First (Choice_List (Contract_Case));

            --  The OTHERS choice requires special processing

            if Nkind (Case_Guard) = N_Others_Choice then
               Others_Guard_Ident := Guard_Ident;
               Others_Guard_Expr :=
                 New_Conditional (Condition => Others_Guard_Expr,
                                  Then_Part => False_Term,
                                  Else_Part => True_Term);

            --  Regular contract case

            else
               Guard_Map.Include (Case_Guard, Guard_Ident);
               Others_Guard_Expr := New_Or_Term (Left  => Others_Guard_Expr,
                                                 Right => Enabled);
            end if;

            Next (Contract_Case);
         end;
      end loop;
   end Compute_Contract_Cases_Guard_Map;

   -----------------------------------------
   -- Compute_Contract_Cases_Entry_Checks --
   -----------------------------------------

   --  Pragma/aspect Contract_Cases (Guard1 => Consequence1,
   --                                Guard2 => Consequence2,
   --                                  ...
   --                                GuardN => ConsequenceN
   --                              [,OTHERS => ConsequenceN+1]);

   --  leads to the generation of checks on subprogram entry. In a context
   --  where the precondition is known to hold, it is checked that no
   --  evaluation of a guard can lead to a run-time error, that no more than
   --  one guard evaluates to True (only if there are at least two non-OTHER
   --  guards), and that at least one guard evaluates to True (only in the case
   --  there is no OTHERS).

   --  Check that contract cases are disjoint only if there are at least two
   --  non-OTHER guards:

   --    assert ((if guard1 = True then 1 else 0) +
   --            (if guard2 = True then 1 else 0) +
   --            ...
   --            (if guardN = True then 1 else 0) <= 1)

   --  Check that contract cases are complete only if there is no OTHERS:

   --    assert ((if guard1 = True then 1 else 0) +
   --            (if guard2 = True then 1 else 0) +
   --            ...
   --            (if guardN = True then 1 else 0) >= 1)

   function Compute_Contract_Cases_Entry_Checks
     (E         : Entity_Id;
      Guard_Map : Ada_To_Why_Ident.Map) return W_Prog_Id
   is
      Prag          : constant Node_Id :=
        Get_Pragma (E, Pragma_Contract_Cases);
      Aggr          : Node_Id;
      Contract_Case : Node_Id;
      Case_Guard    : Node_Id;

      Has_Others  : Boolean := False;
      --  Set to True if there is an OTHERS guard

      Count       : W_Expr_Id := New_Integer_Constant (Value => Uint_0);
      --  Count of the guards enabled

      Result      : W_Prog_Id := +Void;
      --  Why program for these checks

   --  Start of processing for Compute_Contract_Cases_Entry_Checks

   begin
      --  If no Contract_Cases on this subprogram, return the void program

      if No (Prag) then
         return Result;
      end if;

      --  Process individual contract cases

      Aggr := Expression (First (Pragma_Argument_Associations (Prag)));
      Contract_Case := First (Component_Associations (Aggr));
      while Present (Contract_Case) loop
         Case_Guard := First (Choice_List (Contract_Case));

         --  The OTHERS choice requires special processing

         if Nkind (Case_Guard) = N_Others_Choice then
            Has_Others := True;

         --  Regular contract case

         else
            declare
               Guard_Ident : constant W_Identifier_Id :=
                 Guard_Map.Element (Case_Guard);
               --  Temporary Why name for the current guard

               --  Whether the current guard is enabled
               Enabled     : constant W_Expr_Id :=
                 New_Conditional
                   (Ada_Node    => Case_Guard,
                    Domain      => EW_Term,
                    Condition   =>
                      New_Call
                        (Domain => EW_Pred,
                         Name   => Why_Eq,
                         Args   => (1 => +Guard_Ident,
                                    2 => New_Literal (Domain => EW_Term,
                                                      Value  => EW_True)),
                         Typ    => EW_Bool_Type),
                    Then_Part   => New_Integer_Constant (Value => Uint_1),
                    Else_Part   => New_Integer_Constant (Value => Uint_0));
            begin
               Count :=
                 New_Call
                   (Ada_Node => Case_Guard,
                    Domain   => EW_Term,
                    Name     => Int_Infix_Add,
                    Args     => (1 => Count, 2 => Enabled),
                    Typ      => EW_Int_Type);
            end;
         end if;

         Next (Contract_Case);
      end loop;

      --  A check that contract cases are disjoint is generated only when there
      --  are at least two guards, and none is an OTHER guard.

      if List_Length (Component_Associations (Aggr)) >= 2
        and then (if List_Length (Component_Associations (Aggr)) = 2
                  then not Has_Others)
      then
         Append
           (Result,
            New_Assert
              (Pred     =>
                 New_VC_Pred
                   (Prag,
                    New_Call
                      (Name => Int_Infix_Le,
                       Typ  => EW_Bool_Type,
                       Args =>
                         (+Count, New_Integer_Constant (Value => Uint_1))),
                    VC_Disjoint_Contract_Cases),
            Assert_Kind => EW_Check));
      end if;

      --  A check that contract cases are complete is generated only when there
      --  is no OTHER guard.

      if not Has_Others then
         Append
           (Result,
            New_Assert
              (Pred       =>
                 New_VC_Pred
                   (Prag,
                    New_Call
                      (Typ    => EW_Bool_Type,
                       Name   => Int_Infix_Ge,
                       Args => (+Count,
                                New_Integer_Constant (Value => Uint_1))),
                    VC_Complete_Contract_Cases),
               Assert_Kind => EW_Check));
      end if;

      return New_Ignore (Prog => Result);
   end Compute_Contract_Cases_Entry_Checks;

   ----------------------------------------
   -- Compute_Contract_Cases_Exit_Checks --
   ----------------------------------------

   --  Pragma/aspect Contract_Cases (Guard1 => Consequence1,
   --                                Guard2 => Consequence2,
   --                                  ...
   --                                GuardN => ConsequenceN
   --                              [,OTHERS => ConsequenceN+1]);

   --  leads to the generation of checks on subprogram exit. It is checked that
   --  the consequence for the guard that was True on entry also evaluates to
   --  True, without run-time errors.

   --    assert (if guard1 then consequence1);
   --    assert (if guard2 then consequence2);
   --    ...
   --    assert (if guardN then consequenceN);
   --    assert (if not (guard1 or guard2 ... or guardN) then consequenceN+1);

   function Compute_Contract_Cases_Exit_Checks
     (Params             : Transformation_Params;
      E                  : Entity_Id;
      Guard_Map          : Ada_To_Why_Ident.Map;
      Others_Guard_Ident : W_Identifier_Id) return W_Prog_Id
   is
      Prag          : constant Node_Id :=
        Get_Pragma (E, Pragma_Contract_Cases);
      Aggr          : Node_Id;
      Contract_Case : Node_Id;
      Case_Guard    : Node_Id;
      Warn_Others   : Boolean := Params.Warn_On_Dead;

      function Do_One_Contract_Case
        (Contract_Case : Node_Id;
         Enabled       : W_Expr_Id) return W_Prog_Id;
      --  Returns the Why program checking absence of run-time errors and
      --  function verification of the given Contract_Case. Enabled is a
      --  boolean term. Set Warn_Others to False if the current case is
      --  statically disabled for True.

      function Do_One_Contract_Case
        (Contract_Case : Node_Id;
         Enabled       : W_Expr_Id) return W_Prog_Id
      is
         Consequence  : constant Node_Id := Expression (Contract_Case);

         --  Enabled must be converted to a predicate to be used as the
         --  condition in an if-expr inside a predicate.
         Enabled_Pred : constant W_Pred_Id :=
           New_Call
             (Name   => Why_Eq,
              Typ    => EW_Bool_Type,
              Args   => (+Enabled,
                         New_Literal (Domain => EW_Term,
                                      Value  => EW_True)));

         WP_Consequence : W_Prog_Id;

      begin
         --  Possibly warn on an unreachable case. No warning is emitted if
         --  the case is statically disabled.

         declare
            Case_Guard : constant Node_Id :=
              First (Choice_List (Contract_Case));
            Do_Warn    : Boolean;

         begin
            if Nkind (Case_Guard) = N_Others_Choice then
               Do_Warn := Warn_Others;
            else
               Do_Warn := Params.Warn_On_Dead
                 and then not Exp_Util.Is_Statically_Disabled
                   (Case_Guard, False, Include_Valid => True);
               Warn_Others := Warn_Others
                 and then not Exp_Util.Is_Statically_Disabled
                   (Case_Guard, True, Include_Valid => True);
            end if;

            WP_Consequence := Transform_Prog
              (Consequence, (Params with delta Warn_On_Dead => Do_Warn));
            WP_Consequence :=
              Warn_On_Dead_Branch
                (Consequence, WP_Consequence, Params.Phase, Do_Warn);
         end;

         return Sequence
           (New_Ignore
              (Prog =>
                 New_Conditional
                   (Ada_Node    => Contract_Case,
                    Condition   => +Enabled,
                    Then_Part   => WP_Consequence,
                    Else_Part   =>
                      Insert_Simple_Conversion
                        (Expr => True_Prog,
                         To   => Type_Of_Node (Consequence)))),
            New_Assert
              (Pred => New_VC_Pred
                 (Contract_Case,
                  New_Conditional
                    (Ada_Node    => Contract_Case,
                     Condition   => Enabled_Pred,
                     Then_Part   => Transform_Pred (Consequence, Params)),
                  VC_Contract_Case),
               Assert_Kind => EW_Assert));
      end Do_One_Contract_Case;

      Result : W_Prog_Id := +Void;

   --  Start of processing for Compute_Contract_Cases_Exit_Checks

   begin
      --  If no Contract_Cases on this subprogram, return

      if No (Prag) then
         return Result;
      end if;

      --  Process individual contract cases

      Aggr := Expression (First (Pragma_Argument_Associations (Prag)));
      Contract_Case := First (Component_Associations (Aggr));
      while Present (Contract_Case) loop
         Case_Guard := First (Choice_List (Contract_Case));

         declare
            --  Temporary Why name for the current guard
            Guard_Ident : constant W_Identifier_Id :=
              (if Nkind (Case_Guard) = N_Others_Choice then
                 Others_Guard_Ident
               else
                 Guard_Map.Element (Case_Guard));

            --  Whether the current guard is enabled
            Enabled     : constant W_Expr_Id := +Guard_Ident;

         begin
            Append (Result, Do_One_Contract_Case (Contract_Case, Enabled));
         end;

         Next (Contract_Case);
      end loop;

      return Result;
   end Compute_Contract_Cases_Exit_Checks;

   ------------------------------------------
   -- Compute_Contract_Cases_Postcondition --
   ------------------------------------------

   --  Pragma/aspect Contract_Cases (Guard1 => Consequence1,
   --                                Guard2 => Consequence2,
   --                                  ...
   --                                GuardN => ConsequenceN
   --                              [,OTHERS => ConsequenceN+1]);

   --  leads to the generation of a postcondition for the corresponding Why
   --  program function.

   --    if guard1 then consequence1
   --    else if guard2 then consequence2
   --    ...
   --    else if guardN then consequenceN
   --    [else consequenceN+1]

   function Compute_Contract_Cases_Postcondition
     (Params : Transformation_Params;
      E      : Callable_Kind_Id)
      return W_Pred_Id
   is
      Prag          : constant Node_Id :=
        Get_Pragma (E, Pragma_Contract_Cases);
      Aggr          : Node_Id;
      Contract_Case : Node_Id;
      Case_Guard    : Node_Id;
      Consequence   : Node_Id;

      Result : W_Pred_Id := True_Pred;

   --  Start of processing for Compute_Contract_Cases_Postcondition

   begin
      --  If no Contract_Cases on this subprogram, return True

      if No (Prag) then
         return Result;
      end if;

      --  Process individual contract cases in reverse order, to create the
      --  proper if-elsif Why predicate.

      Aggr := Expression (First (Pragma_Argument_Associations (Prag)));
      Contract_Case := Last (Component_Associations (Aggr));
      while Present (Contract_Case) loop
         Case_Guard := First (Choice_List (Contract_Case));
         Consequence := Expression (Contract_Case);

         --  The "others" choice requires special processing

         if Nkind (Case_Guard) = N_Others_Choice then
            Result := Transform_Pred (Consequence, Params);

         --  Regular contract case

         else
            declare
               --  Whether the current guard is enabled in the pre-state

               Enabled : constant W_Expr_Id :=
                  Transform_Attribute_Old (Case_Guard, EW_Pred, Params);
            begin
               Result := New_Conditional
                 (Condition => +Enabled,
                  Then_Part => Transform_Pred (Consequence, Params),
                  Else_Part => Result);
            end;
         end if;

         Prev (Contract_Case);
      end loop;

      return Result;
   end Compute_Contract_Cases_Postcondition;

   ---------------------------------------------
   -- Compute_Exceptional_Cases_Postcondition --
   ---------------------------------------------

   function Compute_Exceptional_Cases_Postcondition
     (Params : Transformation_Params;
      E      : Callable_Kind_Id;
      Exc_Id : W_Identifier_Id)
      return W_Pred_Id
   is
      Prag : constant Node_Id :=
        Get_Pragma (E, Pragma_Exceptional_Cases);
   begin
      if No (Prag) then
         pragma Assert (No_Return (E));
         return True_Pred;
      end if;

      declare
         Aggr                 : constant Node_Id :=
           Expression (First (Pragma_Argument_Associations (Prag)));
         Assocs               : constant List_Id :=
           Component_Associations (Aggr);
         Others_Present       : constant Boolean :=
           Nkind (First (Choice_List (Last (Assocs)))) = N_Others_Choice;
         Nb_Cases             : constant Integer :=
           Natural (List_Length (Assocs));
         Elsif_Parts          : W_Pred_Array
           (2 .. Nb_Cases - (if Others_Present then 1 else 0));
         Else_Part            : W_Pred_Id;
         Exceptional_Case     : Node_Id := First (Assocs);
         Dynamic_Prop_Effects : constant W_Pred_Id :=
           New_And_Pred
             ((1 => Compute_Dynamic_Property_For_Effects
               (E, Params, Exceptional => True),
               2 => Compute_Type_Invariants_For_Subprogram
                 (E, Params, False, Exceptional => True),
               3 => Preservation_Of_Access_Parameters (E, Params)));
         --  Dynamic invariant and type invariant for outputs of the
         --  procedure, as well as preservation of discriminants and
         --  bounds of access parameters.

      begin

         --  Get the case where there is only the others choice out of the way

         if Nb_Cases = 1 and then Others_Present then
            return New_And_Pred
              (Left  => Dynamic_Prop_Effects,
               Right => Transform_Pred
                 (Expression (Exceptional_Case), Params));
         end if;

         --  Fill the Elsif_Parts if any

         Next (Exceptional_Case);
         if Elsif_Parts'Length > 0 then
            for Num in Elsif_Parts'Range loop
               Elsif_Parts (Num) := New_Elsif
                 (Condition => +Compute_Guard_For_Exceptions
                    (Choice_List (Exceptional_Case), Exc_Id, EW_Pred),
                  Then_Part => Transform_Pred
                    (Expression (Exceptional_Case), Params));
               Next (Exceptional_Case);
            end loop;
         end if;

         --  Fill the Else_Part if any

         if Others_Present then
            Else_Part := Transform_Pred
              (Expression (Exceptional_Case), Params);
         else
            Else_Part := False_Pred;
         end if;

         --  Reconstruct the conditional

         Exceptional_Case := First (Assocs);

         return New_And_Pred
           (Left  => Dynamic_Prop_Effects,
            Right => New_Conditional
              (Ada_Node    => Prag,
               Condition   => +Compute_Guard_For_Exceptions
                 (Choice_List (Exceptional_Case), Exc_Id, EW_Pred),
               Then_Part   => Transform_Pred
                 (Expression (Exceptional_Case), Params),
               Elsif_Parts => Elsif_Parts,
               Else_Part   => Else_Part));
      end;
   end Compute_Exceptional_Cases_Postcondition;

   --------------------------
   -- Compute_Inlined_Expr --
   --------------------------

   function Compute_Inlined_Expr
     (Function_Entity    : Entity_Id;
      Logic_Func_Binders : Item_Array;
      W_Return_Type      : W_Type_Id;
      Params             : Transformation_Params)
      return W_Term_Id
   is
      Value : constant Node_Id :=
        Retrieve_Inline_Annotation (Function_Entity);
      W_Def : W_Term_Id;

   begin
      --  We fill the map of parameters, so that in the definition, we use
      --  local names of the parameters, instead of the global names.

      Ada_Ent_To_Why.Push_Scope (Symbol_Table);
      Push_Binders_To_Symbol_Table (Logic_Func_Binders);

      --  If the function is annotated Logical_Eq, return a call to Why_Eq

      if Has_Logical_Eq_Annotation (Function_Entity) then
         declare
            Left  : constant Entity_Id := First_Formal (Function_Entity);
            Right : constant Entity_Id := Next_Formal (Left);
         begin
            W_Def := New_Comparison
              (Symbol => Why_Eq,
               Left   => +Transform_Identifier
                 (Params, Left, Left, EW_Term),
               Right  => +Transform_Identifier
                 (Params, Right, Right, EW_Term));
         end;

      elsif No (Value) then
         W_Def := Why_Empty;

      --  If Function_Entity is recursive, it is not inlined as it may
      --  interfere with its verification.

      elsif Is_Recursive (Function_Entity) then
         Error_Msg_N
           ("info: ?recursive function cannot be inlined for proof",
            Function_Entity);

         W_Def := Why_Empty;

      --  If Function_Entity needs a separate axiom module to break cyclicity
      --  in proof, its postcondition cannot be used to inline it.

      elsif Proof_Module_Cyclic (Function_Entity)
        and then not
          Find_Contracts
            (Function_Entity, Pragma_Postcondition, False, False).Is_Empty
      then
         Error_Msg_N
           ("info: ?function cannot be inlined for proof",
            Function_Entity);
         Error_Msg_N
           ("\inlining might cause circularity in the verification process",
            Function_Entity);

         W_Def := Why_Empty;

      --  Translate the Value expression in Why.

      else
         W_Def := Transform_Term
           (Expr          => Value,
            Expected_Type => W_Return_Type,
            Params        => Params);

         if Is_Tagged_Type (Retysp (Etype (Function_Entity))) then
            W_Def := New_Tag_Update
              (Ada_Node => Value,
               Name     => W_Def,
               Ty       => Etype (Function_Entity));
         end if;
      end if;

      Ada_Ent_To_Why.Pop_Scope (Symbol_Table);

      return W_Def;
   end Compute_Inlined_Expr;

   ------------------------
   -- Declare_Exceptions --
   ------------------------

   procedure Declare_Exceptions (Th : Theory_UC) is
   begin
      for Exc of Subprogram_Exceptions loop
         Emit (Th, New_Exception_Declaration (Name => +Exc));
      end loop;
   end Declare_Exceptions;

   -----------------------------
   -- Declare_Logic_Functions --
   -----------------------------

   procedure Declare_Logic_Functions
     (Th                    : Theory_UC;
      Dispatch_Th           : Theory_UC := Empty_Theory;
      E                     : Callable_Kind_Id;
      Spec_Binders          : Binder_Array := Binder_Array'(1 .. 0 => <>);
      Specialization_Module : Symbol := No_Symbol;
      More_Reads            : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
   is
      --  Local subprograms

      type Scalar_Status is
        (Signed,    --  Signed integer type
         Unsigned,  --  Unsigned integer type = signed with no negative value,
                    --  also used for enumerations with default representation
                    --  clauses.
         Modular);  --  Modular integer type

      function Get_Scalar_Status (Typ : Type_Kind_Id) return Scalar_Status is
        (if Is_Modular_Integer_Type (Typ)   then Modular
         elsif Is_Enumeration_Type (Typ)    then Unsigned
         elsif Is_Unsigned_Type (Typ)       then Unsigned
         elsif Is_Signed_Integer_Type (Typ) then Signed
         else raise Program_Error);

      function Precise_Integer_UC
        (Arg           : W_Term_Id;
         Size          : Uint;
         Source_Type   : W_Type_Id;
         Target_Type   : W_Type_Id;
         Source_Status : Scalar_Status;
         Target_Status : Scalar_Status)
         return W_Term_Id;
      --  Return Arg of Source_Type converted to Target_Type, when both are of
      --  scalar types. Size is the shared size of both types, when arguments
      --  of the UC are integer types, which is used for conversion from an
      --  Unsigned type to a Signed one. Otherwise it is No_Uint.

      function Is_UC_With_Precise_Definition (E : Entity_Id) return Boolean
      with
        Pre => Is_Unchecked_Conversion_Instance (E);
      --  Return whether E is an UC for which a precise definition is given

      -----------------------------------
      -- Is_UC_With_Precise_Definition --
      -----------------------------------

      function Is_UC_With_Precise_Definition (E : Entity_Id) return Boolean is

         function Suitable_For_Precise_UC
           (Arg_Typ : Type_Kind_Id)
            return True_Or_Explain;
         --  Check if Typ is only made of integers. When returning False,
         --  return also the Explanation.

         -----------------------------
         -- Suitable_For_Precise_UC --
         -----------------------------

         function Suitable_For_Precise_UC
           (Arg_Typ : Type_Kind_Id)
            return True_Or_Explain
         is
            Typ : constant Type_Kind_Id := Retysp (Arg_Typ);
         begin
            case Ekind (Typ) is
               when Integer_Kind =>
                  if Has_Biased_Representation (Typ) then
                     return False_With_Explain
                       ("type with biased representation");
                  end if;

               when Enumeration_Kind =>
                  if Has_Enumeration_Rep_Clause (Typ)
                    and then Enumeration_Rep (First_Literal (Typ)) /= Uint_0
                  then
                     return False_With_Explain
                       ("enumeration with non-default representation");
                  end if;

               when Record_Kind =>
                  if Is_Tagged_Type (Typ) then
                     return False_With_Explain ("type is tagged");

                  elsif Has_Discriminants (Typ) then
                     return False_With_Explain ("type has discriminants");

                  elsif Reverse_Storage_Order (Base_Retysp (Typ)) then
                     return False_With_Explain
                       ("type has reverse storage order");
                  end if;

                  declare
                     Comps : constant Component_Sets.Set :=
                       Get_Component_Set (Typ);
                  begin
                     for Comp of Comps loop
                        if No (Component_Bit_Offset (Comp)) then
                           return False_With_Explain
                             ("component offset not known");
                        end if;

                        declare
                           Check : constant True_Or_Explain :=
                             Suitable_For_Precise_UC (Etype (Comp));
                        begin
                           if not Check.Ok then
                              return Check;
                           end if;
                        end;
                     end loop;
                  end;

               when Array_Kind =>
                  declare
                     Check : constant True_Or_Explain :=
                       Suitable_For_Precise_UC (Component_Type (Typ));
                  begin
                     if not Check.Ok then
                        return Check;
                     end if;
                  end;

                  if Number_Dimensions (Typ) > Uint_1 then
                     return False_With_Explain
                       ("array has multiple dimensions");

                  elsif Reverse_Storage_Order (Base_Retysp (Typ)) then
                     return False_With_Explain
                       ("type has reverse storage order");
                  end if;

               when others =>
                  return False_With_Explain ("elementary non-integer type");
            end case;

            return True_Or_Explain'(Ok => True);
         end Suitable_For_Precise_UC;

         --  Local variables

         Source, Target                         : Node_Id;
         Source_Type, Target_Type               : Entity_Id;
         Valid_Source, Valid_Target, Valid_Size : Boolean;
         Explanation                            : Unbounded_String;
         Check                                  : True_Or_Explain;

      begin
         Get_Unchecked_Conversion_Args (E, Source, Target);
         Source_Type := Retysp (Entity (Source));
         Target_Type := Retysp (Entity (Target));

         --  Check that types are suitable for UC.

         Suitable_For_UC (Source_Type, False, Valid_Source, Explanation);
         if not Valid_Source then
            --  Override explanation to avoid special characters
            Explanation := To_Unbounded_String
              ("type is unsuitable as source for unchecked conversion");
            goto UC_Imprecise;
         end if;

         Suitable_For_UC_Target
           (Target_Type, False, Valid_Target, Explanation);
         if not Valid_Target then
            --  Override explanation to avoid special characters
            Explanation := To_Unbounded_String
              ("type is unsuitable as target for unchecked conversion");
            goto UC_Imprecise;
         end if;

         Have_Same_Known_RM_Size
           (Source_Type, Target_Type, Valid_Size, Explanation);
         if not Valid_Size then
            --  Override explanation to avoid special characters
            Explanation := To_Unbounded_String
              ("types in unchecked conversion do not have the same size");
            goto UC_Imprecise;
         end if;

         --  Only support types with size up to 128 bits, to use one of the
         --  available bitvector types with conversions from other bitvector
         --  sizes.

         if Get_Attribute_Value (Source_Type, Attribute_Size) > 128 then
            Explanation :=
              To_Unbounded_String ("type size larger than 128 bits");
            goto UC_Imprecise;
         end if;

         --  Only generate a definition for UC between integer types, and
         --  composites of integer types.

         Check := Suitable_For_Precise_UC (Source_Type);
         if not Check.Ok then
            Explanation := Check.Explanation;
            goto UC_Imprecise;
         end if;

         Check := Suitable_For_Precise_UC (Target_Type);
         if not Check.Ok then
            Explanation := Check.Explanation;
            goto UC_Imprecise;
         end if;

         return True;

      <<UC_Imprecise>>

         --  If --info is set, output information on reason for imprecise
         --  handling of UC.

         if Debug.Debug_Flag_Underscore_F then
            Error_Msg_N
              ("info: ?imprecise handling of Unchecked_Conversion ("
               & To_String (Explanation) & ")", E);
         end if;

         return False;
      end Is_UC_With_Precise_Definition;

      ------------------------
      -- Precise_Integer_UC --
      ------------------------

      function Precise_Integer_UC
        (Arg           : W_Term_Id;
         Size          : Uint;
         Source_Type   : W_Type_Id;
         Target_Type   : W_Type_Id;
         Source_Status : Scalar_Status;
         Target_Status : Scalar_Status)
         return W_Term_Id
      is
         Source_Base_Type : constant W_Type_Id :=
           Base_Why_Type_No_Bool (Source_Type);
         Target_Base_Type : constant W_Type_Id :=
           Base_Why_Type_No_Bool (Target_Type);
         Conv : W_Term_Id;
      begin
         Conv :=
           Insert_Simple_Conversion (Expr => Arg, To => Source_Base_Type);

         if Source_Status = Target_Status then
            null;  --  Trivial case of UC between identical types

         elsif Source_Status = Unsigned
           and then Target_Status = Modular
         then
            null;  --  Unsigned value can be directly converted to modular

         elsif Source_Status = Modular
           and then Target_Status = Unsigned
         then
            null;  --  Modular value can be directly converted to unsigned

         --  Apply the appropriate UC function for conversions between Modular
         --  and Signed.

         elsif Source_Status = Modular
           and then Target_Status = Signed
         then
            Conv := New_Call
              (Name => MF_BVs (Source_Base_Type).UC_To_Int,
               Args => (1 => +Conv),
               Typ  => EW_Int_Type);

         elsif Source_Status = Signed
           and then Target_Status = Modular
         then
            Conv := New_Call
              (Name => MF_BVs (Target_Base_Type).UC_Of_Int,
               Args => (1 => +Conv),
               Typ  => Target_Base_Type);

         --  Otherwise, this is a conversion between Unsigned and Signed.
         --  We need to consider the bit representation of that (possibly
         --  negative) signed value, to see if the high bit is 1, in which
         --  case the Signed value is negative.

         elsif Source_Status = Unsigned
           and then Target_Status = Signed
         then
            --  Generate the value
            --  if Conv >= 2**(Size-1) then Conv-2**Size else Conv
            declare
               Top_Bit : constant W_Term_Id :=
                 New_Integer_Constant
                   (Value => Uint_2 ** (Size - Uint_1));
               Negative_Value : constant W_Term_Id :=
                 New_Call
                   (Name   => Int_Infix_Subtr,
                    Typ    => EW_Int_Type,
                    Args   =>
                      (1 => +Conv,
                       2 => New_Integer_Constant (Value => 2 ** Size)));
            begin
               Conv := New_Conditional
                 (Condition =>
                    New_Comparison
                      (Symbol => Int_Infix_Ge,
                       Left   => Conv,
                       Right  => Top_Bit),
                  Then_Part => Negative_Value,
                  Else_Part => Conv,
                  Typ       => EW_Int_Type);
            end;

         else
            pragma Assert (Source_Status = Signed);
            pragma Assert (Target_Status = Unsigned);

            --  Generate the value
            --  if Conv < 0 then Conv+2**Size else Conv
            declare
               Large_Value : constant W_Term_Id :=
                 New_Call
                   (Name   => Int_Infix_Add,
                    Typ    => EW_Int_Type,
                    Args   =>
                      (1 => +Conv,
                       2 => New_Integer_Constant (Value => 2 ** Size)));
            begin
               Conv := New_Conditional
                 (Condition =>
                    New_Comparison
                      (Symbol => Int_Infix_Lt,
                       Left   => Conv,
                       Right  => New_Integer_Constant (Value => Uint_0)),
                  Then_Part => Large_Value,
                  Else_Part => Conv,
                  Typ       => EW_Int_Type);
            end;
         end if;

         return Insert_Simple_Conversion (Expr => Conv, To => Target_Type);
      end Precise_Integer_UC;

      --  Local variables

      Why_Type           : constant W_Type_Id := Type_Of_Node (E);
      Logic_Func_Binders : constant Item_Array := Compute_Binders
        (E, EW_Term, More_Reads);
      Logic_Why_Binders  : constant Binder_Array :=
        Spec_Binders & To_Binder_Array (Logic_Func_Binders);
      Logic_Id           : constant W_Identifier_Id :=
        To_Local
          (Logic_Function_Name
             (E, Specialization_Module => Specialization_Module));
      Pred_Id            : constant W_Identifier_Id :=
        To_Local
          (Guard_Predicate_Name
             (E, Specialization_Module => Specialization_Module));
      Params             : constant Transformation_Params :=
        (Logic_Params with delta Old_Policy => Ignore);
      Result_Id          : constant W_Identifier_Id :=
        New_Temp_Identifier (Base_Name => "result", Typ => Why_Type);
      Pred_Binders       : constant Binder_Array :=
        Binder_Type'(Ada_Node  => Empty,
                     B_Name    => +Result_Id,
                     B_Ent     => Null_Entity_Name,
                     Mutable   => False,
                     Labels    => <>)
        & Logic_Why_Binders;
      Labels : constant Symbol_Set :=
        (if Is_Expression_Function_Or_Completion (E)
         and then not Has_Contracts (E, Pragma_Postcondition)
         and then not Present (Get_Pragma (E, Pragma_Contract_Cases))
         then Symbol_Sets.To_Set (NID (GP_Inline_Marker))
         else Symbol_Sets.Empty_Set);

      Def : W_Term_Id;

   --  Start of processing for Declare_Logic_Functions

   begin
      if Is_Unchecked_Conversion_Instance (E)
        and then Is_UC_With_Precise_Definition (E)
      then
         declare
            Source, Target : Node_Id;
            Source_Type, Target_Type : Entity_Id;
            Arg         : constant W_Identifier_Id :=
              Logic_Why_Binders (1).B_Name;
         begin
            Get_Unchecked_Conversion_Args (E, Source, Target);
            Source_Type := Retysp (Entity (Source));
            Target_Type := Retysp (Entity (Target));

            if Is_Scalar_Type (Source_Type)
              and then Is_Scalar_Type (Target_Type)
            then
               Def :=
                 Precise_Integer_UC
                   (Arg           => +Arg,
                    Size          =>
                      Get_Attribute_Value (Source_Type, Attribute_Size),
                    Source_Type   => EW_Abstract (Source_Type),
                    Target_Type   => Base_Why_Type_No_Bool (Target_Type),
                    Source_Status => Get_Scalar_Status (Source_Type),
                    Target_Status => Get_Scalar_Status (Target_Type));

            --  At least one of Source or Target is a composite type made up
            --  of integers. Convert Source to a large-enough modular type,
            --  and convert that value to Target. If all types involved are
            --  modular, then this benefits from bitvector support in provers.

            else
               declare
                  --  Representation of a subcomponent of Source
                  type Source_Element is record
                     Typ    : Type_Kind_Id;
                     Offset : Uint;
                     Size   : Uint;
                     Expr   : W_Term_Id;
                  end record;

                  package Source_Elements is new
                    Ada.Containers.Doubly_Linked_Lists (Source_Element);
                  use Source_Elements;

                  --  Local subprograms

                  function Contribute_Value
                    (Base   : W_Type_Id;
                     Expr   : W_Expr_Id;
                     Offset : Uint;
                     Size   : Uint;
                     Typ    : Type_Kind_Id)
                     return W_Expr_Id;
                  --  Given a scalar expression Expr of type Typ, return its
                  --  contribution to a modular value of type Base, when its
                  --  bit representation takes Size bits at a given Offset in
                  --  Base.

                  function Expr_Index
                    (Typ : Type_Kind_Id;
                     Idx : Uint)
                     return W_Expr_Id;
                  --  Return the expression for indexing into array of type Typ

                  function Extract_Value
                    (Base   : W_Type_Id;
                     Bits   : W_Expr_Id;
                     Offset : Uint;
                     Size   : Uint;
                     Typ    : Type_Kind_Id)
                     return W_Expr_Id;
                  --  Return (Bits and (2**(Offset+Size)-1)) / 2**(Offset) as
                  --  a value of type Typ, to extract the value of an element
                  --  from its bit representation.

                  procedure Get_Source_Elements
                    (Typ      : Type_Kind_Id;
                     Offset   : Uint;
                     Size     : Uint;
                     Expr     : W_Term_Id;
                     Elements : in out List);
                  --  Retrieve the list of scalar elements from an object Expr
                  --  of type Typ located at a given Offset and of a given
                  --  Size, and append these to Elements.

                  function Reconstruct_Value
                    (Base   : W_Type_Id;
                     Bits   : W_Expr_Id;
                     Offset : Uint;
                     Size   : Uint;
                     Typ    : Type_Kind_Id)
                     return W_Expr_Id;
                  --  Given the representation Bits of modular type Base for
                  --  the complete object, reconstruct the element of type Typ
                  --  of a given Size at a given Offset.

                  ----------------------
                  -- Contribute_Value --
                  ----------------------

                  function Contribute_Value
                    (Base   : W_Type_Id;
                     Expr   : W_Expr_Id;
                     Offset : Uint;
                     Size   : Uint;
                     Typ    : Type_Kind_Id)
                     return W_Expr_Id
                  is
                     Value : W_Expr_Id;
                  begin
                     --  Special case for Boolean
                     if Is_Standard_Boolean_Type (Typ) then
                        Value :=
                          New_Conditional
                            (Domain    => EW_Term,
                             Condition => Expr,
                             Then_Part =>
                               New_Modular_Constant
                                 (Value => Uint_1,
                                  Typ   => Base),
                             Else_Part =>
                               New_Modular_Constant
                                 (Value => Uint_0,
                                  Typ   => Base),
                             Typ => Base);

                     --  If the value is from a modular type, or from a signed
                     --  type with no negative value, then simply convert it to
                     --  Base.
                     elsif Is_Unsigned_Type (Typ) then
                        Value := Insert_Scalar_Conversion
                          (Domain => EW_Term,
                           Expr   => Expr,
                           To     => Base);

                     --  Otherwise, we need to consider the bit representation
                     --  of that (possibly negative) signed value as Base, and
                     --  extract the low Size bits with the expression
                     --  (uc_of_int Expr) and (2**Size - 1)
                     else
                        Value :=
                          New_Call
                            (Domain   => EW_Term,
                             Name     => MF_BVs (Base).BW_And,
                             Typ      => Base,
                             Args     =>
                               (1 =>
                                  New_Call
                                    (Domain => EW_Term,
                                     Name   => MF_BVs (Base).UC_Of_Int,
                                     Args   =>
                                       (1 =>
                                          Insert_Scalar_Conversion
                                            (Domain => EW_Term,
                                             Expr   => Expr,
                                             To     => EW_Int_Type)),
                                     Typ    => Base),
                                2 =>
                                  New_Modular_Constant
                                    (Value => Uint_2 ** Size - Uint_1,
                                     Typ   => Base)));
                     end if;

                     --  Multiply this value by 2**Offset to get its
                     --  contribution to the overall value.
                     return
                       New_Call
                         (Domain   => EW_Term,
                          Name     => MF_BVs (Base).Mult,
                          Typ      => Base,
                          Args     =>
                            (1 =>
                               New_Modular_Constant
                                 (Value => Uint_2 ** Offset,
                                  Typ   => Base),
                             2 => Value));
                  end Contribute_Value;

                  ----------------
                  -- Expr_Index --
                  ----------------

                  function Expr_Index
                    (Typ : Type_Kind_Id;
                     Idx : Uint)
                     return W_Expr_Id
                  is
                     Index_Typ : constant Type_Kind_Id :=
                       Etype (First_Index (Typ));
                  begin
                     if Is_Modular_Integer_Type (Index_Typ) then
                        return
                          New_Modular_Constant
                            (Value => Idx,
                             Typ   => Base_Why_Type_No_Bool (Index_Typ));
                     else
                        return New_Integer_Constant (Value => Idx);
                     end if;
                  end Expr_Index;

                  -------------------
                  -- Extract_Value --
                  -------------------

                  function Extract_Value
                    (Base   : W_Type_Id;
                     Bits   : W_Expr_Id;
                     Offset : Uint;
                     Size   : Uint;
                     Typ    : Type_Kind_Id)
                     return W_Expr_Id
                  is
                     Mask : constant W_Expr_Id :=
                       New_Modular_Constant
                         (Value => Uint_2 ** (Offset + Size) - Uint_1,
                          Typ   => Base);
                     Divisor : constant W_Expr_Id :=
                       New_Modular_Constant
                         (Value => Uint_2 ** Offset,
                          Typ   => Base);
                     --  Value is (Bits and (2**(Offset+Size)-1)) / 2**(Offset)
                     Value : constant W_Expr_Id :=
                       New_Call
                         (Domain => EW_Term,
                          Name   => MF_BVs (Base).Udiv,
                          Typ    => Base,
                          Args   =>
                            (1 =>
                               New_Call
                                 (Domain => EW_Term,
                                  Name   => MF_BVs (Base).BW_And,
                                  Typ    => Base,
                                  Args   =>
                                    (1 => Bits,
                                     2 => Mask)),
                             2 => Divisor));
                  begin
                     --  Special case for Boolean
                     if Is_Standard_Boolean_Type (Typ) then
                        return
                          New_Conditional
                            (Domain    => EW_Term,
                             Condition =>
                               New_Comparison
                                 (Domain => EW_Term,
                                  Symbol => Why_Eq,
                                  Left   => Value,
                                  Right  =>
                                    New_Modular_Constant
                                      (Value => Uint_1,
                                       Typ   => Base)),
                             Then_Part => +True_Term,
                             Else_Part => +False_Term,
                             Typ       => EW_Bool_Type);

                     --  If the value is to a modular type, or an enumeration
                     --  with default 0-based representation, or to a signed
                     --  type with no negative value, then simply convert it
                     --  to Typ.
                     elsif Is_Unsigned_Type (Typ) then
                        return Insert_Scalar_Conversion
                          (Domain => EW_Term,
                           Expr   => Value,
                           To     => EW_Abstract (Typ));

                     --  Otherwise, we need to consider the bit representation
                     --  of that (possibly negative) signed value, to see
                     --  if the high bit is 1, in which case the value is
                     --  negative. So we generate the value
                     --  if Value >= 2**(Size-1) then Value-2**Size else Value
                     else
                        declare
                           Top_Bit : constant W_Expr_Id :=
                             New_Modular_Constant
                               (Value => Uint_2 ** (Size - Uint_1),
                                Typ   => Base);
                           Negative_Value : constant W_Expr_Id :=
                             New_Call
                               (Domain => EW_Term,
                                Name   => Int_Infix_Subtr,
                                Typ    => EW_Int_Type,
                                Args   =>
                                  (1 =>
                                     Insert_Scalar_Conversion
                                       (Domain => EW_Term,
                                        Expr   => Value,
                                        To     => EW_Int_Type),
                                   2 =>
                                     New_Integer_Constant
                                       (Value => 2 ** Size)));
                        begin
                           return New_Conditional
                             (Domain    => EW_Term,
                              Condition =>
                                New_Comparison
                                  (Domain => EW_Term,
                                   Symbol => MF_BVs (Base).Uge,
                                   Left   => Value,
                                   Right  => Top_Bit),
                              Then_Part =>
                                Insert_Scalar_Conversion
                                  (Domain => EW_Term,
                                   Expr   => Negative_Value,
                                   To     => EW_Abstract (Typ)),
                              Else_Part =>
                                Insert_Scalar_Conversion
                                  (Domain => EW_Term,
                                   Expr   => Value,
                                   To     => EW_Abstract (Typ)),
                              Typ => EW_Abstract (Typ));
                        end;
                     end if;
                  end Extract_Value;

                  --------------------------
                  -- Get_Type_Offset_List --
                  --------------------------

                  procedure Get_Source_Elements
                    (Typ      : Type_Kind_Id;
                     Offset   : Uint;
                     Size     : Uint;
                     Expr     : W_Term_Id;
                     Elements : in out List)
                  is
                  begin
                     if Is_Scalar_Type (Typ) then
                        Elements.Append
                          (Source_Element'(Typ    => Typ,
                                           Offset => Offset,
                                           Size   => Size,
                                           Expr   => Expr));

                     elsif Is_Record_Type (Typ) then
                        declare
                           Comp : Node_Id := First_Component (Typ);
                        begin
                           while Present (Comp) loop
                              Get_Source_Elements
                                (Typ     => Retysp (Etype (Comp)),
                                 Offset  =>
                                   Offset + Component_Bit_Offset (Comp),
                                 Size    => Esize (Comp),
                                 Expr    => New_Ada_Record_Access
                                   (Ada_Node => Types.Empty,
                                    Name     => +Expr,
                                    Ty       => Typ,
                                    Field    => Comp),
                                 Elements => Elements);
                              Next_Component (Comp);
                           end loop;
                        end;

                     elsif Is_Array_Type (Typ) then
                        declare
                           Index : constant Node_Id := First_Index (Typ);
                           Rng   : constant Node_Id := Get_Range (Index);
                           Low   : constant Uint :=
                             Expr_Value (Low_Bound (Rng));
                           High : constant Uint :=
                             Expr_Value (High_Bound (Rng));
                           Cur : Uint;
                        begin
                           if Low <= High then
                              Cur := Low;
                              while Cur <= High loop
                                 Get_Source_Elements
                                   (Typ      => Retysp (Component_Type (Typ)),
                                    Offset   =>
                                      (Cur - Low) * Component_Size (Typ),
                                    Size     => Component_Size (Typ),
                                    Expr     =>
                                      New_Array_Access
                                        (Ar    => Expr,
                                         Index =>
                                           (1 => Expr_Index (Typ, Cur))),
                                    Elements => Elements);
                                 Cur := Cur + Uint_1;
                              end loop;
                           end if;
                        end;

                     else
                        raise Program_Error;
                     end if;
                  end Get_Source_Elements;

                  -----------------------
                  -- Reconstruct_Value --
                  -----------------------

                  function Reconstruct_Value
                    (Base   : W_Type_Id;
                     Bits   : W_Expr_Id;
                     Offset : Uint;
                     Size   : Uint;
                     Typ    : Type_Kind_Id)
                     return W_Expr_Id
                  is
                  begin
                     if Is_Scalar_Type (Typ) then
                        return Extract_Value
                          (Base   => Base,
                           Bits   => Bits,
                           Offset => Offset,
                           Size   => Size,
                           Typ    => Typ);

                     elsif Is_Record_Type (Typ) then
                        declare
                           Comps : constant Component_Sets.Set :=
                             Get_Component_Set (Typ);
                           Assocs : W_Field_Association_Array
                             (1 .. Integer (Comps.Length));
                           Index : Positive := 1;
                        begin
                           for Comp of Comps loop
                              Assocs (Index) :=
                                New_Field_Association
                                  (Domain => EW_Term,
                                   Field  =>
                                     To_Why_Id
                                       (Comp, Local => False, Rec => Typ),
                                   Value  =>
                                     Reconstruct_Value
                                       (Base   => Base,
                                        Bits   => Bits,
                                        Offset =>
                                          Offset + Component_Bit_Offset (Comp),
                                        Size   => Esize (Comp),
                                        Typ    => Retysp (Etype (Comp))));
                              Index := Index + 1;
                           end loop;

                           return New_Record_Aggregate
                             (Associations =>
                                (1 => New_Field_Association
                                   (Domain => EW_Term,
                                    Field  =>
                                      E_Symb (Typ, WNE_Rec_Split_Fields),
                                    Value  =>
                                      New_Record_Aggregate
                                        (Associations => Assocs))),
                              Typ          => EW_Abstract (Typ));
                        end;

                     elsif Is_Array_Type (Typ) then
                        declare
                           Index : constant Node_Id := First_Index (Typ);
                           Rng   : constant Node_Id := Get_Range (Index);
                           Low   : constant Uint :=
                             Expr_Value (Low_Bound (Rng));
                           High  : constant Uint :=
                             Expr_Value (High_Bound (Rng));
                           Cur   : Uint;
                           Ar    : W_Expr_Id := +E_Symb (Typ, WNE_Dummy);
                        begin
                           if Low <= High then
                              Cur := Low;
                              while Cur <= High loop
                                 Ar := New_Array_Update
                                   (Ada_Node => Types.Empty,
                                    Ar     => Ar,
                                    Index  => (1 => Expr_Index (Typ, Cur)),
                                    Value  =>
                                      Reconstruct_Value
                                       (Base   => Base,
                                        Bits   => Bits,
                                        Offset =>
                                          Offset +
                                          (Cur - Low) * Component_Size (Typ),
                                        Size   =>
                                          Component_Size (Typ),
                                        Typ    =>
                                          Retysp (Component_Type (Typ))),
                                    Domain => EW_Term);
                                 Cur := Cur + 1;
                              end loop;
                           end if;

                           return Ar;
                        end;

                     else
                        raise Program_Error;
                     end if;
                  end Reconstruct_Value;

                  --  Local variables

                  Conv         : W_Term_Id;
                  Source_Elems : List;
                  Target_Size  : constant Uint :=
                    Get_Attribute_Value (Target_Type, Attribute_Size);
                  Base         : constant W_Type_Id :=
                    (if    Target_Size <=   Uint_8 then EW_BitVector_8_Type
                     elsif Target_Size <=  Uint_16 then EW_BitVector_16_Type
                     elsif Target_Size <=  Uint_32 then EW_BitVector_32_Type
                     elsif Target_Size <=  Uint_64 then EW_BitVector_64_Type
                     elsif Target_Size <= Uint_128 then EW_BitVector_128_Type
                     else raise Program_Error);

               begin
                  --  1. Convert the argument to a value of modular type Base

                  --  1.a Conversion from a scalar type should be identity or
                  --  call to uc_of_int.

                  if Is_Scalar_Type (Source_Type) then
                     Conv :=
                       Precise_Integer_UC
                         (Arg           => +Arg,
                          Size          => No_Uint,
                          Source_Type   => EW_Abstract (Source_Type),
                          Target_Type   => Base,
                          Source_Status => Get_Scalar_Status (Source_Type),
                          Target_Status => Modular);

                  --  1.b Otherwise extract all scalar subcomponents from the
                  --  composite value and sum up their contributions to the
                  --  value of type Base.

                  else
                     Get_Source_Elements
                       (Source_Type, Uint_0, Uint_0, +Arg, Source_Elems);
                     Conv :=
                       New_Modular_Constant (Value => Uint_0, Typ => Base);

                     for Elem of Source_Elems loop
                        Conv :=
                          New_Call
                            (Name     => MF_BVs (Base).Add,
                             Typ      => Base,
                             Args     =>
                               (1 => +Conv,
                                2 => Contribute_Value
                                  (Base   => Base,
                                   Expr   => +Elem.Expr,
                                   Offset => Elem.Offset,
                                   Size   => Elem.Size,
                                   Typ    => Elem.Typ)));
                     end loop;
                  end if;

                  --  2. Convert the converted argument to a value of the
                  --  target type.

                  --  2.a Conversion to a scalar type should be identity or
                  --  call to uc_to_int.

                  if Is_Scalar_Type (Target_Type) then
                     Def :=
                       Precise_Integer_UC
                         (Arg           => Conv,
                          Size          => No_Uint,
                          Source_Type   => Base,
                          Target_Type   => Base_Why_Type_No_Bool (Target_Type),
                          Source_Status => Modular,
                          Target_Status => Get_Scalar_Status (Target_Type));

                  --  2.b Otherwise recursively reconstruct all scalar
                  --  subcomponents from the value of type Base.

                  else
                     Def :=
                       +Reconstruct_Value
                         (Base   => Base,
                          Bits   => +Conv,
                          Offset => Uint_0,
                          Size   =>
                            Get_Attribute_Value (Target_Type, Attribute_Size),
                          Typ    => Target_Type);
                  end if;
               end;
            end if;
         end;

      else
         Def := Compute_Inlined_Expr (E, Logic_Func_Binders, Why_Type, Params);
      end if;

      --  Generate a logic function

      Emit
        (Th,
         New_Function_Decl
           (Domain      => EW_Pterm,
            Name        => Logic_Id,
            Binders     => Logic_Why_Binders,
            Location    => No_Location,
            Labels      => Labels,
            Def         => +Def,
            Return_Type => Why_Type));

      --  Generate the guard for the postcondition of the function

      Emit
        (Th,
         New_Function_Decl
           (Domain      => EW_Pred,
            Name        => Pred_Id,
            Binders     => Pred_Binders,
            Location    => No_Location,
            Labels      => Symbol_Sets.Empty_Set,
            Return_Type => EW_Bool_Type));

      --  Generate logic functions and guards for dispatching and
      --  refined versions of the function in a separate module.

      if Is_Dispatching_Operation (E)
        and then not Is_Hidden_Dispatching_Operation (E)
      then
         Emit
           (Dispatch_Th,
            New_Function_Decl
              (Domain      => EW_Pterm,
               Name        => Logic_Id,
               Binders     => Tag_Binder & Logic_Why_Binders,
               Location    => No_Location,
               Labels      => Symbol_Sets.Empty_Set,
               Return_Type => Why_Type));
         Emit
           (Dispatch_Th,
            New_Function_Decl
              (Domain      => EW_Pred,
               Name        => Pred_Id,
               Binders     =>
                 Pred_Binders (1) & Tag_Binder &
                 Pred_Binders (2 .. Pred_Binders'Length),
               Labels      => Symbol_Sets.Empty_Set,
               Location    => No_Location,
               Return_Type => EW_Bool_Type));
      end if;

      --  For higher order specializations, we do not take into account
      --  refined postcondition if any.

      if Entity_Body_In_SPARK (E)
        and then Has_Contracts (E, Pragma_Refined_Post)
        and then Specialization_Module = No_Symbol
      then
         Emit
           (Th,
            New_Namespace_Declaration
              (Name         => NID (To_String (WNE_Refine_Module)),
               Declarations =>
                 (1 => New_Function_Decl
                      (Domain      => EW_Pterm,
                       Name        => Logic_Id,
                       Binders     => Logic_Why_Binders,
                       Labels      => Symbol_Sets.Empty_Set,
                       Location    => No_Location,
                       Return_Type => Why_Type),
                  2 => New_Function_Decl
                    (Domain      => EW_Pred,
                     Name        => Pred_Id,
                     Binders     => Pred_Binders,
                     Labels      => Symbol_Sets.Empty_Set,
                     Location    => No_Location,
                     Return_Type => EW_Bool_Type))));
      end if;

      --  Generate a function return the pledge of a traversal function.
      --  We don't need anything specific for dispatching functions as
      --  tagged types cannot be deep.

      if Is_Borrowing_Traversal_Function (E) then
         Declare_At_End_Function (Th, E, Logic_Why_Binders);
      end if;
   end Declare_Logic_Functions;

   --------------------------
   -- Generate_VCs_For_LSP --
   --------------------------

   procedure Generate_VCs_For_LSP (E : Subprogram_Kind_Id) is
      Name      : constant String := Full_Name (E);
      Params    : Transformation_Params;

      Inherited_Pre_List  : Node_Lists.List;
      Classwide_Pre_List  : Node_Lists.List;
      Pre_List            : Node_Lists.List;
      Inherited_Post_List : Node_Lists.List;
      Classwide_Post_List : Node_Lists.List;
      Post_List           : Node_Lists.List;

      Inherited_Pre_Spec   : W_Pred_Id;
      Classwide_Pre_Spec   : W_Pred_Id;
      Pre_Spec             : W_Pred_Id;
      Inherited_Post_Spec  : W_Pred_Id;
      Classwide_Post_Spec  : W_Pred_Id;
      Post_Spec            : W_Pred_Id;

      Inherited_Pre_Assume  : W_Prog_Id;
      Classwide_Pre_Check   : W_Prog_Id;
      Classwide_Pre_Assume  : W_Prog_Id;
      Pre_Check             : W_Prog_Id;
      Pre_Assume            : W_Prog_Id;
      Call_Effects          : W_Prog_Id;
      Post_Assume           : W_Prog_Id;
      Classwide_Post_Check  : W_Prog_Id;
      Classwide_Post_Assume : W_Prog_Id;
      Inherited_Post_Check  : W_Prog_Id;

      Why_Body                : W_Prog_Id := +Void;
      Classwide_Pre_RTE       : W_Prog_Id := +Void;
      Classwide_Weaker_Pre    : W_Prog_Id := +Void;
      Weaker_Pre              : W_Prog_Id := +Void;
      Stronger_Post           : W_Prog_Id := +Void;
      Classwide_Post_RTE      : W_Prog_Id := +Void;
      Stronger_Classwide_Post : W_Prog_Id := +Void;

      Old_Parts               : Node_Sets.Set;

      Th : Theory_UC;
   begin
      Th :=
        Open_Theory (WF_Main,
                     New_Module
                       (Name => Name & "__subprogram_lsp",
                        File => No_Symbol),
                     Comment =>
                       "Module for checking LSP for subprogram "
                     & """" & Get_Name_String (Chars (E)) & """"
                     & (if Sloc (E) > 0 then
                          " defined at " & Build_Location_String (Sloc (E))
                       else "")
                     & ", created in " & GNAT.Source_Info.Enclosing_Entity);

      Current_Subp := E;

      --  First create a new identifier for F'Result

      if Ekind (E) = E_Function then
         Result_Is_Mutable := True;
         Result_Name :=
           New_Identifier
             (Name  => Name & "__result",
              Typ   => Type_Of_Node (E));
      end if;

      Params := Contract_VC_Params;

      --  First retrieve contracts specified on the subprogram and the
      --  subprograms it overrides.

      Inherited_Pre_List := Find_Contracts
        (E, Pragma_Precondition, Inherited => True);
      Classwide_Pre_List := Find_Contracts
        (E, Pragma_Precondition, Classwide => True);
      Pre_List := Find_Contracts (E, Pragma_Precondition);

      Inherited_Post_List := Find_Contracts
        (E, Pragma_Postcondition, Inherited => True);
      Classwide_Post_List := Find_Contracts
        (E, Pragma_Postcondition, Classwide => True);
      Post_List := Find_Contracts (E, Pragma_Postcondition);

      --  Then, generate suitable predicates based on the specified contracts,
      --  with appropriate True defaults.

      Inherited_Pre_Spec :=
        +Compute_Spec (Params, Inherited_Pre_List, EW_Pred);
      Classwide_Pre_Spec :=
        +Compute_Spec (Params, Classwide_Pre_List, EW_Pred);
      Pre_Spec := +Compute_Spec (Params, Pre_List, EW_Pred);

      Inherited_Post_Spec :=
        +Compute_Spec (Params, Inherited_Post_List, EW_Pred);
      Classwide_Post_Spec :=
        +Compute_Spec (Params, Classwide_Post_List, EW_Pred);
      Post_Spec :=
        +New_And_Expr
        (Left   =>
           +Compute_Spec (Params, Post_List, EW_Pred),
         Right  => +Compute_Contract_Cases_Postcondition (Params, E),
         Domain => EW_Pred);

      --  Compute the effect of a call of the subprogram

      Call_Effects := Compute_Call_Effects (Params, E);

      --  If E has a class-wide precondition, check that it cannot raise a
      --  run-time error in an empty context.

      if not Classwide_Pre_List.Is_Empty then
         Classwide_Pre_RTE :=
           +Compute_Spec (Params, Classwide_Pre_List, EW_Prog);
         Classwide_Pre_RTE := New_Ignore (Prog => Classwide_Pre_RTE);
      end if;

      --  If E is overriding another subprogram, check that its specified
      --  classwide precondition is weaker than the inherited one.

      if Is_Overriding_Subprogram (E)
        and then not Classwide_Pre_List.Is_Empty
      then
         Inherited_Pre_Assume :=
           New_Assume_Statement (Pred => Inherited_Pre_Spec);

         Classwide_Pre_Check := New_Located_Assert
           (Ada_Node => Get_Location_For_Aspect (E, Pragma_Precondition,
                                                 Classwide => True),
            Pred     => Classwide_Pre_Spec,
            Reason   => VC_Weaker_Classwide_Pre,
            Kind     => EW_Assert);

         Classwide_Weaker_Pre := Sequence
           ((1 => New_Comment (Comment =>
                               NID ("Checking that class-wide precondition is"
                                  & " implied by inherited precondition")),
             2 => Inherited_Pre_Assume,
             3 => Classwide_Pre_Check));

         Classwide_Weaker_Pre := New_Ignore (Prog => Classwide_Weaker_Pre);
      end if;

      --  If E has a specific precondition, check that it is weaker than the
      --  dispatching one.

      if not Pre_List.Is_Empty then

         --  Normal preconditions are not allowed on dispatching operations
         --  unless the dispatching type is a private type whose partial view
         --  is untagged.

         pragma Assert (Is_Hidden_Dispatching_Operation (E));
         pragma Assert (Classwide_Pre_List.Is_Empty);

         --  Only do the check for overriding subprograms. New primitives of
         --  privately tagged types cannot have classwide contracts.

         if Is_Overriding_Subprogram (E) then
            Classwide_Pre_Assume :=
              New_Assume_Statement
                (Pred => Get_LSP_Contract (Params, E, Pragma_Precondition));

            Pre_Check := New_Located_Assert
              (Ada_Node => Get_Location_For_Aspect (E, Pragma_Precondition),
               Pred     => Pre_Spec,
               Reason   => (if Inherited_Pre_List.Is_Empty
                            then
                               VC_Trivial_Weaker_Pre
                            else
                               VC_Weaker_Pre),
               Kind     => EW_Assert);

            Weaker_Pre := Sequence
              ((1 => New_Comment
                (Comment =>
                   NID ("Checking that precondition is"
                     & " implied by class-wide precondition")),
                2 => Classwide_Pre_Assume,
                3 => Pre_Check));

            Weaker_Pre := New_Ignore (Prog => Weaker_Pre);
         end if;
      end if;

      --  If E has a specific postcondition, check that it is stronger than the
      --  dispatching one. To that end, perform equivalent effects of call in
      --  context of precondition for static call.
      --  Skip this check if the dispatching postcondition is the default True
      --  postcondition.

      if not (Post_List.Is_Empty
               and then No (Get_Pragma (E, Pragma_Contract_Cases)))
        and then not (Classwide_Post_List.Is_Empty
                        and then
                      Inherited_Post_List.Is_Empty)
      then
         Pre_Assume :=
           New_Assume_Statement (Pred =>
             Get_Static_Call_Contract (Params, E, Pragma_Precondition));

         Post_Assume := New_Assume_Statement (Pred => Post_Spec);

         Classwide_Post_Check := New_Located_Assert
           (Ada_Node =>
              (if not Post_List.Is_Empty then
                 Get_Location_For_Aspect (E, Pragma_Postcondition)
               elsif Present (Get_Pragma (E, Pragma_Contract_Cases)) then
                  Expression
                    (First
                      (Pragma_Argument_Associations
                         (Get_Pragma (E, Pragma_Contract_Cases))))
               else
                  Empty),
            Pred     =>
              Get_LSP_Contract (Params, E, Pragma_Postcondition),
            Reason   => VC_Stronger_Post,
            Kind     => EW_Assert);

         Stronger_Post := Sequence
           ((1 => New_Comment (Comment =>
                                 NID ("Simulate static call to subprogram "
                                 & """" & Get_Name_String (Chars (E)) & """")),
             2 => Pre_Assume,
             3 => Call_Effects,
             4 => New_Comment (Comment =>
                               NID ("Checking that class-wide postcondition is"
                                  & " implied by postcondition")),
             5 => Post_Assume,
             6 => Classwide_Post_Check));

         Stronger_Post :=
           New_Ignore (Prog => Stronger_Post);

         --  Collect old attributes referenced by the checks

         Collect_Old_For_Subprogram (E, Old_Parts);
         Collect_Old_Parts (Classwide_Post_List, Old_Parts);
         if Classwide_Post_List.Is_Empty then
            Collect_Old_Parts (Inherited_Post_List, Old_Parts);
         end if;
      end if;

      --  If E is overriding another subprogram, check that its specified
      --  classwide postcondition is stronger than the inherited one.
      --  Note that we should *not* assume the dispatching precondition for
      --  this check, as this would not be transitive.

      if not Classwide_Post_List.Is_Empty
        and then Is_Overriding_Subprogram (E)
      then

         Classwide_Post_Assume :=
           New_Assume_Statement (Pred => Classwide_Post_Spec);

         Inherited_Post_Check := New_Located_Assert
           (Ada_Node  => Get_Location_For_Aspect (E, Pragma_Postcondition,
            Classwide => True),
            Pred      => Inherited_Post_Spec,
            Reason    => VC_Stronger_Classwide_Post,
            Kind      => EW_Assert);

         Stronger_Classwide_Post := Sequence
           ((1 => New_Comment
             (Comment =>
                NID ("Checking that inherited postcondition is"
                  & " implied by class-wide postcondition")),
             2 => Call_Effects,
             3 => Classwide_Post_Assume,
             4 => Inherited_Post_Check));

         Stronger_Classwide_Post :=
           New_Ignore (Prog => Stronger_Classwide_Post);

         --  Collect old attributes referenced by the checks

         Collect_Old_Parts (Inherited_Post_List, Old_Parts);
         Collect_Old_Parts (Classwide_Post_List, Old_Parts);
      end if;

      Why_Body := Sequence
        ((1 => Classwide_Pre_RTE,
          2 => Classwide_Weaker_Pre,
          3 => Weaker_Pre,
          4 => Stronger_Post,
          5 => Stronger_Classwide_Post));

      --  Add declarations for 'Old variables

      Why_Body := +Bind_From_Mapping_In_Expr
        (Params => Params,
         Map    => Map_For_Old,
         Expr   => +Why_Body,
         Domain => EW_Pterm,
         Subset => Old_Parts);

      --  Check that the class-wide postcondition cannot raise runtime errors.
      --  To that end, perform equivalent effects of call in an empty context.
      --  Also check that the evaluation of 'Old variables are free of RTE in
      --  the empty context. Here again, we should *not* assume the dispatching
      --  precondition for this check, as this postcondition can be inherited
      --  in overridings weakening the precondition.

      if not Classwide_Post_List.Is_Empty then
         Classwide_Post_RTE :=
           +Compute_Spec (Params, Classwide_Post_List, EW_Prog);
         Classwide_Post_RTE :=
           New_Ignore (Prog => Classwide_Post_RTE);
         Classwide_Post_RTE := Sequence
           ((1 => New_Comment (Comment =>
                               NID ("Checking absence of RTE in"
                                  & " class-wide postcondition")),
             2 => Call_Effects,
             3 => Classwide_Post_RTE));

         --  Add declarations for 'Old variables with RTE

         Old_Parts.Clear;
         Collect_Old_Parts (Classwide_Post_List, Old_Parts);

         Classwide_Post_RTE := +Bind_From_Mapping_In_Expr
           (Params => Params,
            Map    => Map_For_Old,
            Expr   => +Classwide_Post_RTE,
            Domain => EW_Prog,
            Subset => Old_Parts);
      end if;

      Append (Why_Body, Classwide_Post_RTE);

      --  Insert bindings for variants, they may be needed to check recursive
      --  calls in the classwide post. We use EW_Pterm as a domain here as RTE
      --  has already been checked while verifying E.

      Why_Body := Insert_Bindings_For_Variants
        (E      => E,
         Prog   => Why_Body,
         Domain => EW_Pterm,
         Params => Params);

      --  Assume dynamic property of inputs before the checks

      Prepend
        (Compute_Dynamic_Property_For_Inputs (Params => Params,
                                              E      => E),
         Why_Body);

      --  Assume values of constants

      Assume_Value_Of_Constants (Why_Body, E, Params);

      --  Declare a global variable to hold the result of a function

      if Ekind (E) = E_Function then
         Emit
           (Th,
            New_Global_Ref_Declaration
              (Ada_Node => E,
               Name     => Result_Name,
               Labels   => Get_Counterexample_Labels (E),
               Location => No_Location,
               Ref_Type => Type_Of_Node (E)));
      end if;

      Emit (Th,
            Why.Gen.Binders.New_Function_Decl
              (Domain   => EW_Prog,
               Name     => Def_Name,
               Binders  => (1 => Unit_Param),
               Labels   => Symbol_Sets.Empty_Set,
               Location => Safe_First_Sloc (E),
               Def      => +Why_Body));

      --  We should *not* filter our own entity, it is needed for recursive
      --  calls.

      if Ekind (E) = E_Function then
         Result_Name := Why_Empty;
         Result_Is_Mutable := False;
      end if;

      Close_Theory (Th,
                    Kind => VC_Generation_Theory,
                    Defined_Entity => E);
   end Generate_VCs_For_LSP;

   ------------------------------------------
   -- Generate_VCs_For_Package_Elaboration --
   ------------------------------------------

   procedure Generate_VCs_For_Package_Elaboration (E : E_Package_Id) is
      Name       : constant String  := Full_Name (E);
      Body_N     : constant Node_Id := Package_Body (E);
      Vis_Decls  : constant List_Id :=
        Visible_Declarations_Of_Package (E);
      Priv_Decls : constant List_Id :=
        Private_Declarations_Of_Package (E);
      Init_Cond  : constant Node_Id :=
        Get_Pragma (E, Pragma_Initial_Condition);
      Params     : Transformation_Params;

      Why_Body   : W_Prog_Id := +Void;
      Why_Spec   : W_Prog_Id := +Void;
      Post       : W_Pred_Id;
      Th         : Theory_UC;
   begin
      --  We open a new theory, so that the context is fresh for that package

      Th :=
        Open_Theory (WF_Main,
                     New_Module
                       (Name => Name & "__package_def",
                        File => No_Symbol),
                     Comment =>
                       "Module for checking absence of run-time errors and "
                     & "package initial condition on package elaboration of "
                     & """" & Get_Name_String (Chars (E)) & """"
                     & (if Sloc (E) > 0 then
                          " defined at " & Build_Location_String (Sloc (E))
                       else "")
                     & ", created in " & GNAT.Source_Info.Enclosing_Entity);

      Current_Subp := E;

      Register_VC_Entity (E);

      Params := Body_Params;

      --  Reset the toplevel exceptions for exit paths

      Clear_Exceptions;

      if Within_Protected_Type (E) then
         declare
            CPT : constant Entity_Id := Containing_Protected_Type (E);
         begin
            --  The Ada_Node is important here, because that's how we detect
            --  occurrences of "self" in a term later.

            Self_Name := Concurrent_Self_Ident (CPT);
            Self_Is_Mutable := True;
         end;

         --  Declare global variable to hold the state of a protected object

         Emit
           (Th,
            New_Global_Ref_Declaration
              (Ada_Node => Containing_Protected_Type (E),
               Name     => Self_Name,
               Labels   => Symbol_Sets.Empty_Set,
               Location => Safe_First_Sloc (E),
               Ref_Type =>
                 Type_Of_Node (Containing_Protected_Type (E))));
      end if;

      --  Translate initial condition of E

      if Present (Init_Cond)
        and then (No (Body_N) or else Entity_Body_In_SPARK (E))
      then
         declare
            Expr : constant Node_Id :=
              Expression (First (Pragma_Argument_Associations (Init_Cond)));
         begin
            --  Generate postcondition for generated subprogram, that
            --  corresponds to the initial condition of the package.

            Params.Phase := Generate_Contract_For_Body;
            Post := Transform_Pred (Expr, EW_Bool_Type, Params);
            Post := New_VC_Pred (Init_Cond, Post, VC_Initial_Condition);

            --  Generate program to check the absence of run-time errors in the
            --  initial condition.

            Params.Phase := Generate_VCs_For_Contract;
            Why_Body :=
              New_Ignore (Prog => Transform_Prog (Expr, EW_Bool_Type, Params));
         end;

      --  No initial condition, so no postcondition for the generated
      --  subprogram.

      else
         Post := Why_Empty;
      end if;

      --  Translate declarations and statements in the package body, if there
      --  is one and it is in SPARK.

      if Entity_Body_In_SPARK (E) then
         if Present (Handled_Statement_Sequence (Body_N))
           and then Body_Statements_In_SPARK (E)
         then
            Prepend
              (Transform_Handled_Statements
                 (Handled_Statement_Sequence (Body_N), Body_Params),
               Why_Body);
         end if;

         Why_Body :=
           Transform_Declarations_Block
             (Declarations (Body_N), Why_Body, Body_Params);

         --  Assume initial conditions of withed units from the body

         if Is_Compilation_Unit (E) then
            declare
               Local_Params : constant Transformation_Params :=
                 (Params with delta Phase => Generate_VCs_For_Contract);
            begin
               Prepend
                 (Assume_Initial_Condition_Of_Withed_Units
                    (Package_Body_Entity (Body_N), Local_Params),
                  Why_Body);
            end;
         end if;
      end if;

      --  Introduce a check for the type invariant of all the variables
      --  initialized by the package.

      if No (Body_N) or else Entity_Body_In_SPARK (E) then
         declare
            Params : constant Transformation_Params := Contract_VC_Params;
         begin
            Append
              (Why_Body,
               Check_Type_Invariants_For_Package (E, Params));
         end;
      end if;

      --  Translate public and private declarations of the package

      if Present (Priv_Decls)
        and then Private_Spec_In_SPARK (E)
      then
         Why_Spec :=
           Transform_Declarations_Block (Priv_Decls, Why_Spec, Body_Params);
      end if;

      if Present (Vis_Decls) then
         Why_Spec :=
           Transform_Declarations_Block (Vis_Decls, Why_Spec, Body_Params);
      end if;

      --  Assume initial conditions of withed units.
      --  ??? Currently, we only assume initial conditions of withed units
      --  on compilation units though it is also valid for library level
      --  packages. This is because it does not seem relevant for nested
      --  packages. It may be interesting to rather inline them.

      if Is_Compilation_Unit (E) then
         declare
            Local_Params : constant Transformation_Params :=
              (Params with delta Phase => Generate_VCs_For_Contract);
         begin
            Prepend
              (Assume_Initial_Condition_Of_Withed_Units (E, Local_Params),
               Why_Spec);
         end;
      end if;

      --  Assume precondition of the enclosing subprogram for nested packages
      --  which are declared directly inside the declarative part of the
      --  subprogram.
      --  ??? We could also assume it for other nested packages, but this would
      --  require havoking variables.

      declare
         Enclosing_Subp : constant Entity_Id :=
           Directly_Enclosing_Subprogram_Or_Entry (E);
      begin
         if Present (Enclosing_Subp) then
            declare
               Pre : W_Pred_Id :=
                 Get_Static_Call_Contract
                   (Params, Enclosing_Subp, Pragma_Precondition);
            begin

               --  For entries, also assume that the guard holds

               if Is_Entry (Enclosing_Subp)
                 and then Entity_Body_In_SPARK (Enclosing_Subp)
               then
                  declare
                     Params  : constant Transformation_Params :=
                       Contract_Body_Params;
                     Barrier : constant Node_Id :=
                       Entry_Body_Barrier (Get_Body (Enclosing_Subp));
                  begin
                     Pre :=
                       +New_And_Then_Expr
                       (Domain => EW_Pred,
                        Left   => +Pre,
                        Right  =>
                          Transform_Expr
                            (Barrier, EW_Bool_Type, EW_Pred, Params));
                  end;
               end if;

               Prepend (New_Assume_Statement (Pred => Pre), Why_Spec);
            end;
         end if;
      end;

      --  Assuming information about input variables and constants should be
      --  done separately for Why_Spec and Why_Body so that objects used in
      --  the body are not visible when analyszing the spec. It is necessary as
      --  bodies might introduce cycles in dependencies between packages.
      --  This might introduce duplicated assumptions in the body.

      --  We assume that objects used in the program are in range, if
      --  they are of a dynamic type.

      Params.Phase := Generate_VCs_For_Contract;

      Prepend
        (Assume_Dynamic_Invariant_For_Variables
           (Vars   => Get_Referenced_Variables (Why_Spec, E),
            Params => Params,
            Scope  => E),
         Why_Spec);
      --  Flow analysis does not compute the set of variables used from a
      --  package specification only. Do it from the generated Why.

      Prepend
        (Compute_Dynamic_Property_For_Inputs (Params => Params,
                                              E      => E),
         Why_Body);

      --  Assume values of constants

      Assume_Value_Of_Constants (Why_Spec, E, Params);
      Assume_Value_Of_Constants (Why_Body, E, Params);

      --  Declare the toplevel exceptions for exit paths

      Declare_Exceptions (Th);

      Emit (Th,
            Why.Gen.Binders.New_Function_Decl
              (Domain   => EW_Prog,
               Name     => Def_Name,
               Binders  => (1 => Unit_Param),
               Location => Safe_First_Sloc (E),
               Labels   => Symbol_Sets.Empty_Set,
               Post     => Post,
               Def      => +Sequence (Why_Spec, Why_Body)));

      --  Cleanup

      Self_Name := Why_Empty;
      Self_Is_Mutable := False;

      Close_Theory (Th,
                    Kind           => VC_Generation_Theory,
                    Defined_Entity => E);
   end Generate_VCs_For_Package_Elaboration;

   -------------------------------------
   -- Generate_VCs_For_Protected_Type --
   -------------------------------------

   procedure Generate_VCs_For_Protected_Type (E : E_Protected_Type_Id) is
      type Discr is record
         Id  : W_Identifier_Id;
         Val : W_Expr_Id;
      end record;
      --  Why3 representation of discriminants

      package Discriminant_Lists is new
        Ada.Containers.Doubly_Linked_Lists
          (Element_Type => Discr);

      W_Discriminants : Discriminant_Lists.List;
      --  Container for Why3 representations

      procedure Prepare_Discr;
      --  insert the discriminants into the symbol table so that they can be
      --  referred to by the Why generated for the various checks

      procedure Wrap_Discr (Expr : in out W_Prog_Id);

      -------------------
      -- Prepare_Discr --
      -------------------

      procedure Prepare_Discr is
         Discr_N : Node_Id := Empty;
      begin
         Ada_Ent_To_Why.Push_Scope (Symbol_Table);

         if Has_Discriminants (E) then
            Discr_N := First_Discriminant (E);
         end if;

         while Present (Discr_N) loop
            declare
               Discr_W : constant Discr :=
                 (Id =>
                    New_Temp_Identifier
                      (Typ =>
                           EW_Abstract (Etype (Discr_N))),

                  Val =>
                    New_Ada_Record_Access
                      (Ada_Node => Empty,
                       Domain   => EW_Term,
                       Name     => +Self_Name,
                       Field    => Discr_N,
                       Ty       => E));
            begin
               Insert_Tmp_Item_For_Entity (Discr_N, Discr_W.Id);

               W_Discriminants.Append (Discr_W);
            end;

            Next_Discriminant (Discr_N);
         end loop;
      end Prepare_Discr;

      ----------------
      -- Wrap_Discr --
      ----------------

      procedure Wrap_Discr (Expr : in out W_Prog_Id) is
      begin
         for W_D of reverse W_Discriminants loop
            Expr :=
              New_Typed_Binding
                (Name    => +W_D.Id,
                 Def     => +W_D.Val,
                 Context => Expr);
         end loop;
         Ada_Ent_To_Why.Pop_Scope (Symbol_Table);
      end Wrap_Discr;

      Why_Body   : W_Prog_Id := +Void;
      Name       : constant String  := Full_Name (E);
      Priv_Decls : constant List_Id := Private_Declarations_Of_Prot_Type (E);
      Vis_Decls  : constant List_Id := Visible_Declarations_Of_Prot_Type (E);
      Th         : Theory_UC;

   --  Start of processing for Generate_VCs_For_Protected_Type

   begin
      --  We open a new theory, so that the context is fresh for this task

      Th :=
        Open_Theory
          (WF_Main,
           New_Module
             (Name => Name & "__protected_type",
              File => No_Symbol),
           Comment =>
             "Module for various checks related to the protected type "
           & """" & Get_Name_String (Chars (E)) & """"
           & (if Sloc (E) > 0 then
                " defined at " & Build_Location_String (Sloc (E))
             else "")
           & ", created in " & GNAT.Source_Info.Enclosing_Entity);
      Current_Subp := E;

      Register_VC_Entity (E);

      --  The Ada_Node is important here, because that's how we detect
      --  occurrences of "self" in a term later.

      Self_Name := Concurrent_Self_Ident (E);
      Self_Is_Mutable := False;

      Emit (Th,
            Why.Gen.Binders.New_Function_Decl
              (Domain      => EW_Pterm,
               Name        => Self_Name,
               Binders     => (1 .. 0 => <>),
               Location    => Safe_First_Sloc (E),
               Labels      => Symbol_Sets.Empty_Set,
               Return_Type => Get_Typ (Self_Name)));

      --  ??? Where is the call to Push_Scope?

      Prepare_Discr;

      --  If protected object attaches an interrupt, the priority must be in
      --  range of System.Interrupt_Priority; see RM C.3.1(11/3).

      if Requires_Interrupt_Priority (E) then
         declare
            P : constant Node_Id :=
              Get_Priority_Or_Interrupt_Priority (E);
         begin

            --  If no priority was specified, the default priority is
            --  implementation-defined (RM D.3 (10/3)), but in range
            --  of System.Interrupt_Priority.

            if Present (P) then

               declare
                  P_Expr : constant W_Expr_Id :=
                    Transform_Expr
                      (Expr          => P,
                       Domain        => EW_Term,
                       Params        => Body_Params,
                       Expected_Type => EW_Int_Type);
               begin

                  --  Generate a range check, but with a reason of ceiling
                  --  check, as specified in RM index for "Ceiling_Check".

                  Append
                    (Why_Body,
                     New_Located_Assert
                       (Ada_Node => E,
                        Pred     =>
                          +New_Range_Expr
                          (Domain => EW_Pred,
                           Low    =>
                             New_Attribute_Expr
                               (Domain => EW_Term,
                                Ty     =>
                                  RTE (RE_Interrupt_Priority),
                                Attr   => Attribute_First,
                                Params => Body_Params),
                           High   =>
                             New_Attribute_Expr
                               (Domain => EW_Term,
                                Ty     =>
                                  RTE (RE_Interrupt_Priority),
                                Attr   => Attribute_Last,
                                Params => Body_Params),
                           Expr   => P_Expr),
                        Reason   => VC_Ceiling_Interrupt,
                        Kind     => EW_Check));
               end;
            end if;
         end;
      end if;

      --  Check that no Attach_Handler expression of the protected object
      --  corresponds to a reserved interrupt; see RM C.3.1(10/3).

      Append (Why_Body,
              Compute_Attach_Handler_Check
                (Base_Type (E), Body_Params));

      --  Translate public and private declarations of the package

      if Present (Priv_Decls)
        and then Private_Spec_In_SPARK (E)
      then
         --  Check for absence of runtime error in protected components initial
         --  values.

         declare
            Checks  : W_Statement_Sequence_Id := Void_Sequence;
            F_Check : W_Prog_Id;
         begin
            for Field of Get_Component_Set (E) loop
               if Ekind (Field) in E_Component | E_Discriminant then

                  if Present (Expression (Enclosing_Declaration (Field))) then

                     --  If Field has a default expression, use it

                     F_Check := Transform_Prog
                       (Expr          =>
                          Expression (Enclosing_Declaration (Field)),
                        Expected_Type => Type_Of_Node (Etype (Field)),
                        Params        => Body_Params);
                  else

                     --  Otherwise, use its Field's Etype default value

                     F_Check :=
                       Compute_Default_Check
                         (Field, Etype (Field), Body_Params);
                  end if;

                  if F_Check /= +Void then
                     Append
                       (Checks,
                        New_Ignore
                          (Ada_Node => Etype (Field),
                           Prog     => F_Check));
                  end if;
               end if;
            end loop;

            Append (Why_Body, +Checks);
         end;

         Why_Body :=
           Transform_Declarations_Block (Priv_Decls, Why_Body, Body_Params);
      end if;

      if Present (Vis_Decls) then
         Why_Body :=
           Transform_Declarations_Block (Vis_Decls, Why_Body, Body_Params);
      end if;

      Wrap_Discr (Why_Body);

      Emit (Th,
            Why.Gen.Binders.New_Function_Decl
              (Domain   => EW_Prog,
               Name     => Def_Name,
               Binders  => (1 => Unit_Param),
               Location => Safe_First_Sloc (E),
               Labels   => Symbol_Sets.Empty_Set,
               Def      => +Why_Body));

      Ada_Ent_To_Why.Pop_Scope (Symbol_Table);

      Self_Name := Why_Empty;
      Self_Is_Mutable := False;

      Close_Theory (Th,
                    Kind => VC_Generation_Theory);
   end Generate_VCs_For_Protected_Type;

   ---------------------------------
   -- Generate_VCs_For_Subprogram --
   ---------------------------------

   procedure Generate_VCs_For_Subprogram (E : Callable_Kind_Id) is
      Name : constant String := Full_Name (E);
      Th   : Theory_UC;

   --  Start of processing for Generate_VCs_For_Subprogram

   begin
      Th :=
        Open_Theory
          (WF_Main,
           New_Module
             (Name => Name & "__subprogram_def",
              File => No_Symbol),
           Comment =>
             "Module for checking contracts and absence of "
           & "run-time errors in subprogram "
           & """" & Get_Name_String (Chars (E)) & """"
           & (if Sloc (E) > 0 then
                " defined at " & Build_Location_String (Sloc (E))
             else "")
           & ", created in " & GNAT.Source_Info.Enclosing_Entity);

      Current_Subp := E;

      Register_VC_Entity (E);

      Generate_VCs_For_Subprogram (E, Th, Def_Name);

      Close_Theory (Th,
                    Kind => VC_Generation_Theory,
                    Defined_Entity => E);
   end Generate_VCs_For_Subprogram;

   procedure Generate_VCs_For_Subprogram
     (E          : Callable_Kind_Id;
      Th         : Theory_UC;
      Prog_Name  : W_Identifier_Id)
   is

      function Assume_For_Input return W_Prog_Id;
      --  Generate assumptions for dynamic types used in the program. An
      --  exception is made for predicate functions generated by the frontend,
      --  for which we should not assume that the predicate holds for checking
      --  the absence of RTE in the predicate itself.
      --  Also assume the type invariants of global inputs of E and of global
      --  parameters if E is a boundary subprogram.

      function Assume_For_Output return W_Prog_Id;
      --  Generate assumptions for deep outputs, that all pointers are moved at
      --  subprogram entry.

      function RTE_Of_Pre return W_Prog_Id;
      --  Compute an expression which contains the RTE checks of the
      --  precondition.

      function Assume_Or_Assert_Of_Pre return W_Prog_Id;
      --  Usually assumes the precondition, except for main programs where
      --  the precondition needs to be proved in fact. In this latter case
      --  an assertion is returned instead of an assumption.

      function Check_Feasibility return W_Prog_Id;
      --  Generate an assertion checking that there exists a possible return
      --  value for E consistent with its implicit or explicit postcondition.

      function Check_Inline_Annotation return W_Prog_Id;
      --  Checks that the expression used for inlining is equal to the result.
      --  This is done for functions annotated with Inline_For_Proof and
      --  Logical_Equal.

      function Check_Init_Of_Out_Params return W_Prog_Id;
      --  Checks initialization of out parameters at the end of the subprogram.

      function Check_Invariants_Of_Outputs
        (Exceptional : Boolean := False) return W_Prog_Id;
      --  Checks the type invariants of global output and of out parameters if
      --  E is a boundary subprogram.
      --  If Exceptional is True, only check "by reference" parameters.

      function Checking_Of_Refined_Post (Arg : W_Prog_Id) return W_Prog_Id
      with Pre => Entity_Body_In_SPARK (E);
      --  Encapsulate the translated body inside an abstract program with
      --  the Refined_Post as a postcondition.
      --  Assume the dynamic property of modified variables after the call.

      function Post_As_Pred return W_Pred_Id;
      --  Compute the postcondition predicate based on the Ada postcondition

      function Try_Block (Prog : W_Prog_Id) return W_Prog_Id;
      --  adding try/catch block for the return exception on top of the program

      Pre_Prags  : Node_Lists.List;
      Post_Prags : Node_Lists.List;

      procedure Get_Pre_Post_Pragmas (Decls : List_Id);
      --  Retrieve pragmas Precondition and Postcondition from the list
      --  of body declarations, and add them to Pre_Prags and Post_Prags
      --  when they do not come from aspects.

      function Transform_All_Pragmas
        (Prags   : Node_Lists.List;
         Comment : String) return W_Prog_Id;
      --  Translate the pragma list in Prags into Why3.

      --  Mapping from guards to temporary names, and Why program to check
      --  contract cases on exit.
      Guard_Map          : Ada_To_Why_Ident.Map;
      Others_Guard_Ident : W_Identifier_Id;
      Others_Guard_Expr  : W_Term_Id;

      function CC_And_RTE_Post return W_Prog_Id;
      --  Return verification of the contract cases, plus runtime checks for
      --  the Post

      function Check_Exceptional_Cases
        (Exc_Id : W_Identifier_Id)
         return W_Prog_Id;
      --  Return verification of the exceptional cases

      function Declare_Old_Variables (P : W_Prog_Id) return W_Prog_Id;

      function Declare_Termination_Condition (P : W_Prog_Id) return W_Prog_Id;
      --  If E has a dynamic termination condition, introduce a declaration
      --  for its value at the beginning of the subprogram.

      function Warn_On_Inconsistent_Pre return W_Prog_Id;
      --  Generate a VC to warn on inconsistent preconditions

      function Warn_On_Inconsistent_Post return W_Prog_Id;
      --  Generate a VC to warn on inconsistent postconditions

      function Wrap_Decls_For_CC_Guards (P : W_Prog_Id) return W_Prog_Id;

      ----------------------
      -- Assume_For_Input --
      ----------------------

      function Assume_For_Input return W_Prog_Id is
         Pred_Fun_Param : constant Entity_Id :=
           (if Ekind (E) = E_Function and then Is_Predicate_Function (E)
            then
               First_Formal (E)
            else
               Empty);
         Params : constant Transformation_Params := Contract_VC_Params;
      begin
         if Ekind (E) = E_Procedure and then Null_Present (E) then
            return +Void;
         end if;
         return
           Sequence
             ((1 => New_Comment
               (Comment => NID ("Assume dynamic invariants of inputs of the"
                & " subprogram"
                & (if Sloc (E) > 0 then " " & Build_Location_String (Sloc (E))
                   else ""))),
               2 => Compute_Dynamic_Property_For_Inputs
                 (Params         => Params,
                  E              => E,
                  Pred_Fun_Param => Pred_Fun_Param),
               3 => New_Assume_Statement
                 (Pred => Compute_Type_Invariants_For_Subprogram
                    (E         => E,
                     For_Input => True,
                     Params    => Params))));
      end Assume_For_Input;

      -----------------------
      -- Assume_For_Output --
      -----------------------

      function Assume_For_Output return W_Prog_Id is
         Params : constant Transformation_Params := Contract_VC_Params;
      begin
         if Ekind (E) = E_Procedure and then Null_Present (E) then
            return +Void;
         end if;
         return
           Sequence
             ((1 => New_Comment
               (Comment => NID ("Assume moved pointers in outputs of the"
                & " subprogram"
                & (if Sloc (E) > 0 then " " & Build_Location_String (Sloc (E))
                   else ""))),
               2 => Compute_Moved_Property_For_Deep_Outputs (E, Params)));
      end Assume_For_Output;

      -----------------------------
      -- Assume_Or_Assert_Of_Pre --
      -----------------------------

      function Assume_Or_Assert_Of_Pre return W_Prog_Id is
         Params : constant Transformation_Params := Contract_VC_Params;
         Pre_Node : constant Node_Id :=
           Get_Location_For_Aspect (E, Pragma_Precondition);
         Pre : W_Pred_Id :=
           Get_Static_Call_Contract (Params, E, Pragma_Precondition);
         Stmt : W_Prog_Id;

      begin
         --  Need to prove precondition of Main before use. The test for
         --  entries is just to protect the call to Might_Be_Main.

         if Is_Subprogram (E) and then Might_Be_Main (E) then
            if No (Pre_Node) then
               pragma Assert (Is_True_Boolean (+Pre));
               Stmt := +Void;
            else
               Stmt :=
                 New_Located_Abstract
                   (Ada_Node => Pre_Node,
                    Expr     =>
                      Assume_Initial_Condition_Of_Withed_Units (E, Params),
                    Reason   => VC_Precondition_Main,
                    Post     => Pre);
            end if;
         else
            if Is_Entry (E)
              and then Entity_Body_In_SPARK (E)
            then
               declare
                  Params  : constant Transformation_Params :=
                    Contract_Body_Params;
                  Body_N  : constant Node_Id := Entry_Body (E);
                  Barrier : constant Node_Id := Entry_Body_Barrier (Body_N);
               begin
                  Pre :=
                    +New_And_Then_Expr
                      (Domain => EW_Pred,
                       Left   => +Pre,
                       Right  =>
                         Transform_Expr
                           (Barrier, EW_Bool_Type, EW_Pred, Params));
               end;
            end if;
            Stmt := New_Assume_Statement (Pred => Pre);
         end if;

         return
           Sequence
             (New_Comment
                (Comment => NID ("Assume Pre of the subprogram"
                 & (if Sloc (E) > 0 then " " & Build_Location_String (Sloc (E))
                   else ""))),
              Stmt);
      end Assume_Or_Assert_Of_Pre;

      ---------------------
      -- CC_And_RTE_Post --
      ---------------------

      function CC_And_RTE_Post return W_Prog_Id is
         Params : constant Transformation_Params := Contract_VC_Params;
      begin
         return
           Sequence
             (New_Ignore
                (Prog => +Compute_Spec (Params,
                                        E, Pragma_Postcondition, EW_Prog)),
              Compute_Contract_Cases_Exit_Checks
                (Params             => Params,
                 E                  => E,
                 Guard_Map          => Guard_Map,
                 Others_Guard_Ident => Others_Guard_Ident));
      end CC_And_RTE_Post;

      -----------------------------
      -- Check_Exceptional_Cases --
      -----------------------------

      function Check_Exceptional_Cases
        (Exc_Id : W_Identifier_Id)
         return W_Prog_Id
      is

         function Check_Post_For_Case
           (Exceptional_Case : Node_Id;
            Params           : Transformation_Params)
            return W_Prog_Id;
         --  RTE and post check for Exceptional_Case

         -------------------------
         -- Check_Post_For_Case --
         -------------------------

         function Check_Post_For_Case
           (Exceptional_Case : Node_Id;
            Params           : Transformation_Params)
            return W_Prog_Id
         is
            Post       : constant Node_Id := Expression (Exceptional_Case);
            RTE_Post   : constant W_Prog_Id :=
              Transform_Prog (Post, Params);
         begin
            return
              Sequence
                (New_Ignore
                   (Post,
                    Warn_On_Dead_Branch
                      (Post, RTE_Post, Params.Phase, Params.Warn_On_Dead)),
                 New_Assert
                   (Ada_Node    => Post,
                    Pred        => New_VC_Pred
                      (Post,
                       Transform_Pred (Post, Params),
                       VC_Exceptional_Case),
                    Assert_Kind => EW_Assert));
         end Check_Post_For_Case;

         Params : constant Transformation_Params := Contract_VC_Params;
         Prag   : constant Node_Id := Get_Pragma (E, Pragma_Exceptional_Cases);
      begin
         if No (Prag) then
            pragma Assert (No_Return (E));
            return +Void;
         end if;

         declare
            Aggr             : constant Node_Id :=
              Expression (First (Pragma_Argument_Associations (Prag)));
            Assocs           : constant List_Id :=
              Component_Associations (Aggr);
            Others_Present   : constant Boolean :=
              Nkind (First (Choice_List (Last (Assocs)))) = N_Others_Choice;
            Nb_Cases         : constant Integer :=
              Natural (List_Length (Assocs));
            Elsif_Parts      : W_Prog_Array
              (2 .. Nb_Cases - (if Others_Present then 1 else 0));
            Else_Part        : W_Prog_Id;
            Exceptional_Case : Node_Id := First (Assocs);

            --  Start of processing for Check_Exceptional_Cases

         begin
            --  Get the case where there is only one choice out of the way

            if Nb_Cases = 1 then
               return Check_Post_For_Case (Exceptional_Case, Params);
            end if;

            --  Fill the Elsif_Parts if any

            Next (Exceptional_Case);
            if Elsif_Parts'Length > 0 then
               for Num in Elsif_Parts'Range loop
                  Elsif_Parts (Num) := New_Elsif
                    (Condition => +Compute_Guard_For_Exceptions
                       (Choice_List (Exceptional_Case), Exc_Id, EW_Prog),
                     Then_Part => Check_Post_For_Case
                       (Exceptional_Case, Params));
                  Next (Exceptional_Case);
               end loop;
            end if;

            --  Fill the Else_Part if any

            if Others_Present then
               Else_Part := Check_Post_For_Case (Exceptional_Case, Params);

            --  Checks that no unexpected exceptions are raised are done on
            --  raises.

            else
               Else_Part := Why_Empty;
            end if;

            --  Reconstruct the conditional

            Exceptional_Case := First (Assocs);

            return New_Conditional
              (Ada_Node    => Prag,
               Condition   => +Compute_Guard_For_Exceptions
                 (Choice_List (Exceptional_Case), Exc_Id, EW_Prog),
               Then_Part   => Check_Post_For_Case (Exceptional_Case, Params),
               Elsif_Parts => Elsif_Parts,
               Else_Part   => Else_Part);
         end;
      end Check_Exceptional_Cases;

      -----------------------
      -- Check_Feasibility --
      -----------------------

      function Check_Feasibility return W_Prog_Id is
         Save_Result_Is_Mutable : constant Boolean := Result_Is_Mutable;
         Save_Result_Name       : constant W_Identifier_Id := Result_Name;

         Local_Params           : constant Transformation_Params :=
           (Body_Params with delta Old_Policy => Ignore);
         --  Old can safely be ignored in postconditions of functions
         Why_Type               : constant W_Type_Id := Type_Of_Node (E);
         Result_Id              : constant W_Identifier_Id :=
           New_Result_Ident (Why_Type);

      begin
         --  Store an immutable local name for the result that can be
         --  existentially quantified.

         Result_Is_Mutable := False;
         Result_Name := Result_Id;

         declare
            Dynamic_Prop_Result : constant W_Pred_Id :=
              +New_And_Then_Expr
              (Left   => +Compute_Dynamic_Inv_And_Initialization
                 (Expr             => +Result_Name,
                  Ty               => Etype (E),
                  Only_Var         => False_Term,
                  Include_Type_Inv =>
                    Include_Non_Local_Type_Inv_For_Subp (E),
                  Params           => Local_Params),
               Right  => +Compute_Type_Invariants_For_Subprogram
                 (E, Local_Params, False),
               Domain => EW_Pred);
            Post                : constant W_Pred_Id :=
              New_And_Pred
                (Left  => Get_Static_Call_Contract
                   (Local_Params, E, Pragma_Postcondition),
                 Right => Compute_Contract_Cases_Postcondition
                   (Local_Params, E));

         begin
            --  Restore the previous state

            Result_Is_Mutable := Save_Result_Is_Mutable;
            Result_Name := Save_Result_Name;

            --  Generate:
            --    exists result : why_type.
            --      dyn_prop result /\ post result

            return New_Located_Assert
              (Ada_Node => E,
               Pred     => New_Existential_Quantif
                 (Variables => (1 => Result_Id),
                  Labels    => Symbol_Sets.Empty_Set,
                  Var_Type  => Why_Type,
                  Pred      => New_And_Pred (Dynamic_Prop_Result, Post)),
               Reason   => VC_Feasible_Post,
               Kind     => EW_Assert);
         end;
      end Check_Feasibility;

      ------------------------------
      -- Check_Init_Of_Out_Params --
      ------------------------------

      function Check_Init_Of_Out_Params return W_Prog_Id is
         Param  : Entity_Id := First_Formal (E);
         Checks : W_Prog_Id := +Void;

      begin
         while Present (Param) loop
            declare
               B : constant Item_Type :=
                 Ada_Ent_To_Why.Element (Symbol_Table, Param);
            begin
               if Ekind (Param) = E_Out_Parameter
                 and then Obj_Has_Relaxed_Init (Param)
               then
                  Continuation_Stack.Append
                    (Continuation_Type'
                       (E,
                        To_Unbounded_String
                          ("for parameter " & Source_Name (Param)
                           & " at the end of the subprogram")));

                  if B.Init.Present then
                     Append
                       (Checks,
                        New_Located_Assert
                          (Ada_Node => Param,
                           Pred     => Pred_Of_Boolean_Term
                             (New_Deref (Right => B.Init.Id,
                                         Typ   => Get_Typ (B.Init.Id))),
                           Reason   => VC_Initialization_Check,
                           Kind     => EW_Assert));

                  elsif Has_Scalar_Full_View (Etype (Param)) then
                     Append
                       (Checks,
                        New_Located_Assert
                          (Ada_Node => Param,
                           Pred     => +Compute_Is_Initialized
                             (E                  => Etype (Param),
                              Name               => +Reconstruct_Item
                                (B, Body_Params.Ref_Allowed),
                              Params             => Body_Params,
                              Domain             => EW_Pred,
                              Exclude_Components => Relaxed),
                           Reason   => VC_Initialization_Check,
                           Kind     => EW_Assert));

                  elsif Has_Predicates (Etype (Param)) then
                     Append
                       (Checks,
                        New_Predicate_Check
                          (Ada_Node => Param,
                           W_Expr   => +Reconstruct_Item
                             (B, Body_Params.Ref_Allowed),
                           Ty       => Etype (Param)));
                  end if;

                  Continuation_Stack.Delete_Last;
               end if;
            end;
            Next_Formal (Param);
         end loop;

         return Checks;
      end Check_Init_Of_Out_Params;

      -----------------------------
      -- Check_Inline_Annotation --
      -----------------------------

      function Check_Inline_Annotation return W_Prog_Id is
         Need_Check : constant Boolean :=
           (Present (Retrieve_Inline_Annotation (E)) and then
              (not Is_Expression_Function_Or_Completion (E)
               or else not Entity_Body_Compatible_With_SPARK (E)))
           or else Has_Logical_Eq_Annotation (E);
         Params     : constant Transformation_Params := Contract_VC_Params;
      begin
         if Need_Check then
            declare
               Def : constant W_Term_Id :=
                 Compute_Inlined_Expr
                   (Function_Entity    => E,
                    Logic_Func_Binders => (1 .. 0 => <>),
                    W_Return_Type      => Get_Typ (Result_Name),
                    Params             => Params);
            begin
               if Def /= Why_Empty then
                  return New_Assert
                    (Pred        =>
                       New_VC_Pred
                         (Ada_Node => Find_Inline_Pragma (E),
                          Expr     =>
                            New_Comparison
                              (Symbol => Why_Eq,
                               Left   => New_Deref
                                 (Right => Result_Name,
                                  Typ   => Get_Typ (Result_Name)),
                               Right  => Def),
                          Reason   => VC_Inline_Check),
                     Assert_Kind => EW_Assert);
               else
                  return +Void;
               end if;
            end;
         else
            return +Void;
         end if;
      end Check_Inline_Annotation;

      ---------------------------------
      -- Check_Invariants_Of_Outputs --
      ---------------------------------

      function Check_Invariants_Of_Outputs
        (Exceptional : Boolean := False) return W_Prog_Id
      is
         Params : constant Transformation_Params := Contract_VC_Params;
         Check : constant W_Pred_Id :=
           Compute_Type_Invariants_For_Subprogram
             (E, Params, False, Exceptional);
      begin
         if Is_True_Boolean (+Check) then
            return +Void;
         else
            return New_Assert
              (Pred        =>
                 New_VC_Pred
                   (Ada_Node => E,
                    Expr     => Check,
                    Reason   => VC_Invariant_Check),
               Assert_Kind => EW_Assert);
         end if;
      end Check_Invariants_Of_Outputs;

      ------------------------------
      -- Checking_Of_Refined_Post --
      ------------------------------

      function Checking_Of_Refined_Post (Arg : W_Prog_Id) return W_Prog_Id is
         Params : constant Transformation_Params := Contract_VC_Params;
         Prog   : W_Prog_Id := Arg;
      begin
         if Has_Contracts (E, Pragma_Refined_Post) then
            Append
              (Prog,
               New_Ignore
                 (Prog => +Compute_Spec
                      (Params, E, Pragma_Refined_Post, EW_Prog)));
            Prog :=
              New_Located_Abstract
                (Ada_Node => Get_Location_For_Aspect (E, Pragma_Refined_Post),
                 Expr => Prog,
                 Reason => VC_Refined_Post,
                 Post => +Compute_Spec
                   (Params, E, Pragma_Refined_Post, EW_Pred));
            Append
              (Prog,
               New_Assume_Statement
                 (Pred => Compute_Dynamic_Property_For_Effects (E, Params)));

            --  For functions we also need to assume the dynamic invariant of
            --  the result.

            if Ekind (E) = E_Function then
               declare
                  Include_Type_Inv : constant W_Term_Id :=
                    Include_Non_Local_Type_Inv_For_Subp (E);
                  Dyn_Prop         : W_Pred_Id :=
                    Compute_Dynamic_Inv_And_Initialization
                      (Expr             => New_Deref
                         (Right => Result_Name,
                          Typ   => Get_Typ (Result_Name)),
                       Ty               => Etype (E),
                       Params           => Params,
                       Include_Type_Inv => Include_Type_Inv);

               begin
                  --  For borrowing traversal functions, add the dynamic
                  --  invariant of the result at end and of the borrowed
                  --  parameter at end.

                  if Is_Borrowing_Traversal_Function (E) then
                     declare
                        Brower_At_End   : constant W_Identifier_Id :=
                          Get_Brower_At_End (E);
                        Borrowed_At_End : constant W_Identifier_Id :=
                          To_Local (Get_Borrowed_At_End (E));
                     begin
                        Dyn_Prop :=
                          New_And_Pred
                            (Conjuncts =>
                               (1 => Dyn_Prop,
                                2 => Compute_Dynamic_Inv_And_Initialization
                                  (Expr             => New_Deref
                                       (Right => Brower_At_End,
                                        Typ   => Get_Typ (Brower_At_End)),
                                   Ty               => Etype (E),
                                   Params           => Params,
                                   Include_Type_Inv => Include_Type_Inv),
                                3 => Compute_Dynamic_Inv_And_Initialization
                                  (Expr             => +Borrowed_At_End,
                                   Ty               => Etype
                                     (First_Formal (E)),
                                   Params           => Params,
                                   Include_Type_Inv => Include_Type_Inv)));
                     end;
                  end if;

                  Append
                    (Prog,
                     New_Assume_Statement (Pred => Dyn_Prop));
               end;
            end if;
         end if;
         return Prog;
      end Checking_Of_Refined_Post;

      ---------------------------
      -- Declare_Old_Variables --
      ---------------------------

      function Declare_Old_Variables (P : W_Prog_Id) return W_Prog_Id is
         CC_Prag  : constant Node_Id :=
           Get_Pragma (E, Pragma_Contract_Cases);
         Post_Old : Node_Sets.Set;
         CC_Old   : Node_Sets.Set;
         R        : W_Prog_Id;
      begin
         --  Add mapping for Old variables coming from the postcondition. Use
         --  the EW_Prog domain to generate checks for them.

         Collect_Old_For_Subprogram (E, Post_Old, Exclude_CC => True);

         if Entity_Body_In_SPARK (E) then
            Collect_Old_Parts
              (Find_Contracts (E, Pragma_Refined_Post), Post_Old);
            Collect_Old_Parts (Post_Prags, Post_Old);
         end if;

         R := +Bind_From_Mapping_In_Expr
           (Params => Body_Params,
            Map    => Map_For_Old,
            Expr   => +P,
            Domain => EW_Prog,
            Subset => Post_Old);

         --  Add mapping for Old variables coming from the contract case if
         --  any. Checks are generated separately as they should only be done
         --  when in the correct contract case.

         if Present (CC_Prag) then
            Collect_Old_Parts (CC_Prag, CC_Old);
            R := +Bind_From_Mapping_In_Expr
              (Params => Body_Params,
               Map    => Map_For_Old,
               Expr   => +R,
               Domain => EW_Pterm,
               Subset => CC_Old);

            --  Generate checks for Old variables inside ignore blocks when the
            --  corresponding guard is enabled.

            declare
               Aggr          : constant Node_Id :=
                 Expression (First (Pragma_Argument_Associations (CC_Prag)));
               Contract_Case : Node_Id :=
                 First (Component_Associations (Aggr));
               Case_Guard    : Node_Id;
            begin
               while Present (Contract_Case) loop
                  CC_Old.Clear;
                  Collect_Old_Parts (Expression (Contract_Case), CC_Old);
                  Case_Guard := First (Choice_List (Contract_Case));
                  Prepend
                    (New_Conditional
                       (Condition =>
                            +(if Nkind (Case_Guard) = N_Others_Choice
                              then Others_Guard_Ident
                              else Guard_Map.Element (Case_Guard)),
                        Then_Part => +New_Ignore
                          (Prog => +Bind_From_Mapping_In_Expr
                               (Params => Body_Params,
                                Map    => Map_For_Old,
                                Expr   => +Void,
                                Domain => EW_Prog,
                                Subset => CC_Old))),
                     R);

                  Next (Contract_Case);
               end loop;
            end;
         end if;
         return R;
      end Declare_Old_Variables;

      -----------------------------------
      -- Declare_Termination_Condition --
      -----------------------------------

      function Declare_Termination_Condition (P : W_Prog_Id) return W_Prog_Id
      is
         Cond : constant Termination_Condition :=
           Get_Termination_Condition (E);
      begin
         if Cond.Kind = Dynamic then
            return New_Binding
              (Name    => Termination_Condition_Name,
               Def     => Transform_Prog (Cond.Condition, Body_Params),
               Context => P);
         else
            return P;
         end if;
      end Declare_Termination_Condition;

      --------------------------
      -- Get_Pre_Post_Pragmas --
      --------------------------

      procedure Get_Pre_Post_Pragmas (Decls : List_Id) is
         Decl : Node_Id := First (Decls);
      begin
         while Present (Decl) loop
            if Is_Pragma (Decl, Pragma_Precondition) and then
              not From_Aspect_Specification (Decl)
            then
               Pre_Prags.Append (Decl);

            elsif Is_Pragma (Decl, Pragma_Postcondition) and then
              not From_Aspect_Specification (Decl)
            then
               Post_Prags.Append (Decl);
            end if;
            Next (Decl);
         end loop;
      end Get_Pre_Post_Pragmas;

      ------------------
      -- Post_As_Pred --
      ------------------

      function Post_As_Pred return W_Pred_Id is
         Params : constant Transformation_Params :=
           (Contract_Body_Params with delta Old_Policy  => As_Old);
         Mark_Params : Transformation_Params := Params;
         Post_N    : Node_Id;
      begin

         Mark_Params.Gen_Marker := GM_Toplevel;

         --  There might be no specific postcondition for E. In that case, the
         --  classwide or inherited postcondition is checked if present. Locate
         --  it on E for the inherited case.

         if Has_Contracts (E, Pragma_Postcondition) then
            Post_N := Get_Location_For_Aspect (E, Pragma_Postcondition);
         elsif Has_Contracts (E, Pragma_Postcondition, Classwide => True) then
            Post_N :=
              Get_Location_For_Aspect
               (E, Pragma_Postcondition, Classwide => True);
         elsif Has_Contracts (E, Pragma_Postcondition, Inherited => True) then
            Post_N := Get_Location_For_Aspect (E, Pragma_Postcondition,
                                               Inherited => True);
         else
            Post_N := Empty;
         end if;
         if Entity_Body_In_SPARK (E) then

            --  Translate contract of E. A No_Return subprogram, from the
            --  inside, has postcondition true as non-termination verification
            --  is done by the frontend, but the precondition is unchanged.

            if No_Return (E) or else No (Post_N) then
               pragma Assert (if No (Post_N) then
                                 Is_True_Boolean
                                (+Get_Static_Call_Contract
                                   (Mark_Params, E, Pragma_Postcondition)));
               return Why_Empty;
            else
               return
                 New_VC_Pred (Post_N,
                              Get_Static_Call_Contract
                                (Mark_Params, E, Pragma_Postcondition),
                              VC_Postcondition);
            end if;
         else
            return Why_Empty;
         end if;
      end Post_As_Pred;

      ----------------
      -- RTE_Of_Pre --
      ----------------

      function RTE_Of_Pre return W_Prog_Id is
         Params : constant Transformation_Params := Contract_VC_Params;
         Pre    : constant W_Prog_Id :=
           +Compute_Spec (Params, E, Pragma_Precondition, EW_Prog);
      begin
         return
           Sequence
             (New_Comment
                (Comment => NID ("Check for RTE in the Pre of the subprogram"
                 & (if Sloc (E) > 0 then " " & Build_Location_String (Sloc (E))
                    else ""))),
              New_Ignore
                (Prog => Pre));
      end RTE_Of_Pre;

      ---------------------------
      -- Transform_All_Pragmas --
      ---------------------------

      function Transform_All_Pragmas
        (Prags   : Node_Lists.List;
         Comment : String) return W_Prog_Id
      is
         Result : W_Prog_Id;
      begin
         if Prags.Is_Empty then
            Result := +Void;
         else
            Result :=
              New_Comment
                (Comment => NID (Comment &
                                 (if Sloc (E) > 0 then
                                  " " & Build_Location_String (Sloc (E))
                                  else "")));

            for Prag of Prags loop
               Append
                 (Result, Transform_Pragma (Prag, Body_Params, Force => True));
            end loop;
         end if;

         return Result;
      end Transform_All_Pragmas;

      ---------------
      -- Try_Block --
      ---------------

      function Try_Block (Prog : W_Prog_Id) return W_Prog_Id is
      begin
         return
           New_Try_Block
             (Prog    => Prog,
              Handler =>
                (1 =>
                       New_Handler
                   (Name => M_Main.Return_Exc,
                    Def  => +Void)));
      end Try_Block;

      -------------------------------
      -- Warn_On_Inconsistent_Post --
      -------------------------------

      function Warn_On_Inconsistent_Post return W_Prog_Id is
         Params : constant Transformation_Params := Contract_VC_Params;
         Post : W_Pred_Id :=
           Get_Static_Call_Contract (Params, E, Pragma_Postcondition);
         Stmt : W_Prog_Id;
         Post_Node : constant Node_Id :=
           Get_Location_For_Aspect (E, Pragma_Postcondition);
      begin
         if No (Post_Node) then
            return +Void;
         end if;

         --  Negate the condition to check for an inconsistency
         Post := New_Not (Right => +Post);

         Stmt := Sequence
           (Compute_Call_Effects (Params, E),
            New_Located_Assert
              (Ada_Node => Post_Node,
               Pred     => Post,
               Reason   => VC_Inconsistent_Post,
               Kind     => EW_Assert));

         return
           Sequence
             (New_Comment
                (Comment => NID ("Check inconsistency of Post of subprogram"
                 & (if Sloc (E) > 0 then " " & Build_Location_String (Sloc (E))
                   else ""))),
              New_Ignore (Prog => Stmt));
      end Warn_On_Inconsistent_Post;

      ------------------------------
      -- Warn_On_Inconsistent_Pre --
      ------------------------------

      function Warn_On_Inconsistent_Pre return W_Prog_Id is
         Params : constant Transformation_Params := Contract_VC_Params;
         Pre : W_Pred_Id :=
           Get_Static_Call_Contract (Params, E, Pragma_Precondition);
         Stmt : W_Prog_Id;
         Pre_Node : constant Node_Id :=
           Get_Location_For_Aspect (E, Pragma_Precondition);
      begin
         if No (Pre_Node) then
            return +Void;
         end if;

         if Is_Entry (E) then
            declare
               Params  : constant Transformation_Params :=
                 Contract_Body_Params;
               Body_N  : constant Node_Id := Get_Body (E);
               Barrier : constant Node_Id := Entry_Body_Barrier (Body_N);
            begin
               Pre :=
                 +New_And_Then_Expr
                 (Domain => EW_Pred,
                  Left   => +Pre,
                  Right  =>
                    Transform_Expr
                      (Barrier, EW_Bool_Type, EW_Pred, Params));
            end;
         end if;

         --  Negate the condition to check for an inconsistency
         Pre := New_Not (Right => +Pre);

         Stmt :=
           New_Located_Assert
             (Ada_Node => Pre_Node,
              Pred     => Pre,
              Reason   => VC_Inconsistent_Pre,
              Kind     => EW_Assert);

         return
           Sequence
             (New_Comment
                (Comment => NID ("Check inconsistency of Pre of subprogram"
                 & (if Sloc (E) > 0 then " " & Build_Location_String (Sloc (E))
                   else ""))),
              New_Ignore (Prog => Stmt));
      end Warn_On_Inconsistent_Pre;

      ------------------------------
      -- Wrap_Decls_For_CC_Guards --
      ------------------------------

      function Wrap_Decls_For_CC_Guards (P : W_Prog_Id) return W_Prog_Id is
         Prog : W_Prog_Id := P;
      begin
         if Present (Others_Guard_Ident) then
            Prog := New_Typed_Binding (Name    => Others_Guard_Ident,
                                       Def     => +Others_Guard_Expr,
                                       Context => Prog);
         end if;

         Prog := Bind_From_Mapping_In_Prog
           (Params => Contract_VC_Params,
            Map    => Guard_Map,
            Expr   => Prog);
         return Prog;
      end Wrap_Decls_For_CC_Guards;

      Name      : constant String := Full_Name (E);

      Effects   : constant W_Effects_Id := New_Effects;
      CC_Check  : W_Prog_Id;
      Prog      : W_Prog_Id;
      Why_Body  : W_Prog_Id;

      Result_Var : W_Prog_Id;

      Precondition_Is_Statically_False  : Boolean := False;
      Postcondition_Is_Statically_False : Boolean := False;

   --  Start of processing for Generate_VCs_For_Subprogram

   begin
      --  Reset the toplevel exceptions for exit paths

      Clear_Exceptions;

      if Is_Function_Or_Function_Type (E) then
         Result_Name :=
           New_Identifier
             (Name  => Name & "__result",
              Typ   => Type_Of_Node (E));
         Result_Is_Mutable := True;

         Result_Var :=
           New_Deref
             (Ada_Node => E,
              Right    => Result_Name,
              Typ      => Type_Of_Node (E));
      else
         Result_Var := +Void;
      end if;

      if Within_Protected_Type (E)
        and then Ekind (E) /= E_Subprogram_Type
      then
         declare
            CPT : constant Entity_Id := Containing_Protected_Type (E);
         begin
            --  The Ada_Node is important here, because that's how we detect
            --  occurrences of "self" in a term later.

            Self_Name := Concurrent_Self_Ident (CPT);
            Self_Is_Mutable := True;
         end;
      end if;

      if Get_Termination_Condition (E).Kind = Dynamic then
         Termination_Condition_Name := New_Temp_Identifier
           (Base_Name => "termination_condition", Typ => EW_Bool_Type);
      end if;

      --  If E is a wrapper introduced for an implicit overriding of an
      --  inherited primitive with a dispatching result on a null extension,
      --  add a continuation to better locate the check messages.

      if Is_Wrapper_For_Dispatching_Result (E) then

         --  Go over the ancestors of E to find the first one which is not
         --  an implicit wrapper. There must be one.

         declare
            Parent_E : Entity_Id := E;
         begin
            loop
               Parent_E := Overridden_Operation (Parent_E);
               pragma Assert (Present (Parent_E));
               exit when not Is_Wrapper_For_Dispatching_Result (Parent_E);
            end loop;

            Continuation_Stack.Append
              (Continuation_Type'
                 (Ada_Node => Parent_E,
                  Message  => To_Unbounded_String
                    ("in implicit overriding of primitive function with"
                     & " dispatching result """ & Source_Name (E) & '"')));
         end;
      end if;

      for Expr of Get_Precondition_Expressions (E) loop
         if Nkind (Expr) in N_Expanded_Name | N_Identifier
           and then Entity (Expr) = Standard_False
         then
            Precondition_Is_Statically_False := True;

            --  Do not warn about statically False preconditions if they are
            --  disabled.

            if Original_Node (Expr) /= Expr
              and then not Exp_Util.Is_Statically_Disabled
                (Expr, False, Include_Valid => True)
            then
               Error_Msg_N
                 (Warning_Message (Warn_Precondition_Statically_False), Expr);
            end if;
         end if;
      end loop;

      for Expr of Get_Postcondition_Expressions (E, Refined => False) loop
         if Nkind (Expr) in N_Expanded_Name | N_Identifier
           and then Entity (Expr) = Standard_False
         then
            Postcondition_Is_Statically_False := True;
         end if;
      end loop;

      --  If contract cases are present, generate checks for absence of
      --  run-time errors in guards, and check that contract cases are disjoint
      --  and complete. The completeness is checked in a context where the
      --  precondition is assumed. Init_Prog is set to the program up to the
      --  precondition assumption, and Prog is set to the program starting
      --  with the contract case entry checks.

      Compute_Contract_Cases_Guard_Map
        (E                  => E,
         Guard_Map          => Guard_Map,
         Others_Guard_Ident => Others_Guard_Ident,
         Others_Guard_Expr  => Others_Guard_Expr);

      CC_Check := Compute_Contract_Cases_Entry_Checks (E, Guard_Map);

      --  Declare global variable to hold the state of a protected object

      if Within_Protected_Type (E)
        and then Ekind (E) /= E_Subprogram_Type
      then
         Emit
           (Th,
            New_Global_Ref_Declaration
              (Ada_Node => Containing_Protected_Type (E),
               Name     => Self_Name,
               Labels   => Symbol_Sets.Empty_Set,
               Location => Safe_First_Sloc (E),
               Ref_Type =>
                 Type_Of_Node (Containing_Protected_Type (E))));
      end if;

      --  Declare a global variable to hold the result of a function. This is
      --  useful both for verifying the body of E when it is in SPARK, and for
      --  the warning on inconsistent postcondition when it is issued.

      if Is_Function_Or_Function_Type (E) then
         Emit
           (Th,
            New_Global_Ref_Declaration
              (Ada_Node => E,
               Name     => Result_Name,
               Labels   => Get_Counterexample_Labels (E),
               Location => No_Location,
               Ref_Type => Type_Of_Node (E)));

         --  If E is a traversal function returning a borrower, declare a
         --  reference borrower at end and a constant for the borrowed at end.

         if Is_Borrowing_Traversal_Function (E) then
            declare
               Brower_At_End   : constant W_Identifier_Id :=
                 Get_Brower_At_End (E);
               Borrowed_At_End : constant W_Identifier_Id :=
                 To_Local (Get_Borrowed_At_End (E));
            begin
               Emit (Th,
                     New_Global_Ref_Declaration
                       (Name     => Brower_At_End,
                        Ref_Type => Get_Typ (Brower_At_End),
                        Labels   => Symbol_Sets.Empty_Set,
                        Location => No_Location));
               Emit (Th,
                     Why.Atree.Builders.New_Function_Decl
                       (Domain      => EW_Pterm,
                        Name        => Borrowed_At_End,
                        Binders     => (1 .. 0 => <>),
                        Labels      => Symbol_Sets.Empty_Set,
                        Location    => No_Location,
                        Return_Type => Get_Typ (Borrowed_At_End)));
            end;
         end if;
      end if;

      --  If the subprogram is annotated with a variant but flow analysis
      --  does not see that it is recursive, raise a warning.

      if Entity_Body_In_SPARK (E)
        and then Present (Get_Pragma (E, Pragma_Subprogram_Variant))
        and then not Is_Recursive (E)
      then
         Error_Msg_F (Warning_Message (Warn_Variant_Not_Recursive),
                      Get_Pragma (E, Pragma_Subprogram_Variant));
      end if;

      --  For expression functions, the body is not marked. Retrieve the
      --  expression directly.

      if Is_Expression_Function_Or_Completion (E)
        and then Entity_Body_In_SPARK (E)
      then
         declare
            Expr       : constant Node_Id :=
              Expression (Get_Expression_Function (E));

         begin
            Why_Body :=
              Sequence
                ((1 => Check_Ceiling_Protocol (Body_Params, E),
                  2 => Transform_Simple_Return_Expression
                    (Expr, E, Type_Of_Node (E), Body_Params)));

            Why_Body := Checking_Of_Refined_Post (Why_Body);

            --  Check type invariants on subprogram's ouput, absence of runtime
            --  errors in Post and RTE + validity of contract cases, and
            --  Inline_For_Proof/Logical_Equal annotation.

            Why_Body := Sequence
              ((1 => Why_Body,
                2 => Check_Invariants_Of_Outputs,
                3 => CC_And_RTE_Post,
                4 => Check_Inline_Annotation));
         end;

      --  Regular subprogram with body in SPARK

      elsif Entity_Body_In_SPARK (E) then
         declare
            Body_N     : constant Node_Id := Get_Body (E);
            Raise_Stmt : constant W_Prog_Id :=
              New_Raise
                (Ada_Node => Body_N,
                 Name     => M_Main.Return_Exc);

         begin
            Get_Pre_Post_Pragmas (Declarations (Body_N));

            Why_Body :=
              Sequence
                ((1 => Transform_All_Pragmas
                    (Pre_Prags, "checking of pragma precondition"),
                  2 => Check_Ceiling_Protocol (Body_Params, E),
                  3 => Transform_Declarations
                    (Declarations (Body_N), Body_Params),
                  4 => Transform_Handled_Statements
                    (Handled_Statement_Sequence (Body_N), Body_Params),
                  5 => Raise_Stmt));

            --  Enclose the subprogram body in a try-block, so that return
            --  statements can be translated as raising exceptions.

            Why_Body := Try_Block (Why_Body);

            --  Check pragmas Precondition and Postcondition in the body of the
            --  subprogram as plain assertions.

            Why_Body := Sequence
              ((1 => Why_Body,
                2 => +Havoc_Borrowed_And_Check_No_Leaks_From_Scope
                  (E, Local_CFG.Vertex'(Kind => Local_CFG.Body_Exit,
                                        Node => E)),
                3 => Transform_All_Pragmas
                  (Post_Prags, "checking of pragma postcondition")));

            Why_Body := Checking_Of_Refined_Post (Why_Body);

            --  Check type invariants on subprogram's output, absence of
            --  runtime errors in Post and RTE + validity of contract cases,
            --  and Inline_For_Proof/Logical_Equal annotation.

            Why_Body := Sequence
              ((1 => Why_Body,
                2 => Check_Init_Of_Out_Params,
                3 => Check_Invariants_Of_Outputs,
                4 => CC_And_RTE_Post,
                5 => Check_Inline_Annotation));
         end;

         --  Handling of Ada exceptions

         if Has_Exceptional_Contract (E) then
            declare
               Body_N     : constant Node_Id := Get_Body (E);
               Exc_Id     : constant W_Identifier_Id :=
                 New_Temp_Identifier (Base_Name => "exc", Typ => EW_Int_Type);
               Raise_Stmt : constant W_Prog_Id :=
                 New_Raise
                   (Ada_Node => Body_N,
                    Name     => M_Main.Ada_Exc,
                    Arg      => +Exc_Id);
               Handler    : W_Prog_Id;

            begin
               Effects_Append_To_Raises
                 (Effects,
                  New_Raise_Effect (Domain => EW_Prog,
                                    Name   => M_Main.Ada_Exc));

               --  Handle the scope exit like on normal return. Do not check
               --  initialization for parameters with Relaxed_Initialization as
               --  it is not mandated by Ada.
               --  We do not need to check for absence of memory leaks in
               --  formal parameters which are not passed by reference and
               --  therefore discarded, a such parameters are rejected in
               --  marking.

               Continuation_Stack.Append
                 (Continuation_Type'
                    (Ada_Node => Body_N,
                     Message  =>
                       To_Unbounded_String ("on exceptional exit")));

               Handler := Sequence
                 ((1 => +Havoc_Borrowed_And_Check_No_Leaks_From_Scope
                   (E, Local_CFG.Vertex'(Kind => Local_CFG.Body_Exit,
                                         Node => E)),
                   2 => Check_Invariants_Of_Outputs (Exceptional => True)));

               Continuation_Stack.Delete_Last;

               --  Check RTE + validity of exceptional cases

               Handler := Sequence
                 ((1 => Handler,
                   2 => Check_Exceptional_Cases (Exc_Id)));

               --  Reraise the exception

               Handler := Sequence (Handler, Raise_Stmt);

               --  Add an artificial raise Ada_Exc to Why_Body so the handler
               --  is not ignored when no Ada exception is raised and the
               --  warning on dead branches will be emitted.

               Why_Body := New_Try_Block
                 (Prog    =>
                    Sequence
                      ((1 => Why_Body,
                        2 => New_Conditional
                          (Condition => False_Prog,
                           Then_Part => New_Raise
                             (Name => M_Main.Ada_Exc,
                              Arg  => New_Integer_Constant (Value => Uint_0))),
                        3 => Result_Var)),
                  Handler =>
                    (1 => New_Handler
                         (Name   => M_Main.Ada_Exc,
                          Arg_Id => Exc_Id,
                          Def    => Handler)));
            end;

         --  Otherwise simply append the result of the subprogram to the body

         else
            Why_Body := Sequence
              ((1 => Why_Body,
                2 => Result_Var));
         end if;

      --  Body is not in SPARK

      else
         --  Fill the mapping for uses of 'Old to later check absence of
         --  run-time errors in these expressions.

         declare
            use type Atree.Traverse_Result;

            function Search_Old (N : Node_Id) return Atree.Traverse_Result;
            --  Search for attribute Old and enter its prefix in the map

            ----------------
            -- Search_Old --
            ----------------

            function Search_Old (N : Node_Id) return Atree.Traverse_Result is
               Dummy : W_Identifier_Id;
            begin
               if Nkind (N) = N_Attribute_Reference
                 and then Attribute_Name (N) = Name_Old
               then
                  Dummy := Name_For_Old (Prefix (N));
               end if;

               return Atree.OK;
            end Search_Old;

            procedure Search_Olds is new
              Traverse_More_Proc (Search_Old);

            Prag_Post : constant Node_Id :=
              Get_Pragma (E, Pragma_Postcondition);

            Prag_CC : constant Node_Id :=
              Get_Pragma (E, Pragma_Contract_Cases);

         begin
            Search_Olds (Prag_Post);
            Search_Olds (Prag_CC);

            --  For abstract functions and access-to-functions, generate a
            --  feasibility check.

            if Is_Function_Type (E)
              or else (Ekind (E) = E_Function
                       and then Is_Abstract_Subprogram (E))
            then
               Why_Body := Check_Feasibility;
            else
               Why_Body := +Void;
            end if;
         end;
      end if;

      declare
         Warn_Pre : constant W_Prog_Id :=
           --  Do not issue a check for inconsistent precondition if switch
           --  --proof-warnings is not set
           (if not Gnat2Why_Args.Proof_Warnings
              --  or if a conjunct in the precondition is statically False
              or else Precondition_Is_Statically_False
              --  or if warnings are suppressed.
              or else Opt.Warning_Mode = Opt.Suppress
            then +Void
            else Warn_On_Inconsistent_Pre);

         Warn_Post : constant W_Prog_Id :=
           --  Do not issue a check for inconsistent postcondition if switch
           --  --proof-warnings is not set
           (if not Gnat2Why_Args.Proof_Warnings
              --  or if a conjunct in the postcondition is statically False
              or else Postcondition_Is_Statically_False
              --  or if the body is in SPARK
              or else Entity_Body_In_SPARK (E)
              --  or if warnings are suppressed.
              or else Opt.Warning_Mode = Opt.Suppress
            then +Void
            else Warn_On_Inconsistent_Post);

      begin
         --  Add declarations for 'Old variables

         Prog := Sequence ((CC_Check, Warn_Post, Why_Body));
         Prog := Declare_Old_Variables (Prog);
         Prog := Wrap_Decls_For_CC_Guards (Prog);
         Prog := Insert_Bindings_For_Variants (E, Prog, EW_Prog, Body_Params);
         Prog := Declare_Termination_Condition (Prog);

         Prog := Sequence
           ((Assume_For_Input,
             Assume_For_Output,
             RTE_Of_Pre,
             Warn_Pre,
             Assume_Or_Assert_Of_Pre,
             Prog));
      end;

      --  Assume values of constants

      Assume_Value_Of_Constants (Prog, E, Contract_VC_Params);

      --  Declare the toplevel exceptions for exit paths

      Declare_Exceptions (Th);

      Emit (Th,
            Why.Gen.Binders.New_Function_Decl
              (Domain   => EW_Prog,
               Name     => Prog_Name,
               Binders  => (1 => Unit_Param),
               Labels   => Symbol_Sets.Empty_Set,
               Location => Safe_First_Sloc (E),
               Post     => Post_As_Pred,
               Effects  => Effects,
               Def      => +Prog));

      --  cleanup

      Self_Name := Why_Empty;
      Self_Is_Mutable := False;

      if Ekind (E) = E_Function then
         Result_Name := Why_Empty;
         Result_Is_Mutable := False;
      end if;

      if Get_Termination_Condition (E).Kind = Dynamic then
         Termination_Condition_Name := Why_Empty;
      end if;

      if Is_Wrapper_For_Dispatching_Result (E) then
         Continuation_Stack.Delete_Last;
      end if;

      --  This code emits static VCs (determined by static computations inside
      --  gnat2why), so we can put this code anywhere.

      if Is_Unchecked_Conversion_Instance (E) then
         declare
            Source, Target : Node_Id;
            Src_Ty, Tar_Ty : Entity_Id;
         begin
            Get_Unchecked_Conversion_Args (E, Source, Target);
            Src_Ty := Retysp (Entity (Source));
            Tar_Ty := Retysp (Entity (Target));
            declare
               Valid       : Boolean;
               Explanation : Unbounded_String;
            begin
               Suitable_For_UC (Src_Ty, False, Valid, Explanation);
               Emit_Static_Proof_Result
                 (Source, VC_UC_Source, Valid, E,
                  Explanation => To_String (Explanation));

               Suitable_For_UC_Target (Tar_Ty, False, Valid, Explanation);
               Emit_Static_Proof_Result
                 (Target, VC_UC_Target, Valid, E,
                  Explanation => To_String (Explanation));

               Have_Same_Known_RM_Size
                 (Src_Ty, Tar_Ty, Valid, Explanation);
               Emit_Static_Proof_Result
                 (E, VC_UC_Same_Size, Valid, E,
                  Explanation => To_String (Explanation));
            end;
         end;
      end if;
   end Generate_VCs_For_Subprogram;

   --------------------------------
   -- Generate_VCs_For_Task_Type --
   --------------------------------

   procedure Generate_VCs_For_Task_Type (E : E_Task_Type_Id) is
      Name   : constant String  := Full_Name (E);
      Body_N : constant Node_Id := Task_Body (E);
      Params : constant Transformation_Params := Body_Params;

      Why_Body   : W_Prog_Id;
      Priv_Decls : constant List_Id := Private_Declarations_Of_Task_Type (E);
      Vis_Decls  : constant List_Id := Visible_Declarations_Of_Task_Type (E);
      Th         : Theory_UC;
   begin
      --  We open a new theory, so that the context is fresh for this task

      Th :=
        Open_Theory
          (WF_Main,
           New_Module
             (Name => Name & "__task_body",
              File => No_Symbol),
           Comment =>
             "Module for checking absence of run-time errors and "
           & "non-termination of task body of the task type "
           & """" & Get_Name_String (Chars (E)) & """"
           & (if Sloc (E) > 0 then
                " defined at " & Build_Location_String (Sloc (E))
             else "")
           & ", created in " & GNAT.Source_Info.Enclosing_Entity);
      Current_Subp := E;

      Register_VC_Entity (E);

      --  Reset the toplevel exceptions for exit paths

      Clear_Exceptions;

      Ada_Ent_To_Why.Push_Scope (Symbol_Table);

      --  Translate declarations and statements in the task body, if there
      --  is one.

      if Entity_Body_In_SPARK (E) then
         Why_Body :=
           Transform_Handled_Statements
             (Handled_Statement_Sequence (Body_N), Body_Params);

         Why_Body :=
           Transform_Declarations_Block
             (Declarations (Body_N), Why_Body, Body_Params);

         --  We check that the call graph starting from this task respects the
         --  ceiling priority protocol.

         Prepend
           (Check_Ceiling_Protocol (Params, E),
            Why_Body);
      else
         Why_Body := +Void;
      end if;

      --  We check any assertions and pragma (Interrupt)_Priority in the
      --  declarations of the task.

      --  Translate public and private declarations of the package

      if Present (Priv_Decls)
        and then Private_Spec_In_SPARK (E)
      then
         Why_Body := Transform_Declarations_Block
           (Priv_Decls, Why_Body, Body_Params);
      end if;

      if Present (Vis_Decls) then
         Why_Body := Transform_Declarations_Block
           (Vis_Decls, Why_Body, Body_Params);
      end if;

      --  We assume that objects used in the program are in range, if
      --  they are of a dynamic type.

      Prepend
        (Compute_Dynamic_Property_For_Inputs (Params => Params,
                                              E      => E),
         Why_Body);

      --  Assume values of constants

      Assume_Value_Of_Constants (Why_Body, E, Params);

      --  Declare the toplevel exceptions for exit paths

      Declare_Exceptions (Th);

      declare
         Post : W_Pred_Id;
      begin
         if Entity_Body_In_SPARK (E) then
            Post :=
              New_VC_Pred (Ada_Node   => E,
                           Expr       => False_Pred,
                           Reason     => VC_Task_Termination);
         else
            Post := Why_Empty;
         end if;
         Emit (Th,
               Why.Gen.Binders.New_Function_Decl
                 (Domain   => EW_Prog,
                  Name     => Def_Name,
                  Binders  => (1 => Unit_Param),
                  Location => Safe_First_Sloc (E),
                  Labels   => Symbol_Sets.Empty_Set,
                  Post     => Post,
                  Def      => +Why_Body));
      end;

      Ada_Ent_To_Why.Pop_Scope (Symbol_Table);
      Close_Theory (Th,
                    Kind => VC_Generation_Theory);

   end Generate_VCs_For_Task_Type;

   -----------------------------
   -- Get_Location_For_Aspect --
   -----------------------------

   function Get_Location_For_Aspect
     (E         : Entity_Id;
      Kind      : Pragma_Id;
      Classwide : Boolean := False;
      Inherited : Boolean := False) return Node_Id is
   begin

      --  In the case of a No_Return Subprogram, there is no real location for
      --  the postcondition; simply return the subprogram entity node.

      if Kind = Pragma_Postcondition
        and then No_Return (E)
      then
         return E;
      end if;

      --  Pre- and postconditions are stored in reverse order in
      --  Pre_Post_Conditions, hence retrieve the last assertion in this
      --  list to get the first one in source code.

      declare
         L : constant Node_Lists.List :=
              Find_Contracts (E, Kind,
                              Classwide => Classwide,
                              Inherited => Inherited);
      begin
         if L.Is_Empty then
            return Empty;
         else
            return L.Last_Element;
         end if;
      end;
   end Get_Location_For_Aspect;

   ------------------------------
   -- Generate_Axiom_For_Lemma --
   ------------------------------

   procedure Generate_Axiom_For_Lemma
     (E                     : E_Procedure_Id;
      Specialization_Module : Symbol := No_Symbol;
      More_Reads            : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
   is
      Fun      : constant Entity_Id :=
        Retrieve_Automatic_Instantiation_Annotation (E);
      Binders  : Item_Array := Compute_Binders (E, EW_Term, More_Reads);
      Params   : Transformation_Params;
      Pre      : W_Pred_Id;
      Post     : W_Pred_Id;
      Th       : Theory_UC;

      function Is_Disabled return Boolean;
      --  Return True if there is a conjunct in the precondition of E which is
      --  known to be False at compile time.

      -----------------
      -- Is_Disabled --
      -----------------

      function Is_Disabled return Boolean is

         function Is_Statically_False (N : N_Subexpr_Id) return Boolean;
         --  Return True if there is a conjunct in N which is known to be False
         --  at compile time.

         -------------------------
         -- Is_Statically_False --
         -------------------------

         function Is_Statically_False (N : N_Subexpr_Id) return Boolean is
         begin
            case Nkind (N) is
               when N_And_Then | N_Op_And =>
                  return Is_Statically_False (Left_Opnd (N))
                    or else Is_Statically_False (Right_Opnd (N));
               when others =>
                  return Compile_Time_Known_Value (N)
                    and then not Is_True (Expr_Value (N));
            end case;
         end Is_Statically_False;

      begin
         --  Loop over the list of preconditions of E to see if one is
         --  statically false.

         return (for some Pre_N of Find_Contracts (E, Pragma_Precondition) =>
                   Is_Statically_False (Pre_N));
      end Is_Disabled;

   begin
      --  Do not emit an axiom if E has a precondition which evaluates
      --  statically to False. This optimization is useful for functional
      --  containers which have specific axioms for the handling of
      --  equivalence which can be removed at instantiation using a boolean
      --  formal parameter.

      if Is_Disabled then
         return;
      end if;

      Params := (Logic_Params with delta Old_Policy => Ignore);

      Th :=
        Open_Theory
          (WF_Context,
           (if Specialization_Module = No_Symbol then E_Module (E, Lemma_Axiom)
            else M_Lemma_HO_Specializations (E) (Specialization_Module)),
           Comment =>
             "Module for declaring an axiom for the post condition"
           & " of the lemma procedure "
           & """" & Get_Name_String (Chars (E)) & """"
           & (if Sloc (E) > 0 then
                " defined at " & Build_Location_String (Sloc (E))
             else "")
           & ", created in " & GNAT.Source_Info.Enclosing_Entity);

      Ada_Ent_To_Why.Push_Scope (Symbol_Table);
      Localize_Binders (Binders);
      Push_Binders_To_Symbol_Table (Binders);

      Pre := +Compute_Spec (Params, E, Pragma_Precondition, EW_Pred);
      Post :=
        +New_And_Expr
        (Left   =>
           +Compute_Spec (Params, E, Pragma_Postcondition, EW_Pred),
         Right  => +Compute_Contract_Cases_Postcondition (Params, E),
         Domain => EW_Pred);

      declare
         Guard : constant W_Pred_Id :=
           +New_And_Then_Expr
           (Left   => +Compute_Guard_Formula (Binders, Params),
            Right  => +Compute_Type_Invariants_For_Subprogram
              (E, Params, True),
            Domain => EW_Pred);
         --  Dynamic invariant / type invariants of the inputs

      begin
         --  We generate:
         --  forall binders. Guard /\ Pre -> Post

         Emit
           (Th,
            New_Guarded_Axiom
              (Name    => NID (Short_Name (E) & "__" & Post_Axiom),
               Binders => To_Binder_Array (Binders),
               Pre     =>
                 New_And_Pred
                   (Left  => Guard,
                    Right => Pre),
               Def     => Post,
               Dep   =>
                 New_Axiom_Dep
                   (Name => Logic_Function_Name
                        (Fun, Specialization_Module => Specialization_Module),
                    Kind => EW_Axdep_Func)));
      end;

      Close_Theory (Th, Kind => Definition_Theory);
      Record_Extra_Dependency
        (Defining_Module =>
           (if Specialization_Module = No_Symbol
            then E_Module (Fun, Logic_Function_Decl)
            else M_HO_Specializations (Fun) (Specialization_Module).Module),
         Axiom_Module    => Th.Module);

      Ada_Ent_To_Why.Pop_Scope (Symbol_Table);

      Register_Automatically_Instanciated_Lemma (E);
   end Generate_Axiom_For_Lemma;

   -----------------------------
   -- Generate_Axiom_For_Post --
   -----------------------------

   procedure Generate_Axiom_For_Post
     (Th                    : Theory_UC;
      Dispatch_Th           : Theory_UC := Empty_Theory;
      E                     : Callable_Kind_Id;
      Spec_Binders          : Binder_Array := (1 .. 0 => <>);
      Spec_Guard            : W_Pred_Id := True_Pred;
      Specialization_Module : Symbol := No_Symbol;
      More_Reads            : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
   is
      Logic_Func_Binders : constant Item_Array := Compute_Binders
        (E, EW_Term, More_Reads);
      Params             : Transformation_Params;
      Pre                : W_Pred_Id;
      Post               : W_Pred_Id;
      Dispatch_Pre       : W_Pred_Id := Why_Empty;
      Dispatch_Post      : W_Pred_Id := Why_Empty;
      Refined_Post       : W_Pred_Id := Why_Empty;
      Why_Type           : W_Type_Id := Why_Empty;

   begin
      Params := (Logic_Params with delta Old_Policy => Ignore);

      if Is_Function_Or_Function_Type (E) then
         Why_Type := Type_Of_Node (E);
      end if;

      --  Do not generate an axiom for the postcondition of volatile functions,
      --  protected subprograms and functions with side effects.

      if not Is_Function_Or_Function_Type (E)
        or else Is_Function_With_Side_Effects (E)
        or else Has_Pragma_Volatile_Function (E)
      then
         return;
      end if;

      pragma Assert (Is_Function_Type (E) or else Has_Post_Axiom (E));

      --  For recursive functions, we store the axiom in a different module,
      --  so that we can make sure that it cannot be used to prove the function
      --  itself.

      if Ekind (E) = E_Function and then Proof_Module_Cyclic (E) then

         --  Raise a warning about missing (implicit) contract on recursive
         --  calls.

         declare
            Has_Explicit_Contracts : constant Boolean :=
              Has_Contracts (E, Pragma_Postcondition)
              or else Present (Get_Pragma (E, Pragma_Contract_Cases));
            Has_Implicit_Contracts : constant Boolean :=
              Type_Needs_Dynamic_Invariant (Etype (E));
         begin

            if Debug.Debug_Flag_Underscore_F
              and then (Has_Implicit_Contracts or else Has_Explicit_Contracts)
            then
               declare
                  String_For_Implicit : constant String :=
                    (if Has_Explicit_Contracts then ""
                     else "implicit ");
                  Scope               : constant Entity_Id :=
                    Enclosing_Unit (E);
                  String_For_Scope    : constant String :=
                    (if Present (Scope)
                     and then Ekind (Scope) in
                         E_Package | E_Function | E_Procedure | E_Entry
                     and then Proof_Module_Cyclic (E, Scope)
                     then "calls from enclosing unit"
                     else "");
                  String_For_Rec      : constant String :=
                   (if String_For_Scope = "" then
                      (if Is_Recursive (E) then "recursive calls"
                       else "implicit recursive calls")
                    else
                      (if Is_Recursive (E) then "recursive calls or "
                       else ""));
               begin
                  Error_Msg_N
                    ("info: ?" & String_For_Implicit
                     & "function contract might not be available on "
                     & String_For_Rec & String_For_Scope, E);
               end;
            end if;
         end;

         Register_Proof_Cyclic_Function (E);
      end if;

      --  If the function has a postcondition and is not mutually recursive
      --  then generate an axiom:
      --  axiom def_axiom:
      --     forall args [f (args)]. pre (args) ->
      --           let result = f (args) in post (args)

      --  We fill the map of parameters, so that in the Pre and Post, we use
      --  local names of the parameters, instead of the global names.

      Ada_Ent_To_Why.Push_Scope (Symbol_Table);
      Push_Binders_To_Symbol_Table (Logic_Func_Binders);

      Pre := +Compute_Spec (Params, E, Pragma_Precondition, EW_Pred);
      Post :=
        +New_And_Expr
        (Left   =>
           +Compute_Spec (Params, E, Pragma_Postcondition, EW_Pred),
         Right  => +Compute_Contract_Cases_Postcondition (Params, E),
         Domain => EW_Pred);

      if Is_Dispatching_Operation (E)
        and then not Is_Hidden_Dispatching_Operation (E)
      then
         Dispatch_Pre :=
           Get_Dispatching_Call_Contract (Params, E, Pragma_Precondition);
         Dispatch_Post :=
           Get_Dispatching_Call_Contract (Params, E, Pragma_Postcondition);

         --  Classwide post serves as post if no specific postcondition is
         --  given.

         if Find_Contracts (E, Pragma_Postcondition).Is_Empty
           and then No (Get_Pragma (E, Pragma_Contract_Cases))
         then
            Post := Get_LSP_Contract (Params, E, Pragma_Postcondition);
         end if;

         --  Classwide pre serves as pre if no specific postcondition is given

         if Find_Contracts (E, Pragma_Precondition).Is_Empty then
            Pre := Get_LSP_Contract (Params, E, Pragma_Precondition);
         end if;
      end if;

      --  For higher order specializations, we do not take into account
      --  refined postcondition if any.

      if Entity_Body_In_SPARK (E)
        and then Has_Contracts (E, Pragma_Refined_Post)
        and then Specialization_Module = No_Symbol
      then
         Refined_Post := +Compute_Spec (Params,
                                        E, Pragma_Refined_Post, EW_Pred);
      end if;

      declare
         Logic_Why_Binders   : constant Binder_Array :=
           To_Binder_Array (Logic_Func_Binders);
         Guard               : constant W_Pred_Id :=
           +New_And_Then_Expr
           (Left   => +Compute_Guard_Formula (Logic_Func_Binders, Params),
            Right  => +Compute_Type_Invariants_For_Subprogram
              (E, Params, True),
            Domain => EW_Pred);
         --  Dynamic invariant / type invariants of the inputs

         Dynamic_Prop_Result : constant W_Pred_Id :=
           +New_And_Then_Expr
           (Left   => +Compute_Dynamic_Inv_And_Initialization
              (Expr             => +New_Result_Ident (Why_Type),
               Ty               => Etype (E),
               Only_Var         => False_Term,
               Include_Type_Inv =>
                 Include_Non_Local_Type_Inv_For_Subp (E),
               Params           => Params),
            Right  => +Compute_Type_Invariants_For_Subprogram
              (E, Params, False),
            Domain => EW_Pred);
         --  Dynamic invariant / type invariants of the result

         procedure Emit_Post_Axiom
           (Th        : Theory_UC;
            Suffix    : String;
            Selector  : Selection_Kind;
            Pre, Post : W_Pred_Id);
         --  Emit the post_axiom with the given axiom_suffix, pre and
         --  post for the Why identifier associated to E with Selector.

         ---------------------
         -- Emit_Post_Axiom --
         ---------------------

         procedure Emit_Post_Axiom
           (Th        : Theory_UC;
            Suffix    : String;
            Selector  : Selection_Kind;
            Pre, Post : W_Pred_Id)
         is
            Id            : constant W_Identifier_Id :=
              Logic_Function_Name
                (E,
                 Selector_Name         => Selector,
                 Specialization_Module => Specialization_Module);
            Result_Id     : constant W_Identifier_Id :=
              New_Result_Ident (Why_Type);
            Tag_B         : constant Binder_Array :=
              (if Selector = Dispatch then (1 => Tag_Binder)
               else (1 .. 0 => <>));
            Binders       : constant Binder_Array :=
              Tag_B & Spec_Binders & Logic_Why_Binders;
            Pred_Binders  : constant Binder_Array :=
              Binder_Type'(Ada_Node  => Empty,
                           B_Name    => +Result_Id,
                           B_Ent     => Null_Entity_Name,
                           Mutable   => False,
                           Labels    => <>)
                & Binders;
            Tag_Comp      : constant W_Pred_Id :=
              (if Is_Tagged_Type (Retysp (Etype (E)))
               and then not Is_Class_Wide_Type (Etype (E))
               then
                 +New_Comparison
                   (Symbol => Why_Eq,
                    Left   => New_Tag_Access
                      (Domain   => EW_Term,
                       Name     => +New_Result_Ident (Why_Type),
                       Ty       => Retysp (Etype (E))),
                    Right  =>
                      (if Ekind (E) = E_Function
                       and then Selector = Dispatch
                       and then Has_Controlling_Result (E)
                       then +Tag_Binder.B_Name
                       else +E_Symb (Etype (E), WNE_Tag)),
                    Domain => EW_Pred)
               else True_Pred);
            --  For functions with tagged results, assume the value of the tag
            --  of the result.

            Complete_Post : constant W_Pred_Id :=
              New_And_Pred
              (Conjuncts =>
                 (1 =>
                    (if Is_Borrowing_Traversal_Function (E)
                     then Wrap_Post_Of_Traversal
                       (E      => E,
                        Post   => Post,
                        Args   => Get_Args_From_Binders
                          (Logic_Why_Binders, Ref_Allowed => False),
                        Params => Params)
                     else Post),
                  2 => Dynamic_Prop_Result,
                  3 => Tag_Comp));
            Guarded_Post  : constant W_Pred_Id :=
              (if not Use_Guard_For_Function (E) then Complete_Post
               else New_Conditional
                 (Condition   => +New_Call
                      (Domain  => EW_Pred,
                       Name    => Guard_Predicate_Name
                         (E,
                          Selector_Name         => Selector,
                          Specialization_Module => Specialization_Module),
                       Binders => Pred_Binders),
                  Then_Part   => Complete_Post));
            Call            : constant W_Expr_Id := New_Call
              (Domain  => EW_Term,
               Name    => Id,
               Binders => Binders);
            Def           : constant W_Pred_Id := +New_Typed_Binding
              (Ada_Node => Empty,
               Domain   => EW_Pred,
               Name     => +New_Result_Ident (Why_Type),
               Def      => Call,
               Context  => +Guarded_Post);
            Dep           : constant W_Axiom_Dep_Id :=
              New_Axiom_Dep (Name => Id, Kind => EW_Axdep_Func);
         begin
            if Is_True_Boolean (+Complete_Post) then
               return;

            --  If we have a specific guard, generate:
            --  forall spec_binders [spec_guard].
            --    spec_guard <->
            --      (forall binders [call]. Guard /\ Pre -> Def)

            elsif not Is_True_Boolean (+Spec_Guard) then
               Emit
                 (Th,
                  New_Guarded_Axiom
                    (Name     => NID (Short_Name (E) & "__" & Suffix),
                     Binders  => Spec_Binders,
                     Triggers => New_Triggers
                       (Triggers =>
                            (1 => New_Trigger (Terms => (1 => +Spec_Guard)))),
                     Def      => New_Connection
                       (Left  => +Spec_Guard,
                        Op    => EW_Equivalent,
                        Right => +New_Universal_Quantif
                          (Binders  => Tag_B & Logic_Why_Binders,
                           Triggers =>
                             New_Triggers
                               (Triggers =>
                                    (1 => New_Trigger (Terms => (1 => Call)))),
                           Pred     => New_Conditional
                             (Condition =>
                                  +New_And_Expr (Left   => +Guard,
                                                 Right  => +Pre,
                                                 Domain => EW_Pred),
                              Then_Part => +Def))),
                     Dep      => Dep));

            --  Otherwise, generate:
            --  forall binders [call]. Guard /\ Pre -> Def

            else
               Emit
                 (Th,
                  New_Guarded_Axiom
                    (Name     => NID (Short_Name (E) & "__" & Suffix),
                     Binders  => Binders,
                     Triggers =>
                       New_Triggers
                         (Triggers =>
                              (1 => New_Trigger (Terms => (1 => Call)))),
                     Pre      =>
                       +New_And_Expr (Left   => +Guard,
                                      Right  => +Pre,
                                      Domain => EW_Pred),
                     Def      => +Def,
                     Dep      => Dep));
            end if;
         end Emit_Post_Axiom;

      begin
         --  Do not emit an axiom for E if it is inlined for proof

         if No (Retrieve_Inline_Annotation (E)) then
            Emit_Post_Axiom (Th, Post_Axiom, Why.Inter.Standard, Pre, Post);
         end if;

         if Is_Dispatching_Operation (E)
           and then not Is_Hidden_Dispatching_Operation (E)
         then
            pragma Assert (Present (Dispatch_Pre)
                            and then Present (Dispatch_Post));
            Emit_Post_Axiom (Dispatch_Th,
                             Post_Dispatch_Axiom,
                             Dispatch,
                             New_And_Pred
                               (Left  => Compute_Guard_For_Dispatch
                                  (Subp    => E,
                                   Binders => Logic_Func_Binders,
                                   W_Tag   => +Tag_Binder.B_Name,
                                   Params  => Params),
                                Right => Dispatch_Pre),
                             Dispatch_Post);
         end if;

         --  For higher order specializations, we do not take into account
         --  refined postcondition if any.

         if Entity_Body_In_SPARK (E)
           and then Has_Contracts (E, Pragma_Refined_Post)
           and then Specialization_Module = No_Symbol
         then
            pragma Assert (Present (Refined_Post));
            Emit_Post_Axiom (Th,
                             Post_Refine_Axiom,
                             Refine,
                             Pre,
                             Refined_Post);
         end if;
      end;

      Register_Dependency_For_Soundness (Th.Module, E);
      if Is_Dispatching_Operation (E)
        and then not Is_Hidden_Dispatching_Operation (E)
      then
         Register_Dependency_For_Soundness (Dispatch_Th.Module, E);
      end if;

      Ada_Ent_To_Why.Pop_Scope (Symbol_Table);
   end Generate_Axiom_For_Post;

   --------------------------------------------
   -- Generate_Dispatch_Compatibility_Axioms --
   --------------------------------------------

   procedure Generate_Dispatch_Compatibility_Axioms
     (Th : Theory_UC;
      E  : Entity_Id)
   is
      Ty            : constant Entity_Id :=
        Base_Retysp (SPARK_Util.Subprograms.Find_Dispatching_Type (E));
      Descendants   : Node_Sets.Set := Get_Descendant_Set (Ty);
      Anc_Binders   : constant Binder_Array :=
        (if Ekind (E) = E_Function then
            To_Binder_Array (Compute_Binders (E, EW_Term))
         else Procedure_Logic_Binders (E));
      Dispatch_Args : W_Expr_Array (1 .. Anc_Binders'Length + 1);
      Anc_Id        : constant W_Identifier_Id :=
        (if Ekind (E) = E_Function then
              To_Why_Id (E, Domain => EW_Term, Selector => Dispatch)
         else To_Local (E_Symb (E, WNE_Specific_Post)));
      Anc_Ty        : constant W_Type_Id :=
        (if Ekind (E) = E_Function then Type_Of_Node (E)
         else EW_Bool_Type);
      Descendant_E  : Entity_Id;

   begin
      --  The arguments of the dispatching call are the binders from
      --  Anc_Binders with a hole at the beginning to store the (specific)
      --  value of the tag.

      for I in Anc_Binders'Range loop
         Dispatch_Args (I + 1) := +Anc_Binders (I).B_Name;
      end loop;

      Descendants.Include (Ty);

      for Descendant of Descendants loop
         Descendant_E := Corresponding_Primitive (E, Descendant);

         if Entity_In_SPARK (Descendant_E) then
            Dispatch_Args (1) := +E_Symb (Descendant, WNE_Tag);

            declare
               Desc_Id  : constant W_Identifier_Id :=
                 To_Why_Id (Descendant_E, Domain => EW_Term);
               Anc_Call : constant W_Expr_Id :=
                 New_Call (Domain => EW_Term,
                           Name   => Anc_Id,
                           Args   => Dispatch_Args,
                           Typ    => Anc_Ty);
            begin
               --  If Descendant_E has not the same globals as E, there should
               --  be an error in flow analysis. Do not attempt to generate a
               --  compatibility axiom.

               if not Same_Globals (E, Descendant_E) then
                  return;
               end if;

               --  If E is a function, emit:
               --    for all x1 ... [<E>__dispatch Descendant.tag x1 ...].
               --       <E>__dispatch Descendant.tag x1 ... =
               --            <Descendant.E> X1 ..

               if Ekind (E) = E_Function then

                  --  Do not generate compatibility axioms for volatile
                  --  functions and functions with side effects as they do
                  --  not have any associated logic function.
                  --  ??? They could maybe be handled like procedures, using a
                  --  specific_post predicate.

                  if Is_Function_With_Side_Effects (E)
                    or else Has_Pragma_Volatile_Function (E)
                  then
                     return;
                  end if;

                  declare
                     Desc_Ty      : constant W_Type_Id :=
                       Type_Of_Node (Descendant_E);
                     Desc_Binders : constant Binder_Array := To_Binder_Array
                       (Compute_Binders (Descendant_E, EW_Term));
                     Desc_Args    : W_Expr_Array (1 .. Desc_Binders'Length);
                     Guard        : constant W_Pred_Id :=
                       (if not Use_Guard_For_Function (E) then True_Pred
                        else New_Call
                          (Name   => E_Symb (E, WNE_Dispatch_Func_Guard),
                           Args   => Anc_Call & Dispatch_Args,
                           Typ    => EW_Bool_Type));
                     Call         : W_Term_Id;
                     --  The axiom is protected by the dispatching post
                     --  predicate of E.

                  begin
                     pragma Assert (Anc_Binders'First = Desc_Binders'First
                                    and Anc_Binders'Last = Desc_Binders'Last);

                     --  Conversions are needed for controlling parameters

                     for I in Desc_Binders'Range loop
                        Desc_Args (I) :=
                          Insert_Simple_Conversion
                            (Domain => EW_Term,
                             Expr   => +Anc_Binders (I).B_Name,
                             To     => Get_Typ (Desc_Binders (I).B_Name));
                     end loop;

                     Call := +New_Function_Call
                       (Domain => EW_Term,
                        Subp   => Descendant_E,
                        Name   => Desc_Id,
                        Args   => Desc_Args,
                        Check  => False,
                        Typ    => Desc_Ty);

                     --  If Descendant is a derived type with a null extension,
                     --  Descendant_E can be inherited even if it has a
                     --  controlling result. An overriding is generated in the
                     --  frontend so this case should never occur.

                     pragma Assert
                       (if Has_Controlling_Result (Descendant_E)
                        then Base_Retysp (Descendant) =
                            Base_Retysp (Etype (Descendant_E)));

                     Emit
                       (Th,
                        New_Guarded_Axiom
                          (Ada_Node => Empty,
                           Name     => NID
                             (Full_Name (Descendant) & "__" & Compat_Axiom),
                           Binders  => Anc_Binders,
                           Triggers =>
                             New_Triggers
                               (Triggers =>
                                    (1 => New_Trigger
                                       (Terms => (1 => Anc_Call)))),
                           Pre      => Guard,
                           Def      =>
                             +New_Comparison
                             (Symbol => Why_Eq,

                              --  Conversion is needed for controlling result

                              Left   => Insert_Simple_Conversion
                                (Domain => EW_Term,
                                 Expr   => +Call,
                                 To     => Anc_Ty),
                              Right  => Anc_Call,
                              Domain => EW_Term),
                           Dep      => New_Axiom_Dep (Name => Anc_Id,
                                                      Kind => EW_Axdep_Func)));
                  end;

               --  If E is a procedure, emit:
               --    for all x1 ... [<E>__spec_post Descendant.tag x1 ...].
               --       <E>__spec_post Descendant.tag x1 ... ->
               --           <specific post of Descendant>

               else
                  pragma Assert (Ekind (E) = E_Procedure);

                  declare
                     New_Binders : Item_Array :=
                       Compute_Raw_Binders (E) &
                       Compute_Binders_For_Effects (E);
                     Old_Binders : Item_Array := New_Binders;
                     Desc_Params : Item_Array :=
                       Compute_Raw_Binders (Descendant_E);
                     Desc_Post   : W_Pred_Id;
                     Old_Parts   : Node_Sets.Set;
                     Params      : Transformation_Params;

                  begin
                     Localize_Binders (New_Binders);
                     Localize_Binders (Old_Binders, "old");

                     Ada_Ent_To_Why.Push_Scope (Symbol_Table);

                     --  Controlling parameters may need a conversion. We need
                     --  a binder in non-split form for them. For others, we
                     --  can use the ancestor names directly.

                     for I in Desc_Params'Range loop
                        declare
                           Ada_Node : constant Node_Id :=
                             Get_Ada_Node_From_Item (Desc_Params (I));
                           Typ      : constant W_Type_Id :=
                             Get_Why_Type_From_Item (Desc_Params (I));

                        begin
                           pragma Assert (Present (Ada_Node));

                           if Get_Ada_Node (+Typ) = Descendant then
                              Desc_Params (I) :=
                                (Regular,
                                 Local => True,
                                 Init  => <>,
                                 Main  =>
                                   (B_Name   =>
                                        New_Temp_Identifier
                                      (Base_Name => Short_Name (Ada_Node),
                                       Typ       => Typ),
                                    B_Ent    => Null_Entity_Name,
                                    Mutable  => False,
                                    Ada_Node => Ada_Node,
                                    Labels   => <>));

                              Ada_Ent_To_Why.Insert (Symbol_Table,
                                                     Ada_Node,
                                                     Desc_Params (I));
                           else
                              Ada_Ent_To_Why.Insert (Symbol_Table,
                                                     Ada_Node,
                                                     New_Binders (I));
                           end if;
                        end;
                     end loop;

                     --  Store new binders in the Symbol_Table, so that in the
                     --  Post of Descendant, we use local names of parameters
                     --  and effects, instead of the global names.

                     Push_Binders_To_Symbol_Table (New_Binders);

                     Params := (Logic_Params with delta Old_Policy => Use_Map);

                     --  Translate the specific postcondition of Descendant_E

                     if No_Return (Descendant_E) then
                        Desc_Post := False_Pred;
                     else
                        Desc_Post :=
                          +New_And_Expr
                          (Left   =>
                             +Compute_Spec
                             (Params, Descendant_E, Pragma_Postcondition,
                              EW_Pred),
                           Right  =>
                             +Compute_Contract_Cases_Postcondition
                             (Params, Descendant_E),
                           Domain => EW_Pred);

                        if Find_Contracts
                          (Descendant_E, Pragma_Postcondition).Is_Empty
                          and then No
                            (Get_Pragma (Descendant_E, Pragma_Contract_Cases))
                        then
                           Desc_Post :=
                             Get_LSP_Contract
                               (Params, Descendant_E, Pragma_Postcondition);
                        end if;

                        --  Collect references to Old in Old_Parts

                        Collect_Old_For_Subprogram
                          (Descendant_E, Old_Parts,
                           Exclude_Classwide => False);
                     end if;

                     Ada_Ent_To_Why.Pop_Scope (Symbol_Table);

                     Ada_Ent_To_Why.Push_Scope (Symbol_Table);

                     --  Insert bindings for contolling parameters of
                     --  Descendant_E and update entities which should be used
                     --  for other parameters.

                     for I in Desc_Params'Range loop
                        declare
                           Ada_Node : constant Node_Id :=
                             Get_Ada_Node_From_Item (Desc_Params (I));
                           Typ      : constant W_Type_Id :=
                             Get_Why_Type_From_Item (Desc_Params (I));

                        begin
                           if Get_Ada_Node (+Typ) = Descendant then
                              Desc_Post := New_Typed_Binding
                                (Name     => Desc_Params (I).Main.B_Name,
                                 Def      => Insert_Simple_Conversion
                                   (Expr   =>
                                        Reconstruct_Item
                                      (New_Binders (I), Ref_Allowed => False),
                                    To     =>
                                      Get_Typ (Desc_Params (I).Main.B_Name)),
                                 Context  => Desc_Post);
                              Ada_Ent_To_Why.Insert (Symbol_Table,
                                                     Ada_Node,
                                                     Desc_Params (I));
                           else
                              Ada_Ent_To_Why.Insert (Symbol_Table,
                                                     Ada_Node,
                                                     Old_Binders (I));
                           end if;
                        end;
                     end loop;

                     --  To translate expressions used in old attributes, we
                     --  need to store values in the pre state in the symbol
                     --  table.

                     Push_Binders_To_Symbol_Table (Old_Binders);

                     --  Inner references to Old should be ignored

                     Params.Old_Policy := Ignore;

                     --  Insert let bindings for old expressions

                     Desc_Post := +Bind_From_Mapping_In_Expr
                       (Params => Params,
                        Map    => Map_For_Old,
                        Expr   => +Desc_Post,
                        Domain => EW_Term,
                        Subset => Old_Parts);

                     --  Insert bindings for contolling parameters of
                     --  Descendant_E

                     for I in Desc_Params'Range loop
                        declare
                           Typ : constant W_Type_Id :=
                             Get_Why_Type_From_Item (Desc_Params (I));

                        begin
                           if Get_Ada_Node (+Typ) = Descendant then
                              Desc_Post := New_Typed_Binding
                                (Name     => Desc_Params (I).Main.B_Name,
                                 Def      => Insert_Simple_Conversion
                                   (Expr   =>
                                        Reconstruct_Item
                                      (Old_Binders (I), Ref_Allowed => False),
                                    To     =>
                                      Get_Typ (Desc_Params (I).Main.B_Name)),
                                 Context  => +Desc_Post);
                           end if;
                        end;
                     end loop;

                     Ada_Ent_To_Why.Pop_Scope (Symbol_Table);

                     Emit
                       (Th,
                        New_Guarded_Axiom
                          (Ada_Node => Empty,
                           Name     => NID
                             (Full_Name (Descendant) & "__" & Compat_Axiom),
                           Binders  => Anc_Binders,
                           Triggers =>
                             New_Triggers
                               (Triggers =>
                                    (1 => New_Trigger
                                       (Terms => (1 => Anc_Call)))),
                           Pre      => +Anc_Call,
                           Def      => Desc_Post));
                  end;
               end if;
            end;
         end if;
      end loop;
   end Generate_Dispatch_Compatibility_Axioms;

   ------------------------------------
   -- Generate_Subprogram_Completion --
   ------------------------------------

   procedure Generate_Subprogram_Completion (E : Callable_Kind_Id) is
      Dispatch_Th      : Theory_UC := Empty_Theory;
      Dispatch_Post_Th : Theory_UC := Empty_Theory;
      Post_Axiom_Th    : Theory_UC;
      Program_Th       : Theory_UC;
   begin
      Program_Th :=
        Open_Theory
          (WF_Context, E_Module (E, Program_Function_Decl),
           Comment =>
             "Module for declaring a program function for "
           & """" & Get_Name_String (Chars (E)) & """"
           & (if Sloc (E) > 0 then
                " defined at " & Build_Location_String (Sloc (E))
             else "")
           & ", created in " & GNAT.Source_Info.Enclosing_Entity);
      Post_Axiom_Th :=
        Open_Theory
          (WF_Context, E_Module (E, Fun_Post_Axiom),
           Comment =>
             "Module for defining a post axiom for "
           & """" & Get_Name_String (Chars (E)) & """"
           & (if Sloc (E) > 0 then
                " defined at " & Build_Location_String (Sloc (E))
             else "")
           & ", created in " & GNAT.Source_Info.Enclosing_Entity);

      --  If E is a dispatching operation, create a theory for the axioms of
      --  its dispatching version.

      if Is_Dispatching_Operation (E)
        and then not Is_Hidden_Dispatching_Operation (E)
        and then not Is_Predicate_Function (E)
      then
         Dispatch_Th :=
           Open_Theory
             (WF_Context, E_Module (E, Dispatch_Axiom),
              Comment =>
                "Module for declaring a program function (and compatibility "
              & "axioms) for the dispatching variant of "
              & """" & Get_Name_String (Chars (E)) & """"
              & (if Sloc (E) > 0 then
                   " defined at " & Build_Location_String (Sloc (E))
                else "")
              & ", created in " & GNAT.Source_Info.Enclosing_Entity);
         Dispatch_Post_Th :=
           Open_Theory
             (WF_Context, E_Module (E, Dispatch_Post_Axiom),
              Comment =>
                "Module for declaring a post axiom for the dispatching variant"
              & " of """ & Get_Name_String (Chars (E)) & """"
              & (if Sloc (E) > 0 then
                   " defined at " & Build_Location_String (Sloc (E))
                else "")
              & ", created in " & GNAT.Source_Info.Enclosing_Entity);
      end if;

      declare
         Use_Result_Name : constant Boolean := Ekind (E) = E_Function;
         --  Store the result identifier in Result_Name
      begin
         if Use_Result_Name then
            Result_Name := New_Result_Ident (Type_Of_Node (E));
            Result_Is_Mutable := False;
         end if;

         if Within_Protected_Type (E) then
            Self_Name :=
              Concurrent_Self_Ident (Containing_Protected_Type (E));
            Self_Is_Mutable := Ekind (E) /= E_Function;
         end if;

         Generate_Subprogram_Program_Fun
           (Program_Th, Dispatch_Th, E,
            To_Why_Id (E, Domain => EW_Prog, Local => True));

         Generate_Axiom_For_Post (Post_Axiom_Th, Dispatch_Post_Th, E);

         if Is_Dispatching_Operation (E)
           and then not Is_Hidden_Dispatching_Operation (E)
           and then not Is_Predicate_Function (E)
         then
            Generate_Dispatch_Compatibility_Axioms (Dispatch_Th, E);
         end if;

         if Within_Protected_Type (E) then
            Self_Name := Why_Empty;
            Self_Is_Mutable := False;
         end if;

         if Use_Result_Name then
            Result_Name := Why_Empty;
            Result_Is_Mutable := False;
         end if;
      end;

      Close_Theory (Post_Axiom_Th,
                    Kind           => Axiom_Theory,
                    Defined_Entity => E);

      Close_Theory (Program_Th,
                    Kind => Definition_Theory);

      --  Close the dispatching axiom module if it is not empty and add an
      --  extra dependency to the dispatching definition module.

      if Dispatch_Th /= Empty_Theory then

         --  Compatibility axioms are always sound, so we do not need a
         --  dependency for soundness here.

         Close_Theory (Dispatch_Th,
                       Kind => Definition_Theory);
         Record_Extra_Dependency
           (Defining_Module => E_Module (E, Dispatch),
            Axiom_Module    => Dispatch_Th.Module);

         Close_Theory (Dispatch_Post_Th,
                       Kind => Definition_Theory);
         Record_Extra_Dependency
           (Defining_Module => E_Module (E, Dispatch),
            Axiom_Module    => Dispatch_Post_Th.Module);
      end if;

      --  If E is a lemma procedure with an Automatic_Instantiation annotation,
      --  generate a lemma for the postcondition of E.

      if Has_Automatic_Instantiation_Annotation (E) then
         Generate_Axiom_For_Lemma (E);
      end if;
   end Generate_Subprogram_Completion;

   -------------------------------------
   -- Generate_Subprogram_Program_Fun --
   -------------------------------------

   procedure Generate_Subprogram_Program_Fun
     (Th                    : Theory_UC;
      Dispatch_Th           : Theory_UC := Empty_Theory;
      E                     : Callable_Kind_Id;
      Prog_Id               : W_Identifier_Id;
      Spec_Binders          : Binder_Array := Binder_Array'(1 .. 0 => <>);
      Specialization_Module : Symbol := No_Symbol;
      More_Reads            : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
   is
      Func_Binders     : constant Item_Array :=
        Compute_Binders (E, EW_Prog, More_Reads);
      Func_Why_Binders : constant Binder_Array :=
        To_Binder_Array (Func_Binders);
      Params           : Transformation_Params;
      Effects          : W_Effects_Id;
      Pre              : W_Pred_Id;
      Post             : W_Pred_Id;
      Dispatch_Pre     : W_Pred_Id := Why_Empty;
      Dispatch_Post    : W_Pred_Id := Why_Empty;
      Refined_Post     : W_Pred_Id := Why_Empty;
      Why_Type         : W_Type_Id := Why_Empty;

   begin
      Params := (Logic_Params with delta Ref_Allowed => True);

      --  We fill the map of parameters, so that in the Pre and Post, we use
      --  local names of the parameters, instead of the global names.

      Ada_Ent_To_Why.Push_Scope (Symbol_Table);

      for Binder of Func_Binders loop
         declare
            A : constant Node_Id := Get_Ada_Node_From_Item (Binder);
         begin

            --  If the Ada_Node is Empty, it's not an interesting binder (e.g.
            --  void_param).

            if Present (A) then
               Ada_Ent_To_Why.Insert (Symbol_Table, A, Binder);
            end if;
         end;
      end loop;

      Effects := Compute_Effects (E, More_Reads => More_Reads);

      --  Potentially add raised exceptions to the effects

      if Has_Exceptional_Contract (E) then
         declare
            Exc_Id : constant W_Identifier_Id :=
              New_Temp_Identifier (Base_Name => "exc", Typ => EW_Int_Type);
         begin
            Effects_Append_To_Raises
              (Effects,
               New_Raise_Effect
                 (Domain => EW_Prog,
                  Name   => M_Main.Ada_Exc,
                  Arg_Id => Exc_Id,
                  Post   => Compute_Exceptional_Cases_Postcondition
                    (Params, E, Exc_Id)));
         end;
      end if;

      Pre := Get_Static_Call_Contract (Params, E, Pragma_Precondition);

      if Is_Dispatching_Operation (E)
        and then not Is_Hidden_Dispatching_Operation (E)
      then
         Dispatch_Pre :=
           Get_Dispatching_Call_Contract (Params, E, Pragma_Precondition);
      end if;

      --  For a procedure annotated with No_Return, the postcondition at call
      --  site should be "False", so that it is known in the caller that the
      --  call does not return.

      if No_Return (E) then
         Post := False_Pred;

         if Is_Dispatching_Operation (E)
           and then not Is_Hidden_Dispatching_Operation (E)
         then
            Dispatch_Post := False_Pred;
         end if;

         if Entity_Body_In_SPARK (E)
           and then Has_Contracts (E, Pragma_Refined_Post)
         then
            Refined_Post := False_Pred;
         end if;

      --  In other cases, the postcondition is extracted from the subprogram
      --  contract.

      else
         Post :=
           +New_And_Expr
           (Left   =>
              +Compute_Spec (Params, E, Pragma_Postcondition, EW_Pred),
            Right  => +Compute_Contract_Cases_Postcondition (Params, E),
            Domain => EW_Pred);

         if Is_Dispatching_Operation (E)
           and then not Is_Hidden_Dispatching_Operation (E)
         then
            Dispatch_Post :=
              Get_Dispatching_Call_Contract (Params, E, Pragma_Postcondition);

            if Find_Contracts (E, Pragma_Postcondition).Is_Empty
              and then No (Get_Pragma (E, Pragma_Contract_Cases))
            then
               Post := Get_LSP_Contract (Params, E, Pragma_Postcondition);
            end if;
         end if;

         --  For higher order specializations, we do not take into account
         --  refined postcondition if any.

         if Ekind (E) /= E_Subprogram_Type
           and then Entity_Body_In_SPARK (E)
           and then Has_Contracts (E, Pragma_Refined_Post)
           and then Specialization_Module = No_Symbol
         then
            Refined_Post :=
              Get_Static_Call_Contract (Params, E, Pragma_Refined_Post);
         end if;
      end if;

      if Is_Function_Or_Function_Type (E) then

         Why_Type := Type_Of_Node (E);

         declare
            Logic_Func_Args     : constant W_Expr_Array :=
              Get_Args_From_Binders (Spec_Binders, Ref_Allowed => True)
               & Compute_Args (E, Func_Why_Binders, More_Reads);
            Dynamic_Prop_Result : constant W_Pred_Id :=
              +New_And_Then_Expr
              (Left   => +Compute_Dynamic_Inv_And_Initialization
                 (Expr             => +New_Result_Ident (Why_Type),
                  Ty               => Etype (E),
                  Only_Var         => False_Term,
                  Include_Type_Inv => Include_Non_Local_Type_Inv_For_Subp (E),
                  Params           => Params),
               Right  => +Compute_Type_Invariants_For_Subprogram
                 (E, Params, False),
               Domain => EW_Pred);
            --  Dynamic invariant and type invariant of the result

            Volatile_State  : constant W_Identifier_Id :=
              New_Identifier
                (Domain => EW_Term,
                 Name   => "volatile__effect");

            function Create_Function_Decl
              (Prog_Id   : W_Identifier_Id;
               Selector  : Selection_Kind;
               Pre       : W_Pred_Id;
               Post      : W_Pred_Id;
               Effects   : W_Effects_Id) return W_Declaration_Id;
            --  create the function declaration with the given Logic_Id,
            --  Prog_Id, Pre and Post.

            --------------------------
            -- Create_Function_Decl --
            --------------------------

            function Create_Function_Decl
              (Prog_Id   : W_Identifier_Id;
               Selector  : Selection_Kind;
               Pre       : W_Pred_Id;
               Post      : W_Pred_Id;
               Effects   : W_Effects_Id) return W_Declaration_Id
            is
               --  A tag is needed for dispatching calls, to account for the
               --  fact that the call might be dispatching on its result, which
               --  is not passed as regular argument to the call.
               Need_Tag   : constant Boolean := Selector = Dispatch;

               --  Each function has in its postcondition that its result is
               --  equal to the application of the corresponding logic function
               --  to the same arguments.

               Param_Post : W_Pred_Id :=
                 +New_And_Expr
                 (Left   => +Dynamic_Prop_Result,
                  Right  =>

                  --  If the function is a borrowing traversal function,
                  --  bind the identifier for the pledge of the result. Also
                  --  assume that the pledge holds right after the call.

                    (if Is_Borrowing_Traversal_Function (E)
                     then +Wrap_Post_Of_Traversal
                       (E, Post, Logic_Func_Args, Params)
                     else +Post),
                  Domain => EW_Pred);
               Tag_Arg    : constant W_Expr_Array :=
                 (if Need_Tag then (1 => +Tag_Binder.B_Name)
                  else (1 .. 0 => <>));
               Tag_B      : constant Binder_Array :=
                 (if Need_Tag then (1 => Tag_Binder)
                  else (1 .. 0 => <>));
               Result_Id  : constant W_Identifier_Id :=
                 New_Result_Ident (Why_Type);
               Pred_Args  : constant W_Expr_Array :=
                 +Result_Id & Tag_Arg & Logic_Func_Args;

            begin
               --  A volatile function has an effect, as well as a function
               --  with side effects, and should not have the special
               --  postcondition which says its result is equal to the
               --  logic function.

               if not Is_Function_With_Side_Effects (E)
                 and then not Has_Pragma_Volatile_Function (E)
               then
                  declare
                     --  Add attribute RAC_Assume to the predicate N. This is
                     --  used to assume equality with function results and
                     --  function guards during RAC, because their validity
                     --  cannot be derived.
                     function RAC_Assume
                       (N : W_Pred_Id) return W_Pred_Id
                     is
                        (New_Label
                           (Labels => Symbol_Sets.To_Set
                                (NID (RAC_Assume_Label)),
                            Def    => N));

                     Logic_Id   : constant W_Identifier_Id :=
                       Logic_Function_Name
                         (E, Selector, Specialization_Module);
                     Pred_Id    : constant W_Identifier_Id :=
                       Guard_Predicate_Name
                         (E, Selector, Specialization_Module);
                     Args       : constant W_Expr_Array :=
                       Tag_Arg & Logic_Func_Args;
                     Logic_Call : constant W_Pred_Id :=
                       RAC_Assume
                         (New_Call
                            (Name => Why_Eq,
                             Args => (+Result_Id,
                                      New_Call
                                        (Domain => EW_Term,
                                         Name   => Logic_Id,
                                         Args   => Args))));
                     Pred_Call  : constant W_Pred_Id :=
                       (if Use_Guard_For_Function (E) then
                             RAC_Assume
                          (New_Call
                               (Name => Pred_Id,
                                Args => Pred_Args))
                                     else True_Pred);

                  begin
                     Param_Post :=
                       New_And_Pred
                         ((1 => Logic_Call, 2 => Pred_Call, 3 => Param_Post));
                  end;
               end if;

               --  For functions returning specific tagged type, the result has
               --  the expected tag.

               if Is_Tagged_Type (Retysp (Etype (E)))
                 and then not Is_Class_Wide_Type (Etype (E))
               then
                  Param_Post := New_And_Pred
                    ((1 => Param_Post,
                      2 => +New_Comparison
                        (Symbol => Why_Eq,
                         Left   => New_Tag_Access
                           (Domain   => EW_Term,
                            Name     => +New_Result_Ident (Why_Type),
                            Ty       => Retysp (Etype (E))),
                         Right  =>
                           (if Ekind (E) = E_Function
                            and then Selector = Dispatch
                            and then Has_Controlling_Result (E)
                            then +Tag_Binder.B_Name
                            else +E_Symb (Etype (E), WNE_Tag)),
                         Domain => EW_Pred)));
               end if;

               return New_Function_Decl
                 (Domain      => EW_Prog,
                  Name        => Prog_Id,
                  Binders     => Tag_B & Spec_Binders & Func_Why_Binders,
                  Return_Type => Type_Of_Node (E),
                  Labels      => Symbol_Sets.Empty_Set,
                  Location    => No_Location,
                  Effects     => Effects,
                  Pre         => Pre,
                  Post        => Param_Post);
            end Create_Function_Decl;

         begin
            --  For a volatile function that is not protected, we need to
            --  generate a dummy effect. Protected functions are OK, they
            --  already have their own state (the protected object).

            if Has_Pragma_Volatile_Function (E) then
               Effects_Append_To_Writes (Effects, Volatile_State);

               Emit
                 (Th,
                  New_Global_Ref_Declaration
                    (Ada_Node => E,
                     Labels   => Symbol_Sets.Empty_Set,
                     Location => No_Location,
                     Name     => Volatile_State,
                     Ref_Type => EW_Private_Type));
            end if;

            --  If the expression function definition might be hidden, generate
            --  a program function without the body as a post.

            if Expr_Fun_Might_Be_Hidden (E) then
               Emit
                 (Th,
                  New_Namespace_Declaration
                    (Name         => NID (To_String (WNE_Hidden_Module)),
                     Declarations =>
                       (1 => Create_Function_Decl
                            (Prog_Id  => Prog_Id,
                             Selector => Why.Inter.Standard,
                             Pre      => Pre,
                             Post     => Post,
                             Effects  => Effects))));
            end if;

            --  If E is an expression function, add its body to its
            --  postcondition. For higher order specializations, the expression
            --  function body is not taken into account.

            if Is_Expression_Function_Or_Completion (E)
              and then Entity_Body_Compatible_With_SPARK (E)
              and then not Has_Pragma_Volatile_Function (E)
              and then Specialization_Module = No_Symbol
            then
               declare
                  Domain    : constant EW_Domain :=
                    (if Is_Standard_Boolean_Type (Etype (E)) then EW_Pred
                     else EW_Term);
                  Expr_Fun_N : constant Node_Id :=
                    Get_Expression_Function (E);
                  Expr_Body : constant W_Expr_Id :=
                    Transform_Expr (Expression (Expr_Fun_N),
                                    Expected_Type => Why_Type,
                                    Domain        => Domain,
                                    Params        => Params);
                  Res_Expr  : constant W_Expr_Id :=
                    +New_Result_Ident (Why_Type);
                  Eq_Expr   : constant W_Pred_Id :=
                    (New_Call (Name => Why_Eq,
                               Args => (Res_Expr, Expr_Body),
                               Typ  => EW_Bool_Type));
               begin
                  if Entity_Body_In_SPARK (E)
                    and then Has_Contracts (E, Pragma_Refined_Post)
                  then
                     Refined_Post :=
                       +New_And_Expr (+Eq_Expr, +Refined_Post, EW_Pred);
                  else
                     Post := +New_And_Expr (+Eq_Expr, +Post, EW_Pred);
                  end if;
               end;
            end if;

            Emit
              (Th,
               Create_Function_Decl (Prog_Id  => Prog_Id,
                                     Selector => Why.Inter.Standard,
                                     Pre      => Pre,
                                     Post     => Post,
                                     Effects  => Effects));

            if Is_Dispatching_Operation (E)
              and then not Is_Hidden_Dispatching_Operation (E)
            then
               Emit
                 (Dispatch_Th,
                  Create_Function_Decl
                            (Prog_Id   => Prog_Id,
                             Selector  => Dispatch,
                             Pre       => Dispatch_Pre,
                             Post      => Dispatch_Post,
                             Effects   => Effects));
            end if;

            --  For higher order specializations, we do not take into account
            --  refined postcondition if any.

            if Entity_Body_In_SPARK (E)
              and then Has_Contracts (E, Pragma_Refined_Post)
              and then Specialization_Module = No_Symbol
            then
               Emit
                 (Th,
                  New_Namespace_Declaration
                    (Name         => NID (To_String (WNE_Refine_Module)),
                     Declarations =>
                       (1 => Create_Function_Decl
                            (Prog_Id   => Prog_Id,
                             Selector  => Refine,
                             Pre       => Pre,
                             Post      => Refined_Post,
                             Effects   => Effects))));
            end if;
         end;

      else
         pragma Assert
           (Ekind (E) in E_Entry | E_Procedure | E_Subprogram_Type);

         declare
            Dynamic_Prop_Effects : constant W_Pred_Id :=
              New_And_Pred
                ((1 => Compute_Dynamic_Property_For_Effects (E, Params),
                  2 => Compute_Type_Invariants_For_Subprogram
                    (E, Params, False),
                  3 => Preservation_Of_Access_Parameters (E, Params)));
            --  Dynamic invariant and type invariant for outputs of the
            --  procedure, as well as preservation of discriminants and
            --  bounds of access parameters.

         begin
            Post := +New_And_Expr (Left   => +Post,
                                   Right  => +Dynamic_Prop_Effects,
                                   Domain => EW_Pred);

            Emit
              (Th,
               New_Function_Decl
                 (Domain      => EW_Prog,
                  Name        => Prog_Id,
                  Binders     => Spec_Binders & Func_Why_Binders,
                  Labels      => Symbol_Sets.Empty_Set,
                  Location    => No_Location,
                  Return_Type => EW_Unit_Type,
                  Effects     => Effects,
                  Pre         => Pre,
                  Post        => Post));

            if Is_Dispatching_Operation (E)
              and then not Is_Hidden_Dispatching_Operation (E)
            then

               --  For dispatching procedure, declare a new predicate symbol
               --  standing for the specific postcondition which applies to the
               --  dispatching tag and add it to the dispatching postcondition
               --  of E.

               declare
                  Spec_Post_Id   : constant W_Identifier_Id :=
                    New_Identifier
                      (Domain => EW_Pred,
                       Symb   => NID (Short_Name (E) & "__" & Specific_Post),
                       Typ    => EW_Bool_Type);
                  --  Name of the predicate function for E's specific post

                  Spec_Post_Call : W_Pred_Id := True_Pred;

               begin
                  --  Construct the Pred_Id corresponding to the call to
                  --  Spec_Post_Id in the postcondition of E.

                  declare
                     Logic_Binders   : constant Item_Array :=
                       Compute_Raw_Binders (E) &
                       Compute_Binders_For_Effects (E);
                     --  Binders for parameters and effects of E

                     Dispatch_Param  : constant Entity_Id :=
                       Find_Dispatching_Parameter (E);
                     Dispatch_Binder : constant Item_Type :=
                       Ada_Ent_To_Why.Element
                         (Symbol_Table, Dispatch_Param);
                     Dispatch_Typ    : constant W_Type_Id :=
                       Get_Why_Type_From_Item (Dispatch_Binder);
                     Tag_Arg         : constant W_Expr_Id :=
                       (case Dispatch_Binder.Kind is
                           when Regular =>
                              New_Tag_Access
                          (Domain => EW_Term,
                           Name   =>
                             (if Dispatch_Binder.Main.Mutable then
                                   New_Deref
                                (Right => Dispatch_Binder.Main.B_Name,
                                 Typ   => Dispatch_Typ)
                              else +Dispatch_Binder.Main.B_Name),
                           Ty     =>
                              Get_Ada_Node (+Dispatch_Typ)),
                           when DRecord => +Dispatch_Binder.Tag.Id,
                           when others  => raise Program_Error);
                     --  Tag used for dispatching in calls to E

                     Logic_Args      : W_Expr_Array :=
                       Tag_Arg &
                       Get_Args_From_Binders
                       (To_Binder_Array
                          (Logic_Binders, Keep_Const => Local_Only) &
                          To_Binder_Array
                          (Logic_Binders, Keep_Const => Erase),
                        Ref_Allowed => True);
                     --  Arguments of the predicate function for E's
                     --  specific post:
                     --    - the specific tag
                     --    - values of parameters and binders after the call
                     --    - old values of mutable parts of binders

                     First_Old       : constant Natural :=
                       2 + Item_Array_Length
                         (Logic_Binders, Keep_Const => Local_Only);

                  begin
                     --  Insert calls to old on expressions for the old
                     --  values of parameters and global variables.

                     for I in First_Old .. Logic_Args'Last loop
                        Logic_Args (I) := New_Old (Logic_Args (I), EW_Term);
                     end loop;

                     Spec_Post_Call := New_Call
                       (Name   => Spec_Post_Id,
                        Args   => Logic_Args,
                        Typ    => EW_Bool_Type);
                  end;

                  Emit
                    (Dispatch_Th,
                     New_Function_Decl
                       (Domain      => EW_Pred,
                        Name        => Spec_Post_Id,
                        Binders     =>
                          Tag_Binder & Procedure_Logic_Binders (E),
                        Location    => No_Location,
                        Labels      => Symbol_Sets.Empty_Set,
                        Return_Type => EW_Bool_Type));
                  Emit
                    (Dispatch_Th,
                     New_Function_Decl
                       (Domain      => EW_Prog,
                        Name        => Prog_Id,
                        Binders     => Spec_Binders & Func_Why_Binders,
                        Location    => No_Location,
                        Labels      => Symbol_Sets.Empty_Set,
                        Return_Type => EW_Unit_Type,
                        Effects     => Effects,
                        Pre         => Dispatch_Pre,
                        Post        => New_And_Pred
                          (Conjuncts =>
                               (1 => Dispatch_Post,
                                2 => Dynamic_Prop_Effects,
                                3 => Spec_Post_Call))));
               end;
            end if;

            --  For higher order specializations, we do not take into account
            --  refined postcondition if any.

            if Entity_Body_In_SPARK (E)
              and then Has_Contracts (E, Pragma_Refined_Post)
              and then Specialization_Module = No_Symbol
            then
               Emit
                 (Th,
                  New_Namespace_Declaration
                    (Name         => NID (To_String (WNE_Refine_Module)),
                     Declarations =>
                       (1 => New_Function_Decl
                            (Domain      => EW_Prog,
                             Name        => Prog_Id,
                             Binders     => Spec_Binders & Func_Why_Binders,
                             Location    => No_Location,
                             Labels      => Symbol_Sets.Empty_Set,
                             Return_Type => EW_Unit_Type,
                             Effects     => Effects,
                             Pre         => Pre,
                             Post        => +New_And_Expr
                               (Left   => +Refined_Post,
                                Right  => +Dynamic_Prop_Effects,
                                Domain => EW_Pred)))));
            end if;
         end;
      end if;

      --  Generate a check_invariants_on_call program function with the
      --  same parameters as E but with the invariant for E's inputs as a
      --  precondition.

      declare
         Inv_Checks : constant W_Pred_Id :=
           Compute_Type_Invariants_For_Subprogram (E, Params, True);
      begin
         if not Is_True_Boolean (+Inv_Checks) then
            Emit
              (Th,
               New_Function_Decl
                 (Domain      => EW_Prog,
                  Name        =>
                    To_Local (E_Symb (E, WNE_Check_Invariants_On_Call)),
                  Binders     => Spec_Binders & Func_Why_Binders,
                  Location    => No_Location,
                  Labels      => Symbol_Sets.Empty_Set,
                  Return_Type => EW_Unit_Type,
                  Pre         => Inv_Checks,
                  Post        => Inv_Checks));
         end if;
      end;

      --  Generate a check_subprogram_variants function. It has the same
      --  parameters as E as well as previous variant values. Its
      --  precondition checks that E's variants progress.
      --
      --  For a subprogram:
      --
      --    Y : Unsigned_8;
      --    procedure Proc (X : in out Integer) with
      --      Variant => (Decreases => X + 1, Increases => Y - 1);
      --
      --  we generate:
      --
      --    val proc__check_subprogram_variants
      --        (x : int ref) (variant_1 : int) (variant_2 : bv_8) : unit
      --      requires { x + 1 < variant_1 \/
      --                 x + 1 = variant_1 /\ y - 1 > variant_2 }

      if Present (Get_Pragma (E, Pragma_Subprogram_Variant)) then
         declare
            Variant_Check  : constant W_Identifier_Id :=
              (if Specialization_Module = No_Symbol
               then E_Symb (E, WNE_Check_Subprogram_Variants)
               else M_HO_Specializations (E)
                 (Specialization_Module).Variant_Id);
            Variants_Ids   : constant W_Expr_Array := Get_Variants_Ids (E);
            Variants_Exprs : constant W_Expr_Array (Variants_Ids'Range) :=
              Get_Variants_Exprs (E, Domain => EW_Term, Params => Params);
            Binders        : Binder_Array :=
              Binder_Array'(Variants_Ids'Range => <>)
              & Spec_Binders & Func_Why_Binders;
            Variants       : constant Node_Id :=
              Get_Pragma (E, Pragma_Subprogram_Variant);
            Aggr           : constant Node_Id :=
              Expression (First (Pragma_Argument_Associations (Variants)));
            Variant        : Node_Id :=
              Last (Component_Associations (Aggr));
            Checks         : W_Pred_Id := False_Pred;

         begin
            --  Iterate through the list of variants to complete Binders and
            --  generate Checks.

            for Count in reverse Variants_Ids'Range loop
               declare
                  WTyp : constant W_Type_Id :=
                    Get_Typ (W_Identifier_Id'(+Variants_Ids (Count)));
                  Cmp  : constant W_Identifier_Id :=
                    (if Chars (First (Choice_List (Variant))) = Name_Decreases
                     then (if Why_Type_Is_BitVector (WTyp)
                       then MF_BVs (WTyp).Ult
                       else Int_Infix_Lt)
                     else (if Why_Type_Is_BitVector (WTyp)
                       then MF_BVs (WTyp).Ugt
                       else Int_Infix_Gt));
               begin
                  Binders (Count) :=
                    Binder_Type'(B_Ent  => Why_Empty,
                                 B_Name => +Variants_Ids (Count),
                                 others => <>);

                  --  <expression> (</>) variant__i or else
                  --    <expression> = variant__i and then Checks

                  Checks := +New_Or_Else_Expr
                    (Left   => New_Comparison
                       (Symbol => Cmp,
                        Left   => Variants_Exprs (Count),
                        Right  => Variants_Ids (Count),
                        Domain => EW_Pred),
                     Right  => New_And_Then_Expr
                       (Left   => New_Comparison
                            (Symbol => Why_Eq,
                             Left   => Variants_Exprs (Count),
                             Right  => Variants_Ids (Count),
                             Domain => EW_Pred),
                        Right  => +Checks,
                        Domain => EW_Pred),
                     Domain => EW_Pred);
               end;
               Prev (Variant);
            end loop;

            Emit
              (Th,
               New_Function_Decl
                 (Domain      => EW_Prog,
                  Name        => To_Local (Variant_Check),
                  Binders     => Binders,
                  Location    => No_Location,
                  Labels      => Symbol_Sets.Empty_Set,
                  Return_Type => EW_Unit_Type,
                  Pre         => Checks));
         end;
      end if;

      --  Generate a check_termination_condition function. It has the same
      --  parameters as E. Its precondition checks that E's termination
      --  condition evaluates to True.
      --
      --  For a subprogram:
      --
      --    Y : Unsigned_8;
      --    procedure Proc (X : in out Integer) with
      --      Always_Terminates => X = Y;
      --
      --  we generate:
      --
      --    val proc__check_termination_condition (x : int ref) : unit
      --      requires { x = y }

      declare
         Cond : constant Termination_Condition :=
           Get_Termination_Condition (E);
      begin
         if Cond.Kind = Dynamic then

            --  Procedures with a dynamic termination condition cannot be
            --  specialized.

            pragma Assert (Specialization_Module = No_Symbol);

            declare
               P_Name : constant W_Identifier_Id :=
                 E_Symb (E, WNE_Check_Termination_Condition);

            begin
               Emit
                 (Th,
                  New_Function_Decl
                    (Domain      => EW_Prog,
                     Name        => To_Local (P_Name),
                     Binders     => Spec_Binders & Func_Why_Binders,
                     Location    => No_Location,
                     Labels      => Symbol_Sets.Empty_Set,
                     Return_Type => EW_Unit_Type,
                     Pre         => Transform_Pred (Cond.Condition, Params)));
            end;
         end if;
      end;

      Ada_Ent_To_Why.Pop_Scope (Symbol_Table);
   end Generate_Subprogram_Program_Fun;

   --------------------
   -- Get_Logic_Args --
   --------------------

   function Get_Logic_Args
     (E           : Entity_Id;
      Ref_Allowed : Boolean;
      More_Reads  : Flow_Id_Sets.Set := Flow_Id_Sets.Empty_Set)
      return W_Expr_Array
   is
      Effect_Binders : constant Item_Array :=
        Compute_Binders_For_Effects (E, More_Reads => More_Reads);
      Logic_Binders  : constant Binder_Array :=
        To_Binder_Array (Effect_Binders);

   begin
      return Get_Args_From_Binders (Logic_Binders, Ref_Allowed);
   end Get_Logic_Args;

   ----------------------------------
   -- Insert_Bindings_For_Variants --
   ----------------------------------

   function Insert_Bindings_For_Variants
     (E      : Entity_Id;
      Prog   : W_Prog_Id;
      Domain : EW_Domain;
      Params : Transformation_Params) return W_Prog_Id
   is
      Variants_Ids   : constant W_Expr_Array := Get_Variants_Ids (E);
      Variants_Exprs : constant W_Expr_Array (Variants_Ids'Range) :=
        Get_Variants_Exprs (E, Domain, Params);
      W_Ty           : constant W_Type_Id := Get_Type (+Prog);
      T              : W_Prog_Id := Prog;
   begin
      for Count in Variants_Ids'Range loop
         T := New_Binding
           (Name    => +Variants_Ids (Count),
            Def     => +Variants_Exprs (Count),
            Context => T,
            Typ     => W_Ty);
      end loop;
      return T;
   end Insert_Bindings_For_Variants;

   ----------------------
   -- Insert_Exception --
   ----------------------

   procedure Insert_Exception (Exc : W_Name_Id) is
   begin
      Subprogram_Exceptions.Insert (+Exc);
   end Insert_Exception;

   ----------------------
   -- Need_Self_Binder --
   ----------------------

   function Need_Self_Binder (E : Callable_Kind_Id) return Boolean is
     (Is_Subprogram_Or_Entry (E) and then Within_Protected_Type (E));

   ---------------------------------------
   -- Preservation_Of_Access_Parameters --
   ---------------------------------------

   function Preservation_Of_Access_Parameters
     (E      : Entity_Id;
      Params : Transformation_Params) return W_Pred_Id
   is
      Func_Why_Binders : constant Item_Array :=
        Compute_Binders (E, EW_Prog);
      Result           : W_Pred_Id := True_Pred;

   begin
      pragma Assert (Params.Old_Policy = As_Old);

      for I in Func_Why_Binders'Range loop
         if Item_Is_Mutable (Func_Why_Binders (I)) then
            declare
               E : constant Entity_Id :=
                 Get_Ada_Node_From_Item (Func_Why_Binders (I));

            begin

               if Ekind (E) = E_In_Parameter
                 and then Is_Access_Type (Retysp (Etype (E)))
               then

                  declare
                     Expr            : constant W_Term_Id :=
                       +Transform_Identifier
                       (Params => Params,
                        Expr   => E,
                        Ent    => E,
                        Domain => EW_Term);
                     Old_Expr        : constant W_Term_Id :=
                       +New_Old (+Expr, EW_Term);
                     Ty              : constant Type_Kind_Id :=
                       Retysp (Etype (E));
                     Des_Ty          : constant Type_Kind_Id :=
                       Retysp (Directly_Designated_Type (Ty));
                     Preserved_Parts : constant W_Pred_Id :=
                       New_Equality_Of_Preserved_Parts
                         (Ty    => Des_Ty,
                          Expr1 => New_Pointer_Value_Access
                            (E => Ty, Name => Old_Expr),
                          Expr2 => New_Pointer_Value_Access
                            (E => Ty, Name => Expr));

                  begin
                     if not Is_True_Boolean (+Preserved_Parts) then
                        Result := New_And_Pred
                          (Left  => Result,
                           Right => New_Conditional
                             (Condition => New_Not
                                  (Right => Pred_Of_Boolean_Term
                                       (New_Pointer_Is_Null_Access
                                          (Ty, Expr))),
                              Then_Part => Preserved_Parts));
                     end if;
                  end;
               end if;
            end;
         end if;
      end loop;

      return Result;
   end Preservation_Of_Access_Parameters;

   -----------------------------
   -- Procedure_Logic_Binders --
   -----------------------------

   function Procedure_Logic_Binders (E : Entity_Id) return Binder_Array is
      Logic_Binders     : constant Item_Array :=
        Compute_Raw_Binders (E) &
        Compute_Binders_For_Effects (E);
      New_Binders       : Item_Array := Logic_Binders;
      Old_Binders       : Item_Array := Logic_Binders;
   begin
      Localize_Binders (New_Binders);
      Localize_Binders (Old_Binders, "old");
      return To_Binder_Array (New_Binders, Keep_Const => Local_Only) &
        To_Binder_Array (Old_Binders, Keep_Const => Erase);
   end Procedure_Logic_Binders;

   ------------------
   -- Same_Globals --
   ------------------

   function Same_Globals (Subp_1, Subp_2 : Callable_Kind_Id) return Boolean is
      use type Flow_Types.Flow_Id_Sets.Set;

      Subp_1_Read_Ids  : Flow_Types.Flow_Id_Sets.Set;
      Subp_2_Read_Ids  : Flow_Types.Flow_Id_Sets.Set;
      Subp_1_Write_Ids : Flow_Types.Flow_Id_Sets.Set;
      Subp_2_Write_Ids : Flow_Types.Flow_Id_Sets.Set;

   begin
      --  Collect global variables potentially read and written

      Flow_Utility.Get_Proof_Globals (Subprogram      => Subp_1,
                                      Reads           => Subp_1_Read_Ids,
                                      Writes          => Subp_1_Write_Ids,
                                      Erase_Constants => True);

      Flow_Utility.Get_Proof_Globals (Subprogram      => Subp_2,
                                      Reads           => Subp_2_Read_Ids,
                                      Writes          => Subp_2_Write_Ids,
                                      Erase_Constants => True);

      return Subp_1_Read_Ids = Subp_2_Read_Ids
        and then Subp_1_Write_Ids = Subp_2_Write_Ids;
   end Same_Globals;

   ----------------------------------------
   -- Translate_Expression_Function_Body --
   ----------------------------------------

   procedure Translate_Expression_Function_Body (E : E_Function_Id) is
      Expr : constant Node_Id := Expression (Get_Expression_Function (E));

      Logic_Func_Binders : constant Item_Array := Compute_Binders (E, EW_Term);
      Flat_Binders       : constant Binder_Array :=
        To_Binder_Array (Logic_Func_Binders);

      Use_Refined_Post : constant Boolean :=
        Entity_Body_In_SPARK (E)
        and then Has_Contracts (E, Pragma_Refined_Post);

      Logic_Id           : constant W_Identifier_Id :=
        To_Why_Id (E, Domain => EW_Term, Local => False,
                   Selector => (if Use_Refined_Post
                                then Refine
                                else Why.Inter.Standard));
      Pred_Name          : constant Why_Name_Enum :=
        (if Use_Refined_Post
         then WNE_Refined_Func_Guard
         else WNE_Func_Guard);
      Result_Id          : constant W_Identifier_Id :=
         New_Result_Ident (Type_Of_Node (E));
      Pred_Binders       : constant Binder_Array :=
         Binder_Type'(Ada_Node  => Empty,
                      B_Name    => +Result_Id,
                      B_Ent     => Null_Entity_Name,
                      Mutable   => False,
                      Labels    => <>)
           & Flat_Binders;
      Func_Guard         : constant W_Pred_Id :=
        (if not Use_Guard_For_Function (E)
         or else not Proof_Module_Cyclic (E)
         then True_Pred
         else New_Typed_Binding
           (Name     => Result_Id,
            Def      => +New_Call (Domain  => EW_Pred,
                                   Name    => Logic_Id,
                                   Binders => Flat_Binders,
                                   Typ     => EW_Bool_Type),
            Context  => +New_Call (Domain  => EW_Pred,
                                   Name    => E_Symb (E, Pred_Name),
                                   Binders => Pred_Binders,
                                   Typ     => EW_Bool_Type)));

      Params            : Transformation_Params;
      Post_Axiom_Th     : Theory_UC;
      Expr_Fun_Axiom_Th : Theory_UC;
      Program_Th        : Theory_UC;
      Dispatch_Th       : Theory_UC := Empty_Theory;
      Dispatch_Post_Th  : Theory_UC := Empty_Theory;

   begin
      Program_Th :=
        Open_Theory
          (WF_Context, E_Module (E, Program_Function_Decl),
           Comment =>
             "Module giving a program function for the expression function "
           & """" & Get_Name_String (Chars (E)) & """"
           & (if Sloc (E) > 0 then
                " defined at " & Build_Location_String (Sloc (E))
             else "")
           & ", created in " & GNAT.Source_Info.Enclosing_Entity);
      Post_Axiom_Th :=
        Open_Theory
          (WF_Context, E_Module (E, Fun_Post_Axiom),
           Comment =>
             "Module giving a post axiom for the expression function "
           & """" & Get_Name_String (Chars (E)) & """"
           & (if Sloc (E) > 0 then
                " defined at " & Build_Location_String (Sloc (E))
             else "")
           & ", created in " & GNAT.Source_Info.Enclosing_Entity);

      --  If E is a dispatching operation, create a theory for the axioms of
      --  its dispatching version.

      if Is_Dispatching_Operation (E)
        and then not Is_Hidden_Dispatching_Operation (E)
      then
         Dispatch_Th :=
           Open_Theory
             (WF_Context, E_Module (E, Dispatch_Axiom),
              Comment =>
                "Module for declaring a program function and compatibility "
              & "axioms for the dispatching variant of "
              & """" & Get_Name_String (Chars (E)) & """"
              & (if Sloc (E) > 0 then
                   " defined at " & Build_Location_String (Sloc (E))
                else "")
              & ", created in " & GNAT.Source_Info.Enclosing_Entity);
         Dispatch_Post_Th :=
           Open_Theory
             (WF_Context, E_Module (E, Dispatch_Post_Axiom),
              Comment =>
                "Module for declaring a post axiom for the dispatching variant"
              & " of """ & Get_Name_String (Chars (E)) & """"
              & (if Sloc (E) > 0 then
                   " defined at " & Build_Location_String (Sloc (E))
                else "")
              & ", created in " & GNAT.Source_Info.Enclosing_Entity);
      end if;

      --  Store an appropriate value for the result identifier in Result_Name.

      Result_Name := New_Result_Ident (Type_Of_Node (E));
      Result_Is_Mutable := False;

      if Within_Protected_Type (E) then
         Self_Name :=
           Concurrent_Self_Ident (Containing_Protected_Type (E));
         Self_Is_Mutable := False;
      end if;

      Generate_Subprogram_Program_Fun
        (Program_Th, Dispatch_Th, E,
         To_Why_Id (E, Domain => EW_Prog, Local => True));

      Close_Theory (Program_Th,
                    Kind => Definition_Theory);

      Generate_Axiom_For_Post (Post_Axiom_Th, Dispatch_Post_Th, E);

      if Is_Dispatching_Operation (E)
        and then not Is_Hidden_Dispatching_Operation (E)
      then
         Generate_Dispatch_Compatibility_Axioms (Dispatch_Th, E);
      end if;

      Close_Theory (Post_Axiom_Th,
                    Kind           => Axiom_Theory,
                    Defined_Entity => E);

      --  Close the dispatching axiom module if it is not empty and add an
      --  extra dependency to the dispatching definition module.

      if Dispatch_Th /= Empty_Theory then
         Close_Theory (Dispatch_Th,
                       Kind => Definition_Theory);
         Record_Extra_Dependency
           (Defining_Module => E_Module (E, Dispatch),
            Axiom_Module    => Dispatch_Th.Module);

         Close_Theory (Dispatch_Post_Th,
                       Kind => Definition_Theory);
         Record_Extra_Dependency
           (Defining_Module => E_Module (E, Dispatch),
            Axiom_Module    => Dispatch_Post_Th.Module);
      end if;

      --  If the entity's body is not in SPARK, if it is inlined for proof, or
      --  if it is a volatile function or a function with side effects, do not
      --  generate axiom.

      if not Entity_Body_Compatible_With_SPARK (E)
        or else Present (Retrieve_Inline_Annotation (E))
        or else Is_Function_With_Side_Effects (E)
        or else Has_Pragma_Volatile_Function (E)
      then
         Result_Name := Why_Empty;
         Result_Is_Mutable := False;
         return;
      end if;

      Expr_Fun_Axiom_Th :=
        Open_Theory
          (WF_Context, E_Module (E, Expr_Fun_Axiom),
           Comment =>
             "Module giving a defining axiom for the expression function "
           & """" & Get_Name_String (Chars (E)) & """"
           & (if Sloc (E) > 0 then
                " defined at " & Build_Location_String (Sloc (E))
             else "")
           & ", created in " & GNAT.Source_Info.Enclosing_Entity);

      Params := (Logic_Params with delta Gen_Marker => GM_Toplevel);

      Ada_Ent_To_Why.Push_Scope (Symbol_Table);
      Push_Binders_To_Symbol_Table (Logic_Func_Binders);

      --  Given an expression function F with expression E, define an axiom
      --  that states that: "for all <args> => F(<args>) = E".
      --  There is no need to use the precondition here, as the above axiom
      --  is always sound.

      if Is_Standard_Boolean_Type (Etype (E)) then
         Emit
           (Expr_Fun_Axiom_Th,
            New_Defining_Bool_Axiom
              (Ada_Node => E,
               Name     => Logic_Id,
               Binders  => Flat_Binders,
               Dep_Kind => EW_Axdep_Func,
               Def      => Transform_Pred (Expr, Params)));

      else
         declare
            Equ_Ty : constant W_Type_Id := Type_Of_Node (E);
         begin
            Emit
              (Expr_Fun_Axiom_Th,
               New_Defining_Axiom
                 (Ada_Node => E,
                  Name     => Logic_Id,
                  Binders  => Flat_Binders,
                  Def      => +Transform_Expr
                    (Expr,
                     Expected_Type => Equ_Ty,
                     Domain        => EW_Term,
                     Params        => Params)));
         end;
      end if;

      --  If the function is a traversal function add an axiom to assume the
      --  value of its borrowed at end function.

      if Is_Borrowing_Traversal_Function (E) then
         declare
            Guard                : constant W_Pred_Id :=
              +New_And_Then_Expr
              (Left   => +Compute_Guard_Formula
                 (Logic_Func_Binders, Params),
               Right  => +Func_Guard,
               Domain => EW_Pred);
            Params               : constant Binder_Array := Flat_Binders
              & Binder_Type'(B_Name => Get_Brower_At_End (E),
                             B_Ent  => Null_Entity_Name,
                             Labels => Symbol_Sets.Empty_Set,
                             others => <>);
            Borrowed_At_End_Call : constant W_Expr_Id := New_Call
              (Domain  => EW_Term,
               Name    => Get_Borrowed_At_End (E),
               Binders => Params,
               Typ     => Get_Typ (Get_Borrowed_At_End (E)));

            Def                  : W_Term_Id;
            Dummy                : W_Statement_Sequence_Id;
            --  The predicate checks are discarded, they should be checked as
            --  part of the verification of the body of E.

         begin
            Compute_Borrow_At_End_Value
              (Check_Node    => Empty,
               W_Brower      => +Get_Brower_At_End (E),
               Expr          => Expr,
               Reconstructed => Def,
               Checks        => Dummy);
            Emit
              (Expr_Fun_Axiom_Th,
               New_Guarded_Axiom
                 (Ada_Node => E,
                  Name     => NID (Short_Name (E) & "__" & Pledge_Axiom),
                  Binders  => Params,
                  Triggers => New_Triggers
                    (Triggers =>
                         (1 => New_Trigger
                              (Terms => (1 => Borrowed_At_End_Call)))),
                  Pre      => Guard,
                  Def      => +New_Comparison
                    (Symbol => Why_Eq,
                     Left   => Borrowed_At_End_Call,
                     Right  => +Def,
                     Domain => EW_Pred),
                  Dep      => New_Axiom_Dep
                    (Name => Get_Borrowed_At_End (E),
                     Kind => EW_Axdep_Func)));
         end;
      end if;

      Ada_Ent_To_Why.Pop_Scope (Symbol_Table);

      if Within_Protected_Type (E) then
         Self_Name := Why_Empty;
         Self_Is_Mutable := False;
      end if;

      Result_Name := Why_Empty;
      Result_Is_Mutable := False;

      --  If the body of the expression function is hidden by default, do not
      --  record the dependency to the defining module. It will be added on a
      --  case by case bases if the body is made visible.

      Close_Theory (Expr_Fun_Axiom_Th,
                    Kind => Definition_Theory);

      if not Expr_Fun_Hidden_By_Default (E) then
         Record_Extra_Dependency
           (Axiom_Module    => Expr_Fun_Axiom_Th.Module,
            Defining_Module => E_Module (E));
      end if;

      --  The defining axiom has the form f params = expr which is always sound
      --  unless expr depends on f params, which should not be possible if F is
      --  not recursive or if it structurally terminates. We don't protect the
      --  axiom if F does not have a variant either, as in this case a check
      --  message about termination will be emitted.

      if Ekind (E) = E_Function
        and then Is_Recursive (E)
        and then Has_Subprogram_Variant (E)
        and then not Is_Structural_Subprogram_Variant
          (Get_Pragma (E, Pragma_Subprogram_Variant))
      then

         --  Raise a warning about missing definition on recursive calls

         if Debug.Debug_Flag_Underscore_F then
            declare
               Scope               : constant Entity_Id :=
                 Enclosing_Unit (E);
               String_For_Scope    : constant String :=
                 (if Present (Scope)
                  and then Ekind (Scope) in
                      E_Package | E_Function | E_Procedure | E_Entry
                  and then Proof_Module_Cyclic (E, Scope)
                  then " and on calls from enclosing unit"
                  else "");
            begin
               Error_Msg_N
                 ("info: ?"
                  & "expression function body of subprograms with a numeric "
                  & "variant might not be available on recursive calls"
                  & String_For_Scope,
                  E);
            end;
         end if;

         Register_Proof_Cyclic_Function (E);
         Register_Dependency_For_Soundness (E_Module (E, Expr_Fun_Axiom), E);
      end if;
   end Translate_Expression_Function_Body;

   -------------------------------
   -- Translate_Subprogram_Spec --
   -------------------------------

   procedure Translate_Subprogram_Spec (E : Callable_Kind_Id) is
      Th          : Theory_UC;
      Dispatch_Th : Theory_UC := Empty_Theory;
   begin
      Th :=
        Open_Theory
          (WF_Context, E_Module (E),
           Comment =>
             "Module for possibly declaring "
           & "a logic function for "
           & """" & Get_Name_String (Chars (E)) & """"
           & (if Sloc (E) > 0 then
                " defined at " & Build_Location_String (Sloc (E))
             else "")
           & ", created in " & GNAT.Source_Info.Enclosing_Entity);

      --  If E is a dispatching operation, create a theory for its dispatching
      --  version.

      if Is_Dispatching_Operation (E)
        and then not Is_Hidden_Dispatching_Operation (E)
      then
         Dispatch_Th :=
           Open_Theory
             (WF_Context, E_Module (E, Dispatch),
              Comment =>
                "Module for declaring the dispatching variant of the"
              & " subprogram"
              & """" & Get_Name_String (Chars (E)) & """"
              & (if Sloc (E) > 0 then
                   " defined at " & Build_Location_String (Sloc (E))
                else "")
              & ", created in " & GNAT.Source_Info.Enclosing_Entity);
      end if;

      --  No logic function is created for volatile functions and functions
      --  with side effects. The function's effects are modelled by an effect
      --  on the program function.

      if Ekind (E) = E_Function
        and then not Is_Function_With_Side_Effects (E)
        and then not Has_Pragma_Volatile_Function (E)
      then
         declare
            Logic_Module : constant W_Module_Id :=
              E_Module (E, Logic_Function_Decl);
            Logic_Th     : Theory_UC :=
              Open_Theory
                (WF_Context, Logic_Module,
                 Comment =>
                   "Module for initial declaration of the logic function for "
                 & """" & Get_Name_String (Chars (E)) & """"
                 & (if Sloc (E) > 0 then
                      " defined at " & Build_Location_String (Sloc (E))
                   else "")
                 & ", created in " & GNAT.Source_Info.Enclosing_Entity);
         begin
            Declare_Logic_Functions (Logic_Th, Dispatch_Th, E);

            Add_With_Clause (Th, Logic_Module, EW_Export);

            Close_Theory (Logic_Th,
                          Kind           => Definition_Theory,
                          Defined_Entity => E);
         end;
      end if;

      Close_Theory (Th,
                    Kind => Definition_Theory,
                    Defined_Entity => E);

      --  Close the dispatching module if it is not empty

      if Dispatch_Th /= Empty_Theory then
         Close_Theory (Dispatch_Th,
                       Kind => Definition_Theory);
      end if;
   end Translate_Subprogram_Spec;

   -------------------------------------------------
   -- Update_Symbol_Table_For_Inherited_Contracts --
   -------------------------------------------------

   procedure Update_Symbol_Table_For_Inherited_Contracts (E : Callable_Kind_Id)
   is
      procedure Relocate_Symbols (Overridden : Entity_Id);
      --  Relocate parameters and result from Overridden subprogram to E

      ----------------------
      -- Relocate_Symbols --
      ----------------------

      procedure Relocate_Symbols (Overridden : Entity_Id) is
         From_Formal : Entity_Id := First_Formal (Overridden);
         To_Formal   : Entity_Id := First_Formal (E);

      begin
         while Present (From_Formal) loop
            Ada_Ent_To_Why.Insert
              (Symbol_Table,
               From_Formal,
               Ada_Ent_To_Why.Element (Symbol_Table, To_Formal));

            Next_Formal (From_Formal);
            Next_Formal (To_Formal);
         end loop;

         pragma Assert (No (To_Formal));
      end Relocate_Symbols;

      Inherit_Subp  : constant Subprogram_List := Inherited_Subprograms (E);
      Subp_For_Pre  : Entity_Id := Empty;
      Subp_For_Post : Entity_Id := Empty;
      Contracts     : Node_Lists.List;

   --  Start of processing for Update_Symbol_Table_For_Inherited_Contracts

   begin
      --  Find the subprogram from which the precondition is inherited, if any

      for J in Inherit_Subp'Range loop
         Contracts := Find_Contracts
           (Inherit_Subp (J), Pragma_Precondition, Classwide => True);

         if not Contracts.Is_Empty then
            Subp_For_Pre := Inherit_Subp (J);
            exit;
         end if;
      end loop;

      --  Find the subprogram from which the postcondition is inherited, if any

      for J in Inherit_Subp'Range loop
         Contracts := Find_Contracts
           (Inherit_Subp (J), Pragma_Postcondition, Classwide => True);

         if not Contracts.Is_Empty then
            Subp_For_Post := Inherit_Subp (J);
            exit;
         end if;
      end loop;

      if Present (Subp_For_Pre) then
         Relocate_Symbols (Subp_For_Pre);
      end if;

      if Present (Subp_For_Post) and then Subp_For_Pre /= Subp_For_Post then
         Relocate_Symbols (Subp_For_Post);
      end if;
   end Update_Symbol_Table_For_Inherited_Contracts;

   ----------------------------
   -- Wrap_Post_Of_Traversal --
   ----------------------------

   function Wrap_Post_Of_Traversal
     (E      : Entity_Id;
      Post   : W_Pred_Id;
      Args   : W_Expr_Array;
      Params : Transformation_Params) return W_Pred_Id
   is
      Brower_Ty       : constant Entity_Id := Retysp (Etype (E));
      Brower_At_End   : constant W_Identifier_Id :=
        Get_Brower_At_End (E);
      Borrowed_At_End : constant W_Identifier_Id :=
        To_Local (Get_Borrowed_At_End (E));
      Borrowed_Ent    : constant Entity_Id := First_Formal (E);
      Borrowed_Ty     : constant Entity_Id := Retysp (Etype (Borrowed_Ent));
      Borrowed        : constant W_Term_Id := +Transform_Identifier
        (Expr   => Borrowed_Ent,
         Ent    => Borrowed_Ent,
         Domain => EW_Term,
         Params => Params);
      Borrowed_Call   : constant W_Expr_Id :=
        New_Call
          (Domain => EW_Term,
           Name   => Get_Borrowed_At_End (E),
           Args   => Args & (1 => +Brower_At_End),
           Typ    => Get_Typ (Borrowed_At_End));

   begin
      --  Generate:
      --    (forall result_at_end [E.borrowed_at_end args result_at_end].
      --       dyn_inv result_at_end ->
      --       result_at_end.is_null = result.is_null ->
      --         let borrowed_at_end = E.borrowed_at_end args result_at_end in
      --           borrowed_at_end.is_null = borrowed_arg.is_null
      --           /\ post)
      --    /\ borrowed_arg = E.borrowed_at_end args result
      --
      --  The ground call to E.borrowed_at_end is used to allow an instance of
      --  the quantified formula just after the borrow.

      --  No need to assume that the address of the borrower is initialized at
      --  the end of the borrow as traversal functions cannot have relaxed
      --  initialization.

      pragma Assert (not Fun_Has_Relaxed_Init (E));

      return New_And_Pred
        (Left   => New_Universal_Quantif
           (Variables => (1 => Brower_At_End),
            Labels    => Symbol_Sets.Empty_Set,
            Var_Type  => Get_Typ (Brower_At_End),
            Triggers  => New_Triggers
              (Triggers =>
                   (1 => New_Trigger (Terms => (1 => +Borrowed_Call)))),
            Pred      => New_Conditional
              (Condition => New_And_Pred
                   (Left   => Compute_Dynamic_Inv_And_Initialization
                        (Expr   => +Brower_At_End,
                         Ty     => Brower_Ty,
                         Params => Params),
                    Right  => New_Comparison
                      (Symbol => Why_Eq,
                       Left   => New_Pointer_Is_Null_Access
                         (E    => Brower_Ty,
                          Name => +Brower_At_End),
                       Right  => New_Pointer_Is_Null_Access
                         (E    => Brower_Ty,
                          Name => +Result_Name))),
               Then_Part => New_Binding
                 (Name    => Borrowed_At_End,
                  Def     => +Borrowed_Call,
                  Context => New_And_Pred
                    (Left   => New_Comparison
                         (Symbol => Why_Eq,
                          Left   => New_Pointer_Is_Null_Access
                            (Borrowed_Ty, +Borrowed_At_End),
                          Right  => New_Pointer_Is_Null_Access
                            (Borrowed_Ty, Borrowed)),
                     Right  => Post),
                  Typ     => EW_Bool_Type))),
         Right  => New_Comparison
           (Symbol => Why_Eq,
            Left   => New_Call
              (Name => Get_Borrowed_At_End (E),
               Args => Args & (1 => +Result_Name),
               Typ  => Get_Typ (Borrowed_At_End)),
            Right  => Borrowed));
   end Wrap_Post_Of_Traversal;

end Gnat2Why.Subprograms;
