-------------------------------------------------------------------------------
-- (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 ContextManager;

separate (DAG)
package body Type_Constraint is

   ------------------------------------------------------------------------------
   --  Utility procedures
   ------------------------------------------------------------------------------

   --  The_Type xor The_Constraint must be non-null. We use the type
   --  if we have an actual index; we use the_constraint for the magic
   --  unconstrained array index.
   procedure Create_Quant_Ident
     (Quant_Ident     :    out Dictionary.Symbol;
      The_Type        : in     Dictionary.Symbol;
      The_Constraint  : in     Dictionary.Symbol;
      Scope           : in     Dictionary.Scopes;
      Quant_Id_Number : in out Positive)
   --# global in out Dictionary.Dict;
   --#        in out LexTokenManager.State;
   --#        in out SPARK_IO.File_Sys;
   --# post Quant_Id_Number = Quant_Id_Number~ + 1;
   is
      Ident_Str : LexTokenManager.Lex_String;

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

      procedure Create_Ident_Str (Ident_Str :    out LexTokenManager.Lex_String;
                                  Suffix    : in     Natural)
      --# global in out LexTokenManager.State;
      is
         Ex_Lin : E_Strings.T;
         Ex_Str : E_Strings.T;
      begin
         -- Add I___ to start of Ex_Lin
         Ex_Str := E_Strings.Copy_String (Str => "I___");
         E_Strings.Put_Int_To_String (Dest     => Ex_Lin,
                                      Item     => Suffix,
                                      Start_Pt => 1,
                                      Base     => 10);
         E_Strings.Append_Examiner_String (E_Str1 => Ex_Str,
                                           E_Str2 => Ex_Lin);
         LexTokenManager.Insert_Examiner_String (Str     => Ex_Str,
                                                 Lex_Str => Ident_Str);
      end Create_Ident_Str;

   begin -- Create_Quant_Ident
      Create_Ident_Str (Ident_Str => Ident_Str,
                        Suffix    => Quant_Id_Number);

      SystemErrors.RT_Assert
        (C       => Quant_Id_Number < Positive'Last,
         Sys_Err => SystemErrors.Other_Internal_Error,
         Msg     => "Seriously? You have positive__last number of nested quantifiers?");

      Quant_Id_Number := Quant_Id_Number + 1;

      Dictionary.AddQuantifiedVariable
        (Name          => Ident_Str,
         Comp_Unit     => ContextManager.NullUnit,
         Declaration   => Dictionary.Null_Location,
         TypeMark      => The_Type,
         TheConstraint => The_Constraint,
         Region        => Dictionary.GetRegion (Scope),
         Variable      => Quant_Ident);
   end Create_Quant_Ident;

   procedure Conjoin_Comma (NewConjunct : in     Cells.Cell;
                            VCGHeap     : in out Cells.Heap_Record;
                            Conjuncts   : in out Cells.Cell)
   --# global in out Statistics.TableUsage;
   is
      CommaCell : Cells.Cell;
   begin
      if Cells.Is_Null_Cell (Conjuncts) then
         Conjuncts := NewConjunct;
      else
         DAG.CreateOpCell (CommaCell, VCGHeap, SP_Symbols.comma);
         DAG.SetLeftArgument (CommaCell, Conjuncts, VCGHeap);
         DAG.SetRightArgument (CommaCell, NewConjunct, VCGHeap);
         Conjuncts := CommaCell;
      end if;
   end Conjoin_Comma;

   procedure Process_Always_Valid
     (The_Type       : in     Dictionary.Symbol;
      The_Expression : in     Cells.Cell;
      Assoc_Var      : in     Dictionary.Symbol;
      The_Constraint :    out Cells.Cell;
      VCG_Heap       : in out Cells.Heap_Record)
   --# global in out Statistics.TableUsage;
   is
      Type_Cell : Cells.Cell;
      AV_Cell   : Cells.Cell;
   begin
      Cells.Create_Cell (VCG_Heap, Type_Cell);
      Cells.Set_Kind (VCG_Heap, Type_Cell, Cell_Storage.Reference);
      Cells.Set_Symbol_Value (VCG_Heap, Type_Cell, The_Type);  -- Set the type
      Cells.Set_Assoc_Var (VCG_Heap, Type_Cell, Assoc_Var);    -- Set the variable

      Cells.Create_Cell (VCG_Heap, AV_Cell);
      Cells.Set_Kind (VCG_Heap, AV_Cell, Cell_Storage.Attrib_Function);
      Cells.Set_Lex_Str (VCG_Heap, AV_Cell, LexTokenManager.Always_Valid_Token);
      Cells.Set_Assoc_Var (VCG_Heap, AV_Cell, Assoc_Var);
      Cells.Set_B_Ptr (VCG_Heap, AV_Cell, The_Expression);

      Cells.Create_Cell (VCG_Heap, The_Constraint);
      Cells.Set_Kind (VCG_Heap, The_Constraint, Cell_Storage.Op);
      Cells.Set_Op_Symbol (VCG_Heap, The_Constraint, SP_Symbols.apostrophe);
      Cells.Set_A_Ptr (VCG_Heap, The_Constraint, Type_Cell);
      Cells.Set_B_Ptr (VCG_Heap, The_Constraint, AV_Cell);
   end Process_Always_Valid;

   ------------------------------------------------------------------------------
   --  The actual meat
   ------------------------------------------------------------------------------

   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)
   is
      --# hide Process_Type_Rec;
   begin
      Process_Type
        (The_Type        => The_Type,
         The_Expression  => The_Expression,
         Assoc_Var       => Assoc_Var,
         Constraint_List => Constraint_List,
         VCG_Heap        => VCG_Heap,
         Context         => Context);
   end Process_Type_Rec;

   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)
   is
      Exp_Copy                 : Cells.Cell;
      Attr_First, Attr_Last    : Cells.Cell;
      Lower_Bound, Upper_Bound : Cells.Cell;
   begin
      if Dictionary.IsTypeMark (The_Type) and then Dictionary.TypeIsBoolean (The_Type) then
         Cells.Utility.Create_Bool (VCG_Heap, True, The_Constraint);
      else
         --  Some callers of this may dispose of the original expression,
         --  so we best make a copy here.
         Structures.CopyStructure (VCG_Heap, The_Expression, Exp_Copy);

         --  Assemble the lower bound.
         Cells.Utility.Create_Type_Attribute
           (VCG_Heap      => VCG_Heap,
            The_Type      => The_Type,
            The_Attribute => Cells.Utility.Tick_First,
            Result        => Attr_First);
         Cells.Utility.Create_Binary_Op_Cell
           (VCG_Heap => VCG_Heap,
            Left     => Exp_Copy,
            Op       => SP_Symbols.greater_or_equal,
            Right    => Attr_First,
            Result   => Lower_Bound);

         --  Assemble the upper bound.
         Cells.Utility.Create_Type_Attribute
           (VCG_Heap      => VCG_Heap,
            The_Type      => The_Type,
            The_Attribute => Cells.Utility.Tick_Last,
            Result        => Attr_Last);
         Cells.Utility.Create_Binary_Op_Cell
           (VCG_Heap => VCG_Heap,
            Left     => Exp_Copy,
            Op       => SP_Symbols.less_or_equal,
            Right    => Attr_Last,
            Result   => Upper_Bound);

         --  Join the two together to form the constraint.
         Cells.Utility.Create_And (VCG_Heap => VCG_Heap,
                                   Left     => Lower_Bound,
                                   Right    => Upper_Bound,
                                   Conjunct => The_Constraint);
      end if;
   end Process_Discrete;

   --  The Assoc_Var is magical. If given, we no longer generate
   --  in-type constraints for the fields. Rather, the assumption is
   --  that we:
   --
   --     * Only want to produce hypotheses.
   --
   --     * All fields are assumed to never be in type.
   --
   --     * Some fields marked valid will yield a 'always_valid magic
   --       function.
   procedure Process_Record
     (Record_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;
   is
      Component      : Dictionary.Symbol;
      Component_Type : Dictionary.Symbol;
      Iter           : Dictionary.Iterator;

      Field_Cell : Cells.Cell;
      Tmp        : Cells.Cell;

      Tmp_List : Cells.Utility.List.Linked_List;
   begin
      Cells.Utility.List.Create (VCG_Heap, Constraint_List);

      --  We have two cases here, and yes, this is nasty. If we have
      --  an assoc var then we must necessarily also have an own in
      --  and we use it to go through the record; if we only have an
      --  expected type we use that and generate actual type
      --  constraints.
      if not Dictionary.Is_Null_Symbol (Assoc_Var) then

         if Dictionary.VariableOrSubcomponentIsMarkedValid (Assoc_Var) then

            Process_Always_Valid
              (The_Type       => Record_Type,
               The_Expression => The_Expression,
               Assoc_Var      => Assoc_Var,
               The_Constraint => Tmp,
               VCG_Heap       => VCG_Heap);
            Cells.Utility.List.Append (VCG_Heap, Constraint_List, Tmp);

         else
            Component := Dictionary.GetFirstRecordSubcomponent (Assoc_Var);

            while not Dictionary.Is_Null_Symbol (Component) loop
               Component_Type := Dictionary.GetType (Component);

               --  Create a field access to the record.
               Cells.Utility.Create_Record_Access
                 (The_Record    => The_Expression,
                  The_Component => Component,
                  The_Field     => Field_Cell,
                  VCG_Heap      => VCG_Heap);

               --  Work out the constraint and join it onto The_Constraint.
               Process_Type_Rec
                 (The_Type        => Component_Type,
                  The_Expression  => Field_Cell,
                  Assoc_Var       => Component,
                  Constraint_List => Tmp_List,
                  VCG_Heap        => VCG_Heap,
                  Context         => Context);
               Cells.Utility.List.Append_List (VCG_Heap, Constraint_List, Tmp_List);

               Component := Dictionary.GetNextRecordSubcomponent (Component);
            end loop;

            --  Note: We could check if all fields have been marked
            --  always valid and actually generate a `this record is
            --  always valid' instead of one for each field.
         end if;

      else
         Iter := Dictionary.FirstRecordComponent (Record_Type);
         while not Dictionary.IsNullIterator (Iter) loop
            Component      := Dictionary.CurrentSymbol (Iter);
            Component_Type := Dictionary.GetType (Component);

            --  Create a field access to the record.
            Cells.Utility.Create_Record_Access
              (The_Record    => The_Expression,
               The_Component => Component,
               The_Field     => Field_Cell,
               VCG_Heap      => VCG_Heap);

            --  Work out the constraint and add it onto the constraint
            --  list.
            Process_Type_Rec
              (The_Type        => Component_Type,
               The_Expression  => Field_Cell,
               Assoc_Var       => Dictionary.NullSymbol,
               Constraint_List => Tmp_List,
               VCG_Heap        => VCG_Heap,
               Context         => Context);
            Cells.Utility.List.Append_List (VCG_Heap, Constraint_List, Tmp_List);

            Iter := Dictionary.NextSymbol (Iter);
         end loop;
      end if;

   end Process_Record;

   --  Again, either The_Index_Type or The_P_Constraint must not be
   --  null.
   procedure Make_Quantifier
     (The_Index_Type   : in     Dictionary.Symbol;
      The_P_Constraint : in     Dictionary.Symbol;
      The_Quantifier   :    out Cells.Cell;
      The_Body_Ptr     :    out Cells.Cell;
      The_Identifier   :    out Dictionary.Symbol;
      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;
   is
      Decl_Cell        : Cells.Cell;
      Comma_Cell       : Cells.Cell;
      Range_Constraint : Cells.Cell;
      Ident_Ref        : Cells.Cell;
      Type_Ref         : Cells.Cell;
      Real_Index_Type  : Dictionary.Symbol;
   begin
      --  Make the identifier.
      Create_Quant_Ident
        (Quant_Ident     => The_Identifier,
         The_Constraint  => The_P_Constraint,
         The_Type        => The_Index_Type,
         Scope           => Context.Scope,
         Quant_Id_Number => Context.Quant_Id_Number);

      --  Make the index in-type constraint: work out the bounds for
      --  the index and the fdl type of the quantified identifier.
      DAG.CreateReferenceCell (Ident_Ref, VCG_Heap, The_Identifier);
      if Dictionary.Is_Null_Symbol (The_Index_Type) then
         --  No actual index, this means we have an unconstrained
         --  array.
         Real_Index_Type := Dictionary.Get_Unconstrained_Array_Index (The_Identifier);
         DAG.CreateFixedVarCell (Type_Ref, VCG_Heap, Dictionary.GetRootType (Dictionary.GetType (Real_Index_Type)));
      else
         --  We do have an index, so just use that.
         Real_Index_Type := The_Index_Type;
         DAG.CreateFixedVarCell (Type_Ref, VCG_Heap, Dictionary.GetRootType (Real_Index_Type));
      end if;

      --  We can only have arrays indexed by discrete
      --  types. Indexing by private types or similar is not
      --  allowed, so process_discrete is OK to use here.
      Process_Discrete
        (The_Type       => Real_Index_Type,
         The_Expression => Ident_Ref,
         The_Constraint => Range_Constraint,
         VCG_Heap       => VCG_Heap);

      if Cells.Is_Null_Cell (Range_Constraint) then
         DAG.CreateTrueCell (VCG_Heap, Range_Constraint);
      end if;

      --  Now we assemble the DAG for the quantifier.

      --  The_Identifier : The_Index_Type
      DAG.CreateOpCell (Decl_Cell, VCG_Heap, SP_Symbols.colon);
      DAG.SetLeftArgument (Decl_Cell, Ident_Ref, VCG_Heap);
      DAG.SetRightArgument (Decl_Cell, Type_Ref, VCG_Heap);

      --  [range constraint] -> ???
      DAG.CreateOpCell (The_Body_Ptr, VCG_Heap, SP_Symbols.implies);
      DAG.SetLeftArgument (The_Body_Ptr, Range_Constraint, VCG_Heap);
      -- the right ptr will be filled in by the calling procedure.

      --  [decl_cell], [the_predicate]
      DAG.CreateOpCell (Comma_Cell, VCG_Heap, SP_Symbols.comma);
      DAG.SetLeftArgument (Comma_Cell, Decl_Cell, VCG_Heap);
      DAG.SetRightArgument (Comma_Cell, The_Body_Ptr, VCG_Heap);

      --  for_all [comma_cell]
      DAG.CreateOpCell (The_Quantifier, VCG_Heap, SP_Symbols.RWforall);
      DAG.SetRightArgument (The_Quantifier, Comma_Cell, VCG_Heap);
   end Make_Quantifier;

   procedure Process_Array
     (The_Type        : in     Dictionary.Symbol;
      The_Expression  : in     Cells.Cell;
      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;
   is
      N_Dim          : Positive;
      Body_Ptr       : Cells.Cell;
      Tmp_Ident      : Dictionary.Symbol;
      Tmp_Ident_Ref  : Cells.Cell;
      Tmp_Quant      : Cells.Cell;
      New_Body_Ptr   : Cells.Cell;
      Element_Cell   : Cells.Cell;
      Tmp_Constraint : Cells.Cell;
      Final_Index    : Cells.Cell := Cells.Null_Cell;
      Quant_Root     : Cells.Cell;
      Tmp_List       : Cells.Utility.List.Linked_List;
      List_Iter      : Cells.Utility.List.Iterator;
      Quant_Copy     : Cells.Cell;

      function Get_Index_Type
        (The_Array_Type : in Dictionary.Symbol;
         Dimension      : in Positive;
         Context        : in Context_T)
        return           Dictionary.Symbol
      --# global in Dictionary.Dict;
      is
         R : Dictionary.Symbol;
      begin
         if Dictionary.Is_Unconstrained_Array_Type_Mark (The_Array_Type, Context.Scope) then
            R := Dictionary.NullSymbol;
         else
            R := Dictionary.GetArrayIndex (The_Array_Type, Dimension);
         end if;
         return R;
      end Get_Index_Type;

      function Get_P_Constraint
        (The_Array_Type : in Dictionary.Symbol;
         Dimension      : in Positive;
         Context        : in Context_T)
        return           Dictionary.Symbol
      --# global in Dictionary.Dict;
      is
         R : Dictionary.Symbol;
      begin
         if Dictionary.Is_Unconstrained_Array_Type_Mark (The_Array_Type, Context.Scope) then
            R := Dictionary.GetSubprogramParameterConstraint (Context.Initial_Var, Dimension);
         else
            R := Dictionary.NullSymbol;
         end if;
         return R;
      end Get_P_Constraint;

   begin
      N_Dim := Dictionary.GetNumberOfDimensions (The_Type);

      --  Create the first outermost quantifier.
      Make_Quantifier
        (The_Index_Type   => Get_Index_Type (The_Type, 1, Context),
         The_P_Constraint => Get_P_Constraint (The_Type, 1, Context),
         The_Quantifier   => Quant_Root,
         The_Body_Ptr     => Body_Ptr,
         The_Identifier   => Tmp_Ident,
         VCG_Heap         => VCG_Heap,
         Context          => Context);
      DAG.CreateReferenceCell (Tmp_Ident_Ref, VCG_Heap, Tmp_Ident);
      Conjoin_Comma (Tmp_Ident_Ref, VCG_Heap, Final_Index);

      --  Chain the other quantifiers for the higher dimensions.
      for Dim in Positive range 2 .. N_Dim loop
         Make_Quantifier
           (The_Index_Type   => Get_Index_Type (The_Type, Dim, Context),
            The_P_Constraint => Get_P_Constraint (The_Type, Dim, Context),
            The_Quantifier   => Tmp_Quant,
            The_Body_Ptr     => New_Body_Ptr,
            The_Identifier   => Tmp_Ident,
            VCG_Heap         => VCG_Heap,
            Context          => Context);
         DAG.CreateReferenceCell (Tmp_Ident_Ref, VCG_Heap, Tmp_Ident);
         Conjoin_Comma (Tmp_Ident_Ref, VCG_Heap, Final_Index);

         DAG.SetRightArgument (Body_Ptr, Tmp_Quant, VCG_Heap);
         Body_Ptr := New_Body_Ptr;
      end loop;

      --  We can now generate the constraint for each element. First
      --  we need an array access.
      Cells.Utility.Create_Array_Access
        (VCG_Heap    => VCG_Heap,
         The_Array   => The_Expression,
         The_Index   => Final_Index,
         The_Element => Element_Cell);

      --  Now we create the constraint for the element type.
      Process_Type_Rec
        (The_Type        => Dictionary.GetArrayComponent (The_Type),
         The_Expression  => Element_Cell,
         Assoc_Var       => Dictionary.NullSymbol,
         Constraint_List => Tmp_List,
         VCG_Heap        => VCG_Heap,
         Context         => Context);

      Cells.Utility.List.Create (VCG_Heap, Constraint_List);

      List_Iter := Cells.Utility.List.First_Cell (VCG_Heap, Tmp_List);
      while not Cells.Utility.List.Is_Null_Iterator (List_Iter) loop
         --  Obtain a constraint.
         Tmp_Constraint := Cells.Utility.List.Current_Cell (VCG_Heap, List_Iter);

         if Cells.Utility.Is_True (VCG_Heap, Tmp_Constraint) then
            --  Do nothing; no need to add this to the list.
            null;

         else
            --  In our temp quantifier, substitute this constraint in.
            DAG.SetRightArgument (Body_Ptr, Tmp_Constraint, VCG_Heap);

            --  Now we copy the entire thing. This means in the next
            --  iteration we can again make use of Body_Ptr to just
            --  change the predicate.
            Structures.CopyStructure (VCG_Heap, Quant_Root, Quant_Copy);

            --  Finally we shove what we have in the constraint list
            --  returned by this procedure.
            Cells.Utility.List.Append (VCG_Heap, Constraint_List, Quant_Copy);
         end if;

         --  Advance the iterator.
         List_Iter := Cells.Utility.List.Next_Cell (VCG_Heap, List_Iter);
      end loop;

      --  TODO: Clean up the quantifier skeleton.
   end Process_Array;

   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)
   is
      The_Constraint : Cells.Cell;
   begin

      --  Try not change the order of these. The following constraints
      --  exist:
      --
      --  * We need to check for private (and similar) types first.
      --
      --  * We need to go through the special record case before we
      --    handle the other always_valid cases.
      --
      --  * We need to check for always valid before we go through any
      --    other case.

      if
        --  The predefined time types are magical.
        not (Dictionary.IsPredefinedTimeType (The_Type) or Dictionary.IsPredefinedTimeSpanType (The_Type))
        and then

        --  Check if we don't know anything about this type.
        (Dictionary.IsPrivateType (The_Type, Context.Scope) or
           Dictionary.TypeIsBoolean (The_Type) or
           Dictionary.TypeIsOwnAbstractHere (The_Type, Context.Scope) or
           Dictionary.IsProtectedType (The_Type)) then
         --  Booleans never have a typecheck. Abstract owns are just
         --  like private types, which also do not have a
         --  typecheck. We also don't typecheck protected types for
         --  the same reason.

         Cells.Utility.List.Create (VCG_Heap, Constraint_List);

      elsif DAG.RecordTypeWithCheck (The_Type, Context.Scope) then
         Process_Record
           (Record_Type     => The_Type,
            The_Expression  => The_Expression,
            Assoc_Var       => Assoc_Var,
            Constraint_List => Constraint_List,
            VCG_Heap        => VCG_Heap,
            Context         => Context);

      elsif not Dictionary.Is_Null_Symbol (Assoc_Var) then

         --  If we have an assoc var, then this means that
         --  Consider_Always_Valid has been requested. This variable
         --  is an own in variable; if it is always valid we say so
         --  otherwise we generate just `true' as an in-type
         --  hypotheses.
         Cells.Utility.List.Create (VCG_Heap, Constraint_List);

         if Dictionary.VariableOrSubcomponentIsMarkedValid (Assoc_Var) then
            Process_Always_Valid
              (The_Type       => The_Type,
               The_Expression => The_Expression,
               Assoc_Var      => Assoc_Var,
               The_Constraint => The_Constraint,
               VCG_Heap       => VCG_Heap);
            Cells.Utility.List.Append (VCG_Heap, Constraint_List, The_Constraint);
         else
            --  Do nothing.
            null;
         end if;

      elsif DAG.DiscreteTypeWithCheck (The_Type, Context.Scope) then
         Process_Discrete
           (The_Type       => The_Type,
            The_Expression => The_Expression,
            The_Constraint => The_Constraint,
            VCG_Heap       => VCG_Heap);

         Cells.Utility.List.Create (VCG_Heap, Constraint_List);
         Cells.Utility.List.Append (VCG_Heap, Constraint_List, The_Constraint);

         if DAG.IsRealType (The_Type) then
            Context.VC_Contains_Reals := True;
         end if;

      elsif DAG.ArrayTypeWithCheck (The_Type, Context.Scope) then
         Process_Array
           (The_Type        => The_Type,
            The_Expression  => The_Expression,
            Constraint_List => Constraint_List,
            VCG_Heap        => VCG_Heap,
            Context         => Context);

      elsif Dictionary.IsUnknownTypeMark (The_Type) then
         --  In the old world of CreateStuctConstraint we used to
         --  silently generate `true'. Now we fail with more noise. We
         --  can get here if, for example, we had semantic errors
         --  earlier in the analysis.

         Cells.Utility.List.Create (VCG_Heap, Constraint_List);
         Context.VC_Failure := True;

      else
         Cells.Utility.List.Create (VCG_Heap, Constraint_List);
         Context.VC_Failure := True;

         Debug.PrintMsg ("*****************************************************************************", True);
         Debug.PrintBool ("* istype: ", Dictionary.IsType (The_Type));
         Debug.Print_Sym ("* offending type: ", The_Type);
         Debug.PrintBool ("* is_task: ", Dictionary.TypeIsTask (The_Type));
         Debug.PrintBool ("* is_own: ", Dictionary.TypeIsOwnAbstractHere (The_Type, Context.Scope));
         Debug.PrintDAG ("* exp: ", The_Expression, VCG_Heap, Context.Scope);
         SystemErrors.Fatal_Error (SystemErrors.Assertion_Failure, "unhandeled type in DAG.create_constraint");
      end if;

      --  Debug.PrintDAG (">>> ", The_Constraint, VCG_Heap, Context.Scope);

   end Process_Type;

   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)
   is
      --# hide Make;
      --  So we can transition to flow=auto here.

      Context         : Context_T;
      Assoc_Var       : Dictionary.Symbol;
      Initial_Var     : Dictionary.Symbol;
      Constraint_List : Cells.Utility.List.Linked_List;
   begin
      --  Debug.PrintMsg ("Creating contraint for:", True);
      --  Debug.PrintScope ("   scope: ", Scope);
      --  Debug.Print_Sym  ("   type : ", The_Type);
      --  Debug.PrintDAG   ("   expr : ", The_Expression, VCG_Heap, Scope);

      --  The initial variable is used to deal with unconstrained
      --  arrays.
      if Cells.Get_Kind (VCG_Heap, The_Expression) = Cell_Storage.Fixed_Var or
        Cells.Is_Reference_Cell (VCG_Heap, The_Expression) then
         Initial_Var := Cells.Get_Symbol_Value (VCG_Heap, The_Expression);
      else
         Initial_Var := Dictionary.NullSymbol;
      end if;

      Context :=
        Context_T'
        (VC_Contains_Reals => VC_Contains_Reals,
         VC_Failure        => VC_Failure,
         Quant_Id_Number   => 1,
         Scope             => Scope,
         Initial_Var       => Initial_Var);

      --  If we are asked to consider 'Always_Valid, we need to work
      --  out the actual variable that The_Expression represents. This
      --  significantly changes the behaviour of the code in this
      --  package. If the entire variable is marked always valid we
      --  generate a very special constraint. For records with
      --  individual fields marked always_valid, we do something very
      --  different. See Process_Record for a description.
      if Consider_Always_Valid then
         Assoc_Var := Initial_Var;
         if not (Dictionary.GetOwnVariableOrConstituentMode (Assoc_Var) = Dictionary.InMode) then
            --  If this is not actually an own in, we don't care.
            Assoc_Var := Dictionary.NullSymbol;
         end if;
      else
         Assoc_Var := Dictionary.NullSymbol;
      end if;

      Process_Type
        (The_Type        => The_Type,
         The_Expression  => The_Expression,
         Assoc_Var       => Assoc_Var,
         Constraint_List => Constraint_List,
         VCG_Heap        => VCG_Heap,
         Context         => Context);

      Cells.Utility.List.Join_And (VCG_Heap, Constraint_List, The_Constraint);

      VC_Contains_Reals := Context.VC_Contains_Reals;
      VC_Failure        := Context.VC_Failure;

      --  Debug.PrintDAG   ("   const: ", The_Constraint, VCG_Heap, Scope);
   end Make;

end Type_Constraint;
