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