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