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