-------------------------------------------------------------------------------
-- (C) Altran Praxis Limited
-------------------------------------------------------------------------------
--
-- The SPARK toolset 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. The SPARK toolset is distributed in the hope that it will be
-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY 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 the SPARK toolset; see file
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
-- the license.
--
--=============================================================================

with Cell_Storage;
with Cells.Utility;
with Cells.Utility.List;
with CStacks;
with CommandLineData;
with ContextManager;
with ContextManager.Ops;
with DAG_IO;
with Debug;
with ErrorHandler;
with E_Strings;
with FileSystem;
with Graph;
with Labels;
with Maths;
with Pairs;
with SP_Symbols;
with StmtStack;
with Structures;
with SystemErrors;

use type SP_Symbols.SP_Symbol;
use type StmtStack.ArcKind;

package body DAG is

   type ArityType is (Unary, Binary);

   --# inherit Cells,
   --#         CStacks,
   --#         Dictionary,
   --#         Statistics;
   package LoopContext is

      type T is limited private;

      procedure Initialize (S : out T);
      --# derives S from ;

      procedure EnterLoop
        (Scope     : in     Dictionary.Scopes;
         S         : in out T;
         VCGHeap   : in out Cells.Heap_Record;
         LoopScope :    out Dictionary.Scopes);
      --# global in     Dictionary.Dict;
      --#        in out Statistics.TableUsage;
      --# derives LoopScope             from Dictionary.Dict,
      --#                                    S,
      --#                                    Scope &
      --#         S,
      --#         VCGHeap               from Dictionary.Dict,
      --#                                    S,
      --#                                    Scope,
      --#                                    VCGHeap &
      --#         Statistics.TableUsage from *,
      --#                                    VCGHeap;

      procedure ExitLoop (S         : in out T;
                          VCGHeap   : in out Cells.Heap_Record;
                          LoopScope : in out Dictionary.Scopes);
      --# global in Dictionary.Dict;
      --# derives LoopScope from *,
      --#                        Dictionary.Dict &
      --#         S,
      --#         VCGHeap   from S,
      --#                        VCGHeap;

      function CurrentLoopSym (S       : T;
                               VCGHeap : Cells.Heap_Record) return Dictionary.Symbol;

      function EnclosingLoopSym
        (S           : T;
         VCGHeap     : Cells.Heap_Record;
         CurrentLoop : Dictionary.Symbol)
        return        Dictionary.Symbol;

      -- Following only applicable to FOR loops ----------------------------------------------
      function CurrentLoopParameterSym (S       : T;
                                        VCGHeap : Cells.Heap_Record) return Dictionary.Symbol;
      --# global in Dictionary.Dict;

      function CurrentLoopMovesInReverse (S       : T;
                                          VCGHeap : Cells.Heap_Record) return Boolean;
      --# global in Dictionary.Dict;

   private
      type T is record
         CurrentLoopNumber : Natural;
         LoopStack         : CStacks.Stack;
      end record;
   end LoopContext;

   --# inherit Cells,
   --#         Cell_Storage,
   --#         CStacks,
   --#         DAG,
   --#         Dictionary,
   --#         SP_Symbols,
   --#         Statistics,
   --#         Structures;
   package Substitutions is

      --  Substitute_Parameters replaces all formal parameters by their
      --  corresponding actual parameter within the Constraint
      --  expression.  If the name is a prefix to an unconstrained array
      --  attribute then the underlying index subtype of the actual name
      --  is substituted.
      --
      --  The "Constraint" expression may be a function precondition or a
      --  function return annotation.
      --
      --  The Called function may be the call of an Ada function from executable
      --  code or it may be the call of an implicitly defined or explicitly defined
      --  proof function applied within a proof context.
      --
      --  If the constraint calls a nested function then the parameters of the
      --  nested function are substituted first, S1,  and then the callers parameters
      --  are substuted within S1.  This applies to all levels of nesting.
      --
      --  The expression referenced by the parameter "Constraint" is
      --  updated in place.
      procedure Substitute_Parameters
        (Called_Function : in     Cells.Cell;
         Constraint      : in out Cells.Cell;
         VCG_Heap        : in out Cells.Heap_Record);
      --# global in     Dictionary.Dict;
      --#        in out Statistics.TableUsage;
      --# derives Constraint,
      --#         Statistics.TableUsage,
      --#         VCG_Heap              from *,
      --#                                    Called_Function,
      --#                                    Constraint,
      --#                                    Dictionary.Dict,
      --#                                    VCG_Heap;

      --  Substitute_Implicit_Vars replaces all occurrences of an
      --  implicit variablle, denoted by "Implicit_Var", by the
      --  corresponding implicitly declared function call within the
      --  return annotation.
      --
      --  The "Impicit_Return_Expr" must be a reference to the predicate
      --  part of an implicit return annotation.
      --
      --  The "Proof_Function" must be a "call" of proof function
      --  (implicitly declared for a concrete function).
      --
      --  The expression referenced by the parameter
      --  "Implicit_Return_Expr" is updated in place.
      --
      --  Note: this subprogram uses the same algorithn as for
      --  Substitute_Parameters but, unfortunately, they cannot be
      --  combined into a single subprogram because Substitute_Parameters
      --  relies upon a concrete view of a function whereas
      --  Substitute_Implicit_Vars requires a proof function view.  The
      --  proof function "call" is substituted for the Implicit_Var.
      procedure Substitute_Implicit_Vars
        (Proof_Function       : in     Cells.Cell;
         Implicit_Var         : in     Dictionary.Symbol;
         Implicit_Return_Expr : in out Cells.Cell;
         VCG_Heap             : in out Cells.Heap_Record);
      --# global in     Dictionary.Dict;
      --#        in out Statistics.TableUsage;
      --# derives Implicit_Return_Expr,
      --#         Statistics.TableUsage,
      --#         VCG_Heap              from *,
      --#                                    Dictionary.Dict,
      --#                                    Implicit_Return_Expr,
      --#                                    Implicit_Var,
      --#                                    Proof_Function,
      --#                                    VCG_Heap;

   end Substitutions;

   --# inherit Cells,
   --#         Cells.Utility,
   --#         Cells.Utility.List,
   --#         Cell_Storage,
   --#         ContextManager,
   --#         CStacks,
   --#         DAG,
   --#         Debug,
   --#         Dictionary,
   --#         E_Strings,
   --#         LexTokenManager,
   --#         SPARK_IO,
   --#         SP_Symbols,
   --#         Statistics,
   --#         Structures,
   --#         SystemErrors;
   package Type_Constraint is

      type Context_T is limited private;

      --  Do NOT call this procedure from the outside. Instead call
      --  procedure Make, declared below...
      procedure Process_Type_Rec
        (The_Type        : in     Dictionary.Symbol;
         The_Expression  : in     Cells.Cell;
         Assoc_Var       : in     Dictionary.Symbol;
         Constraint_List :    out Cells.Utility.List.Linked_List;
         VCG_Heap        : in out Cells.Heap_Record;
         Context         : in out Context_T);
      --# global in out Dictionary.Dict;
      --#        in out LexTokenManager.State;
      --#        in out SPARK_IO.File_Sys;
      --#        in out Statistics.TableUsage;

      --  Do NOT call this procedure from the outside either. Instead
      --  call procedure Make, declared below...
      procedure Process_Type
        (The_Type        : in     Dictionary.Symbol;
         The_Expression  : in     Cells.Cell;
         Assoc_Var       : in     Dictionary.Symbol;
         Constraint_List :    out Cells.Utility.List.Linked_List;
         VCG_Heap        : in out Cells.Heap_Record;
         Context         : in out Context_T);
      --# global in out Dictionary.Dict;
      --#        in out LexTokenManager.State;
      --#        in out SPARK_IO.File_Sys;
      --#        in out Statistics.TableUsage;

      --  Given a discrete type, this produces the DAG for
      --     The_Expression >= The_Type'First /\ The_Expression <= The_Type'Last.
      --  For booelans this always returns true.
      procedure Process_Discrete
        (The_Type       : in     Dictionary.Symbol;
         The_Expression : in     Cells.Cell;
         The_Constraint :    out Cells.Cell;
         VCG_Heap       : in out Cells.Heap_Record);
      --# global in     Dictionary.Dict;
      --#        in out Statistics.TableUsage;
      --# derives Statistics.TableUsage,
      --#         VCG_Heap              from *,
      --#                                    Dictionary.Dict,
      --#                                    The_Expression,
      --#                                    The_Type,
      --#                                    VCG_Heap &
      --#         The_Constraint        from Dictionary.Dict,
      --#                                    The_Expression,
      --#                                    The_Type,
      --#                                    VCG_Heap;

      --  Create in-type constraints for the given expression against
      --  the given type. Scope is imporant here as it affects the
      --  treatment of private and own types: if the type is not
      --  visible at the given scope we simply create a `true'
      --  constraint.
      procedure Make
        (The_Type              : in     Dictionary.Symbol;
         The_Expression        : in     Cells.Cell;
         Scope                 : in     Dictionary.Scopes;
         Consider_Always_Valid : in     Boolean;
         The_Constraint        :    out Cells.Cell;
         VCG_Heap              : in out Cells.Heap_Record;
         VC_Contains_Reals     : in out Boolean;
         VC_Failure            : in out Boolean);
      --# global in out Dictionary.Dict;
      --#        in out LexTokenManager.State;
      --#        in out SPARK_IO.File_Sys;
      --#        in out Statistics.TableUsage;
      --# derives Dictionary.Dict,
      --#         LexTokenManager.State,
      --#         SPARK_IO.File_Sys,
      --#         Statistics.TableUsage,
      --#         VCG_Heap,
      --#         VC_Contains_Reals,
      --#         VC_Failure            from *,
      --#                                    Consider_Always_Valid,
      --#                                    Dictionary.Dict,
      --#                                    LexTokenManager.State,
      --#                                    Scope,
      --#                                    The_Expression,
      --#                                    The_Type,
      --#                                    VCG_Heap &
      --#         The_Constraint        from Consider_Always_Valid,
      --#                                    Dictionary.Dict,
      --#                                    LexTokenManager.State,
      --#                                    Scope,
      --#                                    The_Expression,
      --#                                    The_Type,
      --#                                    VCG_Heap;

   private

      type Context_T is record
         VC_Contains_Reals : Boolean;
         VC_Failure        : Boolean;
         Quant_Id_Number   : Positive;
         Scope             : Dictionary.Scopes;
         Initial_Var       : Dictionary.Symbol;
      end record;
      --# accept W, 394, Context_T, "It is intentional that the outside can",
      --#        "never make one of these.";

   end Type_Constraint;

   package body LoopContext is separate;

   -------------------------------------------------------------------------
   --                    Cell Creation Utilities
   -------------------------------------------------------------------------

   -- Create a cell and set its cell kind at the same time
   procedure CreateCellKind (CellName   :    out Cells.Cell;
                             VCGHeap    : in out Cells.Heap_Record;
                             KindOfCell : in     Cells.Cell_Kind)
   --# global in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    KindOfCell;
   is
      LocalCell : Cells.Cell;
   begin
      Cells.Create_Cell (VCGHeap, LocalCell);
      Cells.Set_Kind (VCGHeap, LocalCell, KindOfCell);
      CellName := LocalCell;
   end CreateCellKind;

   -------------------------------------------------------------------------

   procedure CreateOpCell (CellName :    out Cells.Cell;
                           VCGHeap  : in out Cells.Heap_Record;
                           OpSymbol : in     SP_Symbols.SP_Symbol)
   --# global in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    OpSymbol;
   is
      LocalCell : Cells.Cell;
   begin
      CreateCellKind (LocalCell, VCGHeap, Cell_Storage.Op);
      Cells.Set_Op_Symbol (VCGHeap, LocalCell, OpSymbol);
      CellName := LocalCell;
   end CreateOpCell;

   ---------------------------------------------------------------

   procedure CreateBoolOpCell
     (CellName :    out Cells.Cell;
      VCGHeap  : in out Cells.Heap_Record;
      TypeSym  : in     Dictionary.Symbol;
      OpSymbol : in     SP_Symbols.SP_Symbol)
   --# global in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    OpSymbol,
   --#                                    TypeSym;
   is
      LocalCell : Cells.Cell;
   begin
      CreateCellKind (LocalCell, VCGHeap, Cell_Storage.Bitwise_Op);
      Cells.Set_Symbol_Value (VCGHeap, LocalCell, TypeSym);
      Cells.Set_Op_Symbol (VCGHeap, LocalCell, OpSymbol);

      CellName := LocalCell;
   end CreateBoolOpCell;

   ---------------------------------------------------------------

   procedure CreateModifiedCell (CellName :    out Cells.Cell;
                                 VCGHeap  : in out Cells.Heap_Record;
                                 Sym      : in     Dictionary.Symbol)
   --# global in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    Sym;
   is
      LocalCell : Cells.Cell;
   begin
      CreateCellKind (LocalCell, VCGHeap, Cell_Storage.Modified_Op);
      Cells.Set_Symbol_Value (VCGHeap, LocalCell, Sym);
      CellName := LocalCell;
   end CreateModifiedCell;

   ---------------------------------------------------------------

   procedure CreateReferenceCell (CellName :    out Cells.Cell;
                                  VCGHeap  : in out Cells.Heap_Record;
                                  Sym      : in     Dictionary.Symbol)
   --# global in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    Sym;
   is
      LocalCell : Cells.Cell;
   begin
      CreateCellKind (LocalCell, VCGHeap, Cell_Storage.Reference);
      Cells.Set_Symbol_Value (VCGHeap, LocalCell, Sym);
      CellName := LocalCell;
   end CreateReferenceCell;

   ---------------------------------------------------------------

   procedure CreateUpfCell
     (CellName :    out Cells.Cell;
      VCGHeap  : in out Cells.Heap_Record;
      Sym      : in     Dictionary.Symbol;
      Str      : in     LexTokenManager.Lex_String)
   --# global in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    Str,
   --#                                    Sym;
   is
      LocalCell : Cells.Cell;
   begin
      CreateCellKind (LocalCell, VCGHeap, Cell_Storage.Field_Update_Function);
      Cells.Set_Symbol_Value (VCGHeap, LocalCell, Sym);
      Cells.Set_Lex_Str (VCGHeap, LocalCell, Str);
      CellName := LocalCell;
   end CreateUpfCell;

   ---------------------------------------------------------------------
   -- Simplified names for common operations
   ---------------------------------------------------------------------

   procedure SetRightArgument (OpCell   : in     Cells.Cell;
                               Argument : in     Cells.Cell;
                               VCGHeap  : in out Cells.Heap_Record)
   --# derives VCGHeap from *,
   --#                      Argument,
   --#                      OpCell;
   is
   begin
      Cells.Set_B_Ptr (VCGHeap, OpCell, Argument);
   end SetRightArgument;

   --------------------------------------------------------------

   procedure SetLeftArgument (OpCell   : in     Cells.Cell;
                              Argument : in     Cells.Cell;
                              VCGHeap  : in out Cells.Heap_Record)
   --# derives VCGHeap from *,
   --#                      Argument,
   --#                      OpCell;
   is
   begin
      Cells.Set_A_Ptr (VCGHeap, OpCell, Argument);
   end SetLeftArgument;

   --------------------------------------------------------------

   procedure SetAuxPtr (OpCell   : in     Cells.Cell;
                        Argument : in     Cells.Cell;
                        VCGHeap  : in out Cells.Heap_Record)
   --# derives VCGHeap from *,
   --#                      Argument,
   --#                      OpCell;
   is
   begin
      Cells.Set_C_Ptr (VCGHeap, OpCell, Argument);
   end SetAuxPtr;

   --------------------------------------------------------------

   function Is_Leaf (Node     : in Cells.Cell;
                     VCG_Heap : in Cells.Heap_Record) return Boolean is
   begin
      return Cells.Is_Null_Cell (Cells.Get_B_Ptr (VCG_Heap, Node));
   end Is_Leaf;

   --------------------------------------------------------------

   function RightPtr (VCGHeap : in Cells.Heap_Record;
                      OpCell  : in Cells.Cell) return Cells.Cell is
   begin
      return Cells.Get_B_Ptr (VCGHeap, OpCell);
   end RightPtr;

   --------------------------------------------------------------

   function LeftPtr (VCGHeap : in Cells.Heap_Record;
                     OpCell  : in Cells.Cell) return Cells.Cell is
   begin
      return Cells.Get_A_Ptr (VCGHeap, OpCell);
   end LeftPtr;

   --------------------------------------------------------------

   function AuxPtr (VCGHeap : in Cells.Heap_Record;
                    OpCell  : in Cells.Cell) return Cells.Cell is
   begin
      return Cells.Get_C_Ptr (VCGHeap, OpCell);
   end AuxPtr;

   package body Substitutions is separate;

   --------------------------------------------------------------

   procedure StackCheckStatement
     (Check_Cell : in     Cells.Cell;
      VCGHeap    : in out Cells.Heap_Record;
      CheckStack : in out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives CheckStack            from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    CheckStack,
   --#                                    Check_Cell;
   is
   begin -- StackCheckStatement
      CStacks.Push (VCGHeap, Check_Cell, CheckStack);
   end StackCheckStatement;

   ------------------------------------------------------------------------

   procedure SetTilde (CellName : in     Cells.Cell;
                       VCGHeap  : in out Cells.Heap_Record)
   --# derives VCGHeap from *,
   --#                      CellName;
   is
   begin
      Cells.Set_Op_Symbol (VCGHeap, CellName, SP_Symbols.tilde);
   end SetTilde;

   ---------------------------------------------------------------------
   -- More cell creation utilities
   ---------------------------------------------------------------------

   procedure CreateFixedVarCell
     (CellName  :    out Cells.Cell;
      VCGHeap   : in out Cells.Heap_Record;
      VarSymbol : in     Dictionary.Symbol)
   --# global in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    VarSymbol;
   is
      LocalCell : Cells.Cell;
   begin
      CreateCellKind (LocalCell, VCGHeap, Cell_Storage.Fixed_Var);
      Cells.Set_Symbol_Value (VCGHeap, LocalCell, VarSymbol);
      CellName := LocalCell;
   end CreateFixedVarCell;

   ---------------------------------------------------------------------

   procedure Create_Internal_Natural_Cell (Cell_Name :    out Cells.Cell;
                                           VCG_Heap  : in out Cells.Heap_Record;
                                           N         : in     Natural)
   --# global in out Statistics.TableUsage;
   --# derives Cell_Name             from VCG_Heap &
   --#         Statistics.TableUsage from *,
   --#                                    VCG_Heap &
   --#         VCG_Heap              from *,
   --#                                    N;
   is
   begin
      CreateCellKind (Cell_Name, VCG_Heap, Cell_Storage.Internal_Natural);
      Cells.Set_Natural_Value (VCG_Heap, Cell_Name, N);
   end Create_Internal_Natural_Cell;

   ---------------------------------------------------------------------

   procedure CreateManifestConstCell
     (CellName :    out Cells.Cell;
      VCGHeap  : in out Cells.Heap_Record;
      LexStr   : in     LexTokenManager.Lex_String)
   --# global in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    LexStr;
   is
      LocalCell : Cells.Cell;
   begin
      CreateCellKind (LocalCell, VCGHeap, Cell_Storage.Manifest_Const);
      Cells.Set_Lex_Str (VCGHeap, LocalCell, LexStr);
      CellName := LocalCell;
   end CreateManifestConstCell;

   ---------------------------------------------------------------------

   procedure CreateNamedConstCell
     (CellName :    out Cells.Cell;
      VCGHeap  : in out Cells.Heap_Record;
      ConstVal : in     Dictionary.Symbol)
   --# global in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    ConstVal;
   is
      LocalCell : Cells.Cell;
   begin
      CreateCellKind (LocalCell, VCGHeap, Cell_Storage.Named_Const);
      Cells.Set_Symbol_Value (VCGHeap, LocalCell, ConstVal);
      CellName := LocalCell;
   end CreateNamedConstCell;

   ---------------------------------------------------------------------

   -- PNA new proc to support false VC generation in presence of semantic errs
   procedure CreateFalseCell (VCGHeap  : in out Cells.Heap_Record;
                              CellName :    out Cells.Cell)
   --# global in     Dictionary.Dict;
   --#        in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    Dictionary.Dict;
   is
   begin
      Cells.Utility.Create_Bool (VCGHeap, False, CellName);
   end CreateFalseCell;

   ---------------------------------------------------------------------

   procedure CreateTrueCell (VCGHeap  : in out Cells.Heap_Record;
                             CellName :    out Cells.Cell)
   --# global in     Dictionary.Dict;
   --#        in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    Dictionary.Dict;
   is
   begin
      Cells.Utility.Create_Bool (VCGHeap, True, CellName);
   end CreateTrueCell;

   ---------------------------------------------------------------------

   procedure Imply (Impl    : in     Cells.Cell;
                    VCGHeap : in out Cells.Heap_Record;
                    Expr    : in out Cells.Cell)
   --# global in out Statistics.TableUsage;
   --# derives Expr                  from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    Expr,
   --#                                    Impl;
   is
      ImpCell : Cells.Cell;
   begin
      Cells.Utility.Create_Implies (VCG_Heap    => VCGHeap,
                                    Antecedent  => Impl,
                                    Consequent  => Expr,
                                    Implication => ImpCell);
      Expr := ImpCell;
   end Imply;

   ---------------------------------------------------------------------

   procedure AddAnyShortCircuitImplications
     (VCGHeap           : in out Cells.Heap_Record;
      Expr              : in out Cells.Cell;
      ShortCircuitStack : in out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives Expr,
   --#         ShortCircuitStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    Expr,
   --#                                    ShortCircuitStack,
   --#                                    VCGHeap;
   is
      cp_impl, impl : Cells.Cell;
      TempStack     : CStacks.Stack;
   begin
      if not CStacks.IsEmpty (ShortCircuitStack) then
         CStacks.CreateStack (TempStack);
         while not CStacks.IsEmpty (ShortCircuitStack) loop
            CStacks.PopOff (VCGHeap, ShortCircuitStack, impl);
            Structures.CopyStructure (VCGHeap, impl, cp_impl);
            Imply (cp_impl, VCGHeap, Expr);

            CStacks.Push (VCGHeap, impl, TempStack);
         end loop;

         -- copy all the elements back to the ShortCircuitStack
         while not CStacks.IsEmpty (TempStack) loop
            CStacks.PopOff (VCGHeap, TempStack, impl);
            CStacks.Push (VCGHeap, impl, ShortCircuitStack);
         end loop;
      end if;
   end AddAnyShortCircuitImplications;

   ---------------------------------------------------------------------

   function DiscreteTypeWithCheck (Type_Sym : Dictionary.Symbol;
                                   Scope    : Dictionary.Scopes) return Boolean
   --# global in Dictionary.Dict;
   is

      --  function to deal with optional real rtcs
      function RealTypeAsWell (TypeSym : Dictionary.Symbol) return Boolean
      --# global in Dictionary.Dict;
      is
      begin
         return (Dictionary.IsType (TypeSym) or Dictionary.IsSubtype (TypeSym)) and then Dictionary.TypeIsReal (TypeSym);
      end RealTypeAsWell;

   begin -- DiscreteTypeWithCheck
      return ((Dictionary.IsType (Type_Sym) or Dictionary.IsSubtype (Type_Sym))
              -- guard against unknown types, viz. from multi-dimensional arrays
              and then (not Dictionary.IsPrivateType (Type_Sym, Scope) or else Dictionary.IsPredefinedTimeType (Type_Sym))
                and then not Dictionary.TypeIsBoolean (Type_Sym)
                and then (Dictionary.TypeIsDiscrete (Type_Sym) or else Dictionary.IsPredefinedTimeType (Type_Sym)))
        or else RealTypeAsWell (Type_Sym)
        or else Dictionary.IsParameterConstraint (Type_Sym); -- special "type" for uncon arrays
   end DiscreteTypeWithCheck;

   -------------------------------------------------------------------

   function ArrayTypeWithCheck (Type_Sym : Dictionary.Symbol;
                                Scope    : Dictionary.Scopes) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return ((Dictionary.IsType (Type_Sym) or Dictionary.IsSubtype (Type_Sym))
              and then not Dictionary.IsPrivateType (Type_Sym, Scope)
                and then Dictionary.TypeIsArray (Type_Sym));
   end ArrayTypeWithCheck;

   -------------------------------------------------------------------

   function RecordTypeWithCheck (Type_Sym : Dictionary.Symbol;
                                 Scope    : Dictionary.Scopes) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return ((Dictionary.IsType (Type_Sym) or Dictionary.IsSubtype (Type_Sym))
              and then not Dictionary.IsPrivateType (Type_Sym, Scope)
                and then Dictionary.TypeIsRecord (Type_Sym));
   end RecordTypeWithCheck;

   -------------------------------------------------------------------

   function IsRealType (Type_Sym : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return ((Dictionary.IsType (Type_Sym) or Dictionary.IsSubtype (Type_Sym))
              -- guard against unknown types, viz. from multi-dimensional arrays
              and then Dictionary.TypeIsReal (Type_Sym));
   end IsRealType;

   -------------------------------------------------------------------

   --  Destructively join together a list of cells given in Stack with
   --  /\; if given an empty list return a single true cell.
   procedure Join_And (Stack    : in out CStacks.Stack;
                       Conjunct :    out Cells.Cell;
                       VCG_Heap : in out Cells.Heap_Record)
   --# global in     Dictionary.Dict;
   --#        in out Statistics.TableUsage;
   --# derives Conjunct,
   --#         Stack,
   --#         VCG_Heap              from Dictionary.Dict,
   --#                                    Stack,
   --#                                    VCG_Heap &
   --#         Statistics.TableUsage from *,
   --#                                    Dictionary.Dict,
   --#                                    Stack,
   --#                                    VCG_Heap;
   is
      Tmp : Cells.Cell;
   begin
      if CStacks.IsEmpty (Stack) then
         Cells.Utility.Create_Bool (VCG_Heap, True, Conjunct);
      else
         Conjunct := Cells.Null_Cell;
         while not CStacks.IsEmpty (Stack) loop
            CStacks.PopOff (Heap => VCG_Heap,
                            S    => Stack,
                            C    => Tmp);
            Cells.Utility.Conjoin (VCG_Heap, Tmp, Conjunct);
         end loop;
      end if;
   end Join_And;

   -------------------------------------------------------------------

   package body Type_Constraint is separate;

   -------------------------------------------------------------------

   procedure CreateAttribValueCell
     (CellName  :    out Cells.Cell;
      VCGHeap   : in out Cells.Heap_Record;
      AttribStr : in     LexTokenManager.Lex_String)
   --# global in out Statistics.TableUsage;
   --# derives CellName              from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    AttribStr;
   is
      LocalCell : Cells.Cell;
   begin
      CreateCellKind (LocalCell, VCGHeap, Cell_Storage.Attrib_Value);
      Cells.Set_Lex_Str (VCGHeap, LocalCell, AttribStr);
      CellName := LocalCell;
   end CreateAttribValueCell;

   ---------------------------------------------------------------------

   procedure CreateAttribFunctionCell
     (AttribName     : in     LexTokenManager.Lex_String;
      TypeSym        : in     Dictionary.Symbol;
      VCGHeap        : in out Cells.Heap_Record;
      AttribFuncCell :    out Cells.Cell)
   --# global in out Statistics.TableUsage;
   --# derives AttribFuncCell,
   --#         VCGHeap               from AttribName,
   --#                                    TypeSym,
   --#                                    VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    AttribName,
   --#                                    TypeSym,
   --#                                    VCGHeap;
   is
      TypeCell, TickCell, AttribCell : Cells.Cell;

   begin
      CreateFixedVarCell (TypeCell, VCGHeap, TypeSym);
      CreateCellKind (AttribCell, VCGHeap, Cell_Storage.Attrib_Function);
      Cells.Set_Lex_Str (VCGHeap, AttribCell, AttribName);
      CreateOpCell (TickCell, VCGHeap, SP_Symbols.apostrophe);
      SetLeftArgument (TickCell, TypeCell, VCGHeap);
      SetRightArgument (TickCell, AttribCell, VCGHeap);
      AttribFuncCell := TickCell;
   end CreateAttribFunctionCell;

   ---------------------------------------------------------------------

   procedure CreateAggregateCounter
     (StartPoint : in     Positive;
      VCGHeap    : in out Cells.Heap_Record;
      ExpnStack  : in out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives ExpnStack             from StartPoint,
   --#                                    VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    StartPoint,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    ExpnStack,
   --#                                    StartPoint;
   is
      CounterCell : Cells.Cell;
   begin
      CreateCellKind (CounterCell, VCGHeap, Cell_Storage.Aggregate_Counter);
      Cells.Set_Natural_Value (VCGHeap, CounterCell, StartPoint);
      CStacks.Push (VCGHeap, CounterCell, ExpnStack);
   end CreateAggregateCounter;

   ---------------------------------------------------------------------
   --                    End of Cell Creation Utilities
   ---------------------------------------------------------------------

   -- This function is declared here because it is used by BuildExnDAG and Build_Annotation_Expression
   function IsModularType (Type_Sym : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return ((Dictionary.IsType (Type_Sym) or Dictionary.IsSubtype (Type_Sym))
              -- guard against unknown types, viz. from multi-dimensional arrays
              and then Dictionary.TypeIsModular (Type_Sym));
   end IsModularType;

   ---------------------------------------------------------------------

   function IsIntegerType (Type_Sym : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return ((Dictionary.IsType (Type_Sym) or Dictionary.IsSubtype (Type_Sym))
              -- guard against unknown types, viz. from multi-dimensional arrays
              and then Dictionary.TypeIsInteger (Type_Sym));
   end IsIntegerType;

   ---------------------------------------------------------------------
   function IsScalarType (Type_Sym : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return ((Dictionary.IsType (Type_Sym) or Dictionary.IsSubtype (Type_Sym))
              -- guard against unknown types, viz. from multi-dimensional arrays
              and then Dictionary.TypeIsScalar (Type_Sym));
   end IsScalarType;

   ---------------------------------------------------------------------

   -- This function is declared here because it is used by BuildExnDAG and Build_Annotation_Expression
   function IsModularBitwiseOp (Operator : in SP_Symbols.SP_Symbol;
                                TypeSym  : in Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return IsModularType (TypeSym)
        and then (Operator = SP_Symbols.RWand or else Operator = SP_Symbols.RWor or else Operator = SP_Symbols.RWxor);
   end IsModularBitwiseOp;

   ---------------------------------------------------------------------

   procedure CalculateInsertPoint
     (VCGHeap         : in     Cells.Heap_Record;
      ExpnStack       : in     CStacks.Stack;
      ParameterNumber : in     Natural;
      InsertPoint     :    out Cells.Cell;
      LastOne         :    out Boolean)
   --# derives InsertPoint,
   --#         LastOne     from ExpnStack,
   --#                          ParameterNumber,
   --#                          VCGHeap;
   is
      Ptr : Cells.Cell;
   begin
      LastOne := True;
      Ptr     := CStacks.Top (VCGHeap, ExpnStack);
      for i in Natural range 1 .. ParameterNumber loop
         if Cells.Is_Null_Cell (RightPtr (VCGHeap, Ptr)) then
            LastOne := True;
         else
            LastOne := False;
            Ptr     := RightPtr (VCGHeap, Ptr);
         end if;
      end loop;
      InsertPoint := Ptr;
   end CalculateInsertPoint;

   ----------------------------------------------------------------------------------

   procedure PushOperator
     (Arity          : in     ArityType;
      OperatorSymbol : in     SP_Symbols.SP_Symbol;
      VCGHeap        : in out Cells.Heap_Record;
      ExpnStack      : in out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    Arity,
   --#                                    ExpnStack,
   --#                                    OperatorSymbol,
   --#                                    VCGHeap;
   is
      DAGCell : Cells.Cell;
   begin -- PushOperator
      CreateOpCell (DAGCell, VCGHeap, OperatorSymbol);
      SetRightArgument (DAGCell, CStacks.Top (VCGHeap, ExpnStack), VCGHeap);
      CStacks.Pop (VCGHeap, ExpnStack);
      if Arity = Binary then
         SetLeftArgument (DAGCell, CStacks.Top (VCGHeap, ExpnStack), VCGHeap);
         CStacks.Pop (VCGHeap, ExpnStack);
      end if;
      CStacks.Push (VCGHeap, DAGCell, ExpnStack);
   end PushOperator;

   ---------------------------------------------------------------------

   procedure CreateEmptyList (Size      : in     Natural;
                              VCGHeap   : in out Cells.Heap_Record;
                              ExpnStack : in out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    ExpnStack,
   --#                                    Size,
   --#                                    VCGHeap;
   is
      CommaCell    : Cells.Cell;
      ArgumentList : Cells.Cell;

   begin
      if Size > 1 then
         CreateOpCell (CommaCell, VCGHeap, SP_Symbols.comma);
         CStacks.Push (VCGHeap, CommaCell, ExpnStack);

         for i in Natural range 3 .. Size loop
            CreateOpCell (CommaCell, VCGHeap, SP_Symbols.comma);
            SetRightArgument (CommaCell, CStacks.Top (VCGHeap, ExpnStack), VCGHeap);
            CStacks.Pop (VCGHeap, ExpnStack);
            CStacks.Push (VCGHeap, CommaCell, ExpnStack);
         end loop;
         CStacks.PopOff (VCGHeap, ExpnStack, ArgumentList);
         SetRightArgument (CStacks.Top (VCGHeap, ExpnStack), ArgumentList, VCGHeap);
      end if;
   end CreateEmptyList;

   ---------------------------------------------------------------------

   procedure Chain (NewArcLabel : in     Labels.Label;
                    VCGHeap     : in out Cells.Heap_Record)
   --# global in out Graph.Table;
   --#        in out Statistics.TableUsage;
   --#        in out StmtStack.S;
   --# derives Graph.Table,
   --#         StmtStack.S           from Graph.Table,
   --#                                    StmtStack.S,
   --#                                    VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    Graph.Table,
   --#                                    NewArcLabel,
   --#                                    StmtStack.S;
   is
      R : StmtStack.StmtRecord;
   begin
      R := StmtStack.Top;
      StmtStack.Pop;
      Graph.Inc_Nmbr_Of_Stmts;
      Graph.Create_Coeff (Heap => VCGHeap,
                          I    => R.StmtNmbr,
                          J    => Graph.Get_Nmbr_Of_Stmts,
                          K    => NewArcLabel);
      R.StmtNmbr := Graph.Get_Nmbr_Of_Stmts;
      StmtStack.Push (R);
   end Chain;

   --------------------------------------------------------------------------------

   procedure CreateUnitLabel (StmtLabel :    out Labels.Label;
                              VCGHeap   : in out Cells.Heap_Record)
   --# global in out Statistics.TableUsage;
   --# derives Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    VCGHeap &
   --#         StmtLabel             from VCGHeap;
   is
      LocalLabel   : Labels.Label;
      UnitStmtCell : Cells.Cell;
   begin
      Labels.CreateLabel (VCGHeap, LocalLabel);
      Cells.Create_Cell (VCGHeap, UnitStmtCell);
      Labels.AppendPair (VCGHeap, Pairs.CellToPair (UnitStmtCell), LocalLabel);
      StmtLabel := LocalLabel;
   end CreateUnitLabel;

   ------------------------------------------------------------------------

   procedure ModelNullStmt (VCGHeap : in out Cells.Heap_Record)
   --# global in out Graph.Table;
   --#        in out Statistics.TableUsage;
   --#        in out StmtStack.S;
   --# derives Graph.Table,
   --#         StmtStack.S,
   --#         VCGHeap               from Graph.Table,
   --#                                    StmtStack.S,
   --#                                    VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap;
   is
      StmtLabel : Labels.Label;
   begin
      CreateUnitLabel (StmtLabel, VCGHeap);
      Chain (StmtLabel, VCGHeap);
   end ModelNullStmt;

   -------------------------------------------------------------------------

   procedure PrepareLabel (VCGHeap   : in out Cells.Heap_Record;
                           StmtLabel :    out Labels.Label;
                           StmtCell  :    out Cells.Cell)
   --# global in out Statistics.TableUsage;
   --# derives Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    VCGHeap &
   --#         StmtCell,
   --#         StmtLabel             from VCGHeap;
   is
      LocalLabel : Labels.Label;
      LocalCell  : Cells.Cell;
   begin
      Labels.CreateLabel (VCGHeap, LocalLabel);
      Cells.Create_Cell (VCGHeap, LocalCell);
      Labels.AppendPair (VCGHeap, Pairs.CellToPair (LocalCell), LocalLabel);
      StmtLabel := LocalLabel;
      StmtCell  := LocalCell;
   end PrepareLabel;

   ------------------------------------------------------------------------

   procedure IncorporateAssumption (VCGHeap  : in out Cells.Heap_Record;
                                    DAG_Root : in     Cells.Cell)
   --# global in out Graph.Table;
   --#        in out Statistics.TableUsage;
   --#        in out StmtStack.S;
   --# derives Graph.Table,
   --#         StmtStack.S,
   --#         VCGHeap               from DAG_Root,
   --#                                    Graph.Table,
   --#                                    StmtStack.S,
   --#                                    VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    DAG_Root,
   --#                                    VCGHeap;
   is
      Stmt_Cell  : Cells.Cell;
      Stmt_Label : Labels.Label;
   begin
      PrepareLabel (VCGHeap, Stmt_Label, Stmt_Cell);
      SetRightArgument (Stmt_Cell, DAG_Root, VCGHeap);
      Chain (Stmt_Label, VCGHeap);
   end IncorporateAssumption;

   -------------------------------------------------------------------------

   procedure PlantStackedChecks
     (LineNmbr           : in     Integer;
      VCGHeap            : in out Cells.Heap_Record;
      CheckStack         : in out CStacks.Stack;
      KindOfStackedCheck : in out Graph.Proof_Context_Type)
   --# global in     Dictionary.Dict;
   --#        in out Graph.Table;
   --#        in out Statistics.TableUsage;
   --#        in out StmtStack.S;
   --# derives CheckStack,
   --#         KindOfStackedCheck    from *,
   --#                                    CheckStack,
   --#                                    Dictionary.Dict,
   --#                                    VCGHeap &
   --#         Graph.Table,
   --#         Statistics.TableUsage,
   --#         StmtStack.S,
   --#         VCGHeap               from *,
   --#                                    CheckStack,
   --#                                    Dictionary.Dict,
   --#                                    Graph.Table,
   --#                                    KindOfStackedCheck,
   --#                                    LineNmbr,
   --#                                    StmtStack.S,
   --#                                    VCGHeap;
   is
      CheckList, CpCheckList, StmtCell, CheckCell : Cells.Cell;
      StmtLabel                                   : Labels.Label;

   begin -- PlantStackedChecks
         -- conjoin all the checks on CheckStack
      CheckList := Cells.Null_Cell;
      while not CStacks.IsEmpty (CheckStack) loop
         CStacks.PopOff (VCGHeap, CheckStack, CheckCell);
         Cells.Utility.Conjoin (VCGHeap, CheckCell, CheckList);
      end loop;

      if not Cells.Is_Null_Cell (CheckList) then
         Structures.CopyStructure (VCGHeap, CheckList, CpCheckList);

         -- plant conjoined check statement
         ModelNullStmt (VCGHeap);
         -- distinguish Run_Time_Check from PreConCheck
         Graph.Set_Proof_Context (X => KindOfStackedCheck);
         KindOfStackedCheck := Graph.Run_Time_Check;   -- re-set default value
         Graph.Set_Text_Line_Nmbr (X => LineNmbr);
         Graph.Set_Assertion_Locn (X => CheckList);
         ModelNullStmt (VCGHeap);

         PrepareLabel (VCGHeap, StmtLabel, StmtCell);
         SetRightArgument (StmtCell, CpCheckList, VCGHeap);
         Chain (StmtLabel, VCGHeap);
      end if;
   end PlantStackedChecks;

   --------------------------------------------------------------------------------

   procedure UnStackRtcs
     (LineNmbr           : in     Integer;
      VCGHeap            : in out Cells.Heap_Record;
      CheckStack         : in out CStacks.Stack;
      KindOfStackedCheck : in out Graph.Proof_Context_Type)
   --# global in     Dictionary.Dict;
   --#        in out Graph.Table;
   --#        in out Statistics.TableUsage;
   --#        in out StmtStack.S;
   --# derives CheckStack,
   --#         KindOfStackedCheck    from *,
   --#                                    CheckStack,
   --#                                    Dictionary.Dict,
   --#                                    VCGHeap &
   --#         Graph.Table,
   --#         Statistics.TableUsage,
   --#         StmtStack.S,
   --#         VCGHeap               from *,
   --#                                    CheckStack,
   --#                                    Dictionary.Dict,
   --#                                    Graph.Table,
   --#                                    KindOfStackedCheck,
   --#                                    LineNmbr,
   --#                                    StmtStack.S,
   --#                                    VCGHeap;
   is
   begin
      PlantStackedChecks (LineNmbr, VCGHeap, CheckStack, KindOfStackedCheck);
   end UnStackRtcs;

   ---------------------------------------------------------------------

   procedure PlantCheckStatement
     (Check_Stmt        : in     Cells.Cell;
      VCGHeap           : in out Cells.Heap_Record;
      ShortCircuitStack : in out CStacks.Stack;
      CheckStack        : in out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives CheckStack,
   --#         ShortCircuitStack     from Check_Stmt,
   --#                                    ShortCircuitStack,
   --#                                    VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    Check_Stmt,
   --#                                    ShortCircuitStack,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    CheckStack,
   --#                                    Check_Stmt,
   --#                                    ShortCircuitStack;
   is
      Check_Cell1 : Cells.Cell;
   begin -- PlantCheckStatement
      Check_Cell1 := Check_Stmt;

      -- deal with any encompassing short-circuit forms
      AddAnyShortCircuitImplications (VCGHeap, Check_Cell1, ShortCircuitStack);

      StackCheckStatement (Check_Cell1, VCGHeap, CheckStack);
   end PlantCheckStatement;

   ---------------------------------------------------------------------

   procedure CheckConstraintRunTimeError
     (Type_Sym          : in     Dictionary.Symbol;
      Expr              : in     Cells.Cell;
      Scope             : in     Dictionary.Scopes;
      VCGHeap           : in out Cells.Heap_Record;
      ShortCircuitStack : in out CStacks.Stack;
      CheckStack        : in out CStacks.Stack;
      ContainsReals     : in out Boolean)
   --# global in     Dictionary.Dict;
   --#        in out Statistics.TableUsage;
   --# derives CheckStack,
   --#         ShortCircuitStack,
   --#         Statistics.TableUsage from *,
   --#                                    Dictionary.Dict,
   --#                                    Expr,
   --#                                    Scope,
   --#                                    ShortCircuitStack,
   --#                                    Type_Sym,
   --#                                    VCGHeap &
   --#         ContainsReals         from *,
   --#                                    Dictionary.Dict,
   --#                                    Type_Sym &
   --#         VCGHeap               from *,
   --#                                    CheckStack,
   --#                                    Dictionary.Dict,
   --#                                    Expr,
   --#                                    Scope,
   --#                                    ShortCircuitStack,
   --#                                    Type_Sym;
   is
      Check_Cell : Cells.Cell;
   begin -- CheckConstraintRunTimeError
      if DiscreteTypeWithCheck (Type_Sym, Scope) then
         Type_Constraint.Process_Discrete
           (The_Type       => Type_Sym,
            The_Expression => Expr,
            The_Constraint => Check_Cell,
            VCG_Heap       => VCGHeap);
         PlantCheckStatement (Check_Cell, VCGHeap, ShortCircuitStack, CheckStack);
      end if;
      -- check for reals separated out in support of optional real RTCs
      if IsRealType (Type_Sym) then
         ContainsReals := True;
      end if;
   end CheckConstraintRunTimeError;

   ---------------------------------------------------------------------

   procedure CreateOverflowConstraint
     (Expr     : in     Cells.Cell;
      Type_Sym : in     Dictionary.Symbol;
      VCGHeap  : in out Cells.Heap_Record;
      RangeDAG :    out Cells.Cell)
   --# global in     Dictionary.Dict;
   --#        in out Statistics.TableUsage;
   --# derives RangeDAG,
   --#         VCGHeap               from Dictionary.Dict,
   --#                                    Expr,
   --#                                    Type_Sym,
   --#                                    VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    Dictionary.Dict,
   --#                                    Expr,
   --#                                    Type_Sym,
   --#                                    VCGHeap;
   is
      RelOperationLHS, RelOperationRHS, MiddleOperator : SP_Symbols.SP_Symbol;

      BaseTypeCell     : Cells.Cell;
      Exp_Copy         : Cells.Cell;
      Type_Of_LHS      : Cells.Cell;
      AttribCell       : Cells.Cell;
      LeftSideofRange  : Cells.Cell;
      RightSideofRange : Cells.Cell;
      LeftAnd          : Cells.Cell;
      RightAnd         : Cells.Cell;
      RangeDAG1        : Cells.Cell;

   begin -- CreateOverflowConstraint

      -- make a copy of Expr
      Structures.CopyStructure (VCGHeap, Expr, Exp_Copy);

      RelOperationLHS := SP_Symbols.greater_or_equal;
      RelOperationRHS := SP_Symbols.less_or_equal;
      MiddleOperator  := SP_Symbols.RWand;

      -- if the type is universal integer then build constraint in terms of Min_Int
      -- and Max_Int
      if Dictionary.IsUniversalIntegerType (Type_Sym) then
         -- RootInteger is a special kind of cell used to model Min_Int and Max_Int

         CreateCellKind (LeftSideofRange, VCGHeap, Cell_Storage.Root_Integer);
         Cells.Set_Lex_Str (VCGHeap, LeftSideofRange, LexTokenManager.Min_Token);

         CreateCellKind (RightSideofRange, VCGHeap, Cell_Storage.Root_Integer);
         Cells.Set_Lex_Str (VCGHeap, RightSideofRange, LexTokenManager.Max_Token);

         -- otherwise build constraint in terms of t'base'first and t'base'last
      else
         -- create cell for Type_Sym
         CreateFixedVarCell (Type_Of_LHS, VCGHeap, Dictionary.GetRootType (Type_Sym));

         -- Create BaseTypeCell as apostrophe (Type_Of_LHS, first)
         CreateCellKind (AttribCell, VCGHeap, Cell_Storage.Attrib_Value);
         CreateOpCell (BaseTypeCell, VCGHeap, SP_Symbols.apostrophe);
         SetLeftArgument (BaseTypeCell, Type_Of_LHS, VCGHeap);
         SetRightArgument (BaseTypeCell, AttribCell, VCGHeap);
         Cells.Set_Lex_Str (VCGHeap, RightPtr (VCGHeap, BaseTypeCell), LexTokenManager.Base_Token);

         -- Create LeftSideofRange as apostrophe (BaseTypeCell, first)
         CreateCellKind (AttribCell, VCGHeap, Cell_Storage.Attrib_Value);
         CreateOpCell (LeftSideofRange, VCGHeap, SP_Symbols.apostrophe);
         SetLeftArgument (LeftSideofRange, BaseTypeCell, VCGHeap);
         SetRightArgument (LeftSideofRange, AttribCell, VCGHeap);
         Cells.Set_Lex_Str (VCGHeap, RightPtr (VCGHeap, LeftSideofRange), LexTokenManager.First_Token);

         -- Create RightSideofRange as apostrophe (BaseTypeCell, last)
         Structures.CopyStructure (VCGHeap, LeftSideofRange, RightSideofRange);
         Cells.Set_Lex_Str (VCGHeap, RightPtr (VCGHeap, RightSideofRange), LexTokenManager.Last_Token);

      end if;

      -- now assemble the whole constraint

      -- create left-hand of AND
      CreateOpCell (LeftAnd, VCGHeap, RelOperationLHS);
      SetRightArgument (LeftAnd, LeftSideofRange, VCGHeap);
      SetLeftArgument (LeftAnd, Exp_Copy, VCGHeap);

      -- create right-hand of AND
      CreateOpCell (RightAnd, VCGHeap, RelOperationRHS);
      SetRightArgument (RightAnd, RightSideofRange, VCGHeap);
      SetLeftArgument (RightAnd, Exp_Copy, VCGHeap);

      -- form conjunction of the two constraints;
      CreateOpCell (RangeDAG1, VCGHeap, MiddleOperator);
      SetRightArgument (RangeDAG1, RightAnd, VCGHeap);
      SetLeftArgument (RangeDAG1, LeftAnd, VCGHeap);
      RangeDAG := RangeDAG1;
   end CreateOverflowConstraint;

   --------------------------------------------------------------------------------

   procedure CheckOverflowRunTimeError
     (Type_Sym          : in     Dictionary.Symbol;
      Expr              : in     Cells.Cell;
      Scope             : in     Dictionary.Scopes;
      VCGHeap           : in out Cells.Heap_Record;
      ShortCircuitStack : in out CStacks.Stack;
      ContainsReals     : in out Boolean;
      CheckStack        : in out CStacks.Stack)
   --# global in     Dictionary.Dict;
   --#        in out Statistics.TableUsage;
   --# derives CheckStack,
   --#         ShortCircuitStack,
   --#         Statistics.TableUsage from *,
   --#                                    Dictionary.Dict,
   --#                                    Expr,
   --#                                    Scope,
   --#                                    ShortCircuitStack,
   --#                                    Type_Sym,
   --#                                    VCGHeap &
   --#         ContainsReals         from *,
   --#                                    Dictionary.Dict,
   --#                                    Type_Sym &
   --#         VCGHeap               from *,
   --#                                    CheckStack,
   --#                                    Dictionary.Dict,
   --#                                    Expr,
   --#                                    Scope,
   --#                                    ShortCircuitStack,
   --#                                    Type_Sym;
   is
      Check_Cell : Cells.Cell;

   begin -- CheckOverflowRunTimeError
      if DiscreteTypeWithCheck (Type_Sym, Scope) and then not IsModularType (Type_Sym) then -- no overflows for modulars
         CreateOverflowConstraint (Expr, Type_Sym, VCGHeap, Check_Cell);
         PlantCheckStatement (Check_Cell, VCGHeap, ShortCircuitStack, CheckStack);
      end if;
      -- check for reals separated out in support of optional real RTCs
      if IsRealType (Type_Sym) then
         ContainsReals := True;
      end if;
   end CheckOverflowRunTimeError;

   --------------------------------------------------------------------------------

   -- Given an expression representing f convert it to fld_inherit (f)
   procedure InsertInheritDeReference
     (FieldSymbol : in     Dictionary.Symbol;
      VCGHeap     : in out Cells.Heap_Record;
      Expression  : in out Cells.Cell)
   --# global in out Statistics.TableUsage;
   --# derives Expression            from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    Expression,
   --#                                    FieldSymbol;
   is
      DAGCell : Cells.Cell;

   begin -- InsertInheritDeReference
      CreateCellKind (DAGCell, VCGHeap, Cell_Storage.Field_Access_Function);
      Cells.Set_Symbol_Value (VCGHeap, DAGCell, FieldSymbol);
      Cells.Set_Lex_Str (VCGHeap, DAGCell, LexTokenManager.Inherit_Token);
      SetRightArgument (DAGCell, Expression, VCGHeap);
      Expression := DAGCell;
   end InsertInheritDeReference;

   ---------------------------------------------------------------------

   -- Used in ModelProcedureCall, BuildExpnDAG, Build_Annotation_Expression
   procedure ConvertTaggedActualIfNecessary
     (SubprogSym : in     Dictionary.Symbol;
      VCGHeap    : in out Cells.Heap_Record;
      Expression : in out Cells.Cell)
   --# global in     Dictionary.Dict;
   --#        in out Statistics.TableUsage;
   --# derives Expression,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    Dictionary.Dict,
   --#                                    Expression,
   --#                                    SubprogSym,
   --#                                    VCGHeap;
   is

      function ExpressionType (VCGHeap    : Cells.Heap_Record;
                               Expression : Cells.Cell) return Dictionary.Symbol
      --# global in Dictionary.Dict;
      is
         Result : Dictionary.Symbol;
      begin
         case Cells.Get_Kind (VCGHeap, Expression) is
            when Cell_Storage.Reference | Cell_Storage.Named_Const | Cell_Storage.Field_Access_Function =>
               Result := Dictionary.GetType (Cells.Get_Symbol_Value (VCGHeap, Expression));
            when Cell_Storage.Element_Function =>
               Result := Cells.Get_Symbol_Value (VCGHeap, Expression);
            when others =>
               Result := Dictionary.NullSymbol; -- consider fatal error trap here
         end case;
         return Result;
      end ExpressionType;

      ------------------

      procedure ConvertTaggedActual
        (ActualType      : in     Dictionary.Symbol;
         ControllingType : in     Dictionary.Symbol;
         VCGHeap         : in out Cells.Heap_Record;
         Expression      : in out Cells.Cell)
      --# global in     Dictionary.Dict;
      --#        in out Statistics.TableUsage;
      --# derives Expression,
      --#         Statistics.TableUsage,
      --#         VCGHeap               from *,
      --#                                    ActualType,
      --#                                    ControllingType,
      --#                                    Dictionary.Dict,
      --#                                    Expression,
      --#                                    VCGHeap;
      is
         ActualTypeLocal : Dictionary.Symbol;

      begin
         -- We know in this case that Expression represents the
         -- name of an object so all we need to do is add fld_inherit dereferences in
         -- front of it until the type conversion is complete.
         ActualTypeLocal := ActualType;

         -- ControllingType=NullSym means that the called subprogram doesn't have a controlling
         -- type and so we should just leave expression alone.  Could be considered a special
         -- case of "not Dictionary.IsAnExtensionOf" below (can't be an extension of null).
         if not Dictionary.Is_Null_Symbol (ControllingType) then
            loop
               -- Actual type is null if nothing planted in wf_proc_call
               exit when Dictionary.Is_Null_Symbol (ActualTypeLocal);

               -- Do nothing if we call this with anything other than a tagged type
               exit when not Dictionary.TypeIsTagged (ActualTypeLocal);

               -- Do nothing if type is tagged but is unrelated to controlling type
               exit when not Dictionary.IsAnExtensionOf (ControllingType, ActualTypeLocal);

               exit when Dictionary.Types_Are_Equal
                 (Left_Symbol        => ActualTypeLocal,
                  Right_Symbol       => ControllingType,
                  Full_Range_Subtype => False); -- normal exit, conversion complete

               InsertInheritDeReference
                 (Dictionary.CurrentSymbol (Dictionary.FirstRecordComponent (ActualTypeLocal)),
                  VCGHeap,
                  Expression);
               ActualTypeLocal := Dictionary.GetRootOfExtendedType (ActualTypeLocal);
            end loop;
         end if;
      end ConvertTaggedActual;

      ------------------

   begin -- ConvertTaggedActualIfNecessary
      if Cells.Get_Kind (VCGHeap, Expression) = Cell_Storage.Reference
        or else Cells.Get_Kind (VCGHeap, Expression) = Cell_Storage.Named_Const
        or else Cells.Get_Kind (VCGHeap, Expression) = Cell_Storage.Field_Access_Function
        or else Cells.Get_Kind (VCGHeap, Expression) = Cell_Storage.Element_Function then
         -- it's an object, and may need converting
         ConvertTaggedActual
           (ExpressionType (VCGHeap, Expression), -- type of actual
            Dictionary.GetSubprogramControllingType (SubprogSym), -- type of formal
            VCGHeap,
            Expression); -- actual parameter
      end if;
   end ConvertTaggedActualIfNecessary;

   --------------------------------------------------------------

   -- When we encounter R.F we may need to convert it to R.{Inherit.}F if F is
   -- is a field inherited from a root type that we have extended.
   -- FieldExpn is a DAG representing "F".
   -- This procedure used by both BuildExpnDAg and Build_Annotation_Expression
   procedure ModelInheritedFieldsOfTaggedRecord
     (FieldName  : in     LexTokenManager.Lex_String;
      RecordType : in     Dictionary.Symbol;
      VCGHeap    : in out Cells.Heap_Record;
      FieldExpn  : in out Cells.Cell)
   --# global in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in out Statistics.TableUsage;
   --# derives FieldExpn,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    Dictionary.Dict,
   --#                                    FieldExpn,
   --#                                    FieldName,
   --#                                    LexTokenManager.State,
   --#                                    RecordType,
   --#                                    VCGHeap;
   is
      FieldSymbol    : Dictionary.Symbol;
      RootRecordType : Dictionary.Symbol;

      function InheritedField (OfField : Dictionary.Symbol) return Dictionary.Symbol
      --# global in Dictionary.Dict;
      is
         Result : Dictionary.Symbol;
      begin
         if Dictionary.IsRecordComponent (OfField) then
            Result := Dictionary.CurrentSymbol (Dictionary.FirstRecordComponent (Dictionary.GetType (OfField)));
         else -- we have a record type
            Result := Dictionary.CurrentSymbol (Dictionary.FirstRecordComponent (OfField));
         end if;
         return Result;
      end InheritedField;

   begin -- ModelInheritedFieldsOfTaggedRecord
      RootRecordType := Dictionary.GetRootType (RecordType);
      FieldSymbol    := RootRecordType;
      -- loop executes 0 times if there is no tagged inheritance involved; this leaves
      -- FieldExpn unchanged
      for I in Integer range 1 .. Dictionary.GetInheritDepth (FieldName, RootRecordType) loop
         -- The model of tagged records used meams that the Inherit field is always the first
         -- field so we can get its symbol as follows
         FieldSymbol := InheritedField (FieldSymbol);
         -- for each level of inherit depth, we insert one inherit dereference
         InsertInheritDeReference (FieldSymbol, VCGHeap, FieldExpn);
      end loop;
   end ModelInheritedFieldsOfTaggedRecord;

   ---------------------------------------------------------------

   procedure InsertParameterInNextFreeSlot
     (StartPoint     : in     Cells.Cell;
      ExpressionCell : in     Cells.Cell;
      VCGHeap        : in out Cells.Heap_Record)
   --# derives VCGHeap from *,
   --#                      ExpressionCell,
   --#                      StartPoint;
   is
      InsertPoint : Cells.Cell;
   begin
      InsertPoint := StartPoint;

      loop
         if Cells.Is_Null_Cell (RightPtr (VCGHeap, InsertPoint)) then
            SetRightArgument (InsertPoint, ExpressionCell, VCGHeap);
            exit;
         end if;

         InsertPoint := RightPtr (VCGHeap, InsertPoint);
         if Cells.Is_Null_Cell (LeftPtr (VCGHeap, InsertPoint)) then
            SetLeftArgument (InsertPoint, ExpressionCell, VCGHeap);
            exit;
         end if;

      end loop;

   end InsertParameterInNextFreeSlot;

   --------------------------------------------------------------------------------

   procedure PushFunction (Kind      : in     Cells.Cell_Kind;
                           VCGHeap   : in out Cells.Heap_Record;
                           ExpnStack : in out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    ExpnStack,
   --#                                    Kind,
   --#                                    VCGHeap;
   is
      DAGCell : Cells.Cell;
   begin
      CreateCellKind (DAGCell, VCGHeap, Kind);
      SetRightArgument (DAGCell, CStacks.Top (VCGHeap, ExpnStack), VCGHeap);
      CStacks.Pop (VCGHeap, ExpnStack);
      CStacks.Push (VCGHeap, DAGCell, ExpnStack);
   end PushFunction;

   -----------------------------------------------------------------------

   procedure TransformRangeConstraint (VCGHeap   : in out Cells.Heap_Record;
                                       ExpnStack : in out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    ExpnStack,
   --#                                    VCGHeap;
   is
      LeftSideOfRange, RightSideOfRange : Cells.Cell;

   begin
      --turns 'RANGE into 'FIRST .. 'LAST or pushes .. for discrete range
      if Cells.Get_Op_Symbol (VCGHeap, CStacks.Top (VCGHeap, ExpnStack)) = SP_Symbols.apostrophe then
         CStacks.PopOff (VCGHeap, ExpnStack, LeftSideOfRange);
         Structures.CopyStructure (VCGHeap, LeftSideOfRange, RightSideOfRange);
         Cells.Set_Lex_Str (VCGHeap, RightPtr (VCGHeap, LeftSideOfRange), LexTokenManager.First_Token);
         Cells.Set_Lex_Str (VCGHeap, RightPtr (VCGHeap, RightSideOfRange), LexTokenManager.Last_Token);
         CStacks.Push (VCGHeap, LeftSideOfRange, ExpnStack);
         CStacks.Push (VCGHeap, RightSideOfRange, ExpnStack);
      end if;
      PushOperator (Binary, SP_Symbols.double_dot, VCGHeap, ExpnStack);
   end TransformRangeConstraint;

   ---------------------------------------------------------------------

   procedure TransformTypeName (VCGHeap   : in out Cells.Heap_Record;
                                ExpnStack : in out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    ExpnStack,
   --#                                    VCGHeap;
   is
      AttribCell, TypeMarkcell, LeftSideOfRange, RightSideOfRange : Cells.Cell;

   begin
      --turns TYPE into TYPE'FIRST  ..  TYPE'LAST
      CStacks.PopOff (VCGHeap, ExpnStack, TypeMarkcell);
      CreateCellKind (AttribCell, VCGHeap, Cell_Storage.Attrib_Value);
      CreateOpCell (LeftSideOfRange, VCGHeap, SP_Symbols.apostrophe);
      SetLeftArgument (LeftSideOfRange, TypeMarkcell, VCGHeap);
      SetRightArgument (LeftSideOfRange, AttribCell, VCGHeap);
      Structures.CopyStructure (VCGHeap, LeftSideOfRange, RightSideOfRange);
      Cells.Set_Lex_Str (VCGHeap, RightPtr (VCGHeap, LeftSideOfRange), LexTokenManager.First_Token);
      Cells.Set_Lex_Str (VCGHeap, RightPtr (VCGHeap, RightSideOfRange), LexTokenManager.Last_Token);
      CStacks.Push (VCGHeap, LeftSideOfRange, ExpnStack);
      CStacks.Push (VCGHeap, RightSideOfRange, ExpnStack);
      PushOperator (Binary, SP_Symbols.double_dot, VCGHeap, ExpnStack);
   end TransformTypeName;

   -----------------------------------------------------------------------

   function DoingArrayAggregate (VCGHeap   : Cells.Heap_Record;
                                 ExpnStack : CStacks.Stack) return Boolean
   --# global in Dictionary.Dict;
   is
      AggCell : Cells.Cell;
   begin
      AggCell := CStacks.FindAggregateCell (VCGHeap, ExpnStack);
      return Dictionary.TypeIsArray (Cells.Get_Symbol_Value (VCGHeap, AggCell));
   end DoingArrayAggregate;

   ---------------------------------------------------------------------

   function DoingRecordAggregate (VCGHeap   : Cells.Heap_Record;
                                  ExpnStack : CStacks.Stack) return Boolean
   --# global in Dictionary.Dict;
   is
      AggCell : Cells.Cell;
   begin
      AggCell := CStacks.FindAggregateCell (VCGHeap, ExpnStack);
      return Dictionary.TypeIsRecord (Cells.Get_Symbol_Value (VCGHeap, AggCell));
   end DoingRecordAggregate;

   ---------------------------------------------------------------------

   -- Used with record aggregates.  These are created in DownProcessAggregate
   -- with an empty comma-delimited list into which associations are placed.
   -- If we have a model of tagged extended record, the routine first identifies
   -- which constituent record part of the overall model should have the
   -- association
   procedure InsertAssociation (StartPoint     : in     Cells.Cell;
                                ExpressionCell : in     Cells.Cell;
                                VCGHeap        : in out Cells.Heap_Record)
   --# global in Dictionary.Dict;
   --# derives VCGHeap from *,
   --#                      Dictionary.Dict,
   --#                      ExpressionCell,
   --#                      StartPoint;
   is
      InsertPoint      : Cells.Cell;
      SoughtRecordType : Dictionary.Symbol;
   begin
      -- expression cell has the form FIELD := EXPRESSION
      SoughtRecordType := Dictionary.GetRecordType (Cells.Get_Symbol_Value (VCGHeap, LeftPtr (VCGHeap, ExpressionCell)));
      InsertPoint      := StartPoint;  -- left-most MkAggregate in the model
      loop
         exit when Dictionary.Types_Are_Equal
           (Left_Symbol        => Cells.Get_Symbol_Value (VCGHeap, InsertPoint),
            Right_Symbol       => SoughtRecordType,
            Full_Range_Subtype => False);

         -- move to first parameter slot - this is either a comma or a MkAggregate cell
         InsertPoint := RightPtr (VCGHeap, InsertPoint);
         if Cells.Get_Op_Symbol (VCGHeap, InsertPoint) = SP_Symbols.comma then
            InsertPoint := RightPtr (VCGHeap, LeftPtr (VCGHeap, InsertPoint));
         end if;
      end loop;
      -- InsertPoint now points at the correct MkAggregate cell
      -- So insert expression
      InsertParameterInNextFreeSlot (InsertPoint, ExpressionCell, VCGHeap);
   end InsertAssociation;

   ---------------------------------------------------------------------

   function AggregateType (VCGHeap   : Cells.Heap_Record;
                           ExpnStack : CStacks.Stack) return Dictionary.Symbol is
   begin
      return Cells.Get_Symbol_Value (VCGHeap, CStacks.FindAggregateCell (VCGHeap, ExpnStack));
   end AggregateType;

   ---------------------------------------------------------------------

   function CurrentFieldOrIndex (VCGHeap   : Cells.Heap_Record;
                                 ExpnStack : CStacks.Stack) return Positive is
   begin
      return Cells.Get_Natural_Value (VCGHeap, CStacks.FindAggregateCounter (VCGHeap, ExpnStack));
   end CurrentFieldOrIndex;

   ---------------------------------------------------------------------

   procedure IncCurrentFieldOrIndex (ExpnStack : in     CStacks.Stack;
                                     VCGHeap   : in out Cells.Heap_Record)
   --# derives VCGHeap from *,
   --#                      ExpnStack;
   is
      AggCell : Cells.Cell;
   begin
      AggCell := CStacks.FindAggregateCounter (VCGHeap, ExpnStack);
      Cells.Set_Natural_Value (VCGHeap, AggCell, Cells.Get_Natural_Value (VCGHeap, AggCell) + 1);
   end IncCurrentFieldOrIndex;

   ---------------------------------------------------------------------

   -- Push binary operator on to top of stack but reversing arguments
   -- so we end up with:  "TOS Op 2ndTOS"
   procedure SwitchAndPush
     (OperatorSymbol : in     SP_Symbols.SP_Symbol;
      VCGHeap        : in out Cells.Heap_Record;
      ExpnStack      : in out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    ExpnStack,
   --#                                    OperatorSymbol,
   --#                                    VCGHeap;
   is
      -- pushes binary operator,reversing order of operands;
      DAGCell : Cells.Cell;
   begin
      CreateOpCell (DAGCell, VCGHeap, OperatorSymbol);
      -- Cells.Set_A_Ptr (VCGHeap , DAGCell, CStacks.Top (VCGHeap , ExpnStack));
      SetLeftArgument (DAGCell, CStacks.Top (VCGHeap, ExpnStack), VCGHeap);
      CStacks.Pop (VCGHeap, ExpnStack);
      -- Cells.Set_B_Ptr (VCGHeap , DAGCell, CStacks.Top (VCGHeap , ExpnStack));
      SetRightArgument (DAGCell, CStacks.Top (VCGHeap, ExpnStack), VCGHeap);
      CStacks.Pop (VCGHeap, ExpnStack);
      CStacks.Push (VCGHeap, DAGCell, ExpnStack);
   end SwitchAndPush;

   ---------------------------------------------------------------------

   function GetTOStype (VCGHeap   : Cells.Heap_Record;
                        ExpnStack : CStacks.Stack) return Dictionary.Symbol
   --# global in Dictionary.Dict;
   is
      Sym : Dictionary.Symbol;

   begin
      -- this function is used in various places where a decision on
      -- what to do next depends on the symbol on TOS.

      Sym := Cells.Get_Symbol_Value (VCGHeap, CStacks.Top (VCGHeap, ExpnStack));
      if Cells.Get_Kind (VCGHeap, CStacks.Top (VCGHeap, ExpnStack)) = Cell_Storage.Field_Update_Function then
         -- we have a record field but want record type
         Sym := Dictionary.GetRecordType (Sym);
      elsif Dictionary.IsPackage (Sym) then
         null; -- packages returned intact
      elsif Dictionary.IsTypeMark (Sym) then
         null; -- types returned intact
      else
         Sym := Dictionary.GetType (Sym);  -- return type of thing on TOS
      end if;
      return Sym;
   end GetTOStype;

   ---------------------------------------------------------------------

   -- This procedure adds "mod T'Modulus" to an expression if T is modular
   procedure ModularizeIfNeeded
     (TypeSym   : in     Dictionary.Symbol;
      VCGHeap   : in out Cells.Heap_Record;
      ExpnStack : in out CStacks.Stack)
   --# global in     Dictionary.Dict;
   --#        in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    Dictionary.Dict,
   --#                                    ExpnStack,
   --#                                    TypeSym,
   --#                                    VCGHeap;
   is
      ModOpCell, TickCell, PrefixCell, ModulusCell : Cells.Cell;

      -- Check to avoid getting "mod N mod N" in output
      -- Suspect this is actually redundant but it a cheap safeguard
      function AlreadyModularized (VCGHeap : Cells.Heap_Record) return Boolean
      --# global in Dictionary.Dict;
      --#        in ExpnStack;
      --#        in TypeSym;
      is
      begin
         return Cells.Get_Kind (VCGHeap, CStacks.Top (VCGHeap, ExpnStack)) = Cell_Storage.Op
           and then Cells.Get_Op_Symbol (VCGHeap, CStacks.Top (VCGHeap, ExpnStack)) = SP_Symbols.RWmod
           and then Dictionary.Types_Are_Equal
           (Left_Symbol        => Cells.Get_Symbol_Value (VCGHeap, CStacks.Top (VCGHeap, ExpnStack)),
            Right_Symbol       => TypeSym,
            Full_Range_Subtype => False);
         -- final conjunction makes use of type symbol placed in the Val field
         -- of the cell as described in ModularizeIfNeeded main body
      end AlreadyModularized;

   begin -- ModularizeIfNeeded
      if IsModularType (TypeSym) then
         if not AlreadyModularized (VCGHeap) then
            -- create ' operator
            CreateOpCell (TickCell, VCGHeap, SP_Symbols.apostrophe);
            -- create Modulus attribute name
            CreateCellKind (ModulusCell, VCGHeap, Cell_Storage.Attrib_Value);
            Cells.Set_Lex_Str (VCGHeap, ModulusCell, LexTokenManager.Modulus_Token);
            -- Create prefix
            CreateFixedVarCell (PrefixCell, VCGHeap, TypeSym);
            -- Assemble t'modulus
            SetLeftArgument (TickCell, PrefixCell, VCGHeap);
            SetRightArgument (TickCell, ModulusCell, VCGHeap);

            -- create mod operator
            CreateOpCell (ModOpCell, VCGHeap, SP_Symbols.RWmod);
            -- insert type in the val field of the cell to simplify checking for
            -- unnecessary duplicate MODs.  For an operator cell the val field is
            -- not usually used
            Cells.Set_Symbol_Value (VCGHeap, ModOpCell, TypeSym);

            -- append mod t'modulus to expression on TOS
            SetRightArgument (ModOpCell, TickCell, VCGHeap);
            SetLeftArgument (ModOpCell, CStacks.Top (VCGHeap, ExpnStack), VCGHeap);
            CStacks.Pop (VCGHeap, ExpnStack);
            CStacks.Push (VCGHeap, ModOpCell, ExpnStack);
         end if;
         -- no action if identical mod already there
      end if;
      -- falls through with no action if a valid type is supplied but the type is not modular
   end ModularizeIfNeeded;

   ---------------------------------------------------------------------

   -- Node is in out so that we can prune walk if embedded agg found.
   procedure DownProcessAggregate
     (QualExpNode : in     SP_Symbols.SP_Symbol;
      VCGHeap     : in out Cells.Heap_Record;
      Node        : in out STree.SyntaxNode;
      ExpnStack   : in out CStacks.Stack)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in     STree.Table;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --#        in out Statistics.TableUsage;
   --# derives ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         QualExpNode,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table &
   --#         ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap                    from *,
   --#                                         Dictionary.Dict,
   --#                                         ExpnStack,
   --#                                         Node,
   --#                                         QualExpNode,
   --#                                         STree.Table,
   --#                                         VCGHeap &
   --#         Node                       from *,
   --#                                         QualExpNode,
   --#                                         STree.Table;
   is

      DAGCell                       : Cells.Cell;
      AggTemp                       : Cells.Cell;
      AggType                       : Dictionary.Symbol;
      InsertPointForInheritedFields : Cells.Cell;
      -- following three cells are used to create a model of inherited tagged records
      InheritedFieldsModel : Cells.Cell;
      InheritField         : Cells.Cell;
      MkAggregateCell      : Cells.Cell;
      InheritSym           : Dictionary.Symbol;

      function NumberOfListElementsNeeded (RecordSym : Dictionary.Symbol) return Natural
      --# global in Dictionary.Dict;
      is
         NumberOfFields : Natural;
      begin
         NumberOfFields := Dictionary.GetNumberOfNonExtendedComponents (RecordSym);
         -- If the root type is a null record then we ignore it since it won't have
         -- any aggregate choice expressions to associate with it.  In this case we need
         -- one fewer fields slots in the empty list of the immediately preceding record
         -- in the model.
         if Dictionary.TypeIsExtendedTagged (RecordSym) and then Dictionary.NoFieldsBelowThisRecord (RecordSym) then
            NumberOfFields := NumberOfFields - 1;
         end if;
         return NumberOfFields;
      end NumberOfListElementsNeeded;

   begin
      if STree.Syntax_Node_Type (Node => STree.Parent_Node (Current_Node => Node)) = QualExpNode then --top level aggregate
         Node := STree.Child_Node (Current_Node => Node);

         -- ExpnStack will have symbol of aggregate type on top.  We turn
         -- this into an IncompleteAggregate cell (it becomes MkAggregate when
         -- we get back to the aggregate node on the way up).
         Cells.Set_Kind (VCGHeap, CStacks.Top (VCGHeap, ExpnStack), Cell_Storage.Incomplete_Aggregate);

         -- For record aggregates, create a list of commas into which we can later slot
         -- the aggregate expressions
         if (Dictionary.TypeIsRecord (Cells.Get_Symbol_Value (VCGHeap, CStacks.Top (VCGHeap, ExpnStack)))) then
            -- The type indicated by the qualifier might be a record subtype,
            -- but for the VCG we always use the root type, look it up and
            -- modify that cells symbol for later use.
            AggType := Dictionary.GetRootType (Cells.Get_Symbol_Value (VCGHeap, CStacks.Top (VCGHeap, ExpnStack)));
            Cells.Set_Symbol_Value (VCGHeap, CStacks.Top (VCGHeap, ExpnStack), AggType);

            CreateEmptyList (NumberOfListElementsNeeded (AggType), VCGHeap, ExpnStack);

            -- For extended tagged records we need to extend this "empty record" model to include
            -- all the Inherit fields
            InsertPointForInheritedFields := CStacks.Top (VCGHeap, ExpnStack);

            loop
               -- immediate exit if we aren't doing tagged record model
               exit when not Dictionary.TypeIsTagged (AggType);

               -- Step down to first inherited record
               InheritSym := Dictionary.CurrentSymbol (Dictionary.FirstRecordComponent (AggType));
               AggType    := Dictionary.GetType (InheritSym);

               -- Finally reached field of the root type
               exit when not Dictionary.TypeIsTagged (AggType);

               -- if we have zero components then we don't need to include record in model
               exit when not Dictionary.RecordHasSomeFields (AggType);

               -- At this point we have an inherited record with >0 components

               CreateOpCell (InheritedFieldsModel, VCGHeap, SP_Symbols.becomes);
               -- Create a cell for field name Inherit
               CreateFixedVarCell (InheritField, VCGHeap, InheritSym);
               -- connect it to :=
               SetLeftArgument (InheritedFieldsModel, InheritField, VCGHeap);
               -- Create MkAggregate cell
               CreateCellKind (MkAggregateCell, VCGHeap, Cell_Storage.Mk_Aggregate);
               Cells.Set_Symbol_Value (VCGHeap, MkAggregateCell, AggType);
               -- connect it to :=
               SetRightArgument (InheritedFieldsModel, MkAggregateCell, VCGHeap);
               -- We need to create an empty comma list and to do that need
               -- the aggregate model on top of stack, so we push it for now
               CStacks.Push (VCGHeap, MkAggregateCell, ExpnStack);
               CreateEmptyList (NumberOfListElementsNeeded (AggType), VCGHeap, ExpnStack);
               -- Restore stack
               CStacks.Pop (VCGHeap, ExpnStack);
               -- We now have a completed model of the inherited and just need to insert it in
               -- overall structure
               InsertParameterInNextFreeSlot (InsertPointForInheritedFields, InheritedFieldsModel, VCGHeap);
               InsertPointForInheritedFields := MkAggregateCell; -- ready for next pass through loop
            end loop;
         end if;
         -- no else part, anything else must be a simple qualified expression
         -- and we will later throw this cell away in that case.

         CStacks.PopOff (VCGHeap, ExpnStack, AggTemp);
         -- if we are doing positional association (other than simple
         -- qualified expression) we need to maintain a counter
         -- and we use a new cell's value field for this purpose
         CreateAggregateCounter (1, VCGHeap, ExpnStack);
         -- Put aggregate back on top of stack
         CStacks.Push (VCGHeap, AggTemp, ExpnStack);

      else -- unsupported embedded aggregate
         ErrorHandler.Semantic_Warning
           (Err_Num  => 300,
            Position => STree.Node_Position (Node => Node),
            Id_Str   => LexTokenManager.Null_String);
         --push a null cell to represent the unresolvable anonymous aggregate
         Cells.Create_Cell (VCGHeap, DAGCell);
         CStacks.Push (VCGHeap, DAGCell, ExpnStack);
         Node := STree.NullNode; --prune walk
      end if;
   end DownProcessAggregate;

   ---------------------------------------------------------------------

   procedure DownProcessAggregateChoiceRep
     (Node      : in     STree.SyntaxNode;
      ThisScope : in     Dictionary.Scopes;
      VCGHeap   : in out Cells.Heap_Record;
      ExpnStack : in out CStacks.Stack;
      NextNode  :    out STree.SyntaxNode)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in     STree.Table;
   --#        in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    CommandLineData.Content,
   --#                                    Dictionary.Dict,
   --#                                    ExpnStack,
   --#                                    LexTokenManager.State,
   --#                                    Node,
   --#                                    STree.Table,
   --#                                    ThisScope,
   --#                                    VCGHeap &
   --#         NextNode              from Dictionary.Dict,
   --#                                    ExpnStack,
   --#                                    Node,
   --#                                    STree.Table,
   --#                                    VCGHeap;
   is
      FieldSym : Dictionary.Symbol;
      TypeCell : Cells.Cell;
   begin
      if DoingRecordAggregate (VCGHeap, ExpnStack) then --doing record so need to get field sym
         FieldSym :=
           Dictionary.LookupSelectedItem
           (AggregateType (VCGHeap, ExpnStack),
            STree.Node_Lex_String (Node => STree.Last_Child_Of (Start_Node => Node)),
            ThisScope,
            Dictionary.ProgramContext);
         CreateFixedVarCell (TypeCell, VCGHeap, FieldSym);
         CStacks.Push (VCGHeap, TypeCell, ExpnStack);
         NextNode := STree.NullNode;
      else
         NextNode := STree.Child_Node (Current_Node => Node);
      end if;
   end DownProcessAggregateChoiceRep;

   ----------------------------------------------------------------------------------

   procedure DownProcessRecordComponentSelectorName
     (Node      : in     STree.SyntaxNode;
      ThisScope : in     Dictionary.Scopes;
      VCGHeap   : in out Cells.Heap_Record;
      ExpnStack : in out CStacks.Stack;
      NextNode  :    out STree.SyntaxNode)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in     STree.Table;
   --#        in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    CommandLineData.Content,
   --#                                    Dictionary.Dict,
   --#                                    ExpnStack,
   --#                                    LexTokenManager.State,
   --#                                    Node,
   --#                                    STree.Table,
   --#                                    ThisScope,
   --#                                    VCGHeap &
   --#         NextNode              from ;
   is
      FieldSym : Dictionary.Symbol;
      TypeCell : Cells.Cell;
   begin
      FieldSym :=
        Dictionary.LookupSelectedItem
        (AggregateType (VCGHeap, ExpnStack),
         STree.Node_Lex_String (Node => STree.Last_Child_Of (Start_Node => Node)),
         ThisScope,
         Dictionary.ProgramContext);
      CreateFixedVarCell (TypeCell, VCGHeap, FieldSym);
      CStacks.Push (VCGHeap, TypeCell, ExpnStack);
      NextNode := STree.NullNode;
   end DownProcessRecordComponentSelectorName;

   ---------------------------------------------------------------------

   procedure UpProcessExtensionAggregate (VCGHeap   : in out Cells.Heap_Record;
                                          ExpnStack : in out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    ExpnStack,
   --#                                    VCGHeap;
   is
      TempAgg : Cells.Cell;
   begin
      CStacks.PopOff (VCGHeap, ExpnStack, TempAgg);  -- hold the aggregate expression or list
      if Cells.Get_Kind (VCGHeap, CStacks.Top (VCGHeap, ExpnStack)) = Cell_Storage.Aggregate_Counter then
         -- we are doing a record and just need to get rid of the counter
         CStacks.Pop (VCGHeap, ExpnStack); -- get rid of counter
      end if;
      -- Convert aggregate to a finished MkAggregate function
      Cells.Set_Kind (VCGHeap, TempAgg, Cell_Storage.Mk_Aggregate);
      -- Finally, restore aggregate DAG to TOS
      CStacks.Push (VCGHeap, TempAgg, ExpnStack);
   end UpProcessExtensionAggregate;

   ---------------------------------------------------------------------

   procedure UpProcessAggregateChoiceRep
     (Node      : in     STree.SyntaxNode;
      VCGHeap   : in out Cells.Heap_Record;
      ExpnStack : in out CStacks.Stack)
   --# global in     Dictionary.Dict;
   --#        in     STree.Table;
   --#        in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    Dictionary.Dict,
   --#                                    ExpnStack,
   --#                                    Node,
   --#                                    STree.Table,
   --#                                    VCGHeap;
   is
   begin
      if DoingArrayAggregate (VCGHeap, ExpnStack) then
         PushFunction (Cell_Storage.List_Function, VCGHeap, ExpnStack);
         if STree.Next_Sibling (Current_Node => STree.Child_Node (Current_Node => Node)) /= STree.NullNode then
            PushOperator (Binary, SP_Symbols.ampersand, VCGHeap, ExpnStack);
         end if;
      end if;
   end UpProcessAggregateChoiceRep;

   ---------------------------------------------------------------------

   procedure ProcessAncestorPart
     (Node      : in     STree.SyntaxNode;
      VCGHeap   : in out Cells.Heap_Record;
      ExpnStack : in out CStacks.Stack)
   --# global in     Dictionary.Dict;
   --#        in     STree.Table;
   --#        in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    Dictionary.Dict,
   --#                                    ExpnStack,
   --#                                    Node,
   --#                                    STree.Table,
   --#                                    VCGHeap;
   is
      AggTemp                       : Cells.Cell;
      AggType                       : Dictionary.Symbol;
      InsertPointForInheritedFields : Cells.Cell;
      -- following three cells are used to create a model of inherited tagged records
      InheritedFieldsModel, InheritField, MkAggregateCell : Cells.Cell;
      InheritSym                                          : Dictionary.Symbol;

      AncestorDAG  : Cells.Cell;
      AncestorType : Dictionary.Symbol;

      --------------------------------------------------------------------

      function IsNullAggregate return Boolean
      --# global in Node;
      --#        in STree.Table;
      is
      begin
         return STree.Syntax_Node_Type (Node => STree.Next_Sibling (Current_Node => Node)) = SP_Symbols.RWnull;
      end IsNullAggregate;

      --------------------------------------------------------------------

      function NumberOfListElementsNeeded (RecordSym : Dictionary.Symbol) return Natural
      --# global in Dictionary.Dict;
      is
         NumberOfFields : Natural;
      begin
         NumberOfFields := Dictionary.GetNumberOfNonExtendedComponents (RecordSym);
         -- If the root type is a null record then we ignore it since it won't have
         -- any aggregate choice expressions to associate with it.  In this case we need
         -- one fewer fields slots in the empty list of the immediately preceding record
         -- in the model.
         if Dictionary.TypeIsExtendedTagged (RecordSym) and then Dictionary.NoFieldsBelowThisRecord (RecordSym) then
            NumberOfFields := NumberOfFields - 1;
         end if;
         return NumberOfFields;
      end NumberOfListElementsNeeded;

   begin
      -- Node is SP_Symbols.[annotation_]ancestor_part
      -- Next_Sibling is either RWNull or record_component_association
      -- Direction is UP
      -- TOS is ancestor expression
      -- 2nd TOS is qualified expression prefix giving overall aggregate type

      if IsNullAggregate then
         -- Required model is simply an aggregate with a single assignment of the ancestor part
         -- itself since no other fields are involved
         --
         CStacks.PopOff (VCGHeap, ExpnStack, AncestorDAG);
         AggType    := Cells.Get_Symbol_Value (VCGHeap, CStacks.Top (VCGHeap, ExpnStack));
         InheritSym := Dictionary.CurrentSymbol (Dictionary.FirstRecordComponent (AggType));
         -- Convert qualifier to aggregate
         Cells.Set_Kind (VCGHeap, CStacks.Top (VCGHeap, ExpnStack), Cell_Storage.Mk_Aggregate);
         -- create aggregate association
         CreateOpCell (InheritedFieldsModel, VCGHeap, SP_Symbols.becomes);
         -- Create a cell for field name Inherit
         CreateFixedVarCell (InheritField, VCGHeap, InheritSym);
         -- connect it to :=
         SetLeftArgument (InheritedFieldsModel, InheritField, VCGHeap);
         SetRightArgument (InheritedFieldsModel, AncestorDAG, VCGHeap);
         SetRightArgument (CStacks.Top (VCGHeap, ExpnStack), InheritedFieldsModel, VCGHeap);

      else
         -- not a null aggregate
         AncestorType := STree.NodeSymbol (Node);
         -- Build an empty structure into which the associations can be plugged and
         -- associate the ancestor expression with the inherit field of the rightmost
         -- mk_record in the model
         CStacks.PopOff (VCGHeap, ExpnStack, AncestorDAG);
         -- ExpnStack now has symbol of aggregate type on top.  We turn
         -- this into an IncompleteAggregate cell (it becomes MkAggregate when
         -- we get back to the aggregate node on the way up).
         Cells.Set_Kind (VCGHeap, CStacks.Top (VCGHeap, ExpnStack), Cell_Storage.Incomplete_Aggregate);
         -- We know we are dealing with a record aggregate so we can build an empty
         -- comma-list into which to insert later associaitons
         CreateEmptyList
           (NumberOfListElementsNeeded (Cells.Get_Symbol_Value (VCGHeap, CStacks.Top (VCGHeap, ExpnStack))),
            VCGHeap,
            ExpnStack);
         -- and then add in the "inherit" fields needed to make an extended record model
         InsertPointForInheritedFields := CStacks.Top (VCGHeap, ExpnStack);
         AggType                       := Cells.Get_Symbol_Value (VCGHeap, CStacks.Top (VCGHeap, ExpnStack));
         loop
            -- immediate exit if we aren't doing tagged record model
            exit when not Dictionary.TypeIsTagged (AggType);

            -- stop building model when we get to ancestor part
            exit when Dictionary.Types_Are_Equal
              (Left_Symbol        => AggType,
               Right_Symbol       => AncestorType,
               Full_Range_Subtype => False);

            -- Step down to first inherited record
            InheritSym := Dictionary.CurrentSymbol (Dictionary.FirstRecordComponent (AggType));
            AggType    := Dictionary.GetType (InheritSym);

            -- Finally reached field of the root type - shouldn't get here
            exit when not Dictionary.TypeIsTagged (AggType);

            -- if we have zero components then we don't need to include record in model
            exit when not Dictionary.RecordHasSomeFields (AggType);

            -- At this point we have an inherited record with >0 components

            CreateOpCell (InheritedFieldsModel, VCGHeap, SP_Symbols.becomes);
            -- Create a cell for field name Inherit
            CreateFixedVarCell (InheritField, VCGHeap, InheritSym);
            -- connect it to :=
            SetLeftArgument (InheritedFieldsModel, InheritField, VCGHeap);
            -- if we have reached the ancestor type then we assign that otherwise we
            -- create an MkAggrgeate cell for the next level
            if Dictionary.Types_Are_Equal (Left_Symbol        => AggType,
                                           Right_Symbol       => AncestorType,
                                           Full_Range_Subtype => False) then
               SetRightArgument (InheritedFieldsModel, AncestorDAG, VCGHeap);
               InsertParameterInNextFreeSlot (InsertPointForInheritedFields, InheritedFieldsModel, VCGHeap);
            else
               -- Create MkAggregate cell
               CreateCellKind (MkAggregateCell, VCGHeap, Cell_Storage.Mk_Aggregate);
               Cells.Set_Symbol_Value (VCGHeap, MkAggregateCell, AggType);
               -- connect it to :=
               SetRightArgument (InheritedFieldsModel, MkAggregateCell, VCGHeap);
               -- We need to create an empty comma list and to do that need
               -- the aggregate model on top of stack, so we push it for now
               CStacks.Push (VCGHeap, MkAggregateCell, ExpnStack);
               CreateEmptyList (NumberOfListElementsNeeded (AggType), VCGHeap, ExpnStack);
               -- Restore stack
               CStacks.Pop (VCGHeap, ExpnStack);
               -- We now have a completed model of the inherited and just need to insert it in
               -- overall structure
               InsertParameterInNextFreeSlot (InsertPointForInheritedFields, InheritedFieldsModel, VCGHeap);
               InsertPointForInheritedFields := MkAggregateCell; -- ready for next pass through loop
            end if;
         end loop;

         -- temporarily remove aggregate from stack
         CStacks.PopOff (VCGHeap, ExpnStack, AggTemp);
         -- if we are doing positional association (other than simple
         -- qualified expression) we need to maintain a counter
         -- and we use a new cell's value field for this purpose
         -- Since we will be looking for fields that are not provided by the ancestor part, we
         -- start with the counter set to the number of fields in the ancestor
         CreateAggregateCounter (Dictionary.GetNumberOfComponents (AncestorType) + 1, VCGHeap, ExpnStack);
         -- Put aggregate back on top of stack
         CStacks.Push (VCGHeap, AggTemp, ExpnStack);
      end if;
   end ProcessAncestorPart;

   -- Construct an attribute "PrefixSymbol'tail (ExpnDAG)" and return it as RHS
   procedure BuildStreamRHS
     (VCGHeap      : in out Cells.Heap_Record;
      PrefixSymbol : in     Dictionary.Symbol;
      ExpnDAG      : in     Cells.Cell;
      RHS          :    out Cells.Cell)
   --# global in out Statistics.TableUsage;
   --# derives RHS                   from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    PrefixSymbol,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    ExpnDAG,
   --#                                    PrefixSymbol;
   is
      StreamFunction, StreamPrefix, StreamIdent : Cells.Cell;

   begin -- BuildStreamRHS
         -- create necessary cells
      CreateOpCell (StreamFunction, VCGHeap, SP_Symbols.apostrophe);
      CreateFixedVarCell (StreamPrefix, VCGHeap, PrefixSymbol);

      CreateCellKind (StreamIdent, VCGHeap, Cell_Storage.Attrib_Function);
      Cells.Set_Lex_Str (VCGHeap, StreamIdent, LexTokenManager.Tail_Token);
      --assemble into a function attribute
      SetLeftArgument (StreamFunction, StreamPrefix, VCGHeap);
      SetRightArgument (StreamFunction, StreamIdent, VCGHeap);
      SetRightArgument (StreamIdent, ExpnDAG, VCGHeap);

      RHS := StreamFunction;
   end BuildStreamRHS;

   -------------------------------------------------------------------------

   -- Changed to use a stack to do a depth-first search,
   -- and altered from a function to a procedure to allow
   -- debugging side effects
   procedure ContainsQuantIdent (DataElem, QuantIdent : in     Cells.Cell;
                                 VCGHeap              : in out Cells.Heap_Record;
                                 Result               :    out Boolean)
   --# global in out Statistics.TableUsage;
   --# derives Result,
   --#         VCGHeap               from DataElem,
   --#                                    QuantIdent,
   --#                                    VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    DataElem,
   --#                                    QuantIdent,
   --#                                    VCGHeap;
   is
      CurrElem        : Cells.Cell;
      FoundQuantIdent : Boolean;
      MyTempStack     : CStacks.Stack;
      Ident_To_Find   : Dictionary.Symbol;
   begin
      Ident_To_Find   := Cells.Get_Symbol_Value (VCGHeap, QuantIdent);
      CurrElem        := DataElem;
      FoundQuantIdent := False;
      CStacks.CreateStack (MyTempStack);
      CStacks.Push (VCGHeap, CurrElem, MyTempStack);
      while not (CStacks.IsEmpty (MyTempStack) or FoundQuantIdent) loop
         CStacks.PopOff (VCGHeap, MyTempStack, CurrElem);

         --  Check if we have found what we are looking for.
         if Cells.Get_Symbol_Value (VCGHeap, CurrElem) = Ident_To_Find then
            FoundQuantIdent := True;
         end if;

         case Cells.Get_Kind (VCGHeap, CurrElem) is
            when Cell_Storage.Fixed_Var | Cell_Storage.Reference =>
               --  A fixed identifier; covered above. These can
               --  apparently point to themselves, so we must not push
               --  the A or B pointer on the stack.
               null;
            when others =>
               -- Explore both sides if they are non-null
               if not Cells.Is_Null_Cell (LeftPtr (VCGHeap, CurrElem)) then
                  CStacks.Push (VCGHeap, LeftPtr (VCGHeap, CurrElem), MyTempStack);
               end if;

               if not Cells.Is_Null_Cell (RightPtr (VCGHeap, CurrElem)) then
                  CStacks.Push (VCGHeap, RightPtr (VCGHeap, CurrElem), MyTempStack);
               end if;
         end case;
      end loop;

      --  Clean up a bit...
      while not CStacks.IsEmpty (MyTempStack) loop
         CStacks.Pop (VCGHeap, MyTempStack);
      end loop;

      Result := FoundQuantIdent;
   end ContainsQuantIdent;

   -----------------------------------------------------------------------------

   -- Prints DAG at DAGRoot in GraphViz's "Dot" format.
   --
   -- The output appears in a file called "dagXXX.dot" where
   -- XXX is the decimal integer value of DAGRoot - this suuplies
   -- a low-tech but sure way to differeniate between the
   -- many DAGs that might be produced by a single Examiner run.
   procedure Debug_Print_DAG
     (Start_Node : in     STree.SyntaxNode;
      Scope      : in     Dictionary.Scopes;
      DAG_Root   : in     Cells.Cell;
      VCG_Heap   : in out Cells.Heap_Record)
   --# global in CommandLineData.Content;
   --# derives VCG_Heap from * &
   --#         null     from CommandLineData.Content,
   --#                       DAG_Root,
   --#                       Scope,
   --#                       Start_Node;
   is
      -- Uses String slicing and catenation, so not SPARK...

      --# hide Debug_Print_DAG;
      Current_Unit      : ContextManager.UnitDescriptors;
      Current_File_Name : E_Strings.T;
      DAG_File_Name     : E_Strings.T;
      DAG_File          : SPARK_IO.File_Type := SPARK_IO.Null_File;
      DAG_Posn          : LexTokenManager.Token_Position;
      Status            : SPARK_IO.File_Status;

      DAG_Num : constant String := Cells.Cell'Image (DAG_Root);
      DAG_ID  : constant String := "dag" & DAG_Num (2 .. DAG_Num'Last) & ".dot";
   begin
      -- We want to produce a message that ties the filename containing
      -- the DAG printout to the file, line-number, and column-number of
      -- the offending expression.
      --
      -- The source filename can be obtained from ContextManager, but
      -- This approach DOES NOT WORK for abstract pre-conditions and post-conditions
      -- since these can come from source files other than that associated with
      -- ContextManager.CurrentUnit.  Currently, this code can produce the
      -- incorrect source file reference if called from Build_Annotation_Expression.
      Current_Unit      := ContextManager.Ops.Current_Unit;
      Current_File_Name :=
        LexTokenManager.Lex_String_To_String
        (Lex_Str => ContextManager.Ops.GetSourceFileName
           (Descriptor => ContextManager.Ops.Get_File_Descriptor (Unit_Descriptor => Current_Unit)));

      -- The Source position of the expression itself comes from STree.Table, thus:
      DAG_Posn := STree.Node_Position (Node => Start_Node);

      DAG_File_Name := E_Strings.Copy_String (Str => DAG_ID);
      CommandLineData.Normalize_File_Name_To_Output_Directory (F => DAG_File_Name);

      E_Strings.Put_String
        (File  => SPARK_IO.Standard_Output,
         E_Str => FileSystem.Just_File (Fn  => Current_File_Name,
                                        Ext => True));

      declare
         Line_Str : constant String := DAG_Posn.Start_Line_No'Img;
         Col_Str  : constant String := DAG_Posn.Start_Pos'Img;
      begin
         Debug.PrintMsg
           (":" & Line_Str (2 .. Line_Str'Last) & ":" & Col_Str (2 .. Col_Str'Last) & ": DAG printed to file ",
            False);
         if CommandLineData.Content.Plain_Output then
            E_Strings.Put_String
              (File  => SPARK_IO.Standard_Output,
               E_Str => FileSystem.Just_File (Fn  => DAG_File_Name,
                                              Ext => True));
         else
            E_Strings.Put_String (File  => SPARK_IO.Standard_Output,
                                  E_Str => DAG_File_Name);
         end if;
      end;

      E_Strings.Create (File         => DAG_File,
                        Name_Of_File => DAG_File_Name,
                        Form_Of_File => "",
                        Status       => Status);

      if Status = SPARK_IO.Ok then
         DAG_IO.Print_DAG_Dot
           (Heap        => VCG_Heap,
            Output_File => DAG_File,
            Root        => DAG_Root,
            Scope       => Scope,
            Wrap_Limit  => DAG_IO.No_Wrap);
         SPARK_IO.Close (DAG_File, Status);
      else
         Debug.PrintMsg (" - File create failed", False);
      end if;

      SPARK_IO.New_Line (SPARK_IO.Standard_Output, 1);
   end Debug_Print_DAG;

   -- Model_Catenation - models the semantics of the "&" operator
   -- between characters and/or strings in constant expressions.
   -- For example, if ExpnStack contains two entries representing
   -- "ab" and "cd", then this routine leaves ExpnStack containing
   -- a single top entry representing "abcd"
   procedure Model_Catenation (ExpnStack : in out CStacks.Stack;
                               VCGHeap   : in out Cells.Heap_Record)
   --# global in     Dictionary.Dict;
   --#        in out LexTokenManager.State;
   --#        in out Statistics.TableUsage;
   --# derives ExpnStack,
   --#         LexTokenManager.State,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    Dictionary.Dict,
   --#                                    ExpnStack,
   --#                                    LexTokenManager.State,
   --#                                    VCGHeap;
   is
      Left, Right               : Cells.Cell;
      Left_String, Right_String : E_Strings.T;
      Left_Length, Right_Length : E_Strings.Lengths;
      New_String                : E_Strings.T;
      New_Lex_Str               : LexTokenManager.Lex_String;
      OK_Left, OK_Right         : Boolean;

      procedure Get_String (The_Cell   : in     Cells.Cell;
                            The_String :    out E_Strings.T;
                            OK         :    out Boolean)
      --# global in Dictionary.Dict;
      --#        in LexTokenManager.State;
      --#        in VCGHeap;
      --# derives OK,
      --#         The_String from Dictionary.Dict,
      --#                         LexTokenManager.State,
      --#                         The_Cell,
      --#                         VCGHeap;
      is
         Char_Code : Integer;
         Unused    : Maths.ErrorCode;
         Sym       : Dictionary.Symbol;
         Sym_Type  : Dictionary.Symbol;
      begin
         if Cells.Get_Kind (VCGHeap, The_Cell) = Cell_Storage.Manifest_Const then
            The_String := LexTokenManager.Lex_String_To_String (Lex_Str => Cells.Get_Lex_Str (VCGHeap, The_Cell));
            OK         := True;

         elsif Cells.Get_Kind (VCGHeap, The_Cell) = Cell_Storage.Named_Const then

            Sym      := Cells.Get_Symbol_Value (VCGHeap, The_Cell);
            Sym_Type := Dictionary.GetRootType (Dictionary.GetType (Sym));

            if Dictionary.IsPredefinedStringType (Sym_Type) then

               -- Grab the value of the String constant from the Dictionary. This will
               -- have been recorded in the Dictionary by Sem.CompUnit.Wf_Constant_Declaration
               The_String := LexTokenManager.Lex_String_To_String (Dictionary.Get_Value (The_Constant => Sym));
               OK         := True;

            elsif Dictionary.IsPredefinedCharacterType (Sym_Type) then

               --# accept F, 10, Unused, "Unused here OK";
               Maths.ValueToInteger
                 (Maths.ValueRep (Dictionary.Get_Value (The_Constant => Cells.Get_Symbol_Value (VCGHeap, The_Cell))),
                  Char_Code,
                  Unused);
               --# end accept;
               if Char_Code = 0 then -- can't model nuls in strings
                  The_String := E_Strings.Empty_String;
                  OK         := False;
               else
                  The_String := E_Strings.Copy_String (Str => """");
                  E_Strings.Append_Char (E_Str => The_String,
                                         Ch    => Character'Val (Char_Code));
                  E_Strings.Append_Char (E_Str => The_String,
                                         Ch    => '"');
                  OK := True;
               end if;

            else
               -- Not a String or a Character constant. ?????
               The_String := E_Strings.Empty_String; -- should not occur
               OK         := False;
            end if;

         else
            The_String := E_Strings.Empty_String; -- should not occur
            OK         := False;
         end if;
         --# accept F, 33, Unused, "Unused here OK";
      end Get_String;

   begin -- Model_Catenation

      -- get left and right strings to be concatenated
      CStacks.PopOff (VCGHeap, ExpnStack, Right);
      CStacks.PopOff (VCGHeap, ExpnStack, Left);

      if (Cells.Get_Kind (VCGHeap, Left) = Cell_Storage.Manifest_Const
            or else Cells.Get_Kind (VCGHeap, Left) = Cell_Storage.Named_Const)
        and then (Cells.Get_Kind (VCGHeap, Right) = Cell_Storage.Manifest_Const
                    or else Cells.Get_Kind (VCGHeap, Right) = Cell_Storage.Named_Const) then
         Get_String (The_Cell   => Left,
                     The_String => Left_String,
                     OK         => OK_Left);
         Get_String (The_Cell   => Right,
                     The_String => Right_String,
                     OK         => OK_Right);

         if OK_Left and OK_Right then
            Left_Length  := E_Strings.Get_Length (E_Str => Left_String);
            Right_Length := E_Strings.Get_Length (E_Str => Right_String);

            -- build an examiner line with concatenated strings in it
            New_String := E_Strings.Copy_String (Str => """");
            for I in E_Strings.Lengths range 2 .. Left_Length - 1 loop
               E_Strings.Append_Char (E_Str => New_String,
                                      Ch    => E_Strings.Get_Element (E_Str => Left_String,
                                                                      Pos   => I));
            end loop;
            -- at this point we have " followed by left string and no terminating "
            for I in E_Strings.Lengths range 2 .. Right_Length - 1 loop
               E_Strings.Append_Char (E_Str => New_String,
                                      Ch    => E_Strings.Get_Element (E_Str => Right_String,
                                                                      Pos   => I));
            end loop;
            E_Strings.Append_Char (E_Str => New_String,
                                   Ch    => '"');

            LexTokenManager.Insert_Examiner_String (Str     => New_String,
                                                    Lex_Str => New_Lex_Str);

            -- Having catenated the two halfs, we change Left to
            -- be a Manifest_Const cell in all cases
            Cells.Set_Kind (VCGHeap, Left, Cell_Storage.Manifest_Const);

            Cells.Set_Lex_Str (VCGHeap, Left, New_Lex_Str);
            CStacks.Push (VCGHeap, Left, ExpnStack);
         else -- can't model string with nul in it so push & op instead
            CStacks.Push (VCGHeap, Left, ExpnStack);
            CStacks.Push (VCGHeap, Right, ExpnStack);
            PushOperator (Binary, SP_Symbols.ampersand, VCGHeap, ExpnStack);
         end if;

      else -- & operator shouldn't have got here so just push it as binop
         CStacks.Push (VCGHeap, Left, ExpnStack);
         CStacks.Push (VCGHeap, Right, ExpnStack);
         PushOperator (Binary, SP_Symbols.ampersand, VCGHeap, ExpnStack);
      end if;
   end Model_Catenation;

   ----------------------------------------

   procedure Build_Annotation_Expression
     (Exp_Node                         : in     STree.SyntaxNode;
      Instantiated_Subprogram          : in     Dictionary.Symbol;
      Scope                            : in     Dictionary.Scopes;
      Calling_Scope                    : in     Dictionary.Scopes;
      Force_Abstract                   : in     Boolean;
      Loop_Stack                       : in     LoopContext.T;
      Generate_Function_Instantiations : in     Boolean;
      VC_Failure                       : in out Boolean;
      VC_Contains_Reals                : in out Boolean;
      VCG_Heap                         : in out Cells.Heap_Record;
      DAG_Root                         :    out Cells.Cell;
      Function_Defs                    : in out CStacks.Stack)
   --# global in     CommandLineData.Content;
   --#        in     STree.Table;
   --#        in out Dictionary.Dict;
   --#        in out ErrorHandler.Error_Context;
   --#        in out LexTokenManager.State;
   --#        in out SPARK_IO.File_Sys;
   --#        in out Statistics.TableUsage;
   --# derives DAG_Root,
   --#         Dictionary.Dict,
   --#         Function_Defs,
   --#         LexTokenManager.State,
   --#         VCG_Heap                   from Calling_Scope,
   --#                                         CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         Exp_Node,
   --#                                         Force_Abstract,
   --#                                         Function_Defs,
   --#                                         Generate_Function_Instantiations,
   --#                                         Instantiated_Subprogram,
   --#                                         LexTokenManager.State,
   --#                                         Loop_Stack,
   --#                                         Scope,
   --#                                         STree.Table,
   --#                                         VCG_Heap &
   --#         ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from Calling_Scope,
   --#                                         CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         Exp_Node,
   --#                                         Force_Abstract,
   --#                                         Function_Defs,
   --#                                         Generate_Function_Instantiations,
   --#                                         Instantiated_Subprogram,
   --#                                         LexTokenManager.State,
   --#                                         Loop_Stack,
   --#                                         Scope,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table,
   --#                                         VCG_Heap &
   --#         Statistics.TableUsage,
   --#         VC_Contains_Reals,
   --#         VC_Failure                 from *,
   --#                                         Calling_Scope,
   --#                                         CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         Exp_Node,
   --#                                         Force_Abstract,
   --#                                         Function_Defs,
   --#                                         Generate_Function_Instantiations,
   --#                                         Instantiated_Subprogram,
   --#                                         LexTokenManager.State,
   --#                                         Loop_Stack,
   --#                                         Scope,
   --#                                         STree.Table,
   --#                                         VCG_Heap;
      is separate;

   -- This procedure traverses a syntax tree of an expression, which may be
   --    - an expression of an assignment statement,
   --    - a condition of an if_statement (or elsif_part),
   --    - an expression of a case_statement,
   --    - a condition of an iteration scheme.
   procedure BuildExpnDAG
     (StartNode          : in     STree.SyntaxNode;
      ExpnScope          : in     Dictionary.Scopes;
      Scope              : in     Dictionary.Scopes;
      LineNmbr           : in     Integer;
      DoRtc              : in     Boolean;
      AssumeRvalues      : in     Boolean;
      LoopStack          : in     LoopContext.T;
      FlowHeap           : in out Heap.HeapRecord;
      VCGHeap            : in out Cells.Heap_Record;
      ContainsReals      : in out Boolean;
      VCGFailure         : in out Boolean;
      ShortCircuitStack  : in out CStacks.Stack;
      CheckStack         : in out CStacks.Stack;
      KindOfStackedCheck : in out Graph.Proof_Context_Type;
      DAGRoot            :    out Cells.Cell)
   --# global in     CommandLineData.Content;
   --#        in     STree.Table;
   --#        in out Dictionary.Dict;
   --#        in out ErrorHandler.Error_Context;
   --#        in out Graph.Table;
   --#        in out LexTokenManager.State;
   --#        in out SPARK_IO.File_Sys;
   --#        in out Statistics.TableUsage;
   --#        in out StmtStack.S;
   --# derives CheckStack,
   --#         ContainsReals,
   --#         Dictionary.Dict,
   --#         FlowHeap,
   --#         Graph.Table,
   --#         KindOfStackedCheck,
   --#         LexTokenManager.State,
   --#         ShortCircuitStack,
   --#         Statistics.TableUsage,
   --#         StmtStack.S,
   --#         VCGFailure,
   --#         VCGHeap                    from *,
   --#                                         AssumeRvalues,
   --#                                         CheckStack,
   --#                                         CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         DoRtc,
   --#                                         ExpnScope,
   --#                                         FlowHeap,
   --#                                         Graph.Table,
   --#                                         KindOfStackedCheck,
   --#                                         LexTokenManager.State,
   --#                                         LineNmbr,
   --#                                         LoopStack,
   --#                                         Scope,
   --#                                         ShortCircuitStack,
   --#                                         StartNode,
   --#                                         StmtStack.S,
   --#                                         STree.Table,
   --#                                         VCGHeap &
   --#         DAGRoot                    from AssumeRvalues,
   --#                                         CheckStack,
   --#                                         CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         DoRtc,
   --#                                         ExpnScope,
   --#                                         FlowHeap,
   --#                                         Graph.Table,
   --#                                         KindOfStackedCheck,
   --#                                         LexTokenManager.State,
   --#                                         LineNmbr,
   --#                                         LoopStack,
   --#                                         Scope,
   --#                                         ShortCircuitStack,
   --#                                         StartNode,
   --#                                         StmtStack.S,
   --#                                         STree.Table,
   --#                                         VCGHeap &
   --#         ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from AssumeRvalues,
   --#                                         CheckStack,
   --#                                         CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         DoRtc,
   --#                                         ErrorHandler.Error_Context,
   --#                                         ExpnScope,
   --#                                         FlowHeap,
   --#                                         Graph.Table,
   --#                                         KindOfStackedCheck,
   --#                                         LexTokenManager.State,
   --#                                         LineNmbr,
   --#                                         LoopStack,
   --#                                         Scope,
   --#                                         ShortCircuitStack,
   --#                                         SPARK_IO.File_Sys,
   --#                                         StartNode,
   --#                                         StmtStack.S,
   --#                                         STree.Table,
   --#                                         VCGHeap;
      is separate;

   --------------------------------------------------------------------------------

   procedure BuildGraph
     (StartNode                    : in     STree.SyntaxNode;
      SubprogSym                   : in     Dictionary.Symbol;
      Scope                        : in     Dictionary.Scopes;
      OutputFile                   : in     SPARK_IO.File_Type;
      EndPosition                  : in     LexTokenManager.Token_Position;
      VCGFailure                   : in out Boolean;
      VCGHeap                      : in out Cells.Heap_Record;
      FlowHeap                     : in out Heap.HeapRecord;
      Semantic_Error_In_Subprogram : in     Boolean;
      DataFlowErrorInSubprogram    : in     Boolean;
      Type_Check_Exports           : in     Boolean)
      is separate;

   --------------------------------------------------------------------------

   procedure BuildConstantInitializationDAG
     (StartNode : in     STree.SyntaxNode;
      Scope     : in     Dictionary.Scopes;
      TheHeap   : in out Cells.Heap_Record;
      FlowHeap  : in out Heap.HeapRecord;
      DAGRoot   :    out Cells.Cell)
   is
      ContainsReals      : Boolean;
      VCGFailure         : Boolean;
      ShortCircuitStack  : CStacks.Stack;
      CheckStack         : CStacks.Stack;
      KindOfStackedCheck : Graph.Proof_Context_Type;
      LoopStack          : LoopContext.T;
   begin
      LoopContext.Initialize (LoopStack);
      --# accept F, 10, "ContainsReals, VCGFailure not used here";
      ContainsReals := False; -- Not used in this subprogram
      VCGFailure    := False; -- Not used in this subprogram

      --# end accept;
      CStacks.CreateStack (ShortCircuitStack);
      CStacks.CreateStack (CheckStack);
      KindOfStackedCheck := Graph.Unspecified;
      --# accept F, 10, KindOfStackedCheck, "KindOfStackedCheck not used here" &
      --#        F, 10, CheckStack, "CheckStack not used here" &
      --#        F, 10, ShortCircuitStack, "ShortCircuitStack not used here" &
      --#        F, 10, VCGFailure, "VCGFailure not used here" &
      --#        F, 10, ContainsReals, "ContainsReals not used here";
      BuildExpnDAG
        (StartNode,
         Scope,
         Scope,
         0,
         False,
         False,
         LoopStack,
         FlowHeap,
         TheHeap,
         ContainsReals,
         VCGFailure,
         ShortCircuitStack,
         CheckStack,
         KindOfStackedCheck,
         DAGRoot);
      --# end accept;
   end BuildConstantInitializationDAG;

end DAG;
