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