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