gcc/ada/sem_dim.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M _ D I M                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2011-2015, 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 Exp_Util; use Exp_Util;
  31 with Lib;      use Lib;
  32 with Namet;    use Namet;
  33 with Nlists;   use Nlists;
  34 with Nmake;    use Nmake;
  35 with Opt;      use Opt;
  36 with Rtsfind;  use Rtsfind;
  37 with Sem;      use Sem;
  38 with Sem_Eval; use Sem_Eval;
  39 with Sem_Res;  use Sem_Res;
  40 with Sem_Util; use Sem_Util;
  41 with Sinfo;    use Sinfo;
  42 with Sinput;   use Sinput;
  43 with Snames;   use Snames;
  44 with Stand;    use Stand;
  45 with Stringt;  use Stringt;
  46 with Table;
  47 with Tbuild;   use Tbuild;
  48 with Uintp;    use Uintp;
  49 with Urealp;   use Urealp;
  50
  51 with GNAT.HTable;
  52
  53 package body Sem_Dim is
  54
  55    -------------------------
  56    -- Rational Arithmetic --
  57    -------------------------
  58
  59    type Whole is new Int;
  60    subtype Positive_Whole is Whole range 1 .. Whole'Last;
  61
  62    type Rational is record
  63       Numerator   : Whole;
  64       Denominator : Positive_Whole;
  65    end record;
  66
  67    Zero : constant Rational := Rational'(Numerator =>   0,
  68                                          Denominator => 1);
  69
  70    No_Rational : constant Rational := Rational'(Numerator =>   0,
  71                                                 Denominator => 2);
  72    --  Used to indicate an expression that cannot be interpreted as a rational
  73    --  Returned value of the Create_Rational_From routine when parameter Expr
  74    --  is not a static representation of a rational.
  75
  76    --  Rational constructors
  77
  78    function "+" (Right : Whole) return Rational;
  79    function GCD (Left, Right : Whole) return Int;
  80    function Reduce (X : Rational) return Rational;
  81
  82    --  Unary operator for Rational
  83
  84    function "-" (Right : Rational) return Rational;
  85    function "abs" (Right : Rational) return Rational;
  86
  87    --  Rational operations for Rationals
  88
  89    function "+" (Left, Right : Rational) return Rational;
  90    function "-" (Left, Right : Rational) return Rational;
  91    function "*" (Left, Right : Rational) return Rational;
  92    function "/" (Left, Right : Rational) return Rational;
  93
  94    ------------------
  95    -- System Types --
  96    ------------------
  97
  98    Max_Number_Of_Dimensions : constant := 7;
  99    --  Maximum number of dimensions in a dimension system
 100
 101    High_Position_Bound : constant := Max_Number_Of_Dimensions;
 102    Invalid_Position    : constant := 0;
 103    Low_Position_Bound  : constant := 1;
 104
 105    subtype Dimension_Position is
 106      Nat range Invalid_Position .. High_Position_Bound;
 107
 108    type Name_Array is
 109      array (Dimension_Position range
 110               Low_Position_Bound .. High_Position_Bound) of Name_Id;
 111    --  Store the names of all units within a system
 112
 113    No_Names : constant Name_Array := (others => No_Name);
 114
 115    type Symbol_Array is
 116      array (Dimension_Position range
 117               Low_Position_Bound ..  High_Position_Bound) of String_Id;
 118    --  Store the symbols of all units within a system
 119
 120    No_Symbols : constant Symbol_Array := (others => No_String);
 121
 122    --  The following record should be documented field by field
 123
 124    type System_Type is record
 125       Type_Decl    : Node_Id;
 126       Unit_Names   : Name_Array;
 127       Unit_Symbols : Symbol_Array;
 128       Dim_Symbols  : Symbol_Array;
 129       Count        : Dimension_Position;
 130    end record;
 131
 132    Null_System : constant System_Type :=
 133                    (Empty, No_Names, No_Symbols, No_Symbols, Invalid_Position);
 134
 135    subtype System_Id is Nat;
 136
 137    --  The following table maps types to systems
 138
 139    package System_Table is new Table.Table (
 140      Table_Component_Type => System_Type,
 141      Table_Index_Type     => System_Id,
 142      Table_Low_Bound      => 1,
 143      Table_Initial        => 5,
 144      Table_Increment      => 5,
 145      Table_Name           => "System_Table");
 146
 147    --------------------
 148    -- Dimension Type --
 149    --------------------
 150
 151    type Dimension_Type is
 152      array (Dimension_Position range
 153               Low_Position_Bound ..  High_Position_Bound) of Rational;
 154
 155    Null_Dimension : constant Dimension_Type := (others => Zero);
 156
 157    type Dimension_Table_Range is range 0 .. 510;
 158    function Dimension_Table_Hash (Key : Node_Id) return Dimension_Table_Range;
 159
 160    --  The following table associates nodes with dimensions
 161
 162    package Dimension_Table is new
 163      GNAT.HTable.Simple_HTable
 164        (Header_Num => Dimension_Table_Range,
 165         Element    => Dimension_Type,
 166         No_Element => Null_Dimension,
 167         Key        => Node_Id,
 168         Hash       => Dimension_Table_Hash,
 169         Equal      => "=");
 170
 171    ------------------
 172    -- Symbol Types --
 173    ------------------
 174
 175    type Symbol_Table_Range is range 0 .. 510;
 176    function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range;
 177
 178    --  Each subtype with a dimension has a symbolic representation of the
 179    --  related unit. This table establishes a relation between the subtype
 180    --  and the symbol.
 181
 182    package Symbol_Table is new
 183      GNAT.HTable.Simple_HTable
 184        (Header_Num => Symbol_Table_Range,
 185         Element    => String_Id,
 186         No_Element => No_String,
 187         Key        => Entity_Id,
 188         Hash       => Symbol_Table_Hash,
 189         Equal      => "=");
 190
 191    --  The following array enumerates all contexts which may contain or
 192    --  produce a dimension.
 193
 194    OK_For_Dimension : constant array (Node_Kind) of Boolean :=
 195      (N_Attribute_Reference       => True,
 196       N_Expanded_Name             => True,
 197       N_Defining_Identifier       => True,
 198       N_Function_Call             => True,
 199       N_Identifier                => True,
 200       N_Indexed_Component         => True,
 201       N_Integer_Literal           => True,
 202       N_Op_Abs                    => True,
 203       N_Op_Add                    => True,
 204       N_Op_Divide                 => True,
 205       N_Op_Expon                  => True,
 206       N_Op_Minus                  => True,
 207       N_Op_Mod                    => True,
 208       N_Op_Multiply               => True,
 209       N_Op_Plus                   => True,
 210       N_Op_Rem                    => True,
 211       N_Op_Subtract               => True,
 212       N_Qualified_Expression      => True,
 213       N_Real_Literal              => True,
 214       N_Selected_Component        => True,
 215       N_Slice                     => True,
 216       N_Type_Conversion           => True,
 217       N_Unchecked_Type_Conversion => True,
 218
 219       others                      => False);
 220
 221    -----------------------
 222    -- Local Subprograms --
 223    -----------------------
 224
 225    procedure Analyze_Dimension_Assignment_Statement (N : Node_Id);
 226    --  Subroutine of Analyze_Dimension for assignment statement. Check that the
 227    --  dimensions of the left-hand side and the right-hand side of N match.
 228
 229    procedure Analyze_Dimension_Binary_Op (N : Node_Id);
 230    --  Subroutine of Analyze_Dimension for binary operators. Check the
 231    --  dimensions of the right and the left operand permit the operation.
 232    --  Then, evaluate the resulting dimensions for each binary operator.
 233
 234    procedure Analyze_Dimension_Component_Declaration (N : Node_Id);
 235    --  Subroutine of Analyze_Dimension for component declaration. Check that
 236    --  the dimensions of the type of N and of the expression match.
 237
 238    procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id);
 239    --  Subroutine of Analyze_Dimension for extended return statement. Check
 240    --  that the dimensions of the returned type and of the returned object
 241    --  match.
 242
 243    procedure Analyze_Dimension_Has_Etype (N : Node_Id);
 244    --  Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
 245    --  the list below:
 246    --    N_Attribute_Reference
 247    --    N_Identifier
 248    --    N_Indexed_Component
 249    --    N_Qualified_Expression
 250    --    N_Selected_Component
 251    --    N_Slice
 252    --    N_Type_Conversion
 253    --    N_Unchecked_Type_Conversion
 254
 255    procedure Analyze_Dimension_Object_Declaration (N : Node_Id);
 256    --  Subroutine of Analyze_Dimension for object declaration. Check that
 257    --  the dimensions of the object type and the dimensions of the expression
 258    --  (if expression is present) match. Note that when the expression is
 259    --  a literal, no error is returned. This special case allows object
 260    --  declaration such as: m : constant Length := 1.0;
 261
 262    procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id);
 263    --  Subroutine of Analyze_Dimension for object renaming declaration. Check
 264    --  the dimensions of the type and of the renamed object name of N match.
 265
 266    procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id);
 267    --  Subroutine of Analyze_Dimension for simple return statement
 268    --  Check that the dimensions of the returned type and of the returned
 269    --  expression match.
 270
 271    procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id);
 272    --  Subroutine of Analyze_Dimension for subtype declaration. Propagate the
 273    --  dimensions from the parent type to the identifier of N. Note that if
 274    --  both the identifier and the parent type of N are not dimensionless,
 275    --  return an error.
 276
 277    procedure Analyze_Dimension_Unary_Op (N : Node_Id);
 278    --  Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
 279    --  Abs operators, propagate the dimensions from the operand to N.
 280
 281    function Create_Rational_From
 282      (Expr     : Node_Id;
 283       Complain : Boolean) return Rational;
 284    --  Given an arbitrary expression Expr, return a valid rational if Expr can
 285    --  be interpreted as a rational. Otherwise return No_Rational and also an
 286    --  error message if Complain is set to True.
 287
 288    function Dimensions_Of (N : Node_Id) return Dimension_Type;
 289    --  Return the dimension vector of node N
 290
 291    function Dimensions_Msg_Of
 292       (N                  : Node_Id;
 293        Description_Needed : Boolean := False) return String;
 294    --  Given a node N, return the dimension symbols of N, preceded by "has
 295    --  dimension" if Description_Needed. if N is dimensionless, return "'[']",
 296    --  or "is dimensionless" if Description_Needed.
 297
 298    procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id);
 299    --  Issue a warning on the given numeric literal N to indicate that the
 300    --  compiler made the assumption that the literal is not dimensionless
 301    --  but has the dimension of Typ.
 302
 303    procedure Eval_Op_Expon_With_Rational_Exponent
 304      (N              : Node_Id;
 305       Exponent_Value : Rational);
 306    --  Evaluate the exponent it is a rational and the operand has a dimension
 307
 308    function Exists (Dim : Dimension_Type) return Boolean;
 309    --  Returns True iff Dim does not denote the null dimension
 310
 311    function Exists (Str : String_Id) return Boolean;
 312    --  Returns True iff Str does not denote No_String
 313
 314    function Exists (Sys : System_Type) return Boolean;
 315    --  Returns True iff Sys does not denote the null system
 316
 317    function From_Dim_To_Str_Of_Dim_Symbols
 318      (Dims         : Dimension_Type;
 319       System       : System_Type;
 320       In_Error_Msg : Boolean := False) return String_Id;
 321    --  Given a dimension vector and a dimension system, return the proper
 322    --  string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id
 323    --  will be used to issue an error message) then this routine has a special
 324    --  handling for the insertion characters * or [ which must be preceded by
 325    --  a quote ' to to be placed literally into the message.
 326
 327    function From_Dim_To_Str_Of_Unit_Symbols
 328      (Dims   : Dimension_Type;
 329       System : System_Type) return String_Id;
 330    --  Given a dimension vector and a dimension system, return the proper
 331    --  string of unit symbols.
 332
 333    function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean;
 334    --  Return True if E is the package entity of System.Dim.Float_IO or
 335    --  System.Dim.Integer_IO.
 336
 337    function Is_Invalid (Position : Dimension_Position) return Boolean;
 338    --  Return True if Pos denotes the invalid position
 339
 340    procedure Move_Dimensions (From : Node_Id; To : Node_Id);
 341    --  Copy dimension vector of From to To and delete dimension vector of From
 342
 343    procedure Remove_Dimensions (N : Node_Id);
 344    --  Remove the dimension vector of node N
 345
 346    procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type);
 347    --  Associate a dimension vector with a node
 348
 349    procedure Set_Symbol (E : Entity_Id; Val : String_Id);
 350    --  Associate a symbol representation of a dimension vector with a subtype
 351
 352    function String_From_Numeric_Literal (N : Node_Id) return String_Id;
 353    --  Return the string that corresponds to the numeric litteral N as it
 354    --  appears in the source.
 355
 356    function Symbol_Of (E : Entity_Id) return String_Id;
 357    --  E denotes a subtype with a dimension. Return the symbol representation
 358    --  of the dimension vector.
 359
 360    function System_Of (E : Entity_Id) return System_Type;
 361    --  E denotes a type, return associated system of the type if it has one
 362
 363    ---------
 364    -- "+" --
 365    ---------
 366
 367    function "+" (Right : Whole) return Rational is
 368    begin
 369       return Rational'(Numerator => Right, Denominator => 1);
 370    end "+";
 371
 372    function "+" (Left, Right : Rational) return Rational is
 373       R : constant Rational :=
 374             Rational'(Numerator   =>  Left.Numerator   * Right.Denominator +
 375                                       Left.Denominator * Right.Numerator,
 376                       Denominator => Left.Denominator  * Right.Denominator);
 377    begin
 378       return Reduce (R);
 379    end "+";
 380
 381    ---------
 382    -- "-" --
 383    ---------
 384
 385    function "-" (Right : Rational) return Rational is
 386    begin
 387       return Rational'(Numerator   => -Right.Numerator,
 388                        Denominator => Right.Denominator);
 389    end "-";
 390
 391    function "-" (Left, Right : Rational) return Rational is
 392       R : constant Rational :=
 393             Rational'(Numerator   => Left.Numerator   * Right.Denominator -
 394                                      Left.Denominator * Right.Numerator,
 395                       Denominator => Left.Denominator * Right.Denominator);
 396
 397    begin
 398       return Reduce (R);
 399    end "-";
 400
 401    ---------
 402    -- "*" --
 403    ---------
 404
 405    function "*" (Left, Right : Rational) return Rational is
 406       R : constant Rational :=
 407             Rational'(Numerator   => Left.Numerator   * Right.Numerator,
 408                       Denominator => Left.Denominator * Right.Denominator);
 409    begin
 410       return Reduce (R);
 411    end "*";
 412
 413    ---------
 414    -- "/" --
 415    ---------
 416
 417    function "/" (Left, Right : Rational) return Rational is
 418       R : constant Rational := abs Right;
 419       L : Rational := Left;
 420
 421    begin
 422       if Right.Numerator < 0 then
 423          L.Numerator := Whole (-Integer (L.Numerator));
 424       end if;
 425
 426       return Reduce (Rational'(Numerator   => L.Numerator   * R.Denominator,
 427                                Denominator => L.Denominator * R.Numerator));
 428    end "/";
 429
 430    -----------
 431    -- "abs" --
 432    -----------
 433
 434    function "abs" (Right : Rational) return Rational is
 435    begin
 436       return Rational'(Numerator   => abs Right.Numerator,
 437                        Denominator => Right.Denominator);
 438    end "abs";
 439
 440    ------------------------------
 441    -- Analyze_Aspect_Dimension --
 442    ------------------------------
 443
 444    --  with Dimension =>
 445    --    ([Symbol =>] SYMBOL, DIMENSION_VALUE {, DIMENSION_Value})
 446    --
 447    --  SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL
 448
 449    --  DIMENSION_VALUE ::=
 450    --    RATIONAL
 451    --  | others               => RATIONAL
 452    --  | DISCRETE_CHOICE_LIST => RATIONAL
 453
 454    --  RATIONAL ::= [-] NUMERIC_LITERAL [/ NUMERIC_LITERAL]
 455
 456    --  Note that when the dimensioned type is an integer type, then any
 457    --  dimension value must be an integer literal.
 458
 459    procedure Analyze_Aspect_Dimension
 460      (N    : Node_Id;
 461       Id   : Entity_Id;
 462       Aggr : Node_Id)
 463    is
 464       Def_Id : constant Entity_Id := Defining_Identifier (N);
 465
 466       Processed : array (Dimension_Type'Range) of Boolean := (others => False);
 467       --  This array is used when processing ranges or Others_Choice as part of
 468       --  the dimension aggregate.
 469
 470       Dimensions : Dimension_Type := Null_Dimension;
 471
 472       procedure Extract_Power
 473         (Expr     : Node_Id;
 474          Position : Dimension_Position);
 475       --  Given an expression with denotes a rational number, read the number
 476       --  and associate it with Position in Dimensions.
 477
 478       function Position_In_System
 479         (Id     : Node_Id;
 480          System : System_Type) return Dimension_Position;
 481       --  Given an identifier which denotes a dimension, return the position of
 482       --  that dimension within System.
 483
 484       -------------------
 485       -- Extract_Power --
 486       -------------------
 487
 488       procedure Extract_Power
 489         (Expr     : Node_Id;
 490          Position : Dimension_Position)
 491       is
 492       begin
 493          --  Integer case
 494
 495          if Is_Integer_Type (Def_Id) then
 496
 497             --  Dimension value must be an integer literal
 498
 499             if Nkind (Expr) = N_Integer_Literal then
 500                Dimensions (Position) := +Whole (UI_To_Int (Intval (Expr)));
 501             else
 502                Error_Msg_N ("integer literal expected", Expr);
 503             end if;
 504
 505          --  Float case
 506
 507          else
 508             Dimensions (Position) := Create_Rational_From (Expr, True);
 509          end if;
 510
 511          Processed (Position) := True;
 512       end Extract_Power;
 513
 514       ------------------------
 515       -- Position_In_System --
 516       ------------------------
 517
 518       function Position_In_System
 519         (Id     : Node_Id;
 520          System : System_Type) return Dimension_Position
 521       is
 522          Dimension_Name : constant Name_Id := Chars (Id);
 523
 524       begin
 525          for Position in System.Unit_Names'Range loop
 526             if Dimension_Name = System.Unit_Names (Position) then
 527                return Position;
 528             end if;
 529          end loop;
 530
 531          return Invalid_Position;
 532       end Position_In_System;
 533
 534       --  Local variables
 535
 536       Assoc          : Node_Id;
 537       Choice         : Node_Id;
 538       Expr           : Node_Id;
 539       Num_Choices    : Nat := 0;
 540       Num_Dimensions : Nat := 0;
 541       Others_Seen    : Boolean := False;
 542       Position       : Nat := 0;
 543       Sub_Ind        : Node_Id;
 544       Symbol         : String_Id := No_String;
 545       Symbol_Expr    : Node_Id;
 546       System         : System_Type;
 547       Typ            : Entity_Id;
 548
 549       Errors_Count : Nat;
 550       --  Errors_Count is a count of errors detected by the compiler so far
 551       --  just before the extraction of symbol, names and values in the
 552       --  aggregate (Step 2).
 553       --
 554       --  At the end of the analysis, there is a check to verify that this
 555       --  count equals to Serious_Errors_Detected i.e. no erros have been
 556       --  encountered during the process. Otherwise the Dimension_Table is
 557       --  not filled.
 558
 559    --  Start of processing for Analyze_Aspect_Dimension
 560
 561    begin
 562       --  STEP 1: Legality of aspect
 563
 564       if Nkind (N) /= N_Subtype_Declaration then
 565          Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id);
 566          return;
 567       end if;
 568
 569       Sub_Ind := Subtype_Indication (N);
 570       Typ := Etype (Sub_Ind);
 571       System := System_Of (Typ);
 572
 573       if Nkind (Sub_Ind) = N_Subtype_Indication then
 574          Error_Msg_NE
 575            ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);
 576          return;
 577       end if;
 578
 579       --  The dimension declarations are useless if the parent type does not
 580       --  declare a valid system.
 581
 582       if not Exists (System) then
 583          Error_Msg_NE
 584            ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
 585          return;
 586       end if;
 587
 588       if Nkind (Aggr) /= N_Aggregate then
 589          Error_Msg_N ("aggregate expected", Aggr);
 590          return;
 591       end if;
 592
 593       --  STEP 2: Symbol, Names and values extraction
 594
 595       --  Get the number of errors detected by the compiler so far
 596
 597       Errors_Count := Serious_Errors_Detected;
 598
 599       --  STEP 2a: Symbol extraction
 600
 601       --  The first entry in the aggregate may be the symbolic representation
 602       --  of the quantity.
 603
 604       --  Positional symbol argument
 605
 606       Symbol_Expr := First (Expressions (Aggr));
 607
 608       --  Named symbol argument
 609
 610       if No (Symbol_Expr)
 611         or else not Nkind_In (Symbol_Expr, N_Character_Literal,
 612                                            N_String_Literal)
 613       then
 614          Symbol_Expr := Empty;
 615
 616          --  Component associations present
 617
 618          if Present (Component_Associations (Aggr)) then
 619             Assoc  := First (Component_Associations (Aggr));
 620             Choice := First (Choices (Assoc));
 621
 622             if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
 623
 624                --  Symbol component association is present
 625
 626                if Chars (Choice) = Name_Symbol then
 627                   Num_Choices := Num_Choices + 1;
 628                   Symbol_Expr := Expression (Assoc);
 629
 630                   --  Verify symbol expression is a string or a character
 631
 632                   if not Nkind_In (Symbol_Expr, N_Character_Literal,
 633                                                 N_String_Literal)
 634                   then
 635                      Symbol_Expr := Empty;
 636                      Error_Msg_N
 637                        ("symbol expression must be character or string",
 638                         Symbol_Expr);
 639                   end if;
 640
 641                --  Special error if no Symbol choice but expression is string
 642                --  or character.
 643
 644                elsif Nkind_In (Expression (Assoc), N_Character_Literal,
 645                                                    N_String_Literal)
 646                then
 647                   Num_Choices := Num_Choices + 1;
 648                   Error_Msg_N
 649                     ("optional component Symbol expected, found&", Choice);
 650                end if;
 651             end if;
 652          end if;
 653       end if;
 654
 655       --  STEP 2b: Names and values extraction
 656
 657       --  Positional elements
 658
 659       Expr := First (Expressions (Aggr));
 660
 661       --  Skip the symbol expression when present
 662
 663       if Present (Symbol_Expr) and then Num_Choices = 0 then
 664          Expr := Next (Expr);
 665       end if;
 666
 667       Position := Low_Position_Bound;
 668       while Present (Expr) loop
 669          if Position > High_Position_Bound then
 670             Error_Msg_N
 671               ("type& has more dimensions than system allows", Def_Id);
 672             exit;
 673          end if;
 674
 675          Extract_Power (Expr, Position);
 676
 677          Position := Position + 1;
 678          Num_Dimensions := Num_Dimensions + 1;
 679
 680          Next (Expr);
 681       end loop;
 682
 683       --  Named elements
 684
 685       Assoc := First (Component_Associations (Aggr));
 686
 687       --  Skip the symbol association when present
 688
 689       if Num_Choices = 1 then
 690          Next (Assoc);
 691       end if;
 692
 693       while Present (Assoc) loop
 694          Expr := Expression (Assoc);
 695
 696          Choice := First (Choices (Assoc));
 697          while Present (Choice) loop
 698
 699             --  Identifier case: NAME => EXPRESSION
 700
 701             if Nkind (Choice) = N_Identifier then
 702                Position := Position_In_System (Choice, System);
 703
 704                if Is_Invalid (Position) then
 705                   Error_Msg_N ("dimension name& not part of system", Choice);
 706                else
 707                   Extract_Power (Expr, Position);
 708                end if;
 709
 710             --  Range case: NAME .. NAME => EXPRESSION
 711
 712             elsif Nkind (Choice) = N_Range then
 713                declare
 714                   Low      : constant Node_Id := Low_Bound (Choice);
 715                   High     : constant Node_Id := High_Bound (Choice);
 716                   Low_Pos  : Dimension_Position;
 717                   High_Pos : Dimension_Position;
 718
 719                begin
 720                   if Nkind (Low) /= N_Identifier then
 721                      Error_Msg_N ("bound must denote a dimension name", Low);
 722
 723                   elsif Nkind (High) /= N_Identifier then
 724                      Error_Msg_N ("bound must denote a dimension name", High);
 725
 726                   else
 727                      Low_Pos  := Position_In_System (Low, System);
 728                      High_Pos := Position_In_System (High, System);
 729
 730                      if Is_Invalid (Low_Pos) then
 731                         Error_Msg_N ("dimension name& not part of system",
 732                                      Low);
 733
 734                      elsif Is_Invalid (High_Pos) then
 735                         Error_Msg_N ("dimension name& not part of system",
 736                                      High);
 737
 738                      elsif Low_Pos > High_Pos then
 739                         Error_Msg_N ("expected low to high range", Choice);
 740
 741                      else
 742                         for Position in Low_Pos .. High_Pos loop
 743                            Extract_Power (Expr, Position);
 744                         end loop;
 745                      end if;
 746                   end if;
 747                end;
 748
 749             --  Others case: OTHERS => EXPRESSION
 750
 751             elsif Nkind (Choice) = N_Others_Choice then
 752                if Present (Next (Choice)) or else Present (Prev (Choice)) then
 753                   Error_Msg_N
 754                     ("OTHERS must appear alone in a choice list", Choice);
 755
 756                elsif Present (Next (Assoc)) then
 757                   Error_Msg_N
 758                     ("OTHERS must appear last in an aggregate", Choice);
 759
 760                elsif Others_Seen then
 761                   Error_Msg_N ("multiple OTHERS not allowed", Choice);
 762
 763                else
 764                   --  Fill the non-processed dimensions with the default value
 765                   --  supplied by others.
 766
 767                   for Position in Processed'Range loop
 768                      if not Processed (Position) then
 769                         Extract_Power (Expr, Position);
 770                      end if;
 771                   end loop;
 772                end if;
 773
 774                Others_Seen := True;
 775
 776             --  All other cases are illegal declarations of dimension names
 777
 778             else
 779                Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
 780             end if;
 781
 782             Num_Choices := Num_Choices + 1;
 783             Next (Choice);
 784          end loop;
 785
 786          Num_Dimensions := Num_Dimensions + 1;
 787          Next (Assoc);
 788       end loop;
 789
 790       --  STEP 3: Consistency of system and dimensions
 791
 792       if Present (First (Expressions (Aggr)))
 793         and then (First (Expressions (Aggr)) /= Symbol_Expr
 794                    or else Present (Next (Symbol_Expr)))
 795         and then (Num_Choices > 1
 796                    or else (Num_Choices = 1 and then not Others_Seen))
 797       then
 798          Error_Msg_N
 799            ("named associations cannot follow positional associations", Aggr);
 800       end if;
 801
 802       if Num_Dimensions > System.Count then
 803          Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
 804
 805       elsif Num_Dimensions < System.Count and then not Others_Seen then
 806          Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
 807       end if;
 808
 809       --  STEP 4: Dimension symbol extraction
 810
 811       if Present (Symbol_Expr) then
 812          if Nkind (Symbol_Expr) = N_Character_Literal then
 813             Start_String;
 814             Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr)));
 815             Symbol := End_String;
 816
 817          else
 818             Symbol := Strval (Symbol_Expr);
 819          end if;
 820
 821          if String_Length (Symbol) = 0 then
 822             Error_Msg_N ("empty string not allowed here", Symbol_Expr);
 823          end if;
 824       end if;
 825
 826       --  STEP 5: Storage of extracted values
 827
 828       --  Check that no errors have been detected during the analysis
 829
 830       if Errors_Count = Serious_Errors_Detected then
 831
 832          --  Check for useless declaration
 833
 834          if Symbol = No_String and then not Exists (Dimensions) then
 835             Error_Msg_N ("useless dimension declaration", Aggr);
 836          end if;
 837
 838          if Symbol /= No_String then
 839             Set_Symbol (Def_Id, Symbol);
 840          end if;
 841
 842          if Exists (Dimensions) then
 843             Set_Dimensions (Def_Id, Dimensions);
 844          end if;
 845       end if;
 846    end Analyze_Aspect_Dimension;
 847
 848    -------------------------------------
 849    -- Analyze_Aspect_Dimension_System --
 850    -------------------------------------
 851
 852    --  with Dimension_System => (DIMENSION {, DIMENSION});
 853
 854    --  DIMENSION ::= (
 855    --    [Unit_Name   =>] IDENTIFIER,
 856    --    [Unit_Symbol =>] SYMBOL,
 857    --    [Dim_Symbol  =>] SYMBOL)
 858
 859    procedure Analyze_Aspect_Dimension_System
 860      (N    : Node_Id;
 861       Id   : Entity_Id;
 862       Aggr : Node_Id)
 863    is
 864       function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
 865       --  Determine whether type declaration N denotes a numeric derived type
 866
 867       -------------------------------
 868       -- Is_Derived_Numeric_Type --
 869       -------------------------------
 870
 871       function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
 872       begin
 873          return
 874            Nkind (N) = N_Full_Type_Declaration
 875              and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
 876              and then Is_Numeric_Type
 877                         (Entity (Subtype_Indication (Type_Definition (N))));
 878       end Is_Derived_Numeric_Type;
 879
 880       --  Local variables
 881
 882       Assoc        : Node_Id;
 883       Choice       : Node_Id;
 884       Dim_Aggr     : Node_Id;
 885       Dim_Symbol   : Node_Id;
 886       Dim_Symbols  : Symbol_Array := No_Symbols;
 887       Dim_System   : System_Type  := Null_System;
 888       Position     : Nat := 0;
 889       Unit_Name    : Node_Id;
 890       Unit_Names   : Name_Array   := No_Names;
 891       Unit_Symbol  : Node_Id;
 892       Unit_Symbols : Symbol_Array := No_Symbols;
 893
 894       Errors_Count : Nat;
 895       --  Errors_Count is a count of errors detected by the compiler so far
 896       --  just before the extraction of names and symbols in the aggregate
 897       --  (Step 3).
 898       --
 899       --  At the end of the analysis, there is a check to verify that this
 900       --  count equals Serious_Errors_Detected i.e. no errors have been
 901       --  encountered during the process. Otherwise the System_Table is
 902       --  not filled.
 903
 904    --  Start of processing for Analyze_Aspect_Dimension_System
 905
 906    begin
 907       --  STEP 1: Legality of aspect
 908
 909       if not Is_Derived_Numeric_Type (N) then
 910          Error_Msg_NE
 911            ("aspect& must apply to numeric derived type declaration", N, Id);
 912          return;
 913       end if;
 914
 915       if Nkind (Aggr) /= N_Aggregate then
 916          Error_Msg_N ("aggregate expected", Aggr);
 917          return;
 918       end if;
 919
 920       --  STEP 2: Structural verification of the dimension aggregate
 921
 922       if Present (Component_Associations (Aggr)) then
 923          Error_Msg_N ("expected positional aggregate", Aggr);
 924          return;
 925       end if;
 926
 927       --  STEP 3: Name and Symbol extraction
 928
 929       Dim_Aggr     := First (Expressions (Aggr));
 930       Errors_Count := Serious_Errors_Detected;
 931       while Present (Dim_Aggr) loop
 932          Position := Position + 1;
 933
 934          if Position > High_Position_Bound then
 935             Error_Msg_N ("too many dimensions in system", Aggr);
 936             exit;
 937          end if;
 938
 939          if Nkind (Dim_Aggr) /= N_Aggregate then
 940             Error_Msg_N ("aggregate expected", Dim_Aggr);
 941
 942          else
 943             if Present (Component_Associations (Dim_Aggr))
 944               and then Present (Expressions (Dim_Aggr))
 945             then
 946                Error_Msg_N
 947                  ("mixed positional/named aggregate not allowed here",
 948                   Dim_Aggr);
 949
 950             --  Verify each dimension aggregate has three arguments
 951
 952             elsif List_Length (Component_Associations (Dim_Aggr)) /= 3
 953               and then List_Length (Expressions (Dim_Aggr)) /= 3
 954             then
 955                Error_Msg_N
 956                  ("three components expected in aggregate", Dim_Aggr);
 957
 958             else
 959                --  Named dimension aggregate
 960
 961                if Present (Component_Associations (Dim_Aggr)) then
 962
 963                   --  Check first argument denotes the unit name
 964
 965                   Assoc     := First (Component_Associations (Dim_Aggr));
 966                   Choice    := First (Choices (Assoc));
 967                   Unit_Name := Expression (Assoc);
 968
 969                   if Present (Next (Choice))
 970                     or else Nkind (Choice) /= N_Identifier
 971                   then
 972                      Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
 973
 974                   elsif Chars (Choice) /= Name_Unit_Name then
 975                      Error_Msg_N ("expected Unit_Name, found&", Choice);
 976                   end if;
 977
 978                   --  Check the second argument denotes the unit symbol
 979
 980                   Next (Assoc);
 981                   Choice      := First (Choices (Assoc));
 982                   Unit_Symbol := Expression (Assoc);
 983
 984                   if Present (Next (Choice))
 985                     or else Nkind (Choice) /= N_Identifier
 986                   then
 987                      Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
 988
 989                   elsif Chars (Choice) /= Name_Unit_Symbol then
 990                      Error_Msg_N ("expected Unit_Symbol, found&", Choice);
 991                   end if;
 992
 993                   --  Check the third argument denotes the dimension symbol
 994
 995                   Next (Assoc);
 996                   Choice     := First (Choices (Assoc));
 997                   Dim_Symbol := Expression (Assoc);
 998
 999                   if Present (Next (Choice))
1000                     or else Nkind (Choice) /= N_Identifier
1001                   then
1002                      Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1003                   elsif Chars (Choice) /= Name_Dim_Symbol then
1004                      Error_Msg_N ("expected Dim_Symbol, found&", Choice);
1005                   end if;
1006
1007                --  Positional dimension aggregate
1008
1009                else
1010                   Unit_Name   := First (Expressions (Dim_Aggr));
1011                   Unit_Symbol := Next (Unit_Name);
1012                   Dim_Symbol  := Next (Unit_Symbol);
1013                end if;
1014
1015                --  Check the first argument for each dimension aggregate is
1016                --  a name.
1017
1018                if Nkind (Unit_Name) = N_Identifier then
1019                   Unit_Names (Position) := Chars (Unit_Name);
1020                else
1021                   Error_Msg_N ("expected unit name", Unit_Name);
1022                end if;
1023
1024                --  Check the second argument for each dimension aggregate is
1025                --  a string or a character.
1026
1027                if not Nkind_In (Unit_Symbol, N_String_Literal,
1028                                              N_Character_Literal)
1029                then
1030                   Error_Msg_N
1031                     ("expected unit symbol (string or character)",
1032                      Unit_Symbol);
1033
1034                else
1035                   --  String case
1036
1037                   if Nkind (Unit_Symbol) = N_String_Literal then
1038                      Unit_Symbols (Position) := Strval (Unit_Symbol);
1039
1040                   --  Character case
1041
1042                   else
1043                      Start_String;
1044                      Store_String_Char
1045                        (UI_To_CC (Char_Literal_Value (Unit_Symbol)));
1046                      Unit_Symbols (Position) := End_String;
1047                   end if;
1048
1049                   --  Verify that the string is not empty
1050
1051                   if String_Length (Unit_Symbols (Position)) = 0 then
1052                      Error_Msg_N
1053                        ("empty string not allowed here", Unit_Symbol);
1054                   end if;
1055                end if;
1056
1057                --  Check the third argument for each dimension aggregate is
1058                --  a string or a character.
1059
1060                if not Nkind_In (Dim_Symbol, N_String_Literal,
1061                                             N_Character_Literal)
1062                then
1063                   Error_Msg_N
1064                     ("expected dimension symbol (string or character)",
1065                      Dim_Symbol);
1066
1067                else
1068                   --  String case
1069
1070                   if Nkind (Dim_Symbol) = N_String_Literal then
1071                      Dim_Symbols (Position) := Strval (Dim_Symbol);
1072
1073                   --  Character case
1074
1075                   else
1076                      Start_String;
1077                      Store_String_Char
1078                        (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
1079                      Dim_Symbols (Position) := End_String;
1080                   end if;
1081
1082                   --  Verify that the string is not empty
1083
1084                   if String_Length (Dim_Symbols (Position)) = 0 then
1085                      Error_Msg_N ("empty string not allowed here", Dim_Symbol);
1086                   end if;
1087                end if;
1088             end if;
1089          end if;
1090
1091          Next (Dim_Aggr);
1092       end loop;
1093
1094       --  STEP 4: Storage of extracted values
1095
1096       --  Check that no errors have been detected during the analysis
1097
1098       if Errors_Count = Serious_Errors_Detected then
1099          Dim_System.Type_Decl    := N;
1100          Dim_System.Unit_Names   := Unit_Names;
1101          Dim_System.Unit_Symbols := Unit_Symbols;
1102          Dim_System.Dim_Symbols  := Dim_Symbols;
1103          Dim_System.Count        := Position;
1104          System_Table.Append (Dim_System);
1105       end if;
1106    end Analyze_Aspect_Dimension_System;
1107
1108    -----------------------
1109    -- Analyze_Dimension --
1110    -----------------------
1111
1112    --  This dispatch routine propagates dimensions for each node
1113
1114    procedure Analyze_Dimension (N : Node_Id) is
1115    begin
1116       --  Aspect is an Ada 2012 feature. Note that there is no need to check
1117       --  dimensions for nodes that don't come from source.
1118
1119       if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
1120          return;
1121       end if;
1122
1123       case Nkind (N) is
1124          when N_Assignment_Statement =>
1125             Analyze_Dimension_Assignment_Statement (N);
1126
1127          when N_Binary_Op =>
1128             Analyze_Dimension_Binary_Op (N);
1129
1130          when N_Component_Declaration =>
1131             Analyze_Dimension_Component_Declaration (N);
1132
1133          when N_Extended_Return_Statement =>
1134             Analyze_Dimension_Extended_Return_Statement (N);
1135
1136          when N_Attribute_Reference       |
1137               N_Expanded_Name             |
1138               N_Function_Call             |
1139               N_Identifier                |
1140               N_Indexed_Component         |
1141               N_Qualified_Expression      |
1142               N_Selected_Component        |
1143               N_Slice                     |
1144               N_Type_Conversion           |
1145               N_Unchecked_Type_Conversion =>
1146             Analyze_Dimension_Has_Etype (N);
1147
1148          when N_Object_Declaration =>
1149             Analyze_Dimension_Object_Declaration (N);
1150
1151          when N_Object_Renaming_Declaration =>
1152             Analyze_Dimension_Object_Renaming_Declaration (N);
1153
1154          when N_Simple_Return_Statement =>
1155             if not Comes_From_Extended_Return_Statement (N) then
1156                Analyze_Dimension_Simple_Return_Statement (N);
1157             end if;
1158
1159          when N_Subtype_Declaration =>
1160             Analyze_Dimension_Subtype_Declaration (N);
1161
1162          when N_Unary_Op =>
1163             Analyze_Dimension_Unary_Op (N);
1164
1165          when others => null;
1166
1167       end case;
1168    end Analyze_Dimension;
1169
1170    ---------------------------------------
1171    -- Analyze_Dimension_Array_Aggregate --
1172    ---------------------------------------
1173
1174    procedure Analyze_Dimension_Array_Aggregate
1175      (N        : Node_Id;
1176       Comp_Typ : Entity_Id)
1177    is
1178       Comp_Ass         : constant List_Id        := Component_Associations (N);
1179       Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
1180       Exps             : constant List_Id        := Expressions (N);
1181
1182       Comp : Node_Id;
1183       Expr : Node_Id;
1184
1185       Error_Detected : Boolean := False;
1186       --  This flag is used in order to indicate if an error has been detected
1187       --  so far by the compiler in this routine.
1188
1189    begin
1190       --  Aspect is an Ada 2012 feature. Nothing to do here if the component
1191       --  base type is not a dimensioned type.
1192
1193       --  Note that here the original node must come from source since the
1194       --  original array aggregate may not have been entirely decorated.
1195
1196       if Ada_Version < Ada_2012
1197         or else not Comes_From_Source (Original_Node (N))
1198         or else not Has_Dimension_System (Base_Type (Comp_Typ))
1199       then
1200          return;
1201       end if;
1202
1203       --  Check whether there is any positional component association
1204
1205       if Is_Empty_List (Exps) then
1206          Comp := First (Comp_Ass);
1207       else
1208          Comp := First (Exps);
1209       end if;
1210
1211       while Present (Comp) loop
1212
1213          --  Get the expression from the component
1214
1215          if Nkind (Comp) = N_Component_Association then
1216             Expr := Expression (Comp);
1217          else
1218             Expr := Comp;
1219          end if;
1220
1221          --  Issue an error if the dimensions of the component type and the
1222          --  dimensions of the component mismatch.
1223
1224          --  Note that we must ensure the expression has been fully analyzed
1225          --  since it may not be decorated at this point. We also don't want to
1226          --  issue the same error message multiple times on the same expression
1227          --  (may happen when an aggregate is converted into a positional
1228          --  aggregate).
1229
1230          if Comes_From_Source (Original_Node (Expr))
1231            and then Present (Etype (Expr))
1232            and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ
1233            and then Sloc (Comp) /= Sloc (Prev (Comp))
1234          then
1235             --  Check if an error has already been encountered so far
1236
1237             if not Error_Detected then
1238                Error_Msg_N ("dimensions mismatch in array aggregate", N);
1239                Error_Detected := True;
1240             end if;
1241
1242             Error_Msg_N
1243               ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
1244                & ", found " & Dimensions_Msg_Of (Expr), Expr);
1245          end if;
1246
1247          --  Look at the named components right after the positional components
1248
1249          if not Present (Next (Comp))
1250            and then List_Containing (Comp) = Exps
1251          then
1252             Comp := First (Comp_Ass);
1253          else
1254             Next (Comp);
1255          end if;
1256       end loop;
1257    end Analyze_Dimension_Array_Aggregate;
1258
1259    --------------------------------------------
1260    -- Analyze_Dimension_Assignment_Statement --
1261    --------------------------------------------
1262
1263    procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1264       Lhs         : constant Node_Id := Name (N);
1265       Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1266       Rhs         : constant Node_Id := Expression (N);
1267       Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1268
1269       procedure Error_Dim_Msg_For_Assignment_Statement
1270         (N   : Node_Id;
1271          Lhs : Node_Id;
1272          Rhs : Node_Id);
1273       --  Error using Error_Msg_N at node N. Output the dimensions of left
1274       --  and right hand sides.
1275
1276       --------------------------------------------
1277       -- Error_Dim_Msg_For_Assignment_Statement --
1278       --------------------------------------------
1279
1280       procedure Error_Dim_Msg_For_Assignment_Statement
1281         (N   : Node_Id;
1282          Lhs : Node_Id;
1283          Rhs : Node_Id)
1284       is
1285       begin
1286          Error_Msg_N ("dimensions mismatch in assignment", N);
1287          Error_Msg_N ("\left-hand side "  & Dimensions_Msg_Of (Lhs, True), N);
1288          Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
1289       end Error_Dim_Msg_For_Assignment_Statement;
1290
1291    --  Start of processing for Analyze_Dimension_Assignment
1292
1293    begin
1294       if Dims_Of_Lhs /= Dims_Of_Rhs then
1295          Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
1296       end if;
1297    end Analyze_Dimension_Assignment_Statement;
1298
1299    ---------------------------------
1300    -- Analyze_Dimension_Binary_Op --
1301    ---------------------------------
1302
1303    --  Check and propagate the dimensions for binary operators
1304    --  Note that when the dimensions mismatch, no dimension is propagated to N.
1305
1306    procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1307       N_Kind : constant Node_Kind := Nkind (N);
1308
1309       procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
1310       --  Error using Error_Msg_NE and Error_Msg_N at node N. Output the
1311       --  dimensions of both operands.
1312
1313       ---------------------------------
1314       -- Error_Dim_Msg_For_Binary_Op --
1315       ---------------------------------
1316
1317       procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
1318       begin
1319          Error_Msg_NE
1320            ("both operands for operation& must have same dimensions",
1321             N, Entity (N));
1322          Error_Msg_N ("\left operand "  & Dimensions_Msg_Of (L, True), N);
1323          Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
1324       end Error_Dim_Msg_For_Binary_Op;
1325
1326    --  Start of processing for Analyze_Dimension_Binary_Op
1327
1328    begin
1329       if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
1330         or else N_Kind in N_Multiplying_Operator
1331         or else N_Kind in N_Op_Compare
1332       then
1333          declare
1334             L                : constant Node_Id        := Left_Opnd (N);
1335             Dims_Of_L        : constant Dimension_Type := Dimensions_Of (L);
1336             L_Has_Dimensions : constant Boolean        := Exists (Dims_Of_L);
1337             R                : constant Node_Id        := Right_Opnd (N);
1338             Dims_Of_R        : constant Dimension_Type := Dimensions_Of (R);
1339             R_Has_Dimensions : constant Boolean        := Exists (Dims_Of_R);
1340             Dims_Of_N        : Dimension_Type          := Null_Dimension;
1341
1342          begin
1343             --  N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1344
1345             if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
1346
1347                --  Check both operands have same dimension
1348
1349                if Dims_Of_L /= Dims_Of_R then
1350                   Error_Dim_Msg_For_Binary_Op (N, L, R);
1351                else
1352                   --  Check both operands are not dimensionless
1353
1354                   if Exists (Dims_Of_L) then
1355                      Set_Dimensions (N, Dims_Of_L);
1356                   end if;
1357                end if;
1358
1359             --  N_Op_Multiply or N_Op_Divide case
1360
1361             elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
1362
1363                --  Check at least one operand is not dimensionless
1364
1365                if L_Has_Dimensions or R_Has_Dimensions then
1366
1367                   --  Multiplication case
1368
1369                   --  Get both operands dimensions and add them
1370
1371                   if N_Kind = N_Op_Multiply then
1372                      for Position in Dimension_Type'Range loop
1373                         Dims_Of_N (Position) :=
1374                           Dims_Of_L (Position) + Dims_Of_R (Position);
1375                      end loop;
1376
1377                   --  Division case
1378
1379                   --  Get both operands dimensions and subtract them
1380
1381                   else
1382                      for Position in Dimension_Type'Range loop
1383                         Dims_Of_N (Position) :=
1384                           Dims_Of_L (Position) - Dims_Of_R (Position);
1385                      end loop;
1386                   end if;
1387
1388                   if Exists (Dims_Of_N) then
1389                      Set_Dimensions (N, Dims_Of_N);
1390                   end if;
1391                end if;
1392
1393             --  Exponentiation case
1394
1395             --  Note: a rational exponent is allowed for dimensioned operand
1396
1397             elsif N_Kind = N_Op_Expon then
1398
1399                --  Check the left operand is not dimensionless. Note that the
1400                --  value of the exponent must be known compile time. Otherwise,
1401                --  the exponentiation evaluation will return an error message.
1402
1403                if L_Has_Dimensions then
1404                   if not Compile_Time_Known_Value (R) then
1405                      Error_Msg_N
1406                        ("exponent of dimensioned operand must be "
1407                         & "known at compile time", N);
1408                   end if;
1409
1410                   declare
1411                      Exponent_Value : Rational := Zero;
1412
1413                   begin
1414                      --  Real operand case
1415
1416                      if Is_Real_Type (Etype (L)) then
1417
1418                         --  Define the exponent as a Rational number
1419
1420                         Exponent_Value := Create_Rational_From (R, False);
1421
1422                         --  Verify that the exponent cannot be interpreted
1423                         --  as a rational, otherwise interpret the exponent
1424                         --  as an integer.
1425
1426                         if Exponent_Value = No_Rational then
1427                            Exponent_Value :=
1428                              +Whole (UI_To_Int (Expr_Value (R)));
1429                         end if;
1430
1431                      --  Integer operand case.
1432
1433                      --  For integer operand, the exponent cannot be
1434                      --  interpreted as a rational.
1435
1436                      else
1437                         Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1438                      end if;
1439
1440                      for Position in Dimension_Type'Range loop
1441                         Dims_Of_N (Position) :=
1442                           Dims_Of_L (Position) * Exponent_Value;
1443                      end loop;
1444
1445                      if Exists (Dims_Of_N) then
1446                         Set_Dimensions (N, Dims_Of_N);
1447                      end if;
1448                   end;
1449                end if;
1450
1451             --  Comparison cases
1452
1453             --  For relational operations, only dimension checking is
1454             --  performed (no propagation).
1455
1456             elsif N_Kind in N_Op_Compare then
1457                if (L_Has_Dimensions or R_Has_Dimensions)
1458                  and then Dims_Of_L /= Dims_Of_R
1459                then
1460                   Error_Dim_Msg_For_Binary_Op (N, L, R);
1461                end if;
1462             end if;
1463
1464             --  Removal of dimensions for each operands
1465
1466             Remove_Dimensions (L);
1467             Remove_Dimensions (R);
1468          end;
1469       end if;
1470    end Analyze_Dimension_Binary_Op;
1471
1472    ----------------------------
1473    -- Analyze_Dimension_Call --
1474    ----------------------------
1475
1476    procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
1477       Actuals        : constant List_Id := Parameter_Associations (N);
1478       Actual         : Node_Id;
1479       Dims_Of_Formal : Dimension_Type;
1480       Formal         : Node_Id;
1481       Formal_Typ     : Entity_Id;
1482
1483       Error_Detected : Boolean := False;
1484       --  This flag is used in order to indicate if an error has been detected
1485       --  so far by the compiler in this routine.
1486
1487    begin
1488       --  Aspect is an Ada 2012 feature. Note that there is no need to check
1489       --  dimensions for calls that don't come from source, or those that may
1490       --  have semantic errors.
1491
1492       if Ada_Version < Ada_2012
1493         or else not Comes_From_Source (N)
1494         or else Error_Posted (N)
1495       then
1496          return;
1497       end if;
1498
1499       --  Check the dimensions of the actuals, if any
1500
1501       if not Is_Empty_List (Actuals) then
1502
1503          --  Special processing for elementary functions
1504
1505          --  For Sqrt call, the resulting dimensions equal to half the
1506          --  dimensions of the actual. For all other elementary calls, this
1507          --  routine check that every actual is dimensionless.
1508
1509          if Nkind (N) = N_Function_Call then
1510             Elementary_Function_Calls : declare
1511                Dims_Of_Call : Dimension_Type;
1512                Ent          : Entity_Id := Nam;
1513
1514                function Is_Elementary_Function_Entity
1515                  (Sub_Id : Entity_Id) return Boolean;
1516                --  Given Sub_Id, the original subprogram entity, return True
1517                --  if call is to an elementary function (see Ada.Numerics.
1518                --  Generic_Elementary_Functions).
1519
1520                -----------------------------------
1521                -- Is_Elementary_Function_Entity --
1522                -----------------------------------
1523
1524                function Is_Elementary_Function_Entity
1525                  (Sub_Id : Entity_Id) return Boolean
1526                is
1527                   Loc : constant Source_Ptr := Sloc (Sub_Id);
1528
1529                begin
1530                   --  Is entity in Ada.Numerics.Generic_Elementary_Functions?
1531
1532                   return
1533                     Loc > No_Location
1534                       and then
1535                         Is_RTU
1536                           (Cunit_Entity (Get_Source_Unit (Loc)),
1537                             Ada_Numerics_Generic_Elementary_Functions);
1538                end Is_Elementary_Function_Entity;
1539
1540             --  Start of processing for Elementary_Function_Calls
1541
1542             begin
1543                --  Get original subprogram entity following the renaming chain
1544
1545                if Present (Alias (Ent)) then
1546                   Ent := Alias (Ent);
1547                end if;
1548
1549                --  Check the call is an Elementary function call
1550
1551                if Is_Elementary_Function_Entity (Ent) then
1552
1553                   --  Sqrt function call case
1554
1555                   if Chars (Ent) = Name_Sqrt then
1556                      Dims_Of_Call := Dimensions_Of (First_Actual (N));
1557
1558                      --  Evaluates the resulting dimensions (i.e. half the
1559                      --  dimensions of the actual).
1560
1561                      if Exists (Dims_Of_Call) then
1562                         for Position in Dims_Of_Call'Range loop
1563                            Dims_Of_Call (Position) :=
1564                              Dims_Of_Call (Position) *
1565                                Rational'(Numerator => 1, Denominator => 2);
1566                         end loop;
1567
1568                         Set_Dimensions (N, Dims_Of_Call);
1569                      end if;
1570
1571                   --  All other elementary functions case. Note that every
1572                   --  actual here should be dimensionless.
1573
1574                   else
1575                      Actual := First_Actual (N);
1576                      while Present (Actual) loop
1577                         if Exists (Dimensions_Of (Actual)) then
1578
1579                            --  Check if error has already been encountered
1580
1581                            if not Error_Detected then
1582                               Error_Msg_NE
1583                                 ("dimensions mismatch in call of&",
1584                                  N, Name (N));
1585                               Error_Detected := True;
1586                            end if;
1587
1588                            Error_Msg_N
1589                              ("\expected dimension '['], found "
1590                               & Dimensions_Msg_Of (Actual), Actual);
1591                         end if;
1592
1593                         Next_Actual (Actual);
1594                      end loop;
1595                   end if;
1596
1597                   --  Nothing more to do for elementary functions
1598
1599                   return;
1600                end if;
1601             end Elementary_Function_Calls;
1602          end if;
1603
1604          --  General case. Check, for each parameter, the dimensions of the
1605          --  actual and its corresponding formal match. Otherwise, complain.
1606
1607          Actual := First_Actual (N);
1608          Formal := First_Formal (Nam);
1609          while Present (Formal) loop
1610
1611             --  A missing corresponding actual indicates that the analysis of
1612             --  the call was aborted due to a previous error.
1613
1614             if No (Actual) then
1615                Check_Error_Detected;
1616                return;
1617             end if;
1618
1619             Formal_Typ     := Etype (Formal);
1620             Dims_Of_Formal := Dimensions_Of (Formal_Typ);
1621
1622             --  If the formal is not dimensionless, check dimensions of formal
1623             --  and actual match. Otherwise, complain.
1624
1625             if Exists (Dims_Of_Formal)
1626               and then Dimensions_Of (Actual) /= Dims_Of_Formal
1627             then
1628                --  Check if an error has already been encountered so far
1629
1630                if not Error_Detected then
1631                   Error_Msg_NE ("dimensions mismatch in& call", N, Name (N));
1632                   Error_Detected := True;
1633                end if;
1634
1635                Error_Msg_N
1636                  ("\expected dimension " & Dimensions_Msg_Of (Formal_Typ)
1637                   & ", found " & Dimensions_Msg_Of (Actual), Actual);
1638             end if;
1639
1640             Next_Actual (Actual);
1641             Next_Formal (Formal);
1642          end loop;
1643       end if;
1644
1645       --  For function calls, propagate the dimensions from the returned type
1646
1647       if Nkind (N) = N_Function_Call then
1648          Analyze_Dimension_Has_Etype (N);
1649       end if;
1650    end Analyze_Dimension_Call;
1651
1652    ---------------------------------------------
1653    -- Analyze_Dimension_Component_Declaration --
1654    ---------------------------------------------
1655
1656    procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is
1657       Expr         : constant Node_Id        := Expression (N);
1658       Id           : constant Entity_Id      := Defining_Identifier (N);
1659       Etyp         : constant Entity_Id      := Etype (Id);
1660       Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1661       Dims_Of_Expr : Dimension_Type;
1662
1663       procedure Error_Dim_Msg_For_Component_Declaration
1664         (N    : Node_Id;
1665          Etyp : Entity_Id;
1666          Expr : Node_Id);
1667       --  Error using Error_Msg_N at node N. Output the dimensions of the
1668       --  type Etyp and the expression Expr of N.
1669
1670       ---------------------------------------------
1671       -- Error_Dim_Msg_For_Component_Declaration --
1672       ---------------------------------------------
1673
1674       procedure Error_Dim_Msg_For_Component_Declaration
1675         (N    : Node_Id;
1676          Etyp : Entity_Id;
1677          Expr : Node_Id) is
1678       begin
1679          Error_Msg_N ("dimensions mismatch in component declaration", N);
1680          Error_Msg_N
1681            ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found "
1682             & Dimensions_Msg_Of (Expr), Expr);
1683       end Error_Dim_Msg_For_Component_Declaration;
1684
1685    --  Start of processing for Analyze_Dimension_Component_Declaration
1686
1687    begin
1688       --  Expression is present
1689
1690       if Present (Expr) then
1691          Dims_Of_Expr := Dimensions_Of (Expr);
1692
1693          --  Check dimensions match
1694
1695          if Dims_Of_Etyp /= Dims_Of_Expr then
1696
1697             --  Numeric literal case. Issue a warning if the object type is not
1698             --  dimensionless to indicate the literal is treated as if its
1699             --  dimension matches the type dimension.
1700
1701             if Nkind_In (Original_Node (Expr), N_Real_Literal,
1702                                                N_Integer_Literal)
1703             then
1704                Dim_Warning_For_Numeric_Literal (Expr, Etyp);
1705
1706             --  Issue a dimension mismatch error for all other cases
1707
1708             else
1709                Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
1710             end if;
1711          end if;
1712       end if;
1713    end Analyze_Dimension_Component_Declaration;
1714
1715    -------------------------------------------------
1716    -- Analyze_Dimension_Extended_Return_Statement --
1717    -------------------------------------------------
1718
1719    procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
1720       Return_Ent       : constant Entity_Id := Return_Statement_Entity (N);
1721       Return_Etyp      : constant Entity_Id :=
1722                            Etype (Return_Applies_To (Return_Ent));
1723       Return_Obj_Decls : constant List_Id := Return_Object_Declarations (N);
1724       Return_Obj_Decl  : Node_Id;
1725       Return_Obj_Id    : Entity_Id;
1726       Return_Obj_Typ   : Entity_Id;
1727
1728       procedure Error_Dim_Msg_For_Extended_Return_Statement
1729         (N              : Node_Id;
1730          Return_Etyp    : Entity_Id;
1731          Return_Obj_Typ : Entity_Id);
1732       --  Error using Error_Msg_N at node N. Output dimensions of the returned
1733       --  type Return_Etyp and the returned object type Return_Obj_Typ of N.
1734
1735       -------------------------------------------------
1736       -- Error_Dim_Msg_For_Extended_Return_Statement --
1737       -------------------------------------------------
1738
1739       procedure Error_Dim_Msg_For_Extended_Return_Statement
1740         (N              : Node_Id;
1741          Return_Etyp    : Entity_Id;
1742          Return_Obj_Typ : Entity_Id)
1743       is
1744       begin
1745          Error_Msg_N ("dimensions mismatch in extended return statement", N);
1746          Error_Msg_N
1747            ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp)
1748             & ", found " & Dimensions_Msg_Of (Return_Obj_Typ), N);
1749       end Error_Dim_Msg_For_Extended_Return_Statement;
1750
1751    --  Start of processing for Analyze_Dimension_Extended_Return_Statement
1752
1753    begin
1754       if Present (Return_Obj_Decls) then
1755          Return_Obj_Decl := First (Return_Obj_Decls);
1756          while Present (Return_Obj_Decl) loop
1757             if Nkind (Return_Obj_Decl) = N_Object_Declaration then
1758                Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
1759
1760                if Is_Return_Object (Return_Obj_Id) then
1761                   Return_Obj_Typ := Etype (Return_Obj_Id);
1762
1763                   --  Issue an error message if dimensions mismatch
1764
1765                   if Dimensions_Of (Return_Etyp) /=
1766                        Dimensions_Of (Return_Obj_Typ)
1767                   then
1768                      Error_Dim_Msg_For_Extended_Return_Statement
1769                        (N, Return_Etyp, Return_Obj_Typ);
1770                      return;
1771                   end if;
1772                end if;
1773             end if;
1774
1775             Next (Return_Obj_Decl);
1776          end loop;
1777       end if;
1778    end Analyze_Dimension_Extended_Return_Statement;
1779
1780    -----------------------------------------------------
1781    -- Analyze_Dimension_Extension_Or_Record_Aggregate --
1782    -----------------------------------------------------
1783
1784    procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id) is
1785       Comp     : Node_Id;
1786       Comp_Id  : Entity_Id;
1787       Comp_Typ : Entity_Id;
1788       Expr     : Node_Id;
1789
1790       Error_Detected : Boolean := False;
1791       --  This flag is used in order to indicate if an error has been detected
1792       --  so far by the compiler in this routine.
1793
1794    begin
1795       --  Aspect is an Ada 2012 feature. Note that there is no need to check
1796       --  dimensions for aggregates that don't come from source, or if we are
1797       --  within an initialization procedure, whose expressions have been
1798       --  checked at the point of record declaration.
1799
1800       if Ada_Version < Ada_2012
1801         or else not Comes_From_Source (N)
1802         or else Inside_Init_Proc
1803       then
1804          return;
1805       end if;
1806
1807       Comp := First (Component_Associations (N));
1808       while Present (Comp) loop
1809          Comp_Id  := Entity (First (Choices (Comp)));
1810          Comp_Typ := Etype (Comp_Id);
1811
1812          --  Check the component type is either a dimensioned type or a
1813          --  dimensioned subtype.
1814
1815          if Has_Dimension_System (Base_Type (Comp_Typ)) then
1816             Expr := Expression (Comp);
1817
1818             --  Issue an error if the dimensions of the component type and the
1819             --  dimensions of the component mismatch.
1820
1821             if Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then
1822
1823                --  Check if an error has already been encountered so far
1824
1825                if not Error_Detected then
1826
1827                   --  Extension aggregate case
1828
1829                   if Nkind (N) = N_Extension_Aggregate then
1830                      Error_Msg_N
1831                        ("dimensions mismatch in extension aggregate", N);
1832
1833                   --  Record aggregate case
1834
1835                   else
1836                      Error_Msg_N
1837                        ("dimensions mismatch in record aggregate", N);
1838                   end if;
1839
1840                   Error_Detected := True;
1841                end if;
1842
1843                Error_Msg_N
1844                  ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
1845                   & ", found " & Dimensions_Msg_Of (Expr), Comp);
1846             end if;
1847          end if;
1848
1849          Next (Comp);
1850       end loop;
1851    end Analyze_Dimension_Extension_Or_Record_Aggregate;
1852
1853    -------------------------------
1854    -- Analyze_Dimension_Formals --
1855    -------------------------------
1856
1857    procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id) is
1858       Dims_Of_Typ : Dimension_Type;
1859       Formal      : Node_Id;
1860       Typ         : Entity_Id;
1861
1862    begin
1863       --  Aspect is an Ada 2012 feature. Note that there is no need to check
1864       --  dimensions for sub specs that don't come from source.
1865
1866       if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
1867          return;
1868       end if;
1869
1870       Formal := First (Formals);
1871       while Present (Formal) loop
1872          Typ         := Parameter_Type (Formal);
1873          Dims_Of_Typ := Dimensions_Of  (Typ);
1874
1875          if Exists (Dims_Of_Typ) then
1876             declare
1877                Expr : constant Node_Id := Expression (Formal);
1878
1879             begin
1880                --  Issue a warning if Expr is a numeric literal and if its
1881                --  dimensions differ with the dimensions of the formal type.
1882
1883                if Present (Expr)
1884                  and then Dims_Of_Typ /= Dimensions_Of (Expr)
1885                  and then Nkind_In (Original_Node (Expr), N_Real_Literal,
1886                                                           N_Integer_Literal)
1887                then
1888                   Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ));
1889                end if;
1890             end;
1891          end if;
1892
1893          Next (Formal);
1894       end loop;
1895    end Analyze_Dimension_Formals;
1896
1897    ---------------------------------
1898    -- Analyze_Dimension_Has_Etype --
1899    ---------------------------------
1900
1901    procedure Analyze_Dimension_Has_Etype (N : Node_Id) is
1902       Etyp         : constant Entity_Id := Etype (N);
1903       Dims_Of_Etyp : Dimension_Type     := Dimensions_Of (Etyp);
1904
1905    begin
1906       --  General case. Propagation of the dimensions from the type
1907
1908       if Exists (Dims_Of_Etyp) then
1909          Set_Dimensions (N, Dims_Of_Etyp);
1910
1911       --  Identifier case. Propagate the dimensions from the entity for
1912       --  identifier whose entity is a non-dimensionless constant.
1913
1914       elsif Nkind (N) = N_Identifier then
1915          Analyze_Dimension_Identifier : declare
1916             Id : constant Entity_Id := Entity (N);
1917
1918          begin
1919             --  If Id is missing, abnormal tree, assume previous error
1920
1921             if No (Id) then
1922                Check_Error_Detected;
1923                return;
1924
1925             elsif Ekind (Id) = E_Constant
1926               and then Exists (Dimensions_Of (Id))
1927             then
1928                Set_Dimensions (N, Dimensions_Of (Id));
1929             end if;
1930          end Analyze_Dimension_Identifier;
1931
1932       --  Attribute reference case. Propagate the dimensions from the prefix.
1933
1934       elsif Nkind (N) = N_Attribute_Reference
1935         and then Has_Dimension_System (Base_Type (Etyp))
1936       then
1937          Dims_Of_Etyp := Dimensions_Of (Prefix (N));
1938
1939          --  Check the prefix is not dimensionless
1940
1941          if Exists (Dims_Of_Etyp) then
1942             Set_Dimensions (N, Dims_Of_Etyp);
1943          end if;
1944       end if;
1945
1946       --  Removal of dimensions in expression
1947
1948       case Nkind (N) is
1949          when N_Attribute_Reference |
1950               N_Indexed_Component   =>
1951             declare
1952                Expr  : Node_Id;
1953                Exprs : constant List_Id := Expressions (N);
1954             begin
1955                if Present (Exprs) then
1956                   Expr := First (Exprs);
1957                   while Present (Expr) loop
1958                      Remove_Dimensions (Expr);
1959                      Next (Expr);
1960                   end loop;
1961                end if;
1962             end;
1963
1964          when N_Qualified_Expression      |
1965               N_Type_Conversion           |
1966               N_Unchecked_Type_Conversion =>
1967             Remove_Dimensions (Expression (N));
1968
1969          when N_Selected_Component =>
1970             Remove_Dimensions (Selector_Name (N));
1971
1972          when others => null;
1973       end case;
1974    end Analyze_Dimension_Has_Etype;
1975
1976    ------------------------------------------
1977    -- Analyze_Dimension_Object_Declaration --
1978    ------------------------------------------
1979
1980    procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is
1981       Expr        : constant Node_Id   := Expression (N);
1982       Id          : constant Entity_Id := Defining_Identifier (N);
1983       Etyp        : constant Entity_Id := Etype (Id);
1984       Dim_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1985       Dim_Of_Expr : Dimension_Type;
1986
1987       procedure Error_Dim_Msg_For_Object_Declaration
1988         (N    : Node_Id;
1989          Etyp : Entity_Id;
1990          Expr : Node_Id);
1991       --  Error using Error_Msg_N at node N. Output the dimensions of the
1992       --  type Etyp and of the expression Expr.
1993
1994       ------------------------------------------
1995       -- Error_Dim_Msg_For_Object_Declaration --
1996       ------------------------------------------
1997
1998       procedure Error_Dim_Msg_For_Object_Declaration
1999         (N    : Node_Id;
2000          Etyp : Entity_Id;
2001          Expr : Node_Id) is
2002       begin
2003          Error_Msg_N ("dimensions mismatch in object declaration", N);
2004          Error_Msg_N
2005            ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found "
2006             & Dimensions_Msg_Of (Expr), Expr);
2007       end Error_Dim_Msg_For_Object_Declaration;
2008
2009    --  Start of processing for Analyze_Dimension_Object_Declaration
2010
2011    begin
2012       --  Expression is present
2013
2014       if Present (Expr) then
2015          Dim_Of_Expr := Dimensions_Of (Expr);
2016
2017          --  Check dimensions match
2018
2019          if Dim_Of_Expr /= Dim_Of_Etyp then
2020
2021             --  Numeric literal case. Issue a warning if the object type is not
2022             --  dimensionless to indicate the literal is treated as if its
2023             --  dimension matches the type dimension.
2024
2025             if Nkind_In (Original_Node (Expr), N_Real_Literal,
2026                                                N_Integer_Literal)
2027             then
2028                Dim_Warning_For_Numeric_Literal (Expr, Etyp);
2029
2030             --  Case of object is a constant whose type is a dimensioned type
2031
2032             elsif Constant_Present (N) and then not Exists (Dim_Of_Etyp) then
2033
2034                --  Propagate dimension from expression to object entity
2035
2036                Set_Dimensions (Id, Dim_Of_Expr);
2037
2038             --  For all other cases, issue an error message
2039
2040             else
2041                Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr);
2042             end if;
2043          end if;
2044
2045          --  Removal of dimensions in expression
2046
2047          Remove_Dimensions (Expr);
2048       end if;
2049    end Analyze_Dimension_Object_Declaration;
2050
2051    ---------------------------------------------------
2052    -- Analyze_Dimension_Object_Renaming_Declaration --
2053    ---------------------------------------------------
2054
2055    procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is
2056       Renamed_Name : constant Node_Id := Name (N);
2057       Sub_Mark     : constant Node_Id := Subtype_Mark (N);
2058
2059       procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2060         (N            : Node_Id;
2061          Sub_Mark     : Node_Id;
2062          Renamed_Name : Node_Id);
2063       --  Error using Error_Msg_N at node N. Output the dimensions of
2064       --  Sub_Mark and of Renamed_Name.
2065
2066       ---------------------------------------------------
2067       -- Error_Dim_Msg_For_Object_Renaming_Declaration --
2068       ---------------------------------------------------
2069
2070       procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2071         (N            : Node_Id;
2072          Sub_Mark     : Node_Id;
2073          Renamed_Name : Node_Id) is
2074       begin
2075          Error_Msg_N ("dimensions mismatch in object renaming declaration", N);
2076          Error_Msg_N
2077            ("\expected dimension " & Dimensions_Msg_Of (Sub_Mark) & ", found "
2078             & Dimensions_Msg_Of (Renamed_Name), Renamed_Name);
2079       end Error_Dim_Msg_For_Object_Renaming_Declaration;
2080
2081    --  Start of processing for Analyze_Dimension_Object_Renaming_Declaration
2082
2083    begin
2084       if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then
2085          Error_Dim_Msg_For_Object_Renaming_Declaration
2086            (N, Sub_Mark, Renamed_Name);
2087       end if;
2088    end Analyze_Dimension_Object_Renaming_Declaration;
2089
2090    -----------------------------------------------
2091    -- Analyze_Dimension_Simple_Return_Statement --
2092    -----------------------------------------------
2093
2094    procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is
2095       Expr                : constant Node_Id := Expression (N);
2096       Dims_Of_Expr        : constant Dimension_Type := Dimensions_Of (Expr);
2097       Return_Ent          : constant Entity_Id := Return_Statement_Entity (N);
2098       Return_Etyp         : constant Entity_Id :=
2099                               Etype (Return_Applies_To (Return_Ent));
2100       Dims_Of_Return_Etyp : constant Dimension_Type :=
2101                               Dimensions_Of (Return_Etyp);
2102
2103       procedure Error_Dim_Msg_For_Simple_Return_Statement
2104         (N           : Node_Id;
2105          Return_Etyp : Entity_Id;
2106          Expr        : Node_Id);
2107       --  Error using Error_Msg_N at node N. Output the dimensions of the
2108       --  returned type Return_Etyp and the returned expression Expr of N.
2109
2110       -----------------------------------------------
2111       -- Error_Dim_Msg_For_Simple_Return_Statement --
2112       -----------------------------------------------
2113
2114       procedure Error_Dim_Msg_For_Simple_Return_Statement
2115         (N           : Node_Id;
2116          Return_Etyp : Entity_Id;
2117          Expr        : Node_Id)
2118       is
2119       begin
2120          Error_Msg_N ("dimensions mismatch in return statement", N);
2121          Error_Msg_N
2122            ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp)
2123             & ", found " & Dimensions_Msg_Of (Expr), Expr);
2124       end Error_Dim_Msg_For_Simple_Return_Statement;
2125
2126    --  Start of processing for Analyze_Dimension_Simple_Return_Statement
2127
2128    begin
2129       if Dims_Of_Return_Etyp /= Dims_Of_Expr then
2130          Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr);
2131          Remove_Dimensions (Expr);
2132       end if;
2133    end Analyze_Dimension_Simple_Return_Statement;
2134
2135    -------------------------------------------
2136    -- Analyze_Dimension_Subtype_Declaration --
2137    -------------------------------------------
2138
2139    procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is
2140       Id           : constant Entity_Id := Defining_Identifier (N);
2141       Dims_Of_Id   : constant Dimension_Type := Dimensions_Of (Id);
2142       Dims_Of_Etyp : Dimension_Type;
2143       Etyp         : Node_Id;
2144
2145    begin
2146       --  No constraint case in subtype declaration
2147
2148       if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
2149          Etyp := Etype (Subtype_Indication (N));
2150          Dims_Of_Etyp := Dimensions_Of (Etyp);
2151
2152          if Exists (Dims_Of_Etyp) then
2153
2154             --  If subtype already has a dimension (from Aspect_Dimension),
2155             --  it cannot inherit a dimension from its subtype.
2156
2157             if Exists (Dims_Of_Id) then
2158                Error_Msg_N
2159                  ("subtype& already" & Dimensions_Msg_Of (Id, True), N);
2160             else
2161                Set_Dimensions (Id, Dims_Of_Etyp);
2162                Set_Symbol (Id, Symbol_Of (Etyp));
2163             end if;
2164          end if;
2165
2166       --  Constraint present in subtype declaration
2167
2168       else
2169          Etyp := Etype (Subtype_Mark (Subtype_Indication (N)));
2170          Dims_Of_Etyp := Dimensions_Of (Etyp);
2171
2172          if Exists (Dims_Of_Etyp) then
2173             Set_Dimensions (Id, Dims_Of_Etyp);
2174             Set_Symbol (Id, Symbol_Of (Etyp));
2175          end if;
2176       end if;
2177    end Analyze_Dimension_Subtype_Declaration;
2178
2179    --------------------------------
2180    -- Analyze_Dimension_Unary_Op --
2181    --------------------------------
2182
2183    procedure Analyze_Dimension_Unary_Op (N : Node_Id) is
2184    begin
2185       case Nkind (N) is
2186          when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
2187
2188             --  Propagate the dimension if the operand is not dimensionless
2189
2190             declare
2191                R : constant Node_Id := Right_Opnd (N);
2192             begin
2193                Move_Dimensions (R, N);
2194             end;
2195
2196          when others => null;
2197
2198       end case;
2199    end Analyze_Dimension_Unary_Op;
2200
2201    ---------------------
2202    -- Copy_Dimensions --
2203    ---------------------
2204
2205    procedure Copy_Dimensions (From, To : Node_Id) is
2206       Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
2207
2208    begin
2209       --  Ignore if not Ada 2012 or beyond
2210
2211       if Ada_Version < Ada_2012 then
2212          return;
2213
2214       --  For Ada 2012, Copy the dimension of 'From to 'To'
2215
2216       elsif Exists (Dims_Of_From) then
2217          Set_Dimensions (To, Dims_Of_From);
2218       end if;
2219    end Copy_Dimensions;
2220
2221    --------------------------
2222    -- Create_Rational_From --
2223    --------------------------
2224
2225    --  RATIONAL ::= [-] NUMERAL [/ NUMERAL]
2226
2227    --  A rational number is a number that can be expressed as the quotient or
2228    --  fraction a/b of two integers, where b is non-zero positive.
2229
2230    function Create_Rational_From
2231      (Expr     : Node_Id;
2232       Complain : Boolean) return Rational
2233    is
2234       Or_Node_Of_Expr : constant Node_Id := Original_Node (Expr);
2235       Result          : Rational := No_Rational;
2236
2237       function Process_Minus (N : Node_Id) return Rational;
2238       --  Create a rational from a N_Op_Minus node
2239
2240       function Process_Divide (N : Node_Id) return Rational;
2241       --  Create a rational from a N_Op_Divide node
2242
2243       function Process_Literal (N : Node_Id) return Rational;
2244       --  Create a rational from a N_Integer_Literal node
2245
2246       -------------------
2247       -- Process_Minus --
2248       -------------------
2249
2250       function Process_Minus (N : Node_Id) return Rational is
2251          Right  : constant Node_Id := Original_Node (Right_Opnd (N));
2252          Result : Rational;
2253
2254       begin
2255          --  Operand is an integer literal
2256
2257          if Nkind (Right) = N_Integer_Literal then
2258             Result := -Process_Literal (Right);
2259
2260          --  Operand is a divide operator
2261
2262          elsif Nkind (Right) = N_Op_Divide then
2263             Result := -Process_Divide (Right);
2264
2265          else
2266             Result := No_Rational;
2267          end if;
2268
2269          --  Provide minimal semantic information on dimension expressions,
2270          --  even though they have no run-time existence. This is for use by
2271          --  ASIS tools, in particular pretty-printing. If generating code
2272          --  standard operator resolution will take place.
2273
2274          if ASIS_Mode then
2275             Set_Entity (N, Standard_Op_Minus);
2276             Set_Etype  (N, Standard_Integer);
2277          end if;
2278
2279          return Result;
2280       end Process_Minus;
2281
2282       --------------------
2283       -- Process_Divide --
2284       --------------------
2285
2286       function Process_Divide (N : Node_Id) return Rational is
2287          Left      : constant Node_Id := Original_Node (Left_Opnd (N));
2288          Right     : constant Node_Id := Original_Node (Right_Opnd (N));
2289          Left_Rat  : Rational;
2290          Result    : Rational := No_Rational;
2291          Right_Rat : Rational;
2292
2293       begin
2294          --  Both left and right operands are integer literals
2295
2296          if Nkind (Left) = N_Integer_Literal
2297               and then
2298             Nkind (Right) = N_Integer_Literal
2299          then
2300             Left_Rat := Process_Literal (Left);
2301             Right_Rat := Process_Literal (Right);
2302             Result := Left_Rat / Right_Rat;
2303          end if;
2304
2305          --  Provide minimal semantic information on dimension expressions,
2306          --  even though they have no run-time existence. This is for use by
2307          --  ASIS tools, in particular pretty-printing. If generating code
2308          --  standard operator resolution will take place.
2309
2310          if ASIS_Mode then
2311             Set_Entity (N, Standard_Op_Divide);
2312             Set_Etype  (N, Standard_Integer);
2313          end if;
2314
2315          return Result;
2316       end Process_Divide;
2317
2318       ---------------------
2319       -- Process_Literal --
2320       ---------------------
2321
2322       function Process_Literal (N : Node_Id) return Rational is
2323       begin
2324          return +Whole (UI_To_Int (Intval (N)));
2325       end Process_Literal;
2326
2327    --  Start of processing for Create_Rational_From
2328
2329    begin
2330       --  Check the expression is either a division of two integers or an
2331       --  integer itself. Note that the check applies to the original node
2332       --  since the node could have already been rewritten.
2333
2334       --  Integer literal case
2335
2336       if Nkind (Or_Node_Of_Expr) = N_Integer_Literal then
2337          Result := Process_Literal (Or_Node_Of_Expr);
2338
2339       --  Divide operator case
2340
2341       elsif Nkind (Or_Node_Of_Expr) = N_Op_Divide then
2342          Result := Process_Divide (Or_Node_Of_Expr);
2343
2344       --  Minus operator case
2345
2346       elsif Nkind (Or_Node_Of_Expr) = N_Op_Minus then
2347          Result := Process_Minus (Or_Node_Of_Expr);
2348       end if;
2349
2350       --  When Expr cannot be interpreted as a rational and Complain is true,
2351       --  generate an error message.
2352
2353       if Complain and then Result = No_Rational then
2354          Error_Msg_N ("rational expected", Expr);
2355       end if;
2356
2357       return Result;
2358    end Create_Rational_From;
2359
2360    -------------------
2361    -- Dimensions_Of --
2362    -------------------
2363
2364    function Dimensions_Of (N : Node_Id) return Dimension_Type is
2365    begin
2366       return Dimension_Table.Get (N);
2367    end Dimensions_Of;
2368
2369    -----------------------
2370    -- Dimensions_Msg_Of --
2371    -----------------------
2372
2373    function Dimensions_Msg_Of
2374       (N                  : Node_Id;
2375        Description_Needed : Boolean := False) return String
2376    is
2377       Dims_Of_N      : constant Dimension_Type := Dimensions_Of (N);
2378       Dimensions_Msg : Name_Id;
2379       System         : System_Type;
2380
2381    begin
2382       --  Initialization of Name_Buffer
2383
2384       Name_Len := 0;
2385
2386       --  N is not dimensionless
2387
2388       if Exists (Dims_Of_N) then
2389          System := System_Of (Base_Type (Etype (N)));
2390
2391          --  When Description_Needed, add to string "has dimension " before the
2392          --  actual dimension.
2393
2394          if Description_Needed then
2395             Add_Str_To_Name_Buffer ("has dimension ");
2396          end if;
2397
2398          Add_String_To_Name_Buffer
2399            (From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True));
2400
2401       --  N is dimensionless
2402
2403       --  When Description_Needed, return "is dimensionless"
2404
2405       elsif Description_Needed then
2406          Add_Str_To_Name_Buffer ("is dimensionless");
2407
2408       --  Otherwise, return "'[']"
2409
2410       else
2411          Add_Str_To_Name_Buffer ("'[']");
2412       end if;
2413
2414       Dimensions_Msg := Name_Find;
2415       return Get_Name_String (Dimensions_Msg);
2416    end Dimensions_Msg_Of;
2417
2418    --------------------------
2419    -- Dimension_Table_Hash --
2420    --------------------------
2421
2422    function Dimension_Table_Hash
2423      (Key : Node_Id) return Dimension_Table_Range
2424    is
2425    begin
2426       return Dimension_Table_Range (Key mod 511);
2427    end Dimension_Table_Hash;
2428
2429    -------------------------------------
2430    -- Dim_Warning_For_Numeric_Literal --
2431    -------------------------------------
2432
2433    procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id) is
2434    begin
2435       --  Initialize name buffer
2436
2437       Name_Len := 0;
2438
2439       Add_String_To_Name_Buffer (String_From_Numeric_Literal (N));
2440
2441       --  Insert a blank between the literal and the symbol
2442
2443       Add_Str_To_Name_Buffer (" ");
2444       Add_String_To_Name_Buffer (Symbol_Of (Typ));
2445
2446       Error_Msg_Name_1 := Name_Find;
2447       Error_Msg_N ("assumed to be%%??", N);
2448    end Dim_Warning_For_Numeric_Literal;
2449
2450    ----------------------------------------
2451    -- Eval_Op_Expon_For_Dimensioned_Type --
2452    ----------------------------------------
2453
2454    --  Evaluate the expon operator for real dimensioned type.
2455
2456    --  Note that if the exponent is an integer (denominator = 1) the node is
2457    --  evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2458
2459    procedure Eval_Op_Expon_For_Dimensioned_Type
2460      (N    : Node_Id;
2461       Btyp : Entity_Id)
2462    is
2463       R       : constant Node_Id := Right_Opnd (N);
2464       R_Value : Rational := No_Rational;
2465
2466    begin
2467       if Is_Real_Type (Btyp) then
2468          R_Value := Create_Rational_From (R, False);
2469       end if;
2470
2471       --  Check that the exponent is not an integer
2472
2473       if R_Value /= No_Rational and then R_Value.Denominator /= 1 then
2474          Eval_Op_Expon_With_Rational_Exponent (N, R_Value);
2475       else
2476          Eval_Op_Expon (N);
2477       end if;
2478    end Eval_Op_Expon_For_Dimensioned_Type;
2479
2480    ------------------------------------------
2481    -- Eval_Op_Expon_With_Rational_Exponent --
2482    ------------------------------------------
2483
2484    --  For dimensioned operand in exponentiation, exponent is allowed to be a
2485    --  Rational and not only an Integer like for dimensionless operands. For
2486    --  that particular case, the left operand is rewritten as a function call
2487    --  using the function Expon_LLF from s-llflex.ads.
2488
2489    procedure Eval_Op_Expon_With_Rational_Exponent
2490      (N              : Node_Id;
2491       Exponent_Value : Rational)
2492    is
2493       Loc                   : constant Source_Ptr     := Sloc (N);
2494       Dims_Of_N             : constant Dimension_Type := Dimensions_Of (N);
2495       L                     : constant Node_Id        := Left_Opnd (N);
2496       Etyp_Of_L             : constant Entity_Id      := Etype (L);
2497       Btyp_Of_L             : constant Entity_Id      := Base_Type (Etyp_Of_L);
2498       Actual_1              : Node_Id;
2499       Actual_2              : Node_Id;
2500       Dim_Power             : Rational;
2501       List_Of_Dims          : List_Id;
2502       New_Aspect            : Node_Id;
2503       New_Aspects           : List_Id;
2504       New_Id                : Entity_Id;
2505       New_N                 : Node_Id;
2506       New_Subtyp_Decl_For_L : Node_Id;
2507       System                : System_Type;
2508
2509    begin
2510       --  Case when the operand is not dimensionless
2511
2512       if Exists (Dims_Of_N) then
2513
2514          --  Get the corresponding System_Type to know the exact number of
2515          --  dimensions in the system.
2516
2517          System := System_Of (Btyp_Of_L);
2518
2519          --  Generation of a new subtype with the proper dimensions
2520
2521          --  In order to rewrite the operator as a type conversion, a new
2522          --  dimensioned subtype with the resulting dimensions of the
2523          --  exponentiation must be created.
2524
2525          --  Generate:
2526
2527          --  Btyp_Of_L   : constant Entity_Id := Base_Type (Etyp_Of_L);
2528          --  System      : constant System_Id :=
2529          --                  Get_Dimension_System_Id (Btyp_Of_L);
2530          --  Num_Of_Dims : constant Number_Of_Dimensions :=
2531          --                  Dimension_Systems.Table (System).Dimension_Count;
2532
2533          --  subtype T is Btyp_Of_L
2534          --    with
2535          --      Dimension => (
2536          --        Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2537          --        Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2538          --        ...
2539          --        Dims_Of_N (Num_Of_Dims).Numerator /
2540          --          Dims_Of_N (Num_Of_Dims).Denominator);
2541
2542          --  Step 1: Generate the new aggregate for the aspect Dimension
2543
2544          New_Aspects  := Empty_List;
2545
2546          List_Of_Dims := New_List;
2547          for Position in Dims_Of_N'First ..  System.Count loop
2548             Dim_Power := Dims_Of_N (Position);
2549             Append_To (List_Of_Dims,
2550                Make_Op_Divide (Loc,
2551                  Left_Opnd  =>
2552                    Make_Integer_Literal (Loc, Int (Dim_Power.Numerator)),
2553                  Right_Opnd =>
2554                    Make_Integer_Literal (Loc, Int (Dim_Power.Denominator))));
2555          end loop;
2556
2557          --  Step 2: Create the new Aspect Specification for Aspect Dimension
2558
2559          New_Aspect :=
2560            Make_Aspect_Specification (Loc,
2561              Identifier => Make_Identifier (Loc, Name_Dimension),
2562              Expression => Make_Aggregate (Loc, Expressions => List_Of_Dims));
2563
2564          --  Step 3: Make a temporary identifier for the new subtype
2565
2566          New_Id := Make_Temporary (Loc, 'T');
2567          Set_Is_Internal (New_Id);
2568
2569          --  Step 4: Declaration of the new subtype
2570
2571          New_Subtyp_Decl_For_L :=
2572             Make_Subtype_Declaration (Loc,
2573                Defining_Identifier => New_Id,
2574                Subtype_Indication  => New_Occurrence_Of (Btyp_Of_L, Loc));
2575
2576          Append (New_Aspect, New_Aspects);
2577          Set_Parent (New_Aspects, New_Subtyp_Decl_For_L);
2578          Set_Aspect_Specifications (New_Subtyp_Decl_For_L, New_Aspects);
2579
2580          Analyze (New_Subtyp_Decl_For_L);
2581
2582       --  Case where the operand is dimensionless
2583
2584       else
2585          New_Id := Btyp_Of_L;
2586       end if;
2587
2588       --  Replacement of N by New_N
2589
2590       --  Generate:
2591
2592       --  Actual_1 := Long_Long_Float (L),
2593
2594       --  Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2595       --                Long_Long_Float (Exponent_Value.Denominator);
2596
2597       --  (T (Expon_LLF (Actual_1, Actual_2)));
2598
2599       --  where T is the subtype declared in step 1
2600
2601       --  The node is rewritten as a type conversion
2602
2603       --  Step 1: Creation of the two parameters of Expon_LLF function call
2604
2605       Actual_1 :=
2606         Make_Type_Conversion (Loc,
2607           Subtype_Mark => New_Occurrence_Of (Standard_Long_Long_Float, Loc),
2608           Expression   => Relocate_Node (L));
2609
2610       Actual_2 :=
2611         Make_Op_Divide (Loc,
2612           Left_Opnd  =>
2613             Make_Real_Literal (Loc,
2614               UR_From_Uint (UI_From_Int (Int (Exponent_Value.Numerator)))),
2615           Right_Opnd =>
2616             Make_Real_Literal (Loc,
2617               UR_From_Uint (UI_From_Int (Int (Exponent_Value.Denominator)))));
2618
2619       --  Step 2: Creation of New_N
2620
2621       New_N :=
2622          Make_Type_Conversion (Loc,
2623            Subtype_Mark => New_Occurrence_Of (New_Id, Loc),
2624            Expression   =>
2625              Make_Function_Call (Loc,
2626                Name => New_Occurrence_Of (RTE (RE_Expon_LLF), Loc),
2627                Parameter_Associations => New_List (
2628                  Actual_1, Actual_2)));
2629
2630       --  Step 3: Rewrite N with the result
2631
2632       Rewrite (N, New_N);
2633       Set_Etype (N, New_Id);
2634       Analyze_And_Resolve (N, New_Id);
2635    end Eval_Op_Expon_With_Rational_Exponent;
2636
2637    ------------
2638    -- Exists --
2639    ------------
2640
2641    function Exists (Dim : Dimension_Type) return Boolean is
2642    begin
2643       return Dim /= Null_Dimension;
2644    end Exists;
2645
2646    function Exists (Str : String_Id) return Boolean is
2647    begin
2648       return Str /= No_String;
2649    end Exists;
2650
2651    function Exists (Sys : System_Type) return Boolean is
2652    begin
2653       return Sys /= Null_System;
2654    end Exists;
2655
2656    ---------------------------------
2657    -- Expand_Put_Call_With_Symbol --
2658    ---------------------------------
2659
2660    --  For procedure Put (resp. Put_Dim_Of) defined in System.Dim.Float_IO
2661    --  (System.Dim.Integer_IO), the default string parameter must be rewritten
2662    --  to include the unit symbols (resp. dimension symbols) in the output
2663    --  of a dimensioned object. Note that if a value is already supplied for
2664    --  parameter Symbol, this routine doesn't do anything.
2665
2666    --  Case 1. Item is dimensionless
2667
2668    --   * Put        : Item appears without a suffix
2669
2670    --   * Put_Dim_Of : the output is []
2671
2672    --      Obj : Mks_Type := 2.6;
2673    --      Put (Obj, 1, 1, 0);
2674    --      Put_Dim_Of (Obj);
2675
2676    --      The corresponding outputs are:
2677    --      $2.6
2678    --      $[]
2679
2680    --  Case 2. Item has a dimension
2681
2682    --   * Put        : If the type of Item is a dimensioned subtype whose
2683    --                  symbol is not empty, then the symbol appears as a
2684    --                  suffix. Otherwise, a new string is created and appears
2685    --                  as a suffix of Item. This string results in the
2686    --                  successive concatanations between each unit symbol
2687    --                  raised by its corresponding dimension power from the
2688    --                  dimensions of Item.
2689
2690    --   * Put_Dim_Of : The output is a new string resulting in the successive
2691    --                  concatanations between each dimension symbol raised by
2692    --                  its corresponding dimension power from the dimensions of
2693    --                  Item.
2694
2695    --      subtype Random is Mks_Type
2696    --        with
2697    --         Dimension => (
2698    --           Meter =>   3,
2699    --           Candela => -1,
2700    --           others =>  0);
2701
2702    --      Obj : Random := 5.0;
2703    --      Put (Obj);
2704    --      Put_Dim_Of (Obj);
2705
2706    --      The corresponding outputs are:
2707    --      $5.0 m**3.cd**(-1)
2708    --      $[l**3.J**(-1)]
2709
2710    procedure Expand_Put_Call_With_Symbol (N : Node_Id) is
2711       Actuals        : constant List_Id := Parameter_Associations (N);
2712       Loc            : constant Source_Ptr := Sloc (N);
2713       Name_Call      : constant Node_Id := Name (N);
2714       New_Actuals    : constant List_Id := New_List;
2715       Actual         : Node_Id;
2716       Dims_Of_Actual : Dimension_Type;
2717       Etyp           : Entity_Id;
2718       New_Str_Lit    : Node_Id := Empty;
2719       Symbols        : String_Id;
2720
2721       Is_Put_Dim_Of : Boolean := False;
2722       --  This flag is used in order to differentiate routines Put and
2723       --  Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
2724       --  defined in System.Dim.Float_IO or System.Dim.Integer_IO.
2725
2726       function Has_Symbols return Boolean;
2727       --  Return True if the current Put call already has a parameter
2728       --  association for parameter "Symbols" with the correct string of
2729       --  symbols.
2730
2731       function Is_Procedure_Put_Call return Boolean;
2732       --  Return True if the current call is a call of an instantiation of a
2733       --  procedure Put defined in the package System.Dim.Float_IO and
2734       --  System.Dim.Integer_IO.
2735
2736       function Item_Actual return Node_Id;
2737       --  Return the item actual parameter node in the output call
2738
2739       -----------------
2740       -- Has_Symbols --
2741       -----------------
2742
2743       function Has_Symbols return Boolean is
2744          Actual     : Node_Id;
2745          Actual_Str : Node_Id;
2746
2747       begin
2748          --  Look for a symbols parameter association in the list of actuals
2749
2750          Actual := First (Actuals);
2751          while Present (Actual) loop
2752
2753             --  Positional parameter association case when the actual is a
2754             --  string literal.
2755
2756             if Nkind (Actual) = N_String_Literal then
2757                Actual_Str := Actual;
2758
2759             --  Named parameter association case when selector name is Symbol
2760
2761             elsif Nkind (Actual) = N_Parameter_Association
2762               and then Chars (Selector_Name (Actual)) = Name_Symbol
2763             then
2764                Actual_Str := Explicit_Actual_Parameter (Actual);
2765
2766             --  Ignore all other cases
2767
2768             else
2769                Actual_Str := Empty;
2770             end if;
2771
2772             if Present (Actual_Str) then
2773
2774                --  Return True if the actual comes from source or if the string
2775                --  of symbols doesn't have the default value (i.e. it is "").
2776
2777                if Comes_From_Source (Actual)
2778                  or else String_Length (Strval (Actual_Str)) /= 0
2779                then
2780                   --  Complain only if the actual comes from source or if it
2781                   --  hasn't been fully analyzed yet.
2782
2783                   if Comes_From_Source (Actual)
2784                     or else not Analyzed (Actual)
2785                   then
2786                      Error_Msg_N ("Symbol parameter should not be provided",
2787                                   Actual);
2788                      Error_Msg_N ("\reserved for compiler use only", Actual);
2789                   end if;
2790
2791                   return True;
2792
2793                else
2794                   return False;
2795                end if;
2796             end if;
2797
2798             Next (Actual);
2799          end loop;
2800
2801          --  At this point, the call has no parameter association. Look to the
2802          --  last actual since the symbols parameter is the last one.
2803
2804          return Nkind (Last (Actuals)) = N_String_Literal;
2805       end Has_Symbols;
2806
2807       ---------------------------
2808       -- Is_Procedure_Put_Call --
2809       ---------------------------
2810
2811       function Is_Procedure_Put_Call return Boolean is
2812          Ent : Entity_Id;
2813          Loc : Source_Ptr;
2814
2815       begin
2816          --  There are three different Put (resp. Put_Dim_Of) routines in each
2817          --  generic dim IO package. Verify the current procedure call is one
2818          --  of them.
2819
2820          if Is_Entity_Name (Name_Call) then
2821             Ent := Entity (Name_Call);
2822
2823             --  Get the original subprogram entity following the renaming chain
2824
2825             if Present (Alias (Ent)) then
2826                Ent := Alias (Ent);
2827             end if;
2828
2829             Loc := Sloc (Ent);
2830
2831             --  Check the name of the entity subprogram is Put (resp.
2832             --  Put_Dim_Of) and verify this entity is located in either
2833             --  System.Dim.Float_IO or System.Dim.Integer_IO.
2834
2835             if Loc > No_Location
2836               and then Is_Dim_IO_Package_Entity
2837                          (Cunit_Entity (Get_Source_Unit (Loc)))
2838             then
2839                if Chars (Ent) = Name_Put_Dim_Of then
2840                   Is_Put_Dim_Of := True;
2841                   return True;
2842
2843                elsif Chars (Ent) = Name_Put then
2844                   return True;
2845                end if;
2846             end if;
2847          end if;
2848
2849          return False;
2850       end Is_Procedure_Put_Call;
2851
2852       -----------------
2853       -- Item_Actual --
2854       -----------------
2855
2856       function Item_Actual return Node_Id is
2857          Actual : Node_Id;
2858
2859       begin
2860          --  Look for the item actual as a parameter association
2861
2862          Actual := First (Actuals);
2863          while Present (Actual) loop
2864             if Nkind (Actual) = N_Parameter_Association
2865               and then Chars (Selector_Name (Actual)) = Name_Item
2866             then
2867                return Explicit_Actual_Parameter (Actual);
2868             end if;
2869
2870             Next (Actual);
2871          end loop;
2872
2873          --  Case where the item has been defined without an association
2874
2875          Actual := First (Actuals);
2876
2877          --  Depending on the procedure Put, Item actual could be first or
2878          --  second in the list of actuals.
2879
2880          if Has_Dimension_System (Base_Type (Etype (Actual))) then
2881             return Actual;
2882          else
2883             return Next (Actual);
2884          end if;
2885       end Item_Actual;
2886
2887    --  Start of processing for Expand_Put_Call_With_Symbol
2888
2889    begin
2890       if Is_Procedure_Put_Call and then not Has_Symbols then
2891          Actual := Item_Actual;
2892          Dims_Of_Actual := Dimensions_Of (Actual);
2893          Etyp := Etype (Actual);
2894
2895          --  Put_Dim_Of case
2896
2897          if Is_Put_Dim_Of then
2898
2899             --  Check that the item is not dimensionless
2900
2901             --  Create the new String_Literal with the new String_Id generated
2902             --  by the routine From_Dim_To_Str_Of_Dim_Symbols.
2903
2904             if Exists (Dims_Of_Actual) then
2905                New_Str_Lit :=
2906                  Make_String_Literal (Loc,
2907                    From_Dim_To_Str_Of_Dim_Symbols
2908                      (Dims_Of_Actual, System_Of (Base_Type (Etyp))));
2909
2910             --  If dimensionless, the output is []
2911
2912             else
2913                New_Str_Lit :=
2914                  Make_String_Literal (Loc, "[]");
2915             end if;
2916
2917          --  Put case
2918
2919          else
2920             --  Add the symbol as a suffix of the value if the subtype has a
2921             --  unit symbol or if the parameter is not dimensionless.
2922
2923             if Exists (Symbol_Of (Etyp)) then
2924                Symbols := Symbol_Of (Etyp);
2925             else
2926                Symbols := From_Dim_To_Str_Of_Unit_Symbols
2927                             (Dims_Of_Actual, System_Of (Base_Type (Etyp)));
2928             end if;
2929
2930             --  Check Symbols exists
2931
2932             if Exists (Symbols) then
2933                Start_String;
2934
2935                --  Put a space between the value and the dimension
2936
2937                Store_String_Char (' ');
2938                Store_String_Chars (Symbols);
2939                New_Str_Lit := Make_String_Literal (Loc, End_String);
2940             end if;
2941          end if;
2942
2943          if Present (New_Str_Lit) then
2944
2945             --  Insert all actuals in New_Actuals
2946
2947             Actual := First (Actuals);
2948             while Present (Actual) loop
2949
2950                --  Copy every actuals in New_Actuals except the Symbols
2951                --  parameter association.
2952
2953                if Nkind (Actual) = N_Parameter_Association
2954                  and then Chars (Selector_Name (Actual)) /= Name_Symbol
2955                then
2956                   Append_To (New_Actuals,
2957                      Make_Parameter_Association (Loc,
2958                         Selector_Name => New_Copy (Selector_Name (Actual)),
2959                         Explicit_Actual_Parameter =>
2960                            New_Copy (Explicit_Actual_Parameter (Actual))));
2961
2962                elsif Nkind (Actual) /= N_Parameter_Association then
2963                   Append_To (New_Actuals, New_Copy (Actual));
2964                end if;
2965
2966                Next (Actual);
2967             end loop;
2968
2969             --  Create new Symbols param association and append to New_Actuals
2970
2971             Append_To (New_Actuals,
2972               Make_Parameter_Association (Loc,
2973                 Selector_Name => Make_Identifier (Loc, Name_Symbol),
2974                 Explicit_Actual_Parameter => New_Str_Lit));
2975
2976             --  Rewrite and analyze the procedure call
2977
2978             Rewrite (N,
2979               Make_Procedure_Call_Statement (Loc,
2980                 Name =>                   New_Copy (Name_Call),
2981                 Parameter_Associations => New_Actuals));
2982
2983             Analyze (N);
2984          end if;
2985       end if;
2986    end Expand_Put_Call_With_Symbol;
2987
2988    ------------------------------------
2989    -- From_Dim_To_Str_Of_Dim_Symbols --
2990    ------------------------------------
2991
2992    --  Given a dimension vector and the corresponding dimension system, create
2993    --  a String_Id to output dimension symbols corresponding to the dimensions
2994    --  Dims. If In_Error_Msg is True, there is a special handling for character
2995    --  asterisk * which is an insertion character in error messages.
2996
2997    function From_Dim_To_Str_Of_Dim_Symbols
2998      (Dims         : Dimension_Type;
2999       System       : System_Type;
3000       In_Error_Msg : Boolean := False) return String_Id
3001    is
3002       Dim_Power : Rational;
3003       First_Dim : Boolean := True;
3004
3005       procedure Store_String_Oexpon;
3006       --  Store the expon operator symbol "**" in the string. In error
3007       --  messages, asterisk * is a special character and must be quoted
3008       --  to be placed literally into the message.
3009
3010       -------------------------
3011       -- Store_String_Oexpon --
3012       -------------------------
3013
3014       procedure Store_String_Oexpon is
3015       begin
3016          if In_Error_Msg then
3017             Store_String_Chars ("'*'*");
3018          else
3019             Store_String_Chars ("**");
3020          end if;
3021       end Store_String_Oexpon;
3022
3023    --  Start of processing for From_Dim_To_Str_Of_Dim_Symbols
3024
3025    begin
3026       --  Initialization of the new String_Id
3027
3028       Start_String;
3029
3030       --  Store the dimension symbols inside boxes
3031
3032       if In_Error_Msg then
3033          Store_String_Chars ("'[");
3034       else
3035          Store_String_Char ('[');
3036       end if;
3037
3038       for Position in Dimension_Type'Range loop
3039          Dim_Power := Dims (Position);
3040          if Dim_Power /= Zero then
3041
3042             if First_Dim then
3043                First_Dim := False;
3044             else
3045                Store_String_Char ('.');
3046             end if;
3047
3048             Store_String_Chars (System.Dim_Symbols (Position));
3049
3050             --  Positive dimension case
3051
3052             if Dim_Power.Numerator > 0 then
3053
3054                --  Integer case
3055
3056                if Dim_Power.Denominator = 1 then
3057                   if Dim_Power.Numerator /= 1 then
3058                      Store_String_Oexpon;
3059                      Store_String_Int (Int (Dim_Power.Numerator));
3060                   end if;
3061
3062                --  Rational case when denominator /= 1
3063
3064                else
3065                   Store_String_Oexpon;
3066                   Store_String_Char ('(');
3067                   Store_String_Int (Int (Dim_Power.Numerator));
3068                   Store_String_Char ('/');
3069                   Store_String_Int (Int (Dim_Power.Denominator));
3070                   Store_String_Char (')');
3071                end if;
3072
3073             --  Negative dimension case
3074
3075             else
3076                Store_String_Oexpon;
3077                Store_String_Char ('(');
3078                Store_String_Char ('-');
3079                Store_String_Int (Int (-Dim_Power.Numerator));
3080
3081                --  Integer case
3082
3083                if Dim_Power.Denominator = 1 then
3084                   Store_String_Char (')');
3085
3086                --  Rational case when denominator /= 1
3087
3088                else
3089                   Store_String_Char ('/');
3090                   Store_String_Int (Int (Dim_Power.Denominator));
3091                   Store_String_Char (')');
3092                end if;
3093             end if;
3094          end if;
3095       end loop;
3096
3097       if In_Error_Msg then
3098          Store_String_Chars ("']");
3099       else
3100          Store_String_Char (']');
3101       end if;
3102
3103       return End_String;
3104    end From_Dim_To_Str_Of_Dim_Symbols;
3105
3106    -------------------------------------
3107    -- From_Dim_To_Str_Of_Unit_Symbols --
3108    -------------------------------------
3109
3110    --  Given a dimension vector and the corresponding dimension system,
3111    --  create a String_Id to output the unit symbols corresponding to the
3112    --  dimensions Dims.
3113
3114    function From_Dim_To_Str_Of_Unit_Symbols
3115      (Dims   : Dimension_Type;
3116       System : System_Type) return String_Id
3117    is
3118       Dim_Power : Rational;
3119       First_Dim : Boolean := True;
3120
3121    begin
3122       --  Return No_String if dimensionless
3123
3124       if not Exists (Dims) then
3125          return No_String;
3126       end if;
3127
3128       --  Initialization of the new String_Id
3129
3130       Start_String;
3131
3132       for Position in Dimension_Type'Range loop
3133          Dim_Power := Dims (Position);
3134
3135          if Dim_Power /= Zero then
3136             if First_Dim then
3137                First_Dim := False;
3138             else
3139                Store_String_Char ('.');
3140             end if;
3141
3142             Store_String_Chars (System.Unit_Symbols (Position));
3143
3144             --  Positive dimension case
3145
3146             if Dim_Power.Numerator > 0 then
3147
3148                --  Integer case
3149
3150                if Dim_Power.Denominator = 1 then
3151                   if Dim_Power.Numerator /= 1 then
3152                      Store_String_Chars ("**");
3153                      Store_String_Int (Int (Dim_Power.Numerator));
3154                   end if;
3155
3156                --  Rational case when denominator /= 1
3157
3158                else
3159                   Store_String_Chars ("**");
3160                   Store_String_Char ('(');
3161                   Store_String_Int (Int (Dim_Power.Numerator));
3162                   Store_String_Char ('/');
3163                   Store_String_Int (Int (Dim_Power.Denominator));
3164                   Store_String_Char (')');
3165                end if;
3166
3167             --  Negative dimension case
3168
3169             else
3170                Store_String_Chars ("**");
3171                Store_String_Char ('(');
3172                Store_String_Char ('-');
3173                Store_String_Int (Int (-Dim_Power.Numerator));
3174
3175                --  Integer case
3176
3177                if Dim_Power.Denominator = 1 then
3178                   Store_String_Char (')');
3179
3180                --  Rational case when denominator /= 1
3181
3182                else
3183                   Store_String_Char ('/');
3184                   Store_String_Int (Int (Dim_Power.Denominator));
3185                   Store_String_Char (')');
3186                end if;
3187             end if;
3188          end if;
3189       end loop;
3190
3191       return End_String;
3192    end From_Dim_To_Str_Of_Unit_Symbols;
3193
3194    ---------
3195    -- GCD --
3196    ---------
3197
3198    function GCD (Left, Right : Whole) return Int is
3199       L : Whole;
3200       R : Whole;
3201
3202    begin
3203       L := Left;
3204       R := Right;
3205       while R /= 0 loop
3206          L := L mod R;
3207
3208          if L = 0 then
3209             return Int (R);
3210          end if;
3211
3212          R := R mod L;
3213       end loop;
3214
3215       return Int (L);
3216    end GCD;
3217
3218    --------------------------
3219    -- Has_Dimension_System --
3220    --------------------------
3221
3222    function Has_Dimension_System (Typ : Entity_Id) return Boolean is
3223    begin
3224       return Exists (System_Of (Typ));
3225    end Has_Dimension_System;
3226
3227    ------------------------------
3228    -- Is_Dim_IO_Package_Entity --
3229    ------------------------------
3230
3231    function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is
3232    begin
3233       --  Check the package entity corresponds to System.Dim.Float_IO or
3234       --  System.Dim.Integer_IO.
3235
3236       return
3237         Is_RTU (E, System_Dim_Float_IO)
3238           or else
3239         Is_RTU (E, System_Dim_Integer_IO);
3240    end Is_Dim_IO_Package_Entity;
3241
3242    -------------------------------------
3243    -- Is_Dim_IO_Package_Instantiation --
3244    -------------------------------------
3245
3246    function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is
3247       Gen_Id : constant Node_Id := Name (N);
3248
3249    begin
3250       --  Check that the instantiated package is either System.Dim.Float_IO
3251       --  or System.Dim.Integer_IO.
3252
3253       return
3254         Is_Entity_Name (Gen_Id)
3255           and then Is_Dim_IO_Package_Entity (Entity (Gen_Id));
3256    end Is_Dim_IO_Package_Instantiation;
3257
3258    ----------------
3259    -- Is_Invalid --
3260    ----------------
3261
3262    function Is_Invalid (Position : Dimension_Position) return Boolean is
3263    begin
3264       return Position = Invalid_Position;
3265    end Is_Invalid;
3266
3267    ---------------------
3268    -- Move_Dimensions --
3269    ---------------------
3270
3271    procedure Move_Dimensions (From, To : Node_Id) is
3272    begin
3273       if Ada_Version < Ada_2012 then
3274          return;
3275       end if;
3276
3277       --  Copy the dimension of 'From to 'To' and remove dimension of 'From'
3278
3279       Copy_Dimensions   (From, To);
3280       Remove_Dimensions (From);
3281    end Move_Dimensions;
3282
3283    ------------
3284    -- Reduce --
3285    ------------
3286
3287    function Reduce (X : Rational) return Rational is
3288    begin
3289       if X.Numerator = 0 then
3290          return Zero;
3291       end if;
3292
3293       declare
3294          G : constant Int := GCD (X.Numerator, X.Denominator);
3295       begin
3296          return Rational'(Numerator =>   Whole (Int (X.Numerator)   / G),
3297                           Denominator => Whole (Int (X.Denominator) / G));
3298       end;
3299    end Reduce;
3300
3301    -----------------------
3302    -- Remove_Dimensions --
3303    -----------------------
3304
3305    procedure Remove_Dimensions (N : Node_Id) is
3306       Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
3307    begin
3308       if Exists (Dims_Of_N) then
3309          Dimension_Table.Remove (N);
3310       end if;
3311    end Remove_Dimensions;
3312
3313    -----------------------------------
3314    -- Remove_Dimension_In_Statement --
3315    -----------------------------------
3316
3317    --  Removal of dimension in statement as part of the Analyze_Statements
3318    --  routine (see package Sem_Ch5).
3319
3320    procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
3321    begin
3322       if Ada_Version < Ada_2012 then
3323          return;
3324       end if;
3325
3326       --  Remove dimension in parameter specifications for accept statement
3327
3328       if Nkind (Stmt) = N_Accept_Statement then
3329          declare
3330             Param : Node_Id := First (Parameter_Specifications (Stmt));
3331          begin
3332             while Present (Param) loop
3333                Remove_Dimensions (Param);
3334                Next (Param);
3335             end loop;
3336          end;
3337
3338       --  Remove dimension of name and expression in assignments
3339
3340       elsif Nkind (Stmt) = N_Assignment_Statement then
3341          Remove_Dimensions (Expression (Stmt));
3342          Remove_Dimensions (Name (Stmt));
3343       end if;
3344    end Remove_Dimension_In_Statement;
3345
3346    --------------------
3347    -- Set_Dimensions --
3348    --------------------
3349
3350    procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
3351    begin
3352       pragma Assert (OK_For_Dimension (Nkind (N)));
3353       pragma Assert (Exists (Val));
3354
3355       Dimension_Table.Set (N, Val);
3356    end Set_Dimensions;
3357
3358    ----------------
3359    -- Set_Symbol --
3360    ----------------
3361
3362    procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
3363    begin
3364       Symbol_Table.Set (E, Val);
3365    end Set_Symbol;
3366
3367    ---------------------------------
3368    -- String_From_Numeric_Literal --
3369    ---------------------------------
3370
3371    function String_From_Numeric_Literal (N : Node_Id) return String_Id is
3372       Loc     : constant Source_Ptr        := Sloc (N);
3373       Sbuffer : constant Source_Buffer_Ptr :=
3374                   Source_Text (Get_Source_File_Index (Loc));
3375       Src_Ptr : Source_Ptr := Loc;
3376
3377       C : Character  := Sbuffer (Src_Ptr);
3378       --  Current source program character
3379
3380       function Belong_To_Numeric_Literal (C : Character) return Boolean;
3381       --  Return True if C belongs to a numeric literal
3382
3383       -------------------------------
3384       -- Belong_To_Numeric_Literal --
3385       -------------------------------
3386
3387       function Belong_To_Numeric_Literal (C : Character) return Boolean is
3388       begin
3389          case C is
3390             when '0' .. '9' |
3391                  '_'        |
3392                  '.'        |
3393                  'e'        |
3394                  '#'        |
3395                  'A'        |
3396                  'B'        |
3397                  'C'        |
3398                  'D'        |
3399                  'E'        |
3400                  'F'        =>
3401                return True;
3402
3403             --  Make sure '+' or '-' is part of an exponent.
3404
3405             when '+'  | '-' =>
3406                declare
3407                   Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
3408                begin
3409                   return Prev_C = 'e' or else Prev_C = 'E';
3410                end;
3411
3412             --  All other character doesn't belong to a numeric literal
3413
3414             when others     =>
3415                return False;
3416          end case;
3417       end Belong_To_Numeric_Literal;
3418
3419    --  Start of processing for String_From_Numeric_Literal
3420
3421    begin
3422       Start_String;
3423       while Belong_To_Numeric_Literal (C) loop
3424          Store_String_Char (C);
3425          Src_Ptr := Src_Ptr + 1;
3426          C       := Sbuffer (Src_Ptr);
3427       end loop;
3428
3429       return End_String;
3430    end String_From_Numeric_Literal;
3431
3432    ---------------
3433    -- Symbol_Of --
3434    ---------------
3435
3436    function Symbol_Of (E : Entity_Id) return String_Id is
3437       Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
3438    begin
3439       if Subtype_Symbol /= No_String then
3440          return Subtype_Symbol;
3441       else
3442          return From_Dim_To_Str_Of_Unit_Symbols
3443                   (Dimensions_Of (E), System_Of (Base_Type (E)));
3444       end if;
3445    end Symbol_Of;
3446
3447    -----------------------
3448    -- Symbol_Table_Hash --
3449    -----------------------
3450
3451    function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
3452    begin
3453       return Symbol_Table_Range (Key mod 511);
3454    end Symbol_Table_Hash;
3455
3456    ---------------
3457    -- System_Of --
3458    ---------------
3459
3460    function System_Of (E : Entity_Id) return System_Type is
3461       Type_Decl : constant Node_Id := Parent (E);
3462
3463    begin
3464       --  Look for Type_Decl in System_Table
3465
3466       for Dim_Sys in 1 .. System_Table.Last loop
3467          if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
3468             return System_Table.Table (Dim_Sys);
3469          end if;
3470       end loop;
3471
3472       return Null_System;
3473    end System_Of;
3474
3475 end Sem_Dim;