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