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