URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_dim.adb] - Blame information for rev 728

Go to most recent revision | Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         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;
 
      --  STEP 6: Storage of extracted values
 
      --  Check that no errors have been detected during the analysis
 
      if Errors_Count = Serious_Errors_Detected then
         if String_Length (Symbol) /= 0 then
            Set_Symbol (Def_Id, Symbol);
         end if;
 
         if Exists (Dimensions) then
            Set_Dimensions (Def_Id, Dimensions);
         end if;
      end if;
   end Analyze_Aspect_Dimension;
 
   -------------------------------------
   -- Analyze_Aspect_Dimension_System --
   -------------------------------------
 
   --  with Dimension_System => DIMENSION_PAIRS
 
   --  DIMENSION_PAIRS ::=
   --    (DIMENSION_PAIR
   --      [, DIMENSION_PAIR]
   --      [, DIMENSION_PAIR]
   --      [, DIMENSION_PAIR]
   --      [, DIMENSION_PAIR]
   --      [, DIMENSION_PAIR]
   --      [, DIMENSION_PAIR])
   --  DIMENSION_PAIR ::= (DIMENSION_IDENTIFIER, DIMENSION_STRING)
   --  DIMENSION_IDENTIFIER ::= IDENTIFIER
   --  DIMENSION_STRING ::= STRING_LITERAL | CHARACTER_LITERAL
 
   procedure Analyze_Aspect_Dimension_System
     (N    : Node_Id;
      Id   : Entity_Id;
      Aggr : Node_Id)
   is
      function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
      --  Determine whether type declaration N denotes a numeric derived type
 
      -------------------------------
      -- Is_Derived_Numeric_Type --
      -------------------------------
 
      function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
      begin
         return
           Nkind (N) = N_Full_Type_Declaration
             and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
             and then Is_Numeric_Type
                        (Entity (Subtype_Indication (Type_Definition (N))));
      end Is_Derived_Numeric_Type;
 
      --  Local variables
 
      Dim_Name     : Node_Id;
      Dim_Pair     : Node_Id;
      Dim_Symbol   : Node_Id;
      Dim_System   : System_Type  := Null_System;
      Names        : Name_Array   := No_Names;
      Position     : Nat := 0;
      Symbols      : Symbol_Array := No_Symbols;
 
      Errors_Count : Nat;
      --  Errors_Count is a count of errors detected by the compiler so far
      --  just before the extraction of names and symbols in the aggregate
      --  (Step 3).
      --
      --  At the end of the analysis, there is a check to verify that this
      --  count equals Serious_Errors_Detected i.e. no errors have been
      --  encountered during the process. Otherwise the System_Table is
      --  not filled.
 
   --  Start of processing for Analyze_Aspect_Dimension_System
 
   begin
      --  STEP 1: Legality of aspect
 
      if not Is_Derived_Numeric_Type (N) then
         Error_Msg_NE
           ("aspect& must apply to numeric derived type declaration", N, Id);
         return;
      end if;
 
      if Nkind (Aggr) /= N_Aggregate then
         Error_Msg_N ("aggregate expected", Aggr);
         return;
      end if;
 
      --  STEP 2: Structural verification of the dimension aggregate
 
      if Present (Component_Associations (Aggr)) then
         Error_Msg_N ("expected positional aggregate", Aggr);
         return;
      end if;
 
      --  STEP 3: Name and Symbol extraction
 
      Dim_Pair     := First (Expressions (Aggr));
      Errors_Count := Serious_Errors_Detected;
      while Present (Dim_Pair) loop
         Position := Position + 1;
 
         if Position > High_Position_Bound then
            Error_Msg_N
              ("too many dimensions in system", Aggr);
            exit;
         end if;
 
         if Nkind (Dim_Pair) /= N_Aggregate then
            Error_Msg_N ("aggregate expected", Dim_Pair);
 
         else
            if Present (Component_Associations (Dim_Pair)) then
               Error_Msg_N ("expected positional aggregate", Dim_Pair);
 
            else
               if List_Length (Expressions (Dim_Pair)) = 2 then
                  Dim_Name := First (Expressions (Dim_Pair));
                  Dim_Symbol := Next (Dim_Name);
 
                  --  Check the first argument for each pair is a name
 
                  if Nkind (Dim_Name) = N_Identifier then
                     Names (Position) := Chars (Dim_Name);
                  else
                     Error_Msg_N ("expected dimension name", Dim_Name);
                  end if;
 
                  --  Check the second argument for each pair is a string or a
                  --  character.
 
                  if not Nkind_In
                           (Dim_Symbol,
                              N_String_Literal,
                              N_Character_Literal)
                  then
                     Error_Msg_N ("expected dimension string or character",
                                  Dim_Symbol);
 
                  else
                     --  String case
 
                     if Nkind (Dim_Symbol) = N_String_Literal then
                        Symbols (Position) := Strval (Dim_Symbol);
 
                     --  Character case
 
                     else
                        Start_String;
                        Store_String_Char
                          (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
                        Symbols (Position) := End_String;
                     end if;
 
                     --  Verify that the string is not empty
 
                     if String_Length (Symbols (Position)) = 0 then
                        Error_Msg_N
                          ("empty string not allowed here", Dim_Symbol);
                     end if;
                  end if;
 
               else
                  Error_Msg_N
                    ("two expressions expected in aggregate", Dim_Pair);
               end if;
            end if;
         end if;
 
         Next (Dim_Pair);
      end loop;
 
      --  STEP 4: Storage of extracted values
 
      --  Check that no errors have been detected during the analysis
 
      if Errors_Count = Serious_Errors_Detected then
         Dim_System.Type_Decl := N;
         Dim_System.Names := Names;
         Dim_System.Count := Position;
         Dim_System.Symbols := Symbols;
         System_Table.Append (Dim_System);
      end if;
   end Analyze_Aspect_Dimension_System;
 
   -----------------------
   -- Analyze_Dimension --
   -----------------------
 
   --  This dispatch routine propagates dimensions for each node
 
   procedure Analyze_Dimension (N : Node_Id) is
   begin
      --  Aspect is an Ada 2012 feature
 
      if Ada_Version < Ada_2012 then
         return;
      end if;
 
      case Nkind (N) is
 
         when N_Assignment_Statement =>
            Analyze_Dimension_Assignment_Statement (N);
 
         when N_Binary_Op =>
            Analyze_Dimension_Binary_Op (N);
 
         when N_Component_Declaration =>
            Analyze_Dimension_Component_Declaration (N);
 
         when N_Extended_Return_Statement =>
            Analyze_Dimension_Extended_Return_Statement (N);
 
         when N_Function_Call =>
            Analyze_Dimension_Function_Call (N);
 
         when N_Attribute_Reference       |
              N_Identifier                |
              N_Indexed_Component         |
              N_Qualified_Expression      |
              N_Selected_Component        |
              N_Slice                     |
              N_Type_Conversion           |
              N_Unchecked_Type_Conversion =>
            Analyze_Dimension_Has_Etype (N);
 
         when N_Object_Declaration =>
            Analyze_Dimension_Object_Declaration (N);
 
         when N_Object_Renaming_Declaration =>
            Analyze_Dimension_Object_Renaming_Declaration (N);
 
         when N_Simple_Return_Statement =>
            if not Comes_From_Extended_Return_Statement (N) then
               Analyze_Dimension_Simple_Return_Statement (N);
            end if;
 
         when N_Subtype_Declaration =>
            Analyze_Dimension_Subtype_Declaration (N);
 
         when N_Unary_Op =>
            Analyze_Dimension_Unary_Op (N);
 
         when others => null;
 
      end case;
   end Analyze_Dimension;
 
   --------------------------------------------
   -- Analyze_Dimension_Assignment_Statement --
   --------------------------------------------
 
   procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
      Lhs         : constant Node_Id := Name (N);
      Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
      Rhs         : constant Node_Id := Expression (N);
      Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
 
      procedure Error_Dim_Msg_For_Assignment_Statement
        (N   : Node_Id;
         Lhs : Node_Id;
         Rhs : Node_Id);
      --  Error using Error_Msg_N at node N. Output the dimensions of left
      --  and right hand sides.
 
      --------------------------------------------
      -- Error_Dim_Msg_For_Assignment_Statement --
      --------------------------------------------
 
      procedure Error_Dim_Msg_For_Assignment_Statement
        (N   : Node_Id;
         Lhs : Node_Id;
         Rhs : Node_Id)
      is
      begin
         Error_Msg_N ("dimensions mismatch in assignment", N);
         Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs), N);
         Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs), N);
      end Error_Dim_Msg_For_Assignment_Statement;
 
   --  Start of processing for Analyze_Dimension_Assignment
 
   begin
      if Dims_Of_Lhs /= Dims_Of_Rhs then
         Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
      end if;
   end Analyze_Dimension_Assignment_Statement;
 
   ---------------------------------
   -- Analyze_Dimension_Binary_Op --
   ---------------------------------
 
   --  Check and propagate the dimensions for binary operators
   --  Note that when the dimensions mismatch, no dimension is propagated to N.
 
   procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
      N_Kind : constant Node_Kind := Nkind (N);
 
      procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
      --  Error using Error_Msg_NE and Error_Msg_N at node N. Output the
      --  dimensions of both operands.
 
      ---------------------------------
      -- Error_Dim_Msg_For_Binary_Op --
      ---------------------------------
 
      procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
      begin
         Error_Msg_NE ("both operands for operation& must have same " &
                       "dimensions",
                       N,
                       Entity (N));
         Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L), N);
         Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R), N);
      end Error_Dim_Msg_For_Binary_Op;
 
   --  Start of processing for Analyze_Dimension_Binary_Op
 
   begin
      if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
        or else N_Kind in N_Multiplying_Operator
        or else N_Kind in N_Op_Compare
      then
         declare
            L                : constant Node_Id := Left_Opnd (N);
            Dims_Of_L        : constant Dimension_Type := Dimensions_Of (L);
            L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
            R                : constant Node_Id := Right_Opnd (N);
            Dims_Of_R        : constant Dimension_Type := Dimensions_Of (R);
            R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
            Dims_Of_N        : Dimension_Type := Null_Dimension;
 
         begin
            --  N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
 
            if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
 
               --  Check both operands have same dimension
 
               if Dims_Of_L /= Dims_Of_R then
                  Error_Dim_Msg_For_Binary_Op (N, L, R);
               else
                  --  Check both operands are not dimensionless
 
                  if Exists (Dims_Of_L) then
                     Set_Dimensions (N, Dims_Of_L);
                  end if;
               end if;
 
            --  N_Op_Multiply or N_Op_Divide case
 
            elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
 
               --  Check at least one operand is not dimensionless
 
               if L_Has_Dimensions or R_Has_Dimensions then
 
                  --  Multiplication case
 
                  --  Get both operands dimensions and add them
 
                  if N_Kind = N_Op_Multiply then
                     for Position in Dimension_Type'Range loop
                        Dims_Of_N (Position) :=
                          Dims_Of_L (Position) + Dims_Of_R (Position);
                     end loop;
 
                  --  Division case
 
                  --  Get both operands dimensions and subtract them
 
                  else
                     for Position in Dimension_Type'Range loop
                        Dims_Of_N (Position) :=
                          Dims_Of_L (Position) - Dims_Of_R (Position);
                     end loop;
                  end if;
 
                  if Exists (Dims_Of_N) then
                     Set_Dimensions (N, Dims_Of_N);
                  end if;
               end if;
 
            --  Exponentiation case
 
            --  Note: a rational exponent is allowed for dimensioned operand
 
            elsif N_Kind = N_Op_Expon then
 
               --  Check the left operand is not dimensionless. Note that the
               --  value of the exponent must be known compile time. Otherwise,
               --  the exponentiation evaluation will return an error message.
 
               if L_Has_Dimensions
                 and then Compile_Time_Known_Value (R)
               then
                  declare
                     Exponent_Value : Rational := Zero;
 
                  begin
                     --  Real operand case
 
                     if Is_Real_Type (Etype (L)) then
 
                        --  Define the exponent as a Rational number
 
                        Exponent_Value := Create_Rational_From (R, False);
 
                        --  Verify that the exponent cannot be interpreted
                        --  as a rational, otherwise interpret the exponent
                        --  as an integer.
 
                        if Exponent_Value = No_Rational then
                           Exponent_Value :=
                             +Whole (UI_To_Int (Expr_Value (R)));
                        end if;
 
                     --  Integer operand case.
 
                     --  For integer operand, the exponent cannot be
                     --  interpreted as a rational.
 
                     else
                        Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
                     end if;
 
                     for Position in Dimension_Type'Range loop
                        Dims_Of_N (Position) :=
                          Dims_Of_L (Position) * Exponent_Value;
                     end loop;
 
                     if Exists (Dims_Of_N) then
                        Set_Dimensions (N, Dims_Of_N);
                     end if;
                  end;
               end if;
 
            --  Comparison cases
 
            --  For relational operations, only dimension checking is
            --  performed (no propagation).
 
            elsif N_Kind in N_Op_Compare then
               if (L_Has_Dimensions or R_Has_Dimensions)
                 and then Dims_Of_L /= Dims_Of_R
               then
                  Error_Dim_Msg_For_Binary_Op (N, L, R);
               end if;
            end if;
 
            --  Removal of dimensions for each operands
 
            Remove_Dimensions (L);
            Remove_Dimensions (R);
         end;
      end if;
   end Analyze_Dimension_Binary_Op;
 
   ---------------------------------------------
   -- Analyze_Dimension_Component_Declaration --
   ---------------------------------------------
 
   procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is
      Expr         : constant Node_Id        := Expression (N);
      Id           : constant Entity_Id      := Defining_Identifier (N);
      Etyp         : constant Entity_Id      := Etype (Id);
      Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
      Dims_Of_Expr : Dimension_Type;
 
      procedure Error_Dim_Msg_For_Component_Declaration
        (N    : Node_Id;
         Etyp : Entity_Id;
         Expr : Node_Id);
      --  Error using Error_Msg_N at node N. Output the dimensions of the
      --  type Etyp and the expression Expr of N.
 
      ---------------------------------------------
      -- Error_Dim_Msg_For_Component_Declaration --
      ---------------------------------------------
 
      procedure Error_Dim_Msg_For_Component_Declaration
        (N    : Node_Id;
         Etyp : Entity_Id;
         Expr : Node_Id) is
      begin
         Error_Msg_N ("dimensions mismatch in component declaration", N);
         Error_Msg_N ("\component type " & Dimensions_Msg_Of (Etyp), N);
         Error_Msg_N ("\component expression " & Dimensions_Msg_Of (Expr), N);
      end Error_Dim_Msg_For_Component_Declaration;
 
   --  Start of processing for Analyze_Dimension_Component_Declaration
 
   begin
      if Present (Expr) then
         Dims_Of_Expr := Dimensions_Of (Expr);
 
         --  Return an error if the dimension of the expression and the
         --  dimension of the type mismatch.
 
         if Dims_Of_Etyp /= Dims_Of_Expr then
            Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
         end if;
 
         --  Removal of dimensions in expression
 
         Remove_Dimensions (Expr);
      end if;
   end Analyze_Dimension_Component_Declaration;
 
   -------------------------------------------------
   -- Analyze_Dimension_Extended_Return_Statement --
   -------------------------------------------------
 
   procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
      Return_Ent            : constant Entity_Id :=
                                Return_Statement_Entity (N);
      Return_Etyp           : constant Entity_Id :=
                                Etype (Return_Applies_To (Return_Ent));
      Dims_Of_Return_Etyp   : constant Dimension_Type :=
                                Dimensions_Of (Return_Etyp);
      Return_Obj_Decls      : constant List_Id :=
                                Return_Object_Declarations (N);
      Dims_Of_Return_Obj_Id : Dimension_Type;
      Return_Obj_Decl       : Node_Id;
      Return_Obj_Id         : Entity_Id;
 
      procedure Error_Dim_Msg_For_Extended_Return_Statement
        (N             : Node_Id;
         Return_Etyp   : Entity_Id;
         Return_Obj_Id : Entity_Id);
      --  Error using Error_Msg_N at node N. Output the dimensions of the
      --  returned type Return_Etyp and the returned object Return_Obj_Id of N.
 
      -------------------------------------------------
      -- Error_Dim_Msg_For_Extended_Return_Statement --
      -------------------------------------------------
 
      procedure Error_Dim_Msg_For_Extended_Return_Statement
        (N             : Node_Id;
         Return_Etyp   : Entity_Id;
         Return_Obj_Id : Entity_Id)
      is
      begin
         Error_Msg_N ("dimensions mismatch in extended return statement", N);
         Error_Msg_N ("\returned type " & Dimensions_Msg_Of (Return_Etyp), N);
         Error_Msg_N ("\returned object " & Dimensions_Msg_Of (Return_Obj_Id),
                      N);
      end Error_Dim_Msg_For_Extended_Return_Statement;
 
   --  Start of processing for Analyze_Dimension_Extended_Return_Statement
 
   begin
      if Present (Return_Obj_Decls) then
         Return_Obj_Decl := First (Return_Obj_Decls);
         while Present (Return_Obj_Decl) loop
            if Nkind (Return_Obj_Decl) = N_Object_Declaration then
               Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
 
               if Is_Return_Object (Return_Obj_Id) then
                  Dims_Of_Return_Obj_Id := Dimensions_Of (Return_Obj_Id);
 
                  if Dims_Of_Return_Etyp /= Dims_Of_Return_Obj_Id then
                     Error_Dim_Msg_For_Extended_Return_Statement
                       (N, Return_Etyp, Return_Obj_Id);
                     return;
                  end if;
               end if;
            end if;
 
            Next (Return_Obj_Decl);
         end loop;
      end if;
   end Analyze_Dimension_Extended_Return_Statement;
 
   -------------------------------------
   -- Analyze_Dimension_Function_Call --
   -------------------------------------
 
   --  Propagate the dimensions from the returned type to the call node. Note
   --  that there is a special treatment for elementary function calls. Indeed
   --  for Sqrt call, the resulting dimensions equal to half the dimensions of
   --  the actual, and for other elementary calls, this routine check that
   --  every actuals are dimensionless.
 
   procedure Analyze_Dimension_Function_Call (N : Node_Id) is
      Actuals        : constant List_Id := Parameter_Associations (N);
      Name_Call      : constant Node_Id := Name (N);
      Actual         : Node_Id;
      Dims_Of_Actual : Dimension_Type;
      Dims_Of_Call   : Dimension_Type;
      Ent            : Entity_Id;
 
      function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean;
      --  Given E, the original subprogram entity, return True if call is to an
      --  elementary function (see Ada.Numerics.Generic_Elementary_Functions).
 
      -----------------------------------
      -- Is_Elementary_Function_Entity --
      -----------------------------------
 
      function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean is
         Loc : constant Source_Ptr := Sloc (E);
 
      begin
         --  Is function entity in Ada.Numerics.Generic_Elementary_Functions?
 
         return
           Loc > No_Location
             and then
               Is_RTU
                (Cunit_Entity (Get_Source_Unit (Loc)),
                 Ada_Numerics_Generic_Elementary_Functions);
      end Is_Elementary_Function_Entity;
 
   --  Start of processing for Analyze_Dimension_Function_Call
 
   begin
      --  Look for elementary function call
 
      if Is_Entity_Name (Name_Call) then
         Ent := Entity (Name_Call);
 
         --  Get the original subprogram entity following the renaming chain
 
         if Present (Alias (Ent)) then
            Ent := Alias (Ent);
         end if;
 
         --  Elementary function case
 
         if Is_Elementary_Function_Entity (Ent) then
 
         --  Sqrt function call case
 
            if Chars (Ent) = Name_Sqrt then
               Dims_Of_Call := Dimensions_Of (First (Actuals));
 
               if Exists (Dims_Of_Call) then
                  for Position in Dims_Of_Call'Range loop
                     Dims_Of_Call (Position) :=
                       Dims_Of_Call (Position) * Rational'(Numerator   => 1,
                                                           Denominator => 2);
                  end loop;
 
                  Set_Dimensions (N, Dims_Of_Call);
               end if;
 
            --  All other elementary functions case. Note that every actual
            --  here should be dimensionless.
 
            else
               Actual := First (Actuals);
               while Present (Actual) loop
                  Dims_Of_Actual := Dimensions_Of (Actual);
 
                  if Exists (Dims_Of_Actual) then
                     Error_Msg_NE ("parameter should be dimensionless for " &
                                   "elementary function&",
                                   Actual, Name_Call);
                     Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
                                  Actual);
                  end if;
 
                  Next (Actual);
               end loop;
            end if;
 
            return;
         end if;
      end if;
 
      --  Other cases
 
      Analyze_Dimension_Has_Etype (N);
   end Analyze_Dimension_Function_Call;
 
   ---------------------------------
   -- Analyze_Dimension_Has_Etype --
   ---------------------------------
 
   procedure Analyze_Dimension_Has_Etype (N : Node_Id) is
      Etyp         : constant Entity_Id := Etype (N);
      Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
 
   begin
      --  Propagation of the dimensions from the type
 
      if Exists (Dims_Of_Etyp) then
         Set_Dimensions (N, Dims_Of_Etyp);
      end if;
 
      --  Removal of dimensions in expression
 
      case Nkind (N) is
 
         when N_Attribute_Reference |
              N_Indexed_Component   =>
            declare
               Expr  : Node_Id;
               Exprs : constant List_Id := Expressions (N);
 
            begin
               if Present (Exprs) then
                  Expr := First (Exprs);
                  while Present (Expr) loop
                     Remove_Dimensions (Expr);
                     Next (Expr);
                  end loop;
               end if;
            end;
 
         when N_Qualified_Expression      |
              N_Type_Conversion           |
              N_Unchecked_Type_Conversion =>
            Remove_Dimensions (Expression (N));
 
         when N_Selected_Component =>
            Remove_Dimensions (Selector_Name (N));
 
         when others => null;
 
      end case;
   end Analyze_Dimension_Has_Etype;
 
   ------------------------------------------
   -- Analyze_Dimension_Object_Declaration --
   ------------------------------------------
 
   procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is
      Expr        : constant Node_Id   := Expression (N);
      Id          : constant Entity_Id := Defining_Identifier (N);
      Etyp        : constant Entity_Id := Etype (Id);
      Dim_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
      Dim_Of_Expr : Dimension_Type;
 
      procedure Error_Dim_Msg_For_Object_Declaration
        (N    : Node_Id;
         Etyp : Entity_Id;
         Expr : Node_Id);
      --  Error using Error_Msg_N at node N. Output the dimensions of the
      --  type Etyp and of the expression Expr.
 
      ------------------------------------------
      -- Error_Dim_Msg_For_Object_Declaration --
      ------------------------------------------
 
      procedure Error_Dim_Msg_For_Object_Declaration
        (N    : Node_Id;
         Etyp : Entity_Id;
         Expr : Node_Id) is
      begin
         Error_Msg_N ("dimensions mismatch in object declaration", N);
         Error_Msg_N ("\object type " & Dimensions_Msg_Of (Etyp), N);
         Error_Msg_N ("\object expression " & Dimensions_Msg_Of (Expr), N);
      end Error_Dim_Msg_For_Object_Declaration;
 
   --  Start of processing for Analyze_Dimension_Object_Declaration
 
   begin
      --  Expression is present
 
      if Present (Expr) then
         Dim_Of_Expr := Dimensions_Of (Expr);
 
         --  case when expression is not a literal and when dimensions of the
         --  expression and of the type mismatch
 
         if not Nkind_In (Original_Node (Expr),
                             N_Real_Literal,
                             N_Integer_Literal)
           and then Dim_Of_Expr /= Dim_Of_Etyp
         then
            Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr);
         end if;
 
         --  Removal of dimensions in expression
 
         Remove_Dimensions (Expr);
      end if;
   end Analyze_Dimension_Object_Declaration;
 
   ---------------------------------------------------
   -- Analyze_Dimension_Object_Renaming_Declaration --
   ---------------------------------------------------
 
   procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is
      Renamed_Name : constant Node_Id := Name (N);
      Sub_Mark     : constant Node_Id := Subtype_Mark (N);
 
      procedure Error_Dim_Msg_For_Object_Renaming_Declaration
        (N            : Node_Id;
         Sub_Mark     : Node_Id;
         Renamed_Name : Node_Id);
      --  Error using Error_Msg_N at node N. Output the dimensions of
      --  Sub_Mark and of Renamed_Name.
 
      ---------------------------------------------------
      -- Error_Dim_Msg_For_Object_Renaming_Declaration --
      ---------------------------------------------------
 
      procedure Error_Dim_Msg_For_Object_Renaming_Declaration
        (N            : Node_Id;
         Sub_Mark     : Node_Id;
         Renamed_Name : Node_Id) is
      begin
         Error_Msg_N ("dimensions mismatch in object renaming declaration",
                      N);
         Error_Msg_N ("\type " & Dimensions_Msg_Of (Sub_Mark), N);
         Error_Msg_N ("\renamed object " & Dimensions_Msg_Of (Renamed_Name),
                      N);
      end Error_Dim_Msg_For_Object_Renaming_Declaration;
 
   --  Start of processing for Analyze_Dimension_Object_Renaming_Declaration
 
   begin
      if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then
         Error_Dim_Msg_For_Object_Renaming_Declaration
           (N, Sub_Mark, Renamed_Name);
      end if;
   end Analyze_Dimension_Object_Renaming_Declaration;
 
   -----------------------------------------------
   -- Analyze_Dimension_Simple_Return_Statement --
   -----------------------------------------------
 
   procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is
      Expr                : constant Node_Id := Expression (N);
      Dims_Of_Expr        : constant Dimension_Type := Dimensions_Of (Expr);
      Return_Ent          : constant Entity_Id := Return_Statement_Entity (N);
      Return_Etyp         : constant Entity_Id :=
                              Etype (Return_Applies_To (Return_Ent));
      Dims_Of_Return_Etyp : constant Dimension_Type :=
                              Dimensions_Of (Return_Etyp);
 
      procedure Error_Dim_Msg_For_Simple_Return_Statement
        (N           : Node_Id;
         Return_Etyp : Entity_Id;
         Expr        : Node_Id);
      --  Error using Error_Msg_N at node N. Output the dimensions of the
      --  returned type Return_Etyp and the returned expression Expr of N.
 
      -----------------------------------------------
      -- Error_Dim_Msg_For_Simple_Return_Statement --
      -----------------------------------------------
 
      procedure Error_Dim_Msg_For_Simple_Return_Statement
        (N           : Node_Id;
         Return_Etyp : Entity_Id;
         Expr        : Node_Id)
      is
      begin
         Error_Msg_N ("dimensions mismatch in return statement", N);
         Error_Msg_N ("\returned type " & Dimensions_Msg_Of (Return_Etyp), N);
         Error_Msg_N ("\returned expression " & Dimensions_Msg_Of (Expr), N);
      end Error_Dim_Msg_For_Simple_Return_Statement;
 
   --  Start of processing for Analyze_Dimension_Simple_Return_Statement
 
   begin
      if Dims_Of_Return_Etyp /= Dims_Of_Expr then
         Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr);
         Remove_Dimensions (Expr);
      end if;
   end Analyze_Dimension_Simple_Return_Statement;
 
   -------------------------------------------
   -- Analyze_Dimension_Subtype_Declaration --
   -------------------------------------------
 
   procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is
      Id           : constant Entity_Id := Defining_Identifier (N);
      Dims_Of_Id   : constant Dimension_Type := Dimensions_Of (Id);
      Dims_Of_Etyp : Dimension_Type;
      Etyp         : Node_Id;
 
   begin
      --  No constraint case in subtype declaration
 
      if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
         Etyp := Etype (Subtype_Indication (N));
         Dims_Of_Etyp := Dimensions_Of (Etyp);
 
         if Exists (Dims_Of_Etyp) then
 
            --  If subtype already has a dimension (from Aspect_Dimension),
            --  it cannot inherit a dimension from its subtype.
 
            if Exists (Dims_Of_Id) then
               Error_Msg_N ("subtype& already" & Dimensions_Msg_Of (Id), N);
            else
               Set_Dimensions (Id, Dims_Of_Etyp);
               Set_Symbol (Id, Symbol_Of (Etyp));
            end if;
         end if;
 
      --  Constraint present in subtype declaration
 
      else
         Etyp := Etype (Subtype_Mark (Subtype_Indication (N)));
         Dims_Of_Etyp := Dimensions_Of (Etyp);
 
         if Exists (Dims_Of_Etyp) then
            Set_Dimensions (Id, Dims_Of_Etyp);
            Set_Symbol (Id, Symbol_Of (Etyp));
         end if;
      end if;
   end Analyze_Dimension_Subtype_Declaration;
 
   --------------------------------
   -- Analyze_Dimension_Unary_Op --
   --------------------------------
 
   procedure Analyze_Dimension_Unary_Op (N : Node_Id) is
   begin
      case Nkind (N) is
         when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
            declare
               R : constant Node_Id := Right_Opnd (N);
 
            begin
               --  Propagate the dimension if the operand is not dimensionless
 
               Move_Dimensions (R, N);
            end;
 
         when others => null;
 
      end case;
   end Analyze_Dimension_Unary_Op;
 
   --------------------------
   -- Create_Rational_From --
   --------------------------
 
   --  RATIONAL ::= [-] NUMERAL [/ NUMERAL]
 
   --  A rational number is a number that can be expressed as the quotient or
   --  fraction a/b of two integers, where b is non-zero positive.
 
   function Create_Rational_From
     (Expr     : Node_Id;
      Complain : Boolean) return Rational
   is
      Or_Node_Of_Expr : constant Node_Id := Original_Node (Expr);
      Result          : Rational := No_Rational;
 
      function Process_Minus (N : Node_Id) return Rational;
      --  Create a rational from a N_Op_Minus node
 
      function Process_Divide (N : Node_Id) return Rational;
      --  Create a rational from a N_Op_Divide node
 
      function Process_Literal (N : Node_Id) return Rational;
      --  Create a rational from a N_Integer_Literal node
 
      -------------------
      -- Process_Minus --
      -------------------
 
      function Process_Minus (N : Node_Id) return Rational is
         Right  : constant Node_Id := Original_Node (Right_Opnd (N));
         Result : Rational;
 
      begin
         --  Operand is an integer literal
 
         if Nkind (Right) = N_Integer_Literal then
            Result := -Process_Literal (Right);
 
         --  Operand is a divide operator
 
         elsif Nkind (Right) = N_Op_Divide then
            Result := -Process_Divide (Right);
 
         else
            Result := No_Rational;
         end if;
 
         return Result;
      end Process_Minus;
 
      --------------------
      -- Process_Divide --
      --------------------
 
      function Process_Divide (N : Node_Id) return Rational is
         Left      : constant Node_Id := Original_Node (Left_Opnd (N));
         Right     : constant Node_Id := Original_Node (Right_Opnd (N));
         Left_Rat  : Rational;
         Result    : Rational := No_Rational;
         Right_Rat : Rational;
 
      begin
         --  Both left and right operands are an integer literal
 
         if Nkind (Left) = N_Integer_Literal
           and then Nkind (Right) = N_Integer_Literal
         then
            Left_Rat := Process_Literal (Left);
            Right_Rat := Process_Literal (Right);
            Result := Left_Rat / Right_Rat;
         end if;
 
         return Result;
      end Process_Divide;
 
      ---------------------
      -- Process_Literal --
      ---------------------
 
      function Process_Literal (N : Node_Id) return Rational is
      begin
         return +Whole (UI_To_Int (Intval (N)));
      end Process_Literal;
 
   --  Start of processing for Create_Rational_From
 
   begin
      --  Check the expression is either a division of two integers or an
      --  integer itself. Note that the check applies to the original node
      --  since the node could have already been rewritten.
 
      --  Integer literal case
 
      if Nkind (Or_Node_Of_Expr) = N_Integer_Literal then
         Result := Process_Literal (Or_Node_Of_Expr);
 
      --  Divide operator case
 
      elsif Nkind (Or_Node_Of_Expr) = N_Op_Divide then
         Result := Process_Divide (Or_Node_Of_Expr);
 
      --  Minus operator case
 
      elsif Nkind (Or_Node_Of_Expr) = N_Op_Minus then
         Result := Process_Minus (Or_Node_Of_Expr);
      end if;
 
      --  When Expr cannot be interpreted as a rational and Complain is true,
      --  generate an error message.
 
      if Complain and then Result = No_Rational then
         Error_Msg_N ("must be a rational", Expr);
      end if;
 
      return Result;
   end Create_Rational_From;
 
   -------------------
   -- Dimensions_Of --
   -------------------
 
   function Dimensions_Of (N : Node_Id) return Dimension_Type is
   begin
      return Dimension_Table.Get (N);
   end Dimensions_Of;
 
   -----------------------
   -- Dimensions_Msg_Of --
   -----------------------
 
   function Dimensions_Msg_Of (N : Node_Id) return String is
      Dims_Of_N      : constant Dimension_Type := Dimensions_Of (N);
      Dimensions_Msg : Name_Id;
      System         : System_Type;
 
      procedure Add_Dimension_Vector_To_Buffer
        (Dims   : Dimension_Type;
         System : System_Type);
      --  Given a Dims and System, add to Name_Buffer the string representation
      --  of a dimension vector.
 
      procedure Add_Whole_To_Buffer (W : Whole);
      --  Add image of Whole to Name_Buffer
 
      ------------------------------------
      -- Add_Dimension_Vector_To_Buffer --
      ------------------------------------
 
      procedure Add_Dimension_Vector_To_Buffer
        (Dims   : Dimension_Type;
         System : System_Type)
      is
         Dim_Power : Rational;
         First_Dim : Boolean := True;
 
      begin
         Add_Char_To_Name_Buffer ('(');
 
         for Position in Dims_Of_N'First ..  System.Count loop
            Dim_Power := Dims (Position);
 
            if First_Dim then
               First_Dim := False;
            else
               Add_Str_To_Name_Buffer (", ");
            end if;
 
            Add_Whole_To_Buffer (Dim_Power.Numerator);
 
            if Dim_Power.Denominator /= 1 then
               Add_Char_To_Name_Buffer ('/');
               Add_Whole_To_Buffer (Dim_Power.Denominator);
            end if;
         end loop;
 
         Add_Char_To_Name_Buffer (')');
      end Add_Dimension_Vector_To_Buffer;
 
      -------------------------
      -- Add_Whole_To_Buffer --
      -------------------------
 
      procedure Add_Whole_To_Buffer (W : Whole) is
      begin
         UI_Image (UI_From_Int (Int (W)));
         Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
      end Add_Whole_To_Buffer;
 
   --  Start of processing for Dimensions_Msg_Of
 
   begin
      --  Initialization of Name_Buffer
 
      Name_Len := 0;
 
      if Exists (Dims_Of_N) then
         System := System_Of (Base_Type (Etype (N)));
         Add_Str_To_Name_Buffer ("has dimensions ");
         Add_Dimension_Vector_To_Buffer (Dims_Of_N, System);
      else
         Add_Str_To_Name_Buffer ("is dimensionless");
      end if;
 
      Dimensions_Msg := Name_Find;
      return Get_Name_String (Dimensions_Msg);
   end Dimensions_Msg_Of;
 
   --------------------------
   -- Dimension_Table_Hash --
   --------------------------
 
   function Dimension_Table_Hash
     (Key : Node_Id) return Dimension_Table_Range
   is
   begin
      return Dimension_Table_Range (Key mod 511);
   end Dimension_Table_Hash;
 
   ----------------------------------------
   -- Eval_Op_Expon_For_Dimensioned_Type --
   ----------------------------------------
 
   --  Evaluate the expon operator for real dimensioned type.
 
   --  Note that if the exponent is an integer (denominator = 1) the node is
   --  evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
 
   procedure Eval_Op_Expon_For_Dimensioned_Type
     (N    : Node_Id;
      Btyp : Entity_Id)
   is
      R       : constant Node_Id := Right_Opnd (N);
      R_Value : Rational := No_Rational;
 
   begin
      if Is_Real_Type (Btyp) then
         R_Value := Create_Rational_From (R, False);
      end if;
 
      --  Check that the exponent is not an integer
 
      if R_Value /= No_Rational and then R_Value.Denominator /= 1 then
         Eval_Op_Expon_With_Rational_Exponent (N, R_Value);
      else
         Eval_Op_Expon (N);
      end if;
   end Eval_Op_Expon_For_Dimensioned_Type;
 
   ------------------------------------------
   -- Eval_Op_Expon_With_Rational_Exponent --
   ------------------------------------------
 
   --  For dimensioned operand in exponentiation, exponent is allowed to be a
   --  Rational and not only an Integer like for dimensionless operands. For
   --  that particular case, the left operand is rewritten as a function call
   --  using the function Expon_LLF from s-llflex.ads.
 
   procedure Eval_Op_Expon_With_Rational_Exponent
     (N              : Node_Id;
      Exponent_Value : Rational)
   is
      Dims_Of_N             : constant Dimension_Type := Dimensions_Of (N);
      L                     : constant Node_Id := Left_Opnd (N);
      Etyp_Of_L             : constant Entity_Id := Etype (L);
      Btyp_Of_L             : constant Entity_Id := Base_Type (Etyp_Of_L);
      Loc                   : constant Source_Ptr := Sloc (N);
      Actual_1              : Node_Id;
      Actual_2              : Node_Id;
      Dim_Power             : Rational;
      List_Of_Dims          : List_Id;
      New_Aspect            : Node_Id;
      New_Aspects           : List_Id;
      New_Id                : Entity_Id;
      New_N                 : Node_Id;
      New_Subtyp_Decl_For_L : Node_Id;
      System                : System_Type;
 
   begin
      --  Case when the operand is not dimensionless
 
      if Exists (Dims_Of_N) then
 
         --  Get the corresponding System_Type to know the exact number of
         --  dimensions in the system.
 
         System := System_Of (Btyp_Of_L);
 
         --  Generation of a new subtype with the proper dimensions
 
         --  In order to rewrite the operator as a type conversion, a new
         --  dimensioned subtype with the resulting dimensions of the
         --  exponentiation must be created.
 
         --  Generate:
 
         --  Btyp_Of_L   : constant Entity_Id := Base_Type (Etyp_Of_L);
         --  System      : constant System_Id :=
         --                  Get_Dimension_System_Id (Btyp_Of_L);
         --  Num_Of_Dims : constant Number_Of_Dimensions :=
         --                  Dimension_Systems.Table (System).Dimension_Count;
 
         --  subtype T is Btyp_Of_L
         --    with
         --      Dimension => ("",
         --        Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
         --        Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
         --        ...
         --        Dims_Of_N (Num_Of_Dims).Numerator /
         --          Dims_Of_N (Num_Of_Dims).Denominator);
 
         --  Step 1: Generate the new aggregate for the aspect Dimension
 
         New_Aspects  := Empty_List;
         List_Of_Dims := New_List;
         Append (Make_String_Literal (Loc, ""), List_Of_Dims);
 
         for Position in Dims_Of_N'First ..  System.Count loop
            Dim_Power := Dims_Of_N (Position);
            Append_To (List_Of_Dims,
               Make_Op_Divide (Loc,
                 Left_Opnd  =>
                   Make_Integer_Literal (Loc,
                     Int (Dim_Power.Numerator)),
                 Right_Opnd =>
                   Make_Integer_Literal (Loc,
                     Int (Dim_Power.Denominator))));
         end loop;
 
         --  Step 2: Create the new Aspect Specification for Aspect Dimension
 
         New_Aspect :=
           Make_Aspect_Specification (Loc,
             Identifier => Make_Identifier (Loc, Name_Dimension),
             Expression => Make_Aggregate (Loc, Expressions => List_Of_Dims));
 
         --  Step 3: Make a temporary identifier for the new subtype
 
         New_Id := Make_Temporary (Loc, 'T');
         Set_Is_Internal (New_Id);
 
         --  Step 4: Declaration of the new subtype
 
         New_Subtyp_Decl_For_L :=
            Make_Subtype_Declaration (Loc,
               Defining_Identifier => New_Id,
               Subtype_Indication  => New_Occurrence_Of (Btyp_Of_L, Loc));
 
         Append (New_Aspect, New_Aspects);
         Set_Parent (New_Aspects, New_Subtyp_Decl_For_L);
         Set_Aspect_Specifications (New_Subtyp_Decl_For_L, New_Aspects);
 
         Analyze (New_Subtyp_Decl_For_L);
 
      --  Case where the operand is dimensionless
 
      else
         New_Id := Btyp_Of_L;
      end if;
 
      --  Replacement of N by New_N
 
      --  Generate:
 
      --  Actual_1 := Long_Long_Float (L),
 
      --  Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
      --                Long_Long_Float (Exponent_Value.Denominator);
 
      --  (T (Expon_LLF (Actual_1, Actual_2)));
 
      --  where T is the subtype declared in step 1
 
      --  The node is rewritten as a type conversion
 
      --  Step 1: Creation of the two parameters of Expon_LLF function call
 
      Actual_1 :=
        Make_Type_Conversion (Loc,
          Subtype_Mark => New_Reference_To (Standard_Long_Long_Float, Loc),
          Expression   => Relocate_Node (L));
 
      Actual_2 :=
        Make_Op_Divide (Loc,
          Left_Opnd  =>
            Make_Real_Literal (Loc,
              UR_From_Uint (UI_From_Int (Int (Exponent_Value.Numerator)))),
          Right_Opnd =>
            Make_Real_Literal (Loc,
              UR_From_Uint (UI_From_Int (Int (Exponent_Value.Denominator)))));
 
      --  Step 2: Creation of New_N
 
      New_N :=
         Make_Type_Conversion (Loc,
           Subtype_Mark => New_Reference_To (New_Id, Loc),
           Expression =>
             Make_Function_Call (Loc,
               Name => New_Reference_To (RTE (RE_Expon_LLF), Loc),
               Parameter_Associations => New_List (
                 Actual_1, Actual_2)));
 
      --  Step 3: Rewrite N with the result
 
      Rewrite (N, New_N);
      Set_Etype (N, New_Id);
      Analyze_And_Resolve (N, New_Id);
   end Eval_Op_Expon_With_Rational_Exponent;
 
   ------------
   -- Exists --
   ------------
 
   function Exists (Dim : Dimension_Type) return Boolean is
   begin
      return Dim /= Null_Dimension;
   end Exists;
 
   function Exists (Sys : System_Type) return Boolean is
   begin
      return Sys /= Null_System;
   end Exists;
 
   -------------------------------------------
   -- Expand_Put_Call_With_Dimension_Symbol --
   -------------------------------------------
 
   --  For procedure Put defined in System.Dim.Float_IO/System.Dim.Integer_IO,
   --  the default string parameter must be rewritten to include the dimension
   --  symbols in the output of a dimensioned object.
 
   --  Case 1: the parameter is a variable
 
   --  The default string parameter is replaced by the symbol defined in the
   --  aspect Dimension of the subtype. For instance to output a speed:
 
   --  subtype Force is Mks_Type
   --    with
   --      Dimension => ("N",
   --        Meter =>    1,
   --        Kilogram => 1,
   --        Second =>   -2,
   --        others =>   0);
   --  F : Force := 2.1 * m * kg * s**(-2);
   --  Put (F);
   --  > 2.1 N
 
   --  Case 2: the parameter is an expression
 
   --  In this case we call the procedure Expand_Put_Call_With_Dimension_Symbol
   --  that creates the string of symbols (for instance "m.s**(-1)") and
   --  rewrites the default string parameter of Put with the corresponding
   --  the String_Id. For instance:
 
   --  Put (2.1 * m * kg * s**(-2));
   --  > 2.1 m.kg.s**(-2)
 
   procedure Expand_Put_Call_With_Dimension_Symbol (N : Node_Id) is
      Actuals        : constant List_Id := Parameter_Associations (N);
      Loc            : constant Source_Ptr := Sloc (N);
      Name_Call      : constant Node_Id := Name (N);
      New_Actuals    : constant List_Id := New_List;
      Actual         : Node_Id;
      Dims_Of_Actual : Dimension_Type;
      Etyp           : Entity_Id;
      New_Str_Lit    : Node_Id := Empty;
      System         : System_Type;
 
      function Has_Dimension_Symbols return Boolean;
      --  Return True if the current Put call already has a parameter
      --  association for parameter "Symbols" with the correct string of
      --  symbols.
 
      function Is_Procedure_Put_Call return Boolean;
      --  Return True if the current call is a call of an instantiation of a
      --  procedure Put defined in the package System.Dim.Float_IO and
      --  System.Dim.Integer_IO.
 
      function Item_Actual return Node_Id;
      --  Return the item actual parameter node in the put call
 
      ---------------------------
      -- Has_Dimension_Symbols --
      ---------------------------
 
      function Has_Dimension_Symbols return Boolean is
         Actual : Node_Id;
 
      begin
         Actual := First (Actuals);
 
         --  Look for a symbols parameter association in the list of actuals
 
         while Present (Actual) loop
            if Nkind (Actual) = N_Parameter_Association
              and then Chars (Selector_Name (Actual)) = Name_Symbols
            then
 
               --  return True if the actual comes from source or if the string
               --  of symbols doesn't have the default value (i.e "").
 
               return Comes_From_Source (Actual)
                        or else String_Length
                                  (Strval
                                    (Explicit_Actual_Parameter (Actual))) /= 0;
            end if;
 
            Next (Actual);
         end loop;
 
         --  At this point, the call has no parameter association
         --  Look to the last actual since the symbols parameter is the last
         --  one.
 
         return Nkind (Last (Actuals)) = N_String_Literal;
      end Has_Dimension_Symbols;
 
      ---------------------------
      -- Is_Procedure_Put_Call --
      ---------------------------
 
      function Is_Procedure_Put_Call return Boolean is
         Ent : Entity_Id;
         Loc : Source_Ptr;
 
      begin
         --  There are three different Put routines in each generic dim IO
         --  package. Verify the current procedure call is one of them.
 
         if Is_Entity_Name (Name_Call) then
            Ent := Entity (Name_Call);
 
            --  Get the original subprogram entity following the renaming chain
 
            if Present (Alias (Ent)) then
               Ent := Alias (Ent);
            end if;
 
            Loc := Sloc (Ent);
 
            --  Check the name of the entity subprogram is Put and verify this
            --  entity is located in either System.Dim.Float_IO or
            --  System.Dim.Integer_IO.
 
            return Chars (Ent) = Name_Put
              and then Loc > No_Location
              and then Is_Dim_IO_Package_Entity
                         (Cunit_Entity (Get_Source_Unit (Loc)));
         end if;
 
         return False;
      end Is_Procedure_Put_Call;
 
      -----------------
      -- Item_Actual --
      -----------------
 
      function Item_Actual return Node_Id is
         Actual : Node_Id;
 
      begin
         --  Look for the item actual as a parameter association
 
         Actual := First (Actuals);
         while Present (Actual) loop
            if Nkind (Actual) = N_Parameter_Association
              and then Chars (Selector_Name (Actual)) = Name_Item
            then
               return Explicit_Actual_Parameter (Actual);
            end if;
 
            Next (Actual);
         end loop;
 
         --  Case where the item has been defined without an association
 
         Actual := First (Actuals);
 
         --  Depending on the procedure Put, Item actual could be first or
         --  second in the list of actuals.
 
         if Has_Dimension_System (Base_Type (Etype (Actual))) then
            return Actual;
         else
            return Next (Actual);
         end if;
      end Item_Actual;
 
   --  Start of processing for Expand_Put_Call_With_Dimension_Symbol
 
   begin
      if Is_Procedure_Put_Call and then not Has_Dimension_Symbols then
         Actual := Item_Actual;
         Dims_Of_Actual := Dimensions_Of (Actual);
         Etyp := Etype (Actual);
 
         --  Add the symbol as a suffix of the value if the subtype has a
         --  dimension symbol or if the parameter is not dimensionless.
 
         if Symbol_Of (Etyp) /= No_String then
            Start_String;
 
            --  Put a space between the value and the dimension
 
            Store_String_Char (' ');
            Store_String_Chars (Symbol_Of (Etyp));
            New_Str_Lit := Make_String_Literal (Loc, End_String);
 
         --  Check that the item is not dimensionless
 
         --  Create the new String_Literal with the new String_Id generated by
         --  the routine From_Dimension_To_String.
 
         elsif Exists (Dims_Of_Actual) then
            System := System_Of (Base_Type (Etyp));
            New_Str_Lit :=
              Make_String_Literal (Loc,
                From_Dimension_To_String_Of_Symbols (Dims_Of_Actual, System));
         end if;
 
         if Present (New_Str_Lit) then
 
            --  Insert all actuals in New_Actuals
 
            Actual := First (Actuals);
            while Present (Actual) loop
 
               --  Copy every actuals in New_Actuals except the Symbols
               --  parameter association.
 
               if Nkind (Actual) = N_Parameter_Association
                 and then Chars (Selector_Name (Actual)) /= Name_Symbols
               then
                  Append_To (New_Actuals,
                     Make_Parameter_Association (Loc,
                        Selector_Name => New_Copy (Selector_Name (Actual)),
                        Explicit_Actual_Parameter =>
                           New_Copy (Explicit_Actual_Parameter (Actual))));
 
               elsif Nkind (Actual) /= N_Parameter_Association then
                  Append_To (New_Actuals, New_Copy (Actual));
               end if;
 
               Next (Actual);
            end loop;
 
            --  Create new Symbols param association and append to New_Actuals
 
            Append_To (New_Actuals,
              Make_Parameter_Association (Loc,
                Selector_Name => Make_Identifier (Loc, Name_Symbols),
                Explicit_Actual_Parameter => New_Str_Lit));
 
            --  Rewrite and analyze the procedure call
 
            Rewrite (N,
              Make_Procedure_Call_Statement (Loc,
                Name =>                   New_Copy (Name_Call),
                Parameter_Associations => New_Actuals));
 
            Analyze (N);
         end if;
      end if;
   end Expand_Put_Call_With_Dimension_Symbol;
 
   -----------------------------------------
   -- From_Dimension_To_String_Of_Symbols --
   -----------------------------------------
 
   --  Given a dimension vector and the corresponding dimension system,
   --  create a String_Id to output the dimension symbols corresponding to
   --  the dimensions Dims.
 
   function From_Dimension_To_String_Of_Symbols
     (Dims   : Dimension_Type;
      System : System_Type) return String_Id
   is
      Dimension_Power     : Rational;
      First_Symbol_In_Str : Boolean := True;
 
   begin
      --  Initialization of the new String_Id
 
      Start_String;
 
      --  Put a space between the value and the symbols
 
      Store_String_Char (' ');
 
      for Position in Dimension_Type'Range loop
         Dimension_Power := Dims (Position);
         if Dimension_Power /= Zero then
 
            if First_Symbol_In_Str then
               First_Symbol_In_Str := False;
            else
               Store_String_Char ('.');
            end if;
 
            --  Positive dimension case
 
            if Dimension_Power.Numerator > 0 then
               if System.Symbols (Position) = No_String then
                  Store_String_Chars
                    (Get_Name_String (System.Names (Position)));
               else
                  Store_String_Chars (System.Symbols (Position));
               end if;
 
               --  Integer case
 
               if Dimension_Power.Denominator = 1 then
                  if Dimension_Power.Numerator /= 1 then
                     Store_String_Chars ("**");
                     Store_String_Int (Int (Dimension_Power.Numerator));
                  end if;
 
               --  Rational case when denominator /= 1
 
               else
                  Store_String_Chars ("**");
                  Store_String_Char ('(');
                  Store_String_Int (Int (Dimension_Power.Numerator));
                  Store_String_Char ('/');
                  Store_String_Int (Int (Dimension_Power.Denominator));
                  Store_String_Char (')');
               end if;
 
            --  Negative dimension case
 
            else
               if System.Symbols (Position) = No_String then
                  Store_String_Chars
                    (Get_Name_String (System.Names (Position)));
               else
                  Store_String_Chars (System.Symbols (Position));
               end if;
 
               Store_String_Chars ("**");
               Store_String_Char ('(');
               Store_String_Char ('-');
               Store_String_Int (Int (-Dimension_Power.Numerator));
 
               --  Integer case
 
               if Dimension_Power.Denominator = 1 then
                  Store_String_Char (')');
 
               --  Rational case when denominator /= 1
 
               else
                  Store_String_Char ('/');
                  Store_String_Int (Int (Dimension_Power.Denominator));
                  Store_String_Char (')');
               end if;
            end if;
         end if;
      end loop;
 
      return End_String;
   end From_Dimension_To_String_Of_Symbols;
 
   ---------
   -- GCD --
   ---------
 
   function GCD (Left, Right : Whole) return Int is
      L : Whole;
      R : Whole;
 
   begin
      L := Left;
      R := Right;
      while R /= 0 loop
         L := L mod R;
 
         if L = 0 then
            return Int (R);
         end if;
 
         R := R mod L;
      end loop;
 
      return Int (L);
   end GCD;
 
   --------------------------
   -- Has_Dimension_System --
   --------------------------
 
   function Has_Dimension_System (Typ : Entity_Id) return Boolean is
   begin
      return Exists (System_Of (Typ));
   end Has_Dimension_System;
 
   ------------------------------
   -- Is_Dim_IO_Package_Entity --
   ------------------------------
 
   function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is
   begin
      --  Check the package entity corresponds to System.Dim.Float_IO or
      --  System.Dim.Integer_IO.
 
      return
        Is_RTU (E, System_Dim_Float_IO)
          or Is_RTU (E, System_Dim_Integer_IO);
   end Is_Dim_IO_Package_Entity;
 
   -------------------------------------
   -- Is_Dim_IO_Package_Instantiation --
   -------------------------------------
 
   function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is
      Gen_Id : constant Node_Id := Name (N);
 
   begin
      --  Check that the instantiated package is either System.Dim.Float_IO
      --  or System.Dim.Integer_IO.
 
      return
        Is_Entity_Name (Gen_Id)
          and then Is_Dim_IO_Package_Entity (Entity (Gen_Id));
   end Is_Dim_IO_Package_Instantiation;
 
   ----------------
   -- Is_Invalid --
   ----------------
 
   function Is_Invalid (Position : Dimension_Position) return Boolean is
   begin
      return Position = Invalid_Position;
   end Is_Invalid;
 
   ---------------------
   -- Move_Dimensions --
   ---------------------
 
   procedure Move_Dimensions (From, To : Node_Id) is
      Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
 
   begin
      --  Copy the dimension of 'From to 'To' and remove dimension of 'From'
 
      if Exists (Dims_Of_From) then
         Set_Dimensions (To, Dims_Of_From);
         Remove_Dimensions (From);
      end if;
   end Move_Dimensions;
 
   ------------
   -- Reduce --
   ------------
 
   function Reduce (X : Rational) return Rational is
   begin
      if X.Numerator = 0 then
         return Zero;
      end if;
 
      declare
         G : constant Int := GCD (X.Numerator, X.Denominator);
      begin
         return Rational'(Numerator =>   Whole (Int (X.Numerator) / G),
                          Denominator => Whole (Int (X.Denominator) / G));
      end;
   end Reduce;
 
   -----------------------
   -- Remove_Dimensions --
   -----------------------
 
   procedure Remove_Dimensions (N : Node_Id) is
      Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
   begin
      if Exists (Dims_Of_N) then
         Dimension_Table.Remove (N);
      end if;
   end Remove_Dimensions;
 
   ------------------------------
   -- Remove_Dimension_In_Call --
   ------------------------------
 
   procedure Remove_Dimension_In_Call (Call : Node_Id) is
      Actual : Node_Id;
 
   begin
      if Ada_Version < Ada_2012 then
         return;
      end if;
 
      Actual := First (Parameter_Associations (Call));
 
      while Present (Actual) loop
         Remove_Dimensions (Actual);
         Next (Actual);
      end loop;
   end Remove_Dimension_In_Call;
 
   -----------------------------------
   -- Remove_Dimension_In_Statement --
   -----------------------------------
 
   --  Removal of dimension in statement as part of the Analyze_Statements
   --  routine (see package Sem_Ch5).
 
   procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
   begin
      if Ada_Version < Ada_2012 then
         return;
      end if;
 
      --  Remove dimension in parameter specifications for accept statement
 
      if Nkind (Stmt) = N_Accept_Statement then
         declare
            Param : Node_Id := First (Parameter_Specifications (Stmt));
         begin
            while Present (Param) loop
               Remove_Dimensions (Param);
               Next (Param);
            end loop;
         end;
 
      --  Remove dimension of name and expression in assignments
 
      elsif Nkind (Stmt) = N_Assignment_Statement then
         Remove_Dimensions (Expression (Stmt));
         Remove_Dimensions (Name (Stmt));
      end if;
   end Remove_Dimension_In_Statement;
 
   --------------------
   -- Set_Dimensions --
   --------------------
 
   procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
   begin
      pragma Assert (OK_For_Dimension (Nkind (N)));
      pragma Assert (Exists (Val));
 
      Dimension_Table.Set (N, Val);
   end Set_Dimensions;
 
   ----------------
   -- Set_Symbol --
   ----------------
 
   procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
   begin
      Symbol_Table.Set (E, Val);
   end Set_Symbol;
 
   ---------------
   -- Symbol_Of --
   ---------------
 
   function Symbol_Of (E : Entity_Id) return String_Id is
   begin
      return Symbol_Table.Get (E);
   end Symbol_Of;
 
   -----------------------
   -- Symbol_Table_Hash --
   -----------------------
 
   function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
   begin
      return Symbol_Table_Range (Key mod 511);
   end Symbol_Table_Hash;
 
   ---------------
   -- System_Of --
   ---------------
 
   function System_Of (E : Entity_Id) return System_Type is
      Type_Decl : constant Node_Id := Parent (E);
 
   begin
      --  Look for Type_Decl in System_Table
 
      for Dim_Sys in 1 .. System_Table.Last loop
         if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
            return System_Table.Table (Dim_Sys);
         end if;
      end loop;
 
      return Null_System;
   end System_Of;
 
end Sem_Dim;
Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_dim.adb] - Blame information for rev 728

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- S E M _ D I M --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING3. If not, go to --`
19			`-- http://www.gnu.org/licenses for a complete copy of the license. --`
20			`-- --`
21			`-- GNAT was originally developed by the GNAT team at New York University. --`
22			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
23			`-- --`
24			`------------------------------------------------------------------------------`
25
26			`with Aspects; use Aspects;`
27			`with Atree; use Atree;`
28			`with Einfo; use Einfo;`
29			`with Errout; use Errout;`
30			`with Lib; use Lib;`
31			`with Namet; use Namet;`
32			`with Nlists; use Nlists;`
33			`with Nmake; use Nmake;`
34			`with Opt; use Opt;`
35			`with Rtsfind; use Rtsfind;`
36			`with Sem; use Sem;`
37			`with Sem_Eval; use Sem_Eval;`
38			`with Sem_Res; use Sem_Res;`
39			`with Sinfo; use Sinfo;`
40			`with Snames; use Snames;`