Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              S E M _ D I M                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 2011-2012, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT 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 GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

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

with Aspects;  use Aspects;

with Atree;    use Atree;

with Einfo;    use Einfo;

with Errout;   use Errout;

with Lib;      use Lib;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

with Opt;      use Opt;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Eval; use Sem_Eval;

with Sem_Res;  use Sem_Res;

with Sinfo;    use Sinfo;

with Snames;   use Snames;

with Stand;    use Stand;

with Stringt;  use Stringt;

with Table;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

with Urealp;   use Urealp;

with GNAT.HTable;

package body Sem_Dim is

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

   -- Rational arithmetic --

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

   type Whole is new Int;

   subtype Positive_Whole is Whole range 1 .. Whole'Last;

   type Rational is record

      Numerator   : Whole;

      Denominator : Positive_Whole;

   end record;

   Zero : constant Rational := Rational'(Numerator =>   0,

                                         Denominator => 1);

   No_Rational : constant Rational := Rational'(Numerator =>   0,

                                                Denominator => 2);

   --  Used to indicate an expression that cannot be interpreted as a rational

   --  Returned value of the Create_Rational_From routine when parameter Expr

   --  is not a static representation of a rational.

   --  Rational constructors

   function "+" (Right : Whole) return Rational;

   function GCD (Left, Right : Whole) return Int;

   function Reduce (X : Rational) return Rational;

   --  Unary operator for Rational

   function "-" (Right : Rational) return Rational;

   function "abs" (Right : Rational) return Rational;

   --  Rational operations for Rationals

   function "+" (Left, Right : Rational) return Rational;

   function "-" (Left, Right : Rational) return Rational;

   function "*" (Left, Right : Rational) return Rational;

   function "/" (Left, Right : Rational) return Rational;

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

   -- System types --

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

   Max_Number_Of_Dimensions : constant := 7;

   --  Maximum number of dimensions in a dimension system

   High_Position_Bound : constant := Max_Number_Of_Dimensions;

   Invalid_Position    : constant := 0;

   Low_Position_Bound  : constant := 1;

   subtype Dimension_Position is

     Nat range Invalid_Position .. High_Position_Bound;

   type Name_Array is

     array (Dimension_Position range

              Low_Position_Bound .. High_Position_Bound) of Name_Id;

   --  A data structure used to store the names of all units within a system

   No_Names : constant Name_Array := (others => No_Name);

   type Symbol_Array is

     array (Dimension_Position range

              Low_Position_Bound ..  High_Position_Bound) of String_Id;

   --  A data structure used to store the symbols of all units within a system

   No_Symbols : constant Symbol_Array := (others => No_String);

   type System_Type is record

      Type_Decl : Node_Id;

      Names     : Name_Array;

      Symbols   : Symbol_Array;

      Count     : Dimension_Position;

   end record;

   Null_System : constant System_Type :=

                   (Empty, No_Names, No_Symbols, Invalid_Position);

   subtype System_Id is Nat;

   --  The following table maps types to systems

   package System_Table is new Table.Table (

     Table_Component_Type => System_Type,

     Table_Index_Type     => System_Id,

     Table_Low_Bound      => 1,

     Table_Initial        => 5,

     Table_Increment      => 5,

     Table_Name           => "System_Table");

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

   -- Dimension type --

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

   type Dimension_Type is

     array (Dimension_Position range

              Low_Position_Bound ..  High_Position_Bound) of Rational;

   Null_Dimension : constant Dimension_Type := (others => Zero);

   type Dimension_Table_Range is range 0 .. 510;

   function Dimension_Table_Hash (Key : Node_Id) return Dimension_Table_Range;

   --  The following table associates nodes with dimensions

   package Dimension_Table is new

     GNAT.HTable.Simple_HTable

       (Header_Num => Dimension_Table_Range,

        Element    => Dimension_Type,

        No_Element => Null_Dimension,

        Key        => Node_Id,

        Hash       => Dimension_Table_Hash,

        Equal      => "=");

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

   -- Symbol types --

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

   type Symbol_Table_Range is range 0 .. 510;

   function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range;

   --  Each subtype with a dimension has a symbolic representation of the

   --  related unit. This table establishes a relation between the subtype

   --  and the symbol.

   package Symbol_Table is new

     GNAT.HTable.Simple_HTable

       (Header_Num => Symbol_Table_Range,

        Element    => String_Id,

        No_Element => No_String,

        Key        => Entity_Id,

        Hash       => Symbol_Table_Hash,

        Equal      => "=");

   --  The following array enumerates all contexts which may contain or

   --  produce a dimension.

   OK_For_Dimension : constant array (Node_Kind) of Boolean :=

     (N_Attribute_Reference       => True,

      N_Defining_Identifier       => True,

      N_Function_Call             => True,

      N_Identifier                => True,

      N_Indexed_Component         => True,

      N_Integer_Literal           => True,

      N_Op_Abs                    => True,

      N_Op_Add                    => True,

      N_Op_Divide                 => True,

      N_Op_Expon                  => True,

      N_Op_Minus                  => True,

      N_Op_Mod                    => True,

      N_Op_Multiply               => True,

      N_Op_Plus                   => True,

      N_Op_Rem                    => True,

      N_Op_Subtract               => True,

      N_Qualified_Expression      => True,

      N_Real_Literal              => True,

      N_Selected_Component        => True,

      N_Slice                     => True,

      N_Type_Conversion           => True,

      N_Unchecked_Type_Conversion => True,

      others                      => False);

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

   -- Local Subprograms --

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

   procedure Analyze_Dimension_Assignment_Statement (N : Node_Id);

   --  Subroutine of Analyze_Dimension for assignment statement. Check that the

   --  dimensions of the left-hand side and the right-hand side of N match.

   procedure Analyze_Dimension_Binary_Op (N : Node_Id);

   --  Subroutine of Analyze_Dimension for binary operators. Check the

   --  dimensions of the right and the left operand permit the operation.

   --  Then, evaluate the resulting dimensions for each binary operator.

   procedure Analyze_Dimension_Component_Declaration (N : Node_Id);

   --  Subroutine of Analyze_Dimension for component declaration. Check that

   --  the dimensions of the type of N and of the expression match.

   procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id);

   --  Subroutine of Analyze_Dimension for extended return statement. Check

   --  that the dimensions of the returned type and of the returned object

   --  match.

   procedure Analyze_Dimension_Function_Call (N : Node_Id);

   --  Subroutine of Analyze_Dimension for function call. General case:

   --  propagate the dimensions from the returned type to N. Elementary

   --  function case (Ada.Numerics.Generic_Elementary_Functions): If N

   --  is a Sqrt call, then evaluate the resulting dimensions as half the

   --  dimensions of the parameter. Otherwise, verify that each parameters

   --  are dimensionless.

   procedure Analyze_Dimension_Has_Etype (N : Node_Id);

   --  Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by

   --  the list below:

   --    N_Attribute_Reference

   --    N_Identifier

   --    N_Indexed_Component

   --    N_Qualified_Expression

   --    N_Selected_Component

   --    N_Slice

   --    N_Type_Conversion

   --    N_Unchecked_Type_Conversion

   procedure Analyze_Dimension_Object_Declaration (N : Node_Id);

   --  Subroutine of Analyze_Dimension for object declaration. Check that

   --  the dimensions of the object type and the dimensions of the expression

   --  (if expression is present) match. Note that when the expression is

   --  a literal, no error is returned. This special case allows object

   --  declaration such as: m : constant Length := 1.0;

   procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id);

   --  Subroutine of Analyze_Dimension for object renaming declaration. Check

   --  the dimensions of the type and of the renamed object name of N match.

   procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id);

   --  Subroutine of Analyze_Dimension for simple return statement

   --  Check that the dimensions of the returned type and of the returned

   --  expression match.

   procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id);

   --  Subroutine of Analyze_Dimension for subtype declaration. Propagate the

   --  dimensions from the parent type to the identifier of N. Note that if

   --  both the identifier and the parent type of N are not dimensionless,

   --  return an error.

   procedure Analyze_Dimension_Unary_Op (N : Node_Id);

   --  Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and

   --  Abs operators, propagate the dimensions from the operand to N.

   function Create_Rational_From

     (Expr     : Node_Id;

      Complain : Boolean) return Rational;

   --  Given an arbitrary expression Expr, return a valid rational if Expr can

   --  be interpreted as a rational. Otherwise return No_Rational and also an

   --  error message if Complain is set to True.

   function Dimensions_Of (N : Node_Id) return Dimension_Type;

   --  Return the dimension vector of node N

   function Dimensions_Msg_Of (N : Node_Id) return String;

   --  Given a node, return "has dimension" followed by the dimension vector of

   --  N or "is dimensionless" if N is dimensionless.

   procedure Eval_Op_Expon_With_Rational_Exponent

     (N              : Node_Id;

      Exponent_Value : Rational);

   --  Evaluate the exponent it is a rational and the operand has a dimension

   function Exists (Dim : Dimension_Type) return Boolean;

   --  Returns True iff Dim does not denote the null dimension

   function Exists (Sys : System_Type) return Boolean;

   --  Returns True iff Sys does not denote the null system

   function From_Dimension_To_String_Of_Symbols

     (Dims   : Dimension_Type;

      System : System_Type) return String_Id;

   --  Given a dimension vector and a dimension system, return the proper

   --  string of symbols.

   function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean;

   --  Return True if E is the package entity of System.Dim.Float_IO or

   --  System.Dim.Integer_IO.

   function Is_Invalid (Position : Dimension_Position) return Boolean;

   --  Return True if Pos denotes the invalid position

   procedure Move_Dimensions (From : Node_Id; To : Node_Id);

   --  Copy dimension vector of From to To, delete dimension vector of From

   procedure Remove_Dimensions (N : Node_Id);

   --  Remove the dimension vector of node N

   procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type);

   --  Associate a dimension vector with a node

   procedure Set_Symbol (E : Entity_Id; Val : String_Id);

   --  Associate a symbol representation of a dimension vector with a subtype

   function Symbol_Of (E : Entity_Id) return String_Id;

   --  E denotes a subtype with a dimension. Return the symbol representation

   --  of the dimension vector.

   function System_Of (E : Entity_Id) return System_Type;

   --  E denotes a type, return associated system of the type if it has one

   ---------

   -- "+" --

   ---------

   function "+" (Right : Whole) return Rational is

   begin

      return Rational'(Numerator =>   Right,

                       Denominator => 1);

   end "+";

   function "+" (Left, Right : Rational) return Rational is

      R : constant Rational :=

            Rational'(Numerator =>   Left.Numerator * Right.Denominator +

                                       Left.Denominator * Right.Numerator,

                      Denominator => Left.Denominator * Right.Denominator);

   begin

      return Reduce (R);

   end "+";

   ---------

   -- "-" --

   ---------

   function "-" (Right : Rational) return Rational is

   begin

      return Rational'(Numerator =>   -Right.Numerator,

                       Denominator => Right.Denominator);

   end "-";

   function "-" (Left, Right : Rational) return Rational is

      R : constant Rational :=

            Rational'(Numerator =>   Left.Numerator * Right.Denominator -

                                       Left.Denominator * Right.Numerator,

                      Denominator => Left.Denominator * Right.Denominator);

   begin

      return Reduce (R);

   end "-";

   ---------

   -- "*" --

   ---------

   function "*" (Left, Right : Rational) return Rational is

      R : constant Rational :=

            Rational'(Numerator =>   Left.Numerator * Right.Numerator,

                      Denominator => Left.Denominator * Right.Denominator);

   begin

      return Reduce (R);

   end "*";

   ---------

   -- "/" --

   ---------

   function "/" (Left, Right : Rational) return Rational is

      R : constant Rational := abs Right;

      L : Rational := Left;

   begin

      if Right.Numerator < 0 then

         L.Numerator := Whole (-Integer (L.Numerator));

      end if;

      return Reduce (Rational'(Numerator =>   L.Numerator * R.Denominator,

                               Denominator => L.Denominator * R.Numerator));

   end "/";

   -----------

   -- "abs" --

   -----------

   function "abs" (Right : Rational) return Rational is

   begin

      return Rational'(Numerator =>   abs Right.Numerator,

                       Denominator => Right.Denominator);

   end "abs";

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

   -- Analyze_Aspect_Dimension --

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

   --  with Dimension => DIMENSION_FOR_SUBTYPE

   --  DIMENSION_FOR_SUBTYPE ::= (DIMENSION_STRING, DIMENSION_RATIONALS)

   --  DIMENSION_RATIONALS ::=

   --    RATIONAL,  {, RATIONAL}

   --  | RATIONAL {, RATIONAL}, others => RATIONAL

   --  | DISCRETE_CHOICE_LIST => RATIONAL

   --  RATIONAL ::= [-] NUMERAL [/ NUMERAL]

   --  (see Analyze_Aspect_Dimension_System for DIMENSION_STRING grammar)

   procedure Analyze_Aspect_Dimension

     (N    : Node_Id;

      Id   : Entity_Id;

      Aggr : Node_Id)

   is

      Def_Id    : constant Entity_Id := Defining_Identifier (N);

      Processed : array (Dimension_Type'Range) of Boolean := (others => False);

      --  This array is used when processing ranges or Others_Choice as part of

      --  the dimension aggregate.

      Dimensions : Dimension_Type := Null_Dimension;

      procedure Extract_Power

        (Expr     : Node_Id;

         Position : Dimension_Position);

      --  Given an expression with denotes a rational number, read the number

      --  and associate it with Position in Dimensions.

      function Has_Compile_Time_Known_Expressions

        (Aggr : Node_Id) return Boolean;

      --  Determine whether aggregate Aggr contains only expressions that are

      --  known at compile time.

      function Position_In_System

        (Id     : Node_Id;

         System : System_Type) return Dimension_Position;

      --  Given an identifier which denotes a dimension, return the position of

      --  that dimension within System.

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

      -- Extract_Power --

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

      procedure Extract_Power

        (Expr     : Node_Id;

         Position : Dimension_Position)

      is

      begin

         if Is_Integer_Type (Def_Id) then

            Dimensions (Position) := +Whole (UI_To_Int (Expr_Value (Expr)));

         else

            Dimensions (Position) := Create_Rational_From (Expr, True);

         end if;

         Processed (Position) := True;

      end Extract_Power;

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

      -- Has_Compile_Time_Known_Expressions --

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

      function Has_Compile_Time_Known_Expressions

        (Aggr : Node_Id) return Boolean

      is

         Comp : Node_Id;

         Expr : Node_Id;

      begin

         Expr := First (Expressions (Aggr));

         if Present (Expr) then

            --  The first expression within the aggregate describes the

            --  symbolic name of a dimension, skip it.

            Next (Expr);

            while Present (Expr) loop

               Analyze_And_Resolve (Expr);

               if not Compile_Time_Known_Value (Expr) then

                  return False;

               end if;

               Next (Expr);

            end loop;

         end if;

         Comp := First (Component_Associations (Aggr));

         while Present (Comp) loop

            Expr := Expression (Comp);

            Analyze_And_Resolve (Expr);

            if not Compile_Time_Known_Value (Expr) then

               return False;

            end if;

            Next (Comp);

         end loop;

         return True;

      end Has_Compile_Time_Known_Expressions;

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

      -- Position_In_System --

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

      function Position_In_System

        (Id     : Node_Id;

         System : System_Type) return Dimension_Position

      is

         Dimension_Name : constant Name_Id := Chars (Id);

      begin

         for Position in System.Names'Range loop

            if Dimension_Name = System.Names (Position) then

               return Position;

            end if;

         end loop;

         return Invalid_Position;

      end Position_In_System;

      --  Local variables

      Assoc          : Node_Id;

      Choice         : Node_Id;

      Expr           : Node_Id;

      Num_Choices    : Nat := 0;

      Num_Dimensions : Nat := 0;

      Others_Seen    : Boolean := False;

      Position       : Nat := 0;

      Sub_Ind        : Node_Id;

      Symbol         : String_Id;

      Symbol_Decl    : Node_Id;

      System         : System_Type;

      Typ            : Entity_Id;

      Errors_Count : Nat;

      --  Errors_Count is a count of errors detected by the compiler so far

      --  just before the extraction of names and values in the aggregate

      --  (Step 3).

      --

      --  At the end of the analysis, there is a check to verify that this

      --  count equals to Serious_Errors_Detected i.e. no erros have been

      --  encountered during the process. Otherwise the Dimension_Table is

      --  not filled.

   --  Start of processing for Analyze_Aspect_Dimension

   begin

      --  STEP 1: Legality of aspect

      if Nkind (N) /= N_Subtype_Declaration then

         Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id);

         return;

      end if;

      Sub_Ind := Subtype_Indication (N);

      Typ := Etype (Sub_Ind);

      System := System_Of (Typ);

      if Nkind (Sub_Ind) = N_Subtype_Indication then

         Error_Msg_NE

           ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);

         return;

      end if;

      if Nkind (Aggr) /= N_Aggregate then

         Error_Msg_N ("aggregate expected", Aggr);

         return;

      end if;

      --  Each expression in dimension aggregate must be known at compile time

      if not Has_Compile_Time_Known_Expressions (Aggr) then

         Error_Msg_N ("values of aggregate must be static", Aggr);

         return;

      end if;

      --  The dimension declarations are useless if the parent type does not

      --  declare a valid system.

      if not Exists (System) then

         Error_Msg_NE

           ("parent type of& lacks dimension system", Sub_Ind, Def_Id);

         return;

      end if;

      --  STEP 2: Structural verification of the dimension aggregate

      --  The first entry in the aggregate is the symbolic representation of

      --  the dimension.

      Symbol_Decl := First (Expressions (Aggr));

      if No (Symbol_Decl)

        or else not Nkind_In (Symbol_Decl, N_Character_Literal,

                                           N_String_Literal)

      then

         Error_Msg_N ("first argument must be character or string", Aggr);

         return;

      end if;

      --  STEP 3: Name and value extraction

      --  Get the number of errors detected by the compiler so far

      Errors_Count := Serious_Errors_Detected;

      --  Positional elements

      Expr := Next (Symbol_Decl);

      Position := Low_Position_Bound;

      while Present (Expr) loop

         if Position > High_Position_Bound then

            Error_Msg_N

              ("type& has more dimensions than system allows", Def_Id);

            exit;

         end if;

         Extract_Power (Expr, Position);

         Position := Position + 1;

         Num_Dimensions := Num_Dimensions + 1;

         Next (Expr);

      end loop;

      --  Named elements

      Assoc := First (Component_Associations (Aggr));

      while Present (Assoc) loop

         Expr   := Expression (Assoc);

         Choice := First (Choices (Assoc));

         while Present (Choice) loop

            --  Identifier case: NAME => EXPRESSION

            if Nkind (Choice) = N_Identifier then

               Position := Position_In_System (Choice, System);

               if Is_Invalid (Position) then

                  Error_Msg_N ("dimension name& not part of system", Choice);

               else

                  Extract_Power (Expr, Position);

               end if;

            --  Range case: NAME .. NAME => EXPRESSION

            elsif Nkind (Choice) = N_Range then

               declare

                  Low      : constant Node_Id := Low_Bound (Choice);

                  High     : constant Node_Id := High_Bound (Choice);

                  Low_Pos  : Dimension_Position;

                  High_Pos : Dimension_Position;

               begin

                  if Nkind (Low) /= N_Identifier then

                     Error_Msg_N ("bound must denote a dimension name", Low);

                  elsif Nkind (High) /= N_Identifier then

                     Error_Msg_N ("bound must denote a dimension name", High);

                  else

                     Low_Pos  := Position_In_System (Low, System);

                     High_Pos := Position_In_System (High, System);

                     if Is_Invalid (Low_Pos) then

                        Error_Msg_N ("dimension name& not part of system",

                                     Low);

                     elsif Is_Invalid (High_Pos) then

                        Error_Msg_N ("dimension name& not part of system",

                                     High);

                     elsif Low_Pos > High_Pos then

                        Error_Msg_N ("expected low to high range", Choice);

                     else

                        for Position in Low_Pos .. High_Pos loop

                           Extract_Power (Expr, Position);

                        end loop;

                     end if;

                  end if;

               end;

            --  Others case: OTHERS => EXPRESSION

            elsif Nkind (Choice) = N_Others_Choice then

               if Present (Next (Choice))

                 or else Present (Prev (Choice))

               then

                  Error_Msg_N

                    ("OTHERS must appear alone in a choice list", Choice);

               elsif Present (Next (Assoc)) then

                  Error_Msg_N

                    ("OTHERS must appear last in an aggregate", Choice);

               elsif Others_Seen then

                  Error_Msg_N ("multiple OTHERS not allowed", Choice);

               else

                  --  Fill the non-processed dimensions with the default value

                  --  supplied by others.

                  for Position in Processed'Range loop

                     if not Processed (Position) then

                        Extract_Power (Expr, Position);

                     end if;

                  end loop;

               end if;

               Others_Seen := True;

            --  All other cases are erroneous declarations of dimension names

            else

               Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);

            end if;

            Num_Choices := Num_Choices + 1;

            Next (Choice);

         end loop;

         Num_Dimensions := Num_Dimensions + 1;

         Next (Assoc);

      end loop;

      --  STEP 4: Consistency of system and dimensions

      if Present (Next (Symbol_Decl))

        and then (Num_Choices > 1

                   or else (Num_Choices = 1 and then not Others_Seen))

      then

         Error_Msg_N

           ("named associations cannot follow positional associations", Aggr);

      elsif Num_Dimensions > System.Count then

         Error_Msg_N ("type& has more dimensions than system allows", Def_Id);

      elsif Num_Dimensions < System.Count and then not Others_Seen then

         Error_Msg_N ("type& has less dimensions than system allows", Def_Id);

      end if;

      --  STEP 5: Dimension symbol extraction

      if Nkind (Symbol_Decl) = N_Character_Literal then

         Start_String;

         Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Decl)));

         Symbol := End_String;

      else

         Symbol := Strval (Symbol_Decl);

      end if;

      if String_Length (Symbol) = 0 and then not Exists (Dimensions) then

         Error_Msg_N ("useless dimension declaration", Aggr);

      end if;