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