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

separate (Sem.Wf_Basic_Declarative_Item.Wf_Basic_Declaration.Wf_Full_Type_Declaration)
procedure Wf_Derived
  (Node       : in     STree.SyntaxNode;
   Scope      : in     Dictionary.Scopes;
   Ident_Node : in     STree.SyntaxNode;
   Dec_Loc    : in     LexTokenManager.Token_Position;
   The_Heap   : in out Heap.HeapRecord)
is
   Base_Type_Node        : STree.SyntaxNode;
   Range_Constraint_Node : STree.SyntaxNode;
   Base_Type_Symbol      : Dictionary.Symbol;
   New_Type_Symbol       : Dictionary.Symbol;
   Left_Exp_Type         : Exp_Record;
   New_First, New_Last   : LexTokenManager.Lex_String := LexTokenManager.Null_String;
   New_Digits            : LexTokenManager.Lex_String;
   Unwanted_Seq          : SeqAlgebra.Seq;
   Unused_Component_Data : ComponentManager.ComponentData;
   Errors                : Boolean                    := False;
begin
   Base_Type_Node := Child_Node (Current_Node => Node);
   -- ASSUME Base_Type_Node = type_mark
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => Base_Type_Node) = SP_Symbols.type_mark,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Base_Type_Node = type_mark in Wf_Derived");

   Range_Constraint_Node := Next_Sibling (Current_Node => Base_Type_Node);
   -- ASSUME Range_Constraint_Node = range_constraint OR floating_point_constraint OR NULL
   if Range_Constraint_Node = STree.NullNode
     or else Syntax_Node_Type (Node => Range_Constraint_Node) = SP_Symbols.range_constraint then
      -- ASSUME Range_Constraint_Node = range_constraint OR NULL
      Wf_Type_Mark
        (Node          => Base_Type_Node,
         Current_Scope => Scope,
         Context       => Dictionary.ProgramContext,
         Type_Sym      => Base_Type_Symbol);

      if Dictionary.IsType (Base_Type_Symbol) then
         if Dictionary.DefinedInPackageStandard (Base_Type_Symbol)
           and then (Dictionary.TypeIsInteger (Base_Type_Symbol) or else Dictionary.TypeIsFloatingPoint (Base_Type_Symbol)) then

            if Range_Constraint_Node = STree.NullNode then
               -- ASSUME Range_Constraint_Node = NULL
               -- No range constraint, so pick up First and Last of new type
               -- directly from those of base type.
               New_First :=
                 Dictionary.GetScalarAttributeValue
                 (Base     => False,
                  Name     => LexTokenManager.First_Token,
                  TypeMark => Base_Type_Symbol);
               New_Last  :=
                 Dictionary.GetScalarAttributeValue
                 (Base     => False,
                  Name     => LexTokenManager.Last_Token,
                  TypeMark => Base_Type_Symbol);
            elsif Syntax_Node_Type (Node => Range_Constraint_Node) = SP_Symbols.range_constraint then
               -- ASSUME Range_Constraint_Node = range_constraint
               -- Range constraint specified, so we need to walk and evaluate those
               -- expressions.

               SeqAlgebra.CreateSeq (The_Heap, Unwanted_Seq);
               ComponentManager.Initialise (Unused_Component_Data);
               --# accept Flow, 10, Unused_Component_Data, "Expected ineffective assignment";
               Walk_Expression_P.Walk_Expression
                 (Exp_Node                => Range_Constraint_Node,
                  Scope                   => Scope,
                  Type_Context            => Base_Type_Symbol,
                  Context_Requires_Static => True,
                  Ref_Var                 => Unwanted_Seq,
                  Result                  => Left_Exp_Type,
                  Component_Data          => Unused_Component_Data,
                  The_Heap                => The_Heap);
               --# end accept;
               SeqAlgebra.DisposeOfSeq (The_Heap, Unwanted_Seq);

               Maths.StorageRep (Left_Exp_Type.Value, New_First);
               Maths.StorageRep (Left_Exp_Type.Range_RHS, New_Last);

               if Left_Exp_Type.Is_Static then
                  if (Dictionary.TypeIsInteger (Base_Type_Symbol) and then Dictionary.TypeIsInteger (Left_Exp_Type.Type_Symbol))
                    or else (Dictionary.TypeIsFloatingPoint (Base_Type_Symbol)
                               and then Dictionary.TypeIsFloatingPoint (Left_Exp_Type.Type_Symbol)) then
                     Errors := Left_Exp_Type.Errors_In_Expression;
                  else
                     ErrorHandler.Semantic_Error
                       (Err_Num   => 38,
                        Reference => ErrorHandler.No_Reference,
                        Position  => Node_Position (Node => Range_Constraint_Node),
                        Id_Str    => LexTokenManager.Null_String);
                     Errors := True;
                  end if;
               else
                  -- not static
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 45,
                     Reference => ErrorHandler.No_Reference,
                     Position  => Node_Position (Node => Range_Constraint_Node),
                     Id_Str    => LexTokenManager.Null_String);
                  Errors := True;
               end if;
            end if;

            -- If the base type is floating point, then inherit 'Digits from it.
            if Dictionary.TypeIsFloatingPoint (Base_Type_Symbol) then
               New_Digits :=
                 Dictionary.GetScalarAttributeValue
                 (Base     => False,
                  Name     => LexTokenManager.Digits_Token,
                  TypeMark => Base_Type_Symbol);
            else
               New_Digits := LexTokenManager.Null_String;
            end if;

            Check_Subtype_Against_Basetype_Bounds
              (Base_Type_Sym  => Base_Type_Symbol,
               Subtype_First  => New_First,
               Subtype_Last   => New_Last,
               Ident_Node_Pos => Node_Position (Node => Base_Type_Node),
               Range_Node_Pos => Node_Position (Node => Range_Constraint_Node),
               Errors         => Errors);

            if not Errors then
               if Dictionary.TypeIsInteger (Base_Type_Symbol) then
                  Dictionary.Add_Integer_Type
                    (Name        => Node_Lex_String (Node => Ident_Node),
                     Comp_Unit   => ContextManager.Ops.Current_Unit,
                     Declaration => Dictionary.Location'(Start_Position => Dec_Loc,
                                                         End_Position   => Dec_Loc),
                     Lower       => New_First,
                     Upper       => New_Last,
                     Scope       => Scope,
                     Context     => Dictionary.ProgramContext,
                     The_Type    => New_Type_Symbol);
               else
                  -- must be floating point
                  Dictionary.Add_Floating_Point_Type
                    (Name        => Node_Lex_String (Node => Ident_Node),
                     Comp_Unit   => ContextManager.Ops.Current_Unit,
                     Declaration => Dictionary.Location'(Start_Position => Dec_Loc,
                                                         End_Position   => Dec_Loc),
                     Lower       => New_First,
                     Upper       => New_Last,
                     Error_Bound => New_Digits,
                     Scope       => Scope,
                     Context     => Dictionary.ProgramContext,
                     The_Type    => New_Type_Symbol);
               end if;
               STree.Add_Node_Symbol (Node => Ident_Node,
                                      Sym  => New_Type_Symbol);
               Dictionary.SetBaseType (TypeMark => New_Type_Symbol,
                                       BaseType => Base_Type_Symbol);

               if ErrorHandler.Generate_SLI then
                  SLI.Generate_Xref_Symbol
                    (Comp_Unit      => ContextManager.Ops.Current_Unit,
                     Parse_Tree     => Ident_Node,
                     Symbol         => New_Type_Symbol,
                     Is_Declaration => True);
               end if;
            end if;
         else
            -- Not a predefined integer or floating point type, so...
            ErrorHandler.Semantic_Error
              (Err_Num   => 871,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Base_Type_Node),
               Id_Str    => LexTokenManager.Null_String);
         end if;
      else
         -- Not a type mark, so...
         ErrorHandler.Semantic_Error
           (Err_Num   => 871,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => Base_Type_Node),
            Id_Str    => LexTokenManager.Null_String);
      end if;
   elsif Syntax_Node_Type (Node => Range_Constraint_Node) = SP_Symbols.floating_point_constraint then
      -- ASSUME Range_Constraint_Node = floating_point_constraint
      ErrorHandler.Semantic_Error
        (Err_Num   => 608,
         Reference => 9,
         Position  => Node_Position (Node => Ident_Node),
         Id_Str    => LexTokenManager.Null_String);
   else
      SystemErrors.Fatal_Error
        (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Range_Constraint_Node = range_constraint OR floating_point_constraint OR NULL in Wf_Derived");
   end if;
end Wf_Derived;
