-------------------------------------------------------------------------------
-- (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.
--
--=============================================================================

-- This procedure checks assignment compatibility given a target type and
-- a record from the expression stack.  It checks type mismatches, use of
-- unqualified string literals, attempts to assign unconstrained objects
-- and assignement of arrays where the bounds do not match.  If any of these
-- checks fail the stack record is changed to the Unknown_Type_Record.
-- Scalars are also checked for Constraint_Error.  If this check fails, the
-- value field of the stack record is changed to Maths.NoValue.

separate (Sem)
procedure Assignment_Check
  (Position    : in     LexTokenManager.Token_Position;
   Scope       : in     Dictionary.Scopes;
   Target_Type : in     Dictionary.Symbol;
   Exp_Result  : in out Exp_Record)
is

   Exp_Value : Maths.Value;
   Store_Rep : LexTokenManager.Lex_String;

   procedure Raise_Error
     (Err_Num    : in     Natural;
      Ref        : in     Natural;
      Position   : in     LexTokenManager.Token_Position;
      Exp_Result :    out Exp_Record)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --# derives ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         Err_Num,
   --#                                         LexTokenManager.State,
   --#                                         Position,
   --#                                         Ref,
   --#                                         SPARK_IO.File_Sys &
   --#         Exp_Result                 from Dictionary.Dict;
   --# post Dictionary.Is_Null_Symbol (Exp_Result.Type_Symbol) or Dictionary.IsTypeMark (Exp_Result.Type_Symbol, Dictionary.Dict);
   is
   begin
      Exp_Result := Unknown_Type_Record;
      ErrorHandler.Semantic_Error
        (Err_Num   => Err_Num,
         Reference => Ref,
         Position  => Position,
         Id_Str    => LexTokenManager.Null_String);
   end Raise_Error;

begin -- Assignment_Check
   if not (Dictionary.IsUnknownTypeMark (Target_Type) or else Dictionary.IsUnknownTypeMark (Exp_Result.Type_Symbol)) then
      if Dictionary.IsPredefinedStringType (Exp_Result.Type_Symbol) then
         -- string literal or parameter
         -- check for type compatibility before other checks
         if not Dictionary.IsPredefinedStringType (Dictionary.GetRootType (Target_Type)) then
            ErrorHandler.Semantic_Error_Sym2
              (Err_Num   => 107,
               Reference => 8,
               Position  => Position,
               Sym       => Exp_Result.Type_Symbol,
               Sym2      => Target_Type,
               Scope     => Scope);
         else
            if Exp_Result.Range_RHS = Maths.NoValue then
               -- parameter
               -- can't assign a string parameter
               Raise_Error (Err_Num    => 39,
                            Ref        => 7,
                            Position   => Position,
                            Exp_Result => Exp_Result);
               -- if its a string literal its ok if the length is right
            elsif not Dictionary.IsPredefinedStringType (Target_Type) then
               Maths.StorageRep (Exp_Result.Range_RHS, Store_Rep);
               if LexTokenManager.Lex_String_Case_Insensitive_Compare
                 (Lex_Str1 => Dictionary.GetScalarAttributeValue
                    (False,
                     LexTokenManager.Last_Token,
                     Dictionary.CurrentSymbol (Dictionary.FirstArrayIndex (Target_Type))),
                  Lex_Str2 => Store_Rep) /=
                 LexTokenManager.Str_Eq then
                  Raise_Error (Err_Num    => 402,
                               Ref        => ErrorHandler.No_Reference,
                               Position   => Position,
                               Exp_Result => Exp_Result);
               end if;
            end if;
         end if;
      elsif Dictionary.Is_Unconstrained_Array_Type_Mark (Exp_Result.Type_Symbol, Scope) then
         Raise_Error (Err_Num    => 39,
                      Ref        => 7,
                      Position   => Position,
                      Exp_Result => Exp_Result);
      elsif not Dictionary.CompatibleTypes (Scope, Target_Type, Exp_Result.Type_Symbol) then
         ErrorHandler.Semantic_Error_Sym2
           (Err_Num   => 107,
            Reference => 8,
            Position  => Position,
            Sym       => Exp_Result.Type_Symbol,
            Sym2      => Target_Type,
            Scope     => Scope);
         Exp_Result := Unknown_Type_Record;
      elsif Exp_Result.Is_ARange then
         Raise_Error (Err_Num    => 91,
                      Ref        => ErrorHandler.No_Reference,
                      Position   => Position,
                      Exp_Result => Exp_Result);
      elsif Illegal_Unconstrained (Left_Type  => Target_Type,
                                   Right_Type => Exp_Result.Type_Symbol) then
         Raise_Error (Err_Num    => 418,
                      Ref        => 5,
                      Position   => Position,
                      Exp_Result => Exp_Result);
      else -- if there is no error we can check for constraint_error
         Constraint_Check
           (Val           => Exp_Result.Value,
            New_Val       => Exp_Value,
            Is_Annotation => False,
            Typ           => Target_Type,
            Position      => Position);
         Exp_Result.Value := Exp_Value;
      end if;
   end if;
end Assignment_Check;
