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 -- Inlined bodies have already been checked for dimensionality 1146 1147 elsif In_Inlined_Body then 1148 return; 1149 1150 elsif not Comes_From_Source (N) then 1151 if Nkind_In (N, N_Explicit_Dereference, 1152 N_Identifier, 1153 N_Object_Declaration, 1154 N_Subtype_Declaration) 1155 then 1156 null; 1157 else 1158 return; 1159 end if; 1160 end if; 1161 1162 case Nkind (N) is 1163 when N_Assignment_Statement => 1164 Analyze_Dimension_Assignment_Statement (N); 1165 1166 when N_Binary_Op => 1167 Analyze_Dimension_Binary_Op (N); 1168 1169 when N_Case_Expression => 1170 Analyze_Dimension_Case_Expression (N); 1171 1172 when N_Component_Declaration => 1173 Analyze_Dimension_Component_Declaration (N); 1174 1175 when N_Extended_Return_Statement => 1176 Analyze_Dimension_Extended_Return_Statement (N); 1177 1178 when N_Attribute_Reference 1179 | N_Expanded_Name 1180 | N_Explicit_Dereference 1181 | N_Function_Call 1182 | N_Indexed_Component 1183 | N_Qualified_Expression 1184 | N_Selected_Component 1185 | N_Slice 1186 | N_Unchecked_Type_Conversion 1187 => 1188 Analyze_Dimension_Has_Etype (N); 1189 1190 -- In the presence of a repaired syntax error, an identifier may be 1191 -- introduced without a usable type. 1192 1193 when N_Identifier => 1194 if Present (Etype (N)) then 1195 Analyze_Dimension_Has_Etype (N); 1196 end if; 1197 1198 when N_If_Expression => 1199 Analyze_Dimension_If_Expression (N); 1200 1201 when N_Number_Declaration => 1202 Analyze_Dimension_Number_Declaration (N); 1203 1204 when N_Object_Declaration => 1205 Analyze_Dimension_Object_Declaration (N); 1206 1207 when N_Object_Renaming_Declaration => 1208 Analyze_Dimension_Object_Renaming_Declaration (N); 1209 1210 when N_Simple_Return_Statement => 1211 if not Comes_From_Extended_Return_Statement (N) then 1212 Analyze_Dimension_Simple_Return_Statement (N); 1213 end if; 1214 1215 when N_Subtype_Declaration => 1216 Analyze_Dimension_Subtype_Declaration (N); 1217 1218 when N_Type_Conversion => 1219 Analyze_Dimension_Type_Conversion (N); 1220 1221 when N_Unary_Op => 1222 Analyze_Dimension_Unary_Op (N); 1223 1224 when others => 1225 null; 1226 end case; 1227 end Analyze_Dimension; 1228 1229 --------------------------------------- 1230 -- Analyze_Dimension_Array_Aggregate -- 1231 --------------------------------------- 1232 1233 procedure Analyze_Dimension_Array_Aggregate 1234 (N : Node_Id; 1235 Comp_Typ : Entity_Id) 1236 is 1237 Comp_Ass : constant List_Id := Component_Associations (N); 1238 Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ); 1239 Exps : constant List_Id := Expressions (N); 1240 1241 Comp : Node_Id; 1242 Dims_Of_Expr : Dimension_Type; 1243 Expr : Node_Id; 1244 1245 Error_Detected : Boolean := False; 1246 -- This flag is used in order to indicate if an error has been detected 1247 -- so far by the compiler in this routine. 1248 1249 begin 1250 -- Aspect is an Ada 2012 feature. Nothing to do here if the component 1251 -- base type is not a dimensioned type. 1252 1253 -- Inlined bodies have already been checked for dimensionality. 1254 1255 -- Note that here the original node must come from source since the 1256 -- original array aggregate may not have been entirely decorated. 1257 1258 if Ada_Version < Ada_2012 1259 or else In_Inlined_Body 1260 or else not Comes_From_Source (Original_Node (N)) 1261 or else not Has_Dimension_System (Base_Type (Comp_Typ)) 1262 then 1263 return; 1264 end if; 1265 1266 -- Check whether there is any positional component association 1267 1268 if Is_Empty_List (Exps) then 1269 Comp := First (Comp_Ass); 1270 else 1271 Comp := First (Exps); 1272 end if; 1273 1274 while Present (Comp) loop 1275 1276 -- Get the expression from the component 1277 1278 if Nkind (Comp) = N_Component_Association then 1279 Expr := Expression (Comp); 1280 else 1281 Expr := Comp; 1282 end if; 1283 1284 -- Issue an error if the dimensions of the component type and the 1285 -- dimensions of the component mismatch. 1286 1287 -- Note that we must ensure the expression has been fully analyzed 1288 -- since it may not be decorated at this point. We also don't want to 1289 -- issue the same error message multiple times on the same expression 1290 -- (may happen when an aggregate is converted into a positional 1291 -- aggregate). We also must verify that this is a scalar component, 1292 -- and not a subaggregate of a multidimensional aggregate. 1293 -- The expression may be an identifier that has been copied several 1294 -- times during expansion, its dimensions are those of its type. 1295 1296 if Is_Entity_Name (Expr) then 1297 Dims_Of_Expr := Dimensions_Of (Etype (Expr)); 1298 else 1299 Dims_Of_Expr := Dimensions_Of (Expr); 1300 end if; 1301 1302 if Comes_From_Source (Original_Node (Expr)) 1303 and then Present (Etype (Expr)) 1304 and then Is_Numeric_Type (Etype (Expr)) 1305 and then Dims_Of_Expr /= Dims_Of_Comp_Typ 1306 and then Sloc (Comp) /= Sloc (Prev (Comp)) 1307 then 1308 -- Check if an error has already been encountered so far 1309 1310 if not Error_Detected then 1311 Error_Msg_N ("dimensions mismatch in array aggregate", N); 1312 Error_Detected := True; 1313 end if; 1314 1315 Error_Msg_N 1316 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ) 1317 & ", found " & Dimensions_Msg_Of (Expr), Expr); 1318 end if; 1319 1320 -- Look at the named components right after the positional components 1321 1322 if not Present (Next (Comp)) 1323 and then List_Containing (Comp) = Exps 1324 then 1325 Comp := First (Comp_Ass); 1326 else 1327 Next (Comp); 1328 end if; 1329 end loop; 1330 end Analyze_Dimension_Array_Aggregate; 1331 1332 -------------------------------------------- 1333 -- Analyze_Dimension_Assignment_Statement -- 1334 -------------------------------------------- 1335 1336 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is 1337 Lhs : constant Node_Id := Name (N); 1338 Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs); 1339 Rhs : constant Node_Id := Expression (N); 1340 Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs); 1341 1342 procedure Error_Dim_Msg_For_Assignment_Statement 1343 (N : Node_Id; 1344 Lhs : Node_Id; 1345 Rhs : Node_Id); 1346 -- Error using Error_Msg_N at node N. Output the dimensions of left 1347 -- and right hand sides. 1348 1349 -------------------------------------------- 1350 -- Error_Dim_Msg_For_Assignment_Statement -- 1351 -------------------------------------------- 1352 1353 procedure Error_Dim_Msg_For_Assignment_Statement 1354 (N : Node_Id; 1355 Lhs : Node_Id; 1356 Rhs : Node_Id) 1357 is 1358 begin 1359 Error_Msg_N ("dimensions mismatch in assignment", N); 1360 Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N); 1361 Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N); 1362 end Error_Dim_Msg_For_Assignment_Statement; 1363 1364 -- Start of processing for Analyze_Dimension_Assignment 1365 1366 begin 1367 if Dims_Of_Lhs /= Dims_Of_Rhs then 1368 Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs); 1369 end if; 1370 end Analyze_Dimension_Assignment_Statement; 1371 1372 --------------------------------- 1373 -- Analyze_Dimension_Binary_Op -- 1374 --------------------------------- 1375 1376 -- Check and propagate the dimensions for binary operators 1377 -- Note that when the dimensions mismatch, no dimension is propagated to N. 1378 1379 procedure Analyze_Dimension_Binary_Op (N : Node_Id) is 1380 N_Kind : constant Node_Kind := Nkind (N); 1381 1382 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type; 1383 -- If the operand is a numeric literal that comes from a declared 1384 -- constant, use the dimensions of the constant which were computed 1385 -- from the expression of the constant declaration. Otherwise the 1386 -- dimensions are those of the operand, or the type of the operand. 1387 -- This takes care of node rewritings from validity checks, where the 1388 -- dimensions of the operand itself may not be preserved, while the 1389 -- type comes from context and must have dimension information. 1390 1391 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id); 1392 -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the 1393 -- dimensions of both operands. 1394 1395 --------------------------- 1396 -- Dimensions_Of_Operand -- 1397 --------------------------- 1398 1399 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type is 1400 Dims : constant Dimension_Type := Dimensions_Of (N); 1401 1402 begin 1403 if Exists (Dims) then 1404 return Dims; 1405 1406 elsif Is_Entity_Name (N) then 1407 return Dimensions_Of (Etype (Entity (N))); 1408 1409 elsif Nkind (N) = N_Real_Literal then 1410 1411 if Present (Original_Entity (N)) then 1412 return Dimensions_Of (Original_Entity (N)); 1413 1414 else 1415 return Dimensions_Of (Etype (N)); 1416 end if; 1417 1418 -- Otherwise return the default dimensions 1419 1420 else 1421 return Dims; 1422 end if; 1423 end Dimensions_Of_Operand; 1424 1425 --------------------------------- 1426 -- Error_Dim_Msg_For_Binary_Op -- 1427 --------------------------------- 1428 1429 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is 1430 begin 1431 Error_Msg_NE 1432 ("both operands for operation& must have same dimensions", 1433 N, Entity (N)); 1434 Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N); 1435 Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N); 1436 end Error_Dim_Msg_For_Binary_Op; 1437 1438 -- Start of processing for Analyze_Dimension_Binary_Op 1439 1440 begin 1441 -- If the node is already analyzed, do not examine the operands. At the 1442 -- end of the analysis their dimensions have been removed, and the node 1443 -- itself may have been rewritten. 1444 1445 if Analyzed (N) then 1446 return; 1447 end if; 1448 1449 if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract) 1450 or else N_Kind in N_Multiplying_Operator 1451 or else N_Kind in N_Op_Compare 1452 then 1453 declare 1454 L : constant Node_Id := Left_Opnd (N); 1455 Dims_Of_L : constant Dimension_Type := 1456 Dimensions_Of_Operand (L); 1457 L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L); 1458 R : constant Node_Id := Right_Opnd (N); 1459 Dims_Of_R : constant Dimension_Type := 1460 Dimensions_Of_Operand (R); 1461 R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R); 1462 Dims_Of_N : Dimension_Type := Null_Dimension; 1463 1464 begin 1465 -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case 1466 1467 if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then 1468 1469 -- Check both operands have same dimension 1470 1471 if Dims_Of_L /= Dims_Of_R then 1472 Error_Dim_Msg_For_Binary_Op (N, L, R); 1473 else 1474 -- Check both operands are not dimensionless 1475 1476 if Exists (Dims_Of_L) then 1477 Set_Dimensions (N, Dims_Of_L); 1478 end if; 1479 end if; 1480 1481 -- N_Op_Multiply or N_Op_Divide case 1482 1483 elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then 1484 1485 -- Check at least one operand is not dimensionless 1486 1487 if L_Has_Dimensions or R_Has_Dimensions then 1488 1489 -- Multiplication case 1490 1491 -- Get both operands dimensions and add them 1492 1493 if N_Kind = N_Op_Multiply then 1494 for Position in Dimension_Type'Range loop 1495 Dims_Of_N (Position) := 1496 Dims_Of_L (Position) + Dims_Of_R (Position); 1497 end loop; 1498 1499 -- Division case 1500 1501 -- Get both operands dimensions and subtract them 1502 1503 else 1504 for Position in Dimension_Type'Range loop 1505 Dims_Of_N (Position) := 1506 Dims_Of_L (Position) - Dims_Of_R (Position); 1507 end loop; 1508 end if; 1509 1510 if Exists (Dims_Of_N) then 1511 Set_Dimensions (N, Dims_Of_N); 1512 end if; 1513 end if; 1514 1515 -- Exponentiation case 1516 1517 -- Note: a rational exponent is allowed for dimensioned operand 1518 1519 elsif N_Kind = N_Op_Expon then 1520 1521 -- Check the left operand is not dimensionless. Note that the 1522 -- value of the exponent must be known compile time. Otherwise, 1523 -- the exponentiation evaluation will return an error message. 1524 1525 if L_Has_Dimensions then 1526 if not Compile_Time_Known_Value (R) then 1527 Error_Msg_N 1528 ("exponent of dimensioned operand must be " 1529 & "known at compile time", N); 1530 end if; 1531 1532 declare 1533 Exponent_Value : Rational := Zero; 1534 1535 begin 1536 -- Real operand case 1537 1538 if Is_Real_Type (Etype (L)) then 1539 1540 -- Define the exponent as a Rational number 1541 1542 Exponent_Value := Create_Rational_From (R, False); 1543 1544 -- Verify that the exponent cannot be interpreted 1545 -- as a rational, otherwise interpret the exponent 1546 -- as an integer. 1547 1548 if Exponent_Value = No_Rational then 1549 Exponent_Value := 1550 +Whole (UI_To_Int (Expr_Value (R))); 1551 end if; 1552 1553 -- Integer operand case. 1554 1555 -- For integer operand, the exponent cannot be 1556 -- interpreted as a rational. 1557 1558 else 1559 Exponent_Value := +Whole (UI_To_Int (Expr_Value (R))); 1560 end if; 1561 1562 for Position in Dimension_Type'Range loop 1563 Dims_Of_N (Position) := 1564 Dims_Of_L (Position) * Exponent_Value; 1565 end loop; 1566 1567 if Exists (Dims_Of_N) then 1568 Set_Dimensions (N, Dims_Of_N); 1569 end if; 1570 end; 1571 end if; 1572 1573 -- Comparison cases 1574 1575 -- For relational operations, only dimension checking is 1576 -- performed (no propagation). If one operand is the result 1577 -- of constant folding the dimensions may have been lost 1578 -- in a tree copy, so assume that preanalysis has verified 1579 -- that dimensions are correct. 1580 1581 elsif N_Kind in N_Op_Compare then 1582 if (L_Has_Dimensions or R_Has_Dimensions) 1583 and then Dims_Of_L /= Dims_Of_R 1584 then 1585 if Nkind (L) = N_Real_Literal 1586 and then not (Comes_From_Source (L)) 1587 and then Expander_Active 1588 then 1589 null; 1590 1591 elsif Nkind (R) = N_Real_Literal 1592 and then not (Comes_From_Source (R)) 1593 and then Expander_Active 1594 then 1595 null; 1596 1597 -- Numeric literal case. Issue a warning to indicate the 1598 -- literal is treated as if its dimension matches the type 1599 -- dimension. 1600 1601 elsif Nkind_In (Original_Node (L), N_Integer_Literal, 1602 N_Real_Literal) 1603 then 1604 Dim_Warning_For_Numeric_Literal (L, Etype (R)); 1605 1606 elsif Nkind_In (Original_Node (R), N_Integer_Literal, 1607 N_Real_Literal) 1608 then 1609 Dim_Warning_For_Numeric_Literal (R, Etype (L)); 1610 1611 else 1612 Error_Dim_Msg_For_Binary_Op (N, L, R); 1613 end if; 1614 end if; 1615 end if; 1616 1617 -- If expander is active, remove dimension information from each 1618 -- operand, as only dimensions of result are relevant. 1619 1620 if Expander_Active then 1621 Remove_Dimensions (L); 1622 Remove_Dimensions (R); 1623 end if; 1624 end; 1625 end if; 1626 end Analyze_Dimension_Binary_Op; 1627 1628 ---------------------------- 1629 -- Analyze_Dimension_Call -- 1630 ---------------------------- 1631 1632 procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is 1633 Actuals : constant List_Id := Parameter_Associations (N); 1634 Actual : Node_Id; 1635 Dims_Of_Formal : Dimension_Type; 1636 Formal : Node_Id; 1637 Formal_Typ : Entity_Id; 1638 1639 Error_Detected : Boolean := False; 1640 -- This flag is used in order to indicate if an error has been detected 1641 -- so far by the compiler in this routine. 1642 1643 begin 1644 -- Aspect is an Ada 2012 feature. Note that there is no need to check 1645 -- dimensions for calls in inlined bodies, or calls that don't come 1646 -- from source, or those that may have semantic errors. 1647 1648 if Ada_Version < Ada_2012 1649 or else In_Inlined_Body 1650 or else not Comes_From_Source (N) 1651 or else Error_Posted (N) 1652 then 1653 return; 1654 end if; 1655 1656 -- Check the dimensions of the actuals, if any 1657 1658 if not Is_Empty_List (Actuals) then 1659 1660 -- Special processing for elementary functions 1661 1662 -- For Sqrt call, the resulting dimensions equal to half the 1663 -- dimensions of the actual. For all other elementary calls, this 1664 -- routine check that every actual is dimensionless. 1665 1666 if Nkind (N) = N_Function_Call then 1667 Elementary_Function_Calls : declare 1668 Dims_Of_Call : Dimension_Type; 1669 Ent : Entity_Id := Nam; 1670 1671 function Is_Elementary_Function_Entity 1672 (Sub_Id : Entity_Id) return Boolean; 1673 -- Given Sub_Id, the original subprogram entity, return True 1674 -- if call is to an elementary function (see Ada.Numerics. 1675 -- Generic_Elementary_Functions). 1676 1677 ----------------------------------- 1678 -- Is_Elementary_Function_Entity -- 1679 ----------------------------------- 1680 1681 function Is_Elementary_Function_Entity 1682 (Sub_Id : Entity_Id) return Boolean 1683 is 1684 Loc : constant Source_Ptr := Sloc (Sub_Id); 1685 1686 begin 1687 -- Is entity in Ada.Numerics.Generic_Elementary_Functions? 1688 1689 return 1690 Loc > No_Location 1691 and then 1692 Is_RTU 1693 (Cunit_Entity (Get_Source_Unit (Loc)), 1694 Ada_Numerics_Generic_Elementary_Functions); 1695 end Is_Elementary_Function_Entity; 1696 1697 -- Start of processing for Elementary_Function_Calls 1698 1699 begin 1700 -- Get original subprogram entity following the renaming chain 1701 1702 if Present (Alias (Ent)) then 1703 Ent := Alias (Ent); 1704 end if; 1705 1706 -- Check the call is an Elementary function call 1707 1708 if Is_Elementary_Function_Entity (Ent) then 1709 1710 -- Sqrt function call case 1711 1712 if Chars (Ent) = Name_Sqrt then 1713 Dims_Of_Call := Dimensions_Of (First_Actual (N)); 1714 1715 -- Evaluates the resulting dimensions (i.e. half the 1716 -- dimensions of the actual). 1717 1718 if Exists (Dims_Of_Call) then 1719 for Position in Dims_Of_Call'Range loop 1720 Dims_Of_Call (Position) := 1721 Dims_Of_Call (Position) * 1722 Rational'(Numerator => 1, Denominator => 2); 1723 end loop; 1724 1725 Set_Dimensions (N, Dims_Of_Call); 1726 end if; 1727 1728 -- All other elementary functions case. Note that every 1729 -- actual here should be dimensionless. 1730 1731 else 1732 Actual := First_Actual (N); 1733 while Present (Actual) loop 1734 if Exists (Dimensions_Of (Actual)) then 1735 1736 -- Check if error has already been encountered 1737 1738 if not Error_Detected then 1739 Error_Msg_NE 1740 ("dimensions mismatch in call of&", 1741 N, Name (N)); 1742 Error_Detected := True; 1743 end if; 1744 1745 Error_Msg_N 1746 ("\expected dimension '['], found " 1747 & Dimensions_Msg_Of (Actual), Actual); 1748 end if; 1749 1750 Next_Actual (Actual); 1751 end loop; 1752 end if; 1753 1754 -- Nothing more to do for elementary functions 1755 1756 return; 1757 end if; 1758 end Elementary_Function_Calls; 1759 end if; 1760 1761 -- General case. Check, for each parameter, the dimensions of the 1762 -- actual and its corresponding formal match. Otherwise, complain. 1763 1764 Actual := First_Actual (N); 1765 Formal := First_Formal (Nam); 1766 while Present (Formal) loop 1767 1768 -- A missing corresponding actual indicates that the analysis of 1769 -- the call was aborted due to a previous error. 1770 1771 if No (Actual) then 1772 Check_Error_Detected; 1773 return; 1774 end if; 1775 1776 Formal_Typ := Etype (Formal); 1777 Dims_Of_Formal := Dimensions_Of (Formal_Typ); 1778 1779 -- If the formal is not dimensionless, check dimensions of formal 1780 -- and actual match. Otherwise, complain. 1781 1782 if Exists (Dims_Of_Formal) 1783 and then Dimensions_Of (Actual) /= Dims_Of_Formal 1784 then 1785 -- Check if an error has already been encountered so far 1786 1787 if not Error_Detected then 1788 Error_Msg_NE ("dimensions mismatch in& call", N, Name (N)); 1789 Error_Detected := True; 1790 end if; 1791 1792 Error_Msg_N 1793 ("\expected dimension " & Dimensions_Msg_Of (Formal_Typ) 1794 & ", found " & Dimensions_Msg_Of (Actual), Actual); 1795 end if; 1796 1797 Next_Actual (Actual); 1798 Next_Formal (Formal); 1799 end loop; 1800 end if; 1801 1802 -- For function calls, propagate the dimensions from the returned type 1803 1804 if Nkind (N) = N_Function_Call then 1805 Analyze_Dimension_Has_Etype (N); 1806 end if; 1807 end Analyze_Dimension_Call; 1808 1809 --------------------------------------- 1810 -- Analyze_Dimension_Case_Expression -- 1811 --------------------------------------- 1812 1813 procedure Analyze_Dimension_Case_Expression (N : Node_Id) is 1814 Frst : constant Node_Id := First (Alternatives (N)); 1815 Frst_Expr : constant Node_Id := Expression (Frst); 1816 Dims : constant Dimension_Type := Dimensions_Of (Frst_Expr); 1817 1818 Alt : Node_Id; 1819 1820 begin 1821 Alt := Next (Frst); 1822 while Present (Alt) loop 1823 if Dimensions_Of (Expression (Alt)) /= Dims then 1824 Error_Msg_N ("dimension mismatch in case expression", Alt); 1825 exit; 1826 end if; 1827 1828 Next (Alt); 1829 end loop; 1830 1831 Copy_Dimensions (Frst_Expr, N); 1832 end Analyze_Dimension_Case_Expression; 1833 1834 --------------------------------------------- 1835 -- Analyze_Dimension_Component_Declaration -- 1836 --------------------------------------------- 1837 1838 procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is 1839 Expr : constant Node_Id := Expression (N); 1840 Id : constant Entity_Id := Defining_Identifier (N); 1841 Etyp : constant Entity_Id := Etype (Id); 1842 Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp); 1843 Dims_Of_Expr : Dimension_Type; 1844 1845 procedure Error_Dim_Msg_For_Component_Declaration 1846 (N : Node_Id; 1847 Etyp : Entity_Id; 1848 Expr : Node_Id); 1849 -- Error using Error_Msg_N at node N. Output the dimensions of the 1850 -- type Etyp and the expression Expr of N. 1851 1852 --------------------------------------------- 1853 -- Error_Dim_Msg_For_Component_Declaration -- 1854 --------------------------------------------- 1855 1856 procedure Error_Dim_Msg_For_Component_Declaration 1857 (N : Node_Id; 1858 Etyp : Entity_Id; 1859 Expr : Node_Id) is 1860 begin 1861 Error_Msg_N ("dimensions mismatch in component declaration", N); 1862 Error_Msg_N 1863 ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found " 1864 & Dimensions_Msg_Of (Expr), Expr); 1865 end Error_Dim_Msg_For_Component_Declaration; 1866 1867 -- Start of processing for Analyze_Dimension_Component_Declaration 1868 1869 begin 1870 -- Expression is present 1871 1872 if Present (Expr) then 1873 Dims_Of_Expr := Dimensions_Of (Expr); 1874 1875 -- Check dimensions match 1876 1877 if Dims_Of_Etyp /= Dims_Of_Expr then 1878 1879 -- Numeric literal case. Issue a warning if the object type is not 1880 -- dimensionless to indicate the literal is treated as if its 1881 -- dimension matches the type dimension. 1882 1883 if Nkind_In (Original_Node (Expr), N_Real_Literal, 1884 N_Integer_Literal) 1885 then 1886 Dim_Warning_For_Numeric_Literal (Expr, Etyp); 1887 1888 -- Issue a dimension mismatch error for all other cases 1889 1890 else 1891 Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr); 1892 end if; 1893 end if; 1894 end if; 1895 end Analyze_Dimension_Component_Declaration; 1896 1897 ------------------------------------------------- 1898 -- Analyze_Dimension_Extended_Return_Statement -- 1899 ------------------------------------------------- 1900 1901 procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is 1902 Return_Ent : constant Entity_Id := Return_Statement_Entity (N); 1903 Return_Etyp : constant Entity_Id := 1904 Etype (Return_Applies_To (Return_Ent)); 1905 Return_Obj_Decls : constant List_Id := Return_Object_Declarations (N); 1906 Return_Obj_Decl : Node_Id; 1907 Return_Obj_Id : Entity_Id; 1908 Return_Obj_Typ : Entity_Id; 1909 1910 procedure Error_Dim_Msg_For_Extended_Return_Statement 1911 (N : Node_Id; 1912 Return_Etyp : Entity_Id; 1913 Return_Obj_Typ : Entity_Id); 1914 -- Error using Error_Msg_N at node N. Output dimensions of the returned 1915 -- type Return_Etyp and the returned object type Return_Obj_Typ of N. 1916 1917 ------------------------------------------------- 1918 -- Error_Dim_Msg_For_Extended_Return_Statement -- 1919 ------------------------------------------------- 1920 1921 procedure Error_Dim_Msg_For_Extended_Return_Statement 1922 (N : Node_Id; 1923 Return_Etyp : Entity_Id; 1924 Return_Obj_Typ : Entity_Id) 1925 is 1926 begin 1927 Error_Msg_N ("dimensions mismatch in extended return statement", N); 1928 Error_Msg_N 1929 ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp) 1930 & ", found " & Dimensions_Msg_Of (Return_Obj_Typ), N); 1931 end Error_Dim_Msg_For_Extended_Return_Statement; 1932 1933 -- Start of processing for Analyze_Dimension_Extended_Return_Statement 1934 1935 begin 1936 if Present (Return_Obj_Decls) then 1937 Return_Obj_Decl := First (Return_Obj_Decls); 1938 while Present (Return_Obj_Decl) loop 1939 if Nkind (Return_Obj_Decl) = N_Object_Declaration then 1940 Return_Obj_Id := Defining_Identifier (Return_Obj_Decl); 1941 1942 if Is_Return_Object (Return_Obj_Id) then 1943 Return_Obj_Typ := Etype (Return_Obj_Id); 1944 1945 -- Issue an error message if dimensions mismatch 1946 1947 if Dimensions_Of (Return_Etyp) /= 1948 Dimensions_Of (Return_Obj_Typ) 1949 then 1950 Error_Dim_Msg_For_Extended_Return_Statement 1951 (N, Return_Etyp, Return_Obj_Typ); 1952 return; 1953 end if; 1954 end if; 1955 end if; 1956 1957 Next (Return_Obj_Decl); 1958 end loop; 1959 end if; 1960 end Analyze_Dimension_Extended_Return_Statement; 1961 1962 ----------------------------------------------------- 1963 -- Analyze_Dimension_Extension_Or_Record_Aggregate -- 1964 ----------------------------------------------------- 1965 1966 procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id) is 1967 Comp : Node_Id; 1968 Comp_Id : Entity_Id; 1969 Comp_Typ : Entity_Id; 1970 Expr : Node_Id; 1971 1972 Error_Detected : Boolean := False; 1973 -- This flag is used in order to indicate if an error has been detected 1974 -- so far by the compiler in this routine. 1975 1976 begin 1977 -- Aspect is an Ada 2012 feature. Note that there is no need to check 1978 -- dimensions in inlined bodies, or for aggregates that don't come 1979 -- from source, or if we are within an initialization procedure, whose 1980 -- expressions have been checked at the point of record declaration. 1981 1982 if Ada_Version < Ada_2012 1983 or else In_Inlined_Body 1984 or else not Comes_From_Source (N) 1985 or else Inside_Init_Proc 1986 then 1987 return; 1988 end if; 1989 1990 Comp := First (Component_Associations (N)); 1991 while Present (Comp) loop 1992 Comp_Id := Entity (First (Choices (Comp))); 1993 Comp_Typ := Etype (Comp_Id); 1994 1995 -- Check the component type is either a dimensioned type or a 1996 -- dimensioned subtype. 1997 1998 if Has_Dimension_System (Base_Type (Comp_Typ)) then 1999 Expr := Expression (Comp); 2000 2001 -- A box-initialized component needs no checking. 2002 2003 if No (Expr) and then Box_Present (Comp) then 2004 null; 2005 2006 -- Issue an error if the dimensions of the component type and the 2007 -- dimensions of the component mismatch. 2008 2009 elsif Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then 2010 2011 -- Check if an error has already been encountered so far 2012 2013 if not Error_Detected then 2014 2015 -- Extension aggregate case 2016 2017 if Nkind (N) = N_Extension_Aggregate then 2018 Error_Msg_N 2019 ("dimensions mismatch in extension aggregate", N); 2020 2021 -- Record aggregate case 2022 2023 else 2024 Error_Msg_N 2025 ("dimensions mismatch in record aggregate", N); 2026 end if; 2027 2028 Error_Detected := True; 2029 end if; 2030 2031 Error_Msg_N 2032 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ) 2033 & ", found " & Dimensions_Msg_Of (Expr), Comp); 2034 end if; 2035 end if; 2036 2037 Next (Comp); 2038 end loop; 2039 end Analyze_Dimension_Extension_Or_Record_Aggregate; 2040 2041 ------------------------------- 2042 -- Analyze_Dimension_Formals -- 2043 ------------------------------- 2044 2045 procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id) is 2046 Dims_Of_Typ : Dimension_Type; 2047 Formal : Node_Id; 2048 Typ : Entity_Id; 2049 2050 begin 2051 -- Aspect is an Ada 2012 feature. Note that there is no need to check 2052 -- dimensions for sub specs that don't come from source. 2053 2054 if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then 2055 return; 2056 end if; 2057 2058 Formal := First (Formals); 2059 while Present (Formal) loop 2060 Typ := Parameter_Type (Formal); 2061 Dims_Of_Typ := Dimensions_Of (Typ); 2062 2063 if Exists (Dims_Of_Typ) then 2064 declare 2065 Expr : constant Node_Id := Expression (Formal); 2066 2067 begin 2068 -- Issue a warning if Expr is a numeric literal and if its 2069 -- dimensions differ with the dimensions of the formal type. 2070 2071 if Present (Expr) 2072 and then Dims_Of_Typ /= Dimensions_Of (Expr) 2073 and then Nkind_In (Original_Node (Expr), N_Real_Literal, 2074 N_Integer_Literal) 2075 then 2076 Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ)); 2077 end if; 2078 end; 2079 end if; 2080 2081 Next (Formal); 2082 end loop; 2083 end Analyze_Dimension_Formals; 2084 2085 --------------------------------- 2086 -- Analyze_Dimension_Has_Etype -- 2087 --------------------------------- 2088 2089 procedure Analyze_Dimension_Has_Etype (N : Node_Id) is 2090 Etyp : constant Entity_Id := Etype (N); 2091 Dims_Of_Etyp : Dimension_Type := Dimensions_Of (Etyp); 2092 2093 begin 2094 -- General case. Propagation of the dimensions from the type 2095 2096 if Exists (Dims_Of_Etyp) then 2097 Set_Dimensions (N, Dims_Of_Etyp); 2098 2099 -- Identifier case. Propagate the dimensions from the entity for 2100 -- identifier whose entity is a non-dimensionless constant. 2101 2102 elsif Nkind (N) = N_Identifier then 2103 Analyze_Dimension_Identifier : declare 2104 Id : constant Entity_Id := Entity (N); 2105 2106 begin 2107 -- If Id is missing, abnormal tree, assume previous error 2108 2109 if No (Id) then 2110 Check_Error_Detected; 2111 return; 2112 2113 elsif Ekind_In (Id, E_Constant, E_Named_Real) 2114 and then Exists (Dimensions_Of (Id)) 2115 then 2116 Set_Dimensions (N, Dimensions_Of (Id)); 2117 end if; 2118 end Analyze_Dimension_Identifier; 2119 2120 -- Attribute reference case. Propagate the dimensions from the prefix. 2121 2122 elsif Nkind (N) = N_Attribute_Reference 2123 and then Has_Dimension_System (Base_Type (Etyp)) 2124 then 2125 Dims_Of_Etyp := Dimensions_Of (Prefix (N)); 2126 2127 -- Check the prefix is not dimensionless 2128 2129 if Exists (Dims_Of_Etyp) then 2130 Set_Dimensions (N, Dims_Of_Etyp); 2131 end if; 2132 end if; 2133 2134 -- Remove dimensions from inner expressions, to prevent dimensions 2135 -- table from growing uselessly. 2136 2137 case Nkind (N) is 2138 when N_Attribute_Reference 2139 | N_Indexed_Component 2140 => 2141 declare 2142 Exprs : constant List_Id := Expressions (N); 2143 Expr : Node_Id; 2144 2145 begin 2146 if Present (Exprs) then 2147 Expr := First (Exprs); 2148 while Present (Expr) loop 2149 Remove_Dimensions (Expr); 2150 Next (Expr); 2151 end loop; 2152 end if; 2153 end; 2154 2155 when N_Qualified_Expression 2156 | N_Type_Conversion 2157 | N_Unchecked_Type_Conversion 2158 => 2159 Remove_Dimensions (Expression (N)); 2160 2161 when N_Selected_Component => 2162 Remove_Dimensions (Selector_Name (N)); 2163 2164 when others => 2165 null; 2166 end case; 2167 end Analyze_Dimension_Has_Etype; 2168 2169 ------------------------------------- 2170 -- Analyze_Dimension_If_Expression -- 2171 ------------------------------------- 2172 2173 procedure Analyze_Dimension_If_Expression (N : Node_Id) is 2174 Then_Expr : constant Node_Id := Next (First (Expressions (N))); 2175 Else_Expr : constant Node_Id := Next (Then_Expr); 2176 2177 begin 2178 if Dimensions_Of (Then_Expr) /= Dimensions_Of (Else_Expr) then 2179 Error_Msg_N ("dimensions mismatch in conditional expression", N); 2180 else 2181 Copy_Dimensions (Then_Expr, N); 2182 end if; 2183 end Analyze_Dimension_If_Expression; 2184 2185 ------------------------------------------ 2186 -- Analyze_Dimension_Number_Declaration -- 2187 ------------------------------------------ 2188 2189 procedure Analyze_Dimension_Number_Declaration (N : Node_Id) is 2190 Expr : constant Node_Id := Expression (N); 2191 Id : constant Entity_Id := Defining_Identifier (N); 2192 Dim_Of_Expr : constant Dimension_Type := Dimensions_Of (Expr); 2193 2194 begin 2195 if Exists (Dim_Of_Expr) then 2196 Set_Dimensions (Id, Dim_Of_Expr); 2197 Set_Etype (Id, Etype (Expr)); 2198 end if; 2199 end Analyze_Dimension_Number_Declaration; 2200 2201 ------------------------------------------ 2202 -- Analyze_Dimension_Object_Declaration -- 2203 ------------------------------------------ 2204 2205 procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is 2206 Expr : constant Node_Id := Expression (N); 2207 Id : constant Entity_Id := Defining_Identifier (N); 2208 Etyp : constant Entity_Id := Etype (Id); 2209 Dim_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp); 2210 Dim_Of_Expr : Dimension_Type; 2211 2212 procedure Error_Dim_Msg_For_Object_Declaration 2213 (N : Node_Id; 2214 Etyp : Entity_Id; 2215 Expr : Node_Id); 2216 -- Error using Error_Msg_N at node N. Output the dimensions of the 2217 -- type Etyp and of the expression Expr. 2218 2219 ------------------------------------------ 2220 -- Error_Dim_Msg_For_Object_Declaration -- 2221 ------------------------------------------ 2222 2223 procedure Error_Dim_Msg_For_Object_Declaration 2224 (N : Node_Id; 2225 Etyp : Entity_Id; 2226 Expr : Node_Id) is 2227 begin 2228 Error_Msg_N ("dimensions mismatch in object declaration", N); 2229 Error_Msg_N 2230 ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found " 2231 & Dimensions_Msg_Of (Expr), Expr); 2232 end Error_Dim_Msg_For_Object_Declaration; 2233 2234 -- Start of processing for Analyze_Dimension_Object_Declaration 2235 2236 begin 2237 -- Expression is present 2238 2239 if Present (Expr) then 2240 Dim_Of_Expr := Dimensions_Of (Expr); 2241 2242 -- Check dimensions match 2243 2244 if Dim_Of_Expr /= Dim_Of_Etyp then 2245 2246 -- Numeric literal case. Issue a warning if the object type is 2247 -- not dimensionless to indicate the literal is treated as if 2248 -- its dimension matches the type dimension. 2249 2250 if Nkind_In (Original_Node (Expr), N_Real_Literal, 2251 N_Integer_Literal) 2252 then 2253 Dim_Warning_For_Numeric_Literal (Expr, Etyp); 2254 2255 -- Case of object is a constant whose type is a dimensioned type 2256 2257 elsif Constant_Present (N) and then not Exists (Dim_Of_Etyp) then 2258 2259 -- Propagate dimension from expression to object entity 2260 2261 Set_Dimensions (Id, Dim_Of_Expr); 2262 2263 -- Expression may have been constant-folded. If nominal type has 2264 -- dimensions, verify that expression has same type. 2265 2266 elsif Exists (Dim_Of_Etyp) and then Etype (Expr) = Etyp then 2267 null; 2268 2269 -- For all other cases, issue an error message 2270 2271 else 2272 Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr); 2273 end if; 2274 end if; 2275 2276 -- Remove dimensions in expression after checking consistency with 2277 -- given type. 2278 2279 Remove_Dimensions (Expr); 2280 end if; 2281 end Analyze_Dimension_Object_Declaration; 2282 2283 --------------------------------------------------- 2284 -- Analyze_Dimension_Object_Renaming_Declaration -- 2285 --------------------------------------------------- 2286 2287 procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is 2288 Renamed_Name : constant Node_Id := Name (N); 2289 Sub_Mark : constant Node_Id := Subtype_Mark (N); 2290 2291 procedure Error_Dim_Msg_For_Object_Renaming_Declaration 2292 (N : Node_Id; 2293 Sub_Mark : Node_Id; 2294 Renamed_Name : Node_Id); 2295 -- Error using Error_Msg_N at node N. Output the dimensions of 2296 -- Sub_Mark and of Renamed_Name. 2297 2298 --------------------------------------------------- 2299 -- Error_Dim_Msg_For_Object_Renaming_Declaration -- 2300 --------------------------------------------------- 2301 2302 procedure Error_Dim_Msg_For_Object_Renaming_Declaration 2303 (N : Node_Id; 2304 Sub_Mark : Node_Id; 2305 Renamed_Name : Node_Id) is 2306 begin 2307 Error_Msg_N ("dimensions mismatch in object renaming declaration", N); 2308 Error_Msg_N 2309 ("\expected dimension " & Dimensions_Msg_Of (Sub_Mark) & ", found " 2310 & Dimensions_Msg_Of (Renamed_Name), Renamed_Name); 2311 end Error_Dim_Msg_For_Object_Renaming_Declaration; 2312 2313 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration 2314 2315 begin 2316 if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then 2317 Error_Dim_Msg_For_Object_Renaming_Declaration 2318 (N, Sub_Mark, Renamed_Name); 2319 end if; 2320 end Analyze_Dimension_Object_Renaming_Declaration; 2321 2322 ----------------------------------------------- 2323 -- Analyze_Dimension_Simple_Return_Statement -- 2324 ----------------------------------------------- 2325 2326 procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is 2327 Expr : constant Node_Id := Expression (N); 2328 Return_Ent : constant Entity_Id := Return_Statement_Entity (N); 2329 Return_Etyp : constant Entity_Id := 2330 Etype (Return_Applies_To (Return_Ent)); 2331 Dims_Of_Return_Etyp : constant Dimension_Type := 2332 Dimensions_Of (Return_Etyp); 2333 2334 procedure Error_Dim_Msg_For_Simple_Return_Statement 2335 (N : Node_Id; 2336 Return_Etyp : Entity_Id; 2337 Expr : Node_Id); 2338 -- Error using Error_Msg_N at node N. Output the dimensions of the 2339 -- returned type Return_Etyp and the returned expression Expr of N. 2340 2341 ----------------------------------------------- 2342 -- Error_Dim_Msg_For_Simple_Return_Statement -- 2343 ----------------------------------------------- 2344 2345 procedure Error_Dim_Msg_For_Simple_Return_Statement 2346 (N : Node_Id; 2347 Return_Etyp : Entity_Id; 2348 Expr : Node_Id) 2349 is 2350 begin 2351 Error_Msg_N ("dimensions mismatch in return statement", N); 2352 Error_Msg_N 2353 ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp) 2354 & ", found " & Dimensions_Msg_Of (Expr), Expr); 2355 end Error_Dim_Msg_For_Simple_Return_Statement; 2356 2357 -- Start of processing for Analyze_Dimension_Simple_Return_Statement 2358 2359 begin 2360 if Dims_Of_Return_Etyp /= Dimensions_Of (Expr) then 2361 Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr); 2362 Remove_Dimensions (Expr); 2363 end if; 2364 end Analyze_Dimension_Simple_Return_Statement; 2365 2366 ------------------------------------------- 2367 -- Analyze_Dimension_Subtype_Declaration -- 2368 ------------------------------------------- 2369 2370 procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is 2371 Id : constant Entity_Id := Defining_Identifier (N); 2372 Dims_Of_Id : constant Dimension_Type := Dimensions_Of (Id); 2373 Dims_Of_Etyp : Dimension_Type; 2374 Etyp : Node_Id; 2375 2376 begin 2377 -- No constraint case in subtype declaration 2378 2379 if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then 2380 Etyp := Etype (Subtype_Indication (N)); 2381 Dims_Of_Etyp := Dimensions_Of (Etyp); 2382 2383 if Exists (Dims_Of_Etyp) then 2384 2385 -- If subtype already has a dimension (from Aspect_Dimension), it 2386 -- cannot inherit different dimensions from its subtype. 2387 2388 if Exists (Dims_Of_Id) and then Dims_Of_Etyp /= Dims_Of_Id then 2389 Error_Msg_NE 2390 ("subtype& already " & Dimensions_Msg_Of (Id, True), N, Id); 2391 else 2392 Set_Dimensions (Id, Dims_Of_Etyp); 2393 Set_Symbol (Id, Symbol_Of (Etyp)); 2394 end if; 2395 end if; 2396 2397 -- Constraint present in subtype declaration 2398 2399 else 2400 Etyp := Etype (Subtype_Mark (Subtype_Indication (N))); 2401 Dims_Of_Etyp := Dimensions_Of (Etyp); 2402 2403 if Exists (Dims_Of_Etyp) then 2404 Set_Dimensions (Id, Dims_Of_Etyp); 2405 Set_Symbol (Id, Symbol_Of (Etyp)); 2406 end if; 2407 end if; 2408 end Analyze_Dimension_Subtype_Declaration; 2409 2410 --------------------------------------- 2411 -- Analyze_Dimension_Type_Conversion -- 2412 --------------------------------------- 2413 2414 procedure Analyze_Dimension_Type_Conversion (N : Node_Id) is 2415 Expr_Root : constant Entity_Id := 2416 Dimension_System_Root (Etype (Expression (N))); 2417 Target_Root : constant Entity_Id := 2418 Dimension_System_Root (Etype (N)); 2419 2420 begin 2421 -- If the expression has dimensions and the target type has dimensions, 2422 -- the conversion has the dimensions of the expression. Consistency is 2423 -- checked below. Converting to a non-dimensioned type such as Float 2424 -- ignores the dimensions of the expression. 2425 2426 if Exists (Dimensions_Of (Expression (N))) 2427 and then Present (Target_Root) 2428 then 2429 Set_Dimensions (N, Dimensions_Of (Expression (N))); 2430 2431 -- Otherwise the dimensions are those of the target type. 2432 2433 else 2434 Analyze_Dimension_Has_Etype (N); 2435 end if; 2436 2437 -- A conversion between types in different dimension systems (e.g. MKS 2438 -- and British units) must respect the dimensions of expression and 2439 -- type, It is up to the user to provide proper conversion factors. 2440 2441 -- Upward conversions to root type of a dimensioned system are legal, 2442 -- and correspond to "view conversions", i.e. preserve the dimensions 2443 -- of the expression; otherwise conversion must be between types with 2444 -- then same dimensions. Conversions to a non-dimensioned type such as 2445 -- Float lose the dimensions of the expression. 2446 2447 if Present (Expr_Root) 2448 and then Present (Target_Root) 2449 and then Etype (N) /= Target_Root 2450 and then Dimensions_Of (Expression (N)) /= Dimensions_Of (Etype (N)) 2451 then 2452 Error_Msg_N ("dimensions mismatch in conversion", N); 2453 Error_Msg_N 2454 ("\expression " & Dimensions_Msg_Of (Expression (N), True), N); 2455 Error_Msg_N 2456 ("\target type " & Dimensions_Msg_Of (Etype (N), True), N); 2457 end if; 2458 end Analyze_Dimension_Type_Conversion; 2459 2460 -------------------------------- 2461 -- Analyze_Dimension_Unary_Op -- 2462 -------------------------------- 2463 2464 procedure Analyze_Dimension_Unary_Op (N : Node_Id) is 2465 begin 2466 case Nkind (N) is 2467 2468 -- Propagate the dimension if the operand is not dimensionless 2469 2470 when N_Op_Abs 2471 | N_Op_Minus 2472 | N_Op_Plus 2473 => 2474 declare 2475 R : constant Node_Id := Right_Opnd (N); 2476 begin 2477 Move_Dimensions (R, N); 2478 end; 2479 2480 when others => 2481 null; 2482 end case; 2483 end Analyze_Dimension_Unary_Op; 2484 2485 --------------------------------- 2486 -- Check_Expression_Dimensions -- 2487 --------------------------------- 2488 2489 procedure Check_Expression_Dimensions 2490 (Expr : Node_Id; 2491 Typ : Entity_Id) 2492 is 2493 begin 2494 if Is_Floating_Point_Type (Etype (Expr)) then 2495 Analyze_Dimension (Expr); 2496 2497 if Dimensions_Of (Expr) /= Dimensions_Of (Typ) then 2498 Error_Msg_N ("dimensions mismatch in array aggregate", Expr); 2499 Error_Msg_N 2500 ("\expected dimension " & Dimensions_Msg_Of (Typ) 2501 & ", found " & Dimensions_Msg_Of (Expr), Expr); 2502 end if; 2503 end if; 2504 end Check_Expression_Dimensions; 2505 2506 --------------------- 2507 -- Copy_Dimensions -- 2508 --------------------- 2509 2510 procedure Copy_Dimensions (From : Node_Id; To : Node_Id) is 2511 Dims_Of_From : constant Dimension_Type := Dimensions_Of (From); 2512 2513 begin 2514 -- Ignore if not Ada 2012 or beyond 2515 2516 if Ada_Version < Ada_2012 then 2517 return; 2518 2519 -- For Ada 2012, Copy the dimension of 'From to 'To' 2520 2521 elsif Exists (Dims_Of_From) then 2522 Set_Dimensions (To, Dims_Of_From); 2523 end if; 2524 end Copy_Dimensions; 2525 2526 ----------------------------------- 2527 -- Copy_Dimensions_Of_Components -- 2528 ----------------------------------- 2529 2530 procedure Copy_Dimensions_Of_Components (Rec : Entity_Id) is 2531 C : Entity_Id; 2532 2533 begin 2534 C := First_Component (Rec); 2535 while Present (C) loop 2536 if Nkind (Parent (C)) = N_Component_Declaration then 2537 Copy_Dimensions 2538 (Expression (Parent (Corresponding_Record_Component (C))), 2539 Expression (Parent (C))); 2540 end if; 2541 Next_Component (C); 2542 end loop; 2543 end Copy_Dimensions_Of_Components; 2544 2545 -------------------------- 2546 -- Create_Rational_From -- 2547 -------------------------- 2548 2549 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL] 2550 2551 -- A rational number is a number that can be expressed as the quotient or 2552 -- fraction a/b of two integers, where b is non-zero positive. 2553 2554 function Create_Rational_From 2555 (Expr : Node_Id; 2556 Complain : Boolean) return Rational 2557 is 2558 Or_Node_Of_Expr : constant Node_Id := Original_Node (Expr); 2559 Result : Rational := No_Rational; 2560 2561 function Process_Minus (N : Node_Id) return Rational; 2562 -- Create a rational from a N_Op_Minus node 2563 2564 function Process_Divide (N : Node_Id) return Rational; 2565 -- Create a rational from a N_Op_Divide node 2566 2567 function Process_Literal (N : Node_Id) return Rational; 2568 -- Create a rational from a N_Integer_Literal node 2569 2570 ------------------- 2571 -- Process_Minus -- 2572 ------------------- 2573 2574 function Process_Minus (N : Node_Id) return Rational is 2575 Right : constant Node_Id := Original_Node (Right_Opnd (N)); 2576 Result : Rational; 2577 2578 begin 2579 -- Operand is an integer literal 2580 2581 if Nkind (Right) = N_Integer_Literal then 2582 Result := -Process_Literal (Right); 2583 2584 -- Operand is a divide operator 2585 2586 elsif Nkind (Right) = N_Op_Divide then 2587 Result := -Process_Divide (Right); 2588 2589 else 2590 Result := No_Rational; 2591 end if; 2592 2593 -- Provide minimal semantic information on dimension expressions, 2594 -- even though they have no run-time existence. This is for use by 2595 -- ASIS tools, in particular pretty-printing. If generating code 2596 -- standard operator resolution will take place. 2597 2598 if ASIS_Mode then 2599 Set_Entity (N, Standard_Op_Minus); 2600 Set_Etype (N, Standard_Integer); 2601 end if; 2602 2603 return Result; 2604 end Process_Minus; 2605 2606 -------------------- 2607 -- Process_Divide -- 2608 -------------------- 2609 2610 function Process_Divide (N : Node_Id) return Rational is 2611 Left : constant Node_Id := Original_Node (Left_Opnd (N)); 2612 Right : constant Node_Id := Original_Node (Right_Opnd (N)); 2613 Left_Rat : Rational; 2614 Result : Rational := No_Rational; 2615 Right_Rat : Rational; 2616 2617 begin 2618 -- Both left and right operands are integer literals 2619 2620 if Nkind (Left) = N_Integer_Literal 2621 and then 2622 Nkind (Right) = N_Integer_Literal 2623 then 2624 Left_Rat := Process_Literal (Left); 2625 Right_Rat := Process_Literal (Right); 2626 Result := Left_Rat / Right_Rat; 2627 end if; 2628 2629 -- Provide minimal semantic information on dimension expressions, 2630 -- even though they have no run-time existence. This is for use by 2631 -- ASIS tools, in particular pretty-printing. If generating code 2632 -- standard operator resolution will take place. 2633 2634 if ASIS_Mode then 2635 Set_Entity (N, Standard_Op_Divide); 2636 Set_Etype (N, Standard_Integer); 2637 end if; 2638 2639 return Result; 2640 end Process_Divide; 2641 2642 --------------------- 2643 -- Process_Literal -- 2644 --------------------- 2645 2646 function Process_Literal (N : Node_Id) return Rational is 2647 begin 2648 return +Whole (UI_To_Int (Intval (N))); 2649 end Process_Literal; 2650 2651 -- Start of processing for Create_Rational_From 2652 2653 begin 2654 -- Check the expression is either a division of two integers or an 2655 -- integer itself. Note that the check applies to the original node 2656 -- since the node could have already been rewritten. 2657 2658 -- Integer literal case 2659 2660 if Nkind (Or_Node_Of_Expr) = N_Integer_Literal then 2661 Result := Process_Literal (Or_Node_Of_Expr); 2662 2663 -- Divide operator case 2664 2665 elsif Nkind (Or_Node_Of_Expr) = N_Op_Divide then 2666 Result := Process_Divide (Or_Node_Of_Expr); 2667 2668 -- Minus operator case 2669 2670 elsif Nkind (Or_Node_Of_Expr) = N_Op_Minus then 2671 Result := Process_Minus (Or_Node_Of_Expr); 2672 end if; 2673 2674 -- When Expr cannot be interpreted as a rational and Complain is true, 2675 -- generate an error message. 2676 2677 if Complain and then Result = No_Rational then 2678 Error_Msg_N ("rational expected", Expr); 2679 end if; 2680 2681 return Result; 2682 end Create_Rational_From; 2683 2684 ------------------- 2685 -- Dimensions_Of -- 2686 ------------------- 2687 2688 function Dimensions_Of (N : Node_Id) return Dimension_Type is 2689 begin 2690 return Dimension_Table.Get (N); 2691 end Dimensions_Of; 2692 2693 ----------------------- 2694 -- Dimensions_Msg_Of -- 2695 ----------------------- 2696 2697 function Dimensions_Msg_Of 2698 (N : Node_Id; 2699 Description_Needed : Boolean := False) return String 2700 is 2701 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N); 2702 Dimensions_Msg : Name_Id; 2703 System : System_Type; 2704 2705 begin 2706 -- Initialization of Name_Buffer 2707 2708 Name_Len := 0; 2709 2710 -- N is not dimensionless 2711 2712 if Exists (Dims_Of_N) then 2713 System := System_Of (Base_Type (Etype (N))); 2714 2715 -- When Description_Needed, add to string "has dimension " before the 2716 -- actual dimension. 2717 2718 if Description_Needed then 2719 Add_Str_To_Name_Buffer ("has dimension "); 2720 end if; 2721 2722 Append 2723 (Global_Name_Buffer, 2724 From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True)); 2725 2726 -- N is dimensionless 2727 2728 -- When Description_Needed, return "is dimensionless" 2729 2730 elsif Description_Needed then 2731 Add_Str_To_Name_Buffer ("is dimensionless"); 2732 2733 -- Otherwise, return "'[']" 2734 2735 else 2736 Add_Str_To_Name_Buffer ("'[']"); 2737 end if; 2738 2739 Dimensions_Msg := Name_Find; 2740 return Get_Name_String (Dimensions_Msg); 2741 end Dimensions_Msg_Of; 2742 2743 -------------------------- 2744 -- Dimension_Table_Hash -- 2745 -------------------------- 2746 2747 function Dimension_Table_Hash 2748 (Key : Node_Id) return Dimension_Table_Range 2749 is 2750 begin 2751 return Dimension_Table_Range (Key mod 511); 2752 end Dimension_Table_Hash; 2753 2754 ------------------------------------- 2755 -- Dim_Warning_For_Numeric_Literal -- 2756 ------------------------------------- 2757 2758 procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id) is 2759 begin 2760 -- Consider the literal zero (integer 0 or real 0.0) to be of any 2761 -- dimension. 2762 2763 case Nkind (Original_Node (N)) is 2764 when N_Real_Literal => 2765 if Expr_Value_R (N) = Ureal_0 then 2766 return; 2767 end if; 2768 2769 when N_Integer_Literal => 2770 if Expr_Value (N) = Uint_0 then 2771 return; 2772 end if; 2773 2774 when others => 2775 null; 2776 end case; 2777 2778 -- Initialize name buffer 2779 2780 Name_Len := 0; 2781 2782 Append (Global_Name_Buffer, String_From_Numeric_Literal (N)); 2783 2784 -- Insert a blank between the literal and the symbol 2785 2786 Add_Str_To_Name_Buffer (" "); 2787 Append (Global_Name_Buffer, Symbol_Of (Typ)); 2788 2789 Error_Msg_Name_1 := Name_Find; 2790 Error_Msg_N ("assumed to be%%??", N); 2791 end Dim_Warning_For_Numeric_Literal; 2792 2793 ---------------------- 2794 -- Dimensions_Match -- 2795 ---------------------- 2796 2797 function Dimensions_Match (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 2798 begin 2799 return 2800 not Has_Dimension_System (Base_Type (T1)) 2801 or else Dimensions_Of (T1) = Dimensions_Of (T2); 2802 end Dimensions_Match; 2803 2804 --------------------------- 2805 -- Dimension_System_Root -- 2806 --------------------------- 2807 2808 function Dimension_System_Root (T : Entity_Id) return Entity_Id is 2809 Root : Entity_Id; 2810 2811 begin 2812 Root := Base_Type (T); 2813 2814 if Has_Dimension_System (Root) then 2815 return First_Subtype (Root); -- for example Dim_Mks 2816 2817 else 2818 return Empty; 2819 end if; 2820 end Dimension_System_Root; 2821 2822 ---------------------------------------- 2823 -- Eval_Op_Expon_For_Dimensioned_Type -- 2824 ---------------------------------------- 2825 2826 -- Evaluate the expon operator for real dimensioned type. 2827 2828 -- Note that if the exponent is an integer (denominator = 1) the node is 2829 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval). 2830 2831 procedure Eval_Op_Expon_For_Dimensioned_Type 2832 (N : Node_Id; 2833 Btyp : Entity_Id) 2834 is 2835 R : constant Node_Id := Right_Opnd (N); 2836 R_Value : Rational := No_Rational; 2837 2838 begin 2839 if Is_Real_Type (Btyp) then 2840 R_Value := Create_Rational_From (R, False); 2841 end if; 2842 2843 -- Check that the exponent is not an integer 2844 2845 if R_Value /= No_Rational and then R_Value.Denominator /= 1 then 2846 Eval_Op_Expon_With_Rational_Exponent (N, R_Value); 2847 else 2848 Eval_Op_Expon (N); 2849 end if; 2850 end Eval_Op_Expon_For_Dimensioned_Type; 2851 2852 ------------------------------------------ 2853 -- Eval_Op_Expon_With_Rational_Exponent -- 2854 ------------------------------------------ 2855 2856 -- For dimensioned operand in exponentiation, exponent is allowed to be a 2857 -- Rational and not only an Integer like for dimensionless operands. For 2858 -- that particular case, the left operand is rewritten as a function call 2859 -- using the function Expon_LLF from s-llflex.ads. 2860 2861 procedure Eval_Op_Expon_With_Rational_Exponent 2862 (N : Node_Id; 2863 Exponent_Value : Rational) 2864 is 2865 Loc : constant Source_Ptr := Sloc (N); 2866 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N); 2867 L : constant Node_Id := Left_Opnd (N); 2868 Etyp_Of_L : constant Entity_Id := Etype (L); 2869 Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L); 2870 Actual_1 : Node_Id; 2871 Actual_2 : Node_Id; 2872 Dim_Power : Rational; 2873 List_Of_Dims : List_Id; 2874 New_Aspect : Node_Id; 2875 New_Aspects : List_Id; 2876 New_Id : Entity_Id; 2877 New_N : Node_Id; 2878 New_Subtyp_Decl_For_L : Node_Id; 2879 System : System_Type; 2880 2881 begin 2882 -- Case when the operand is not dimensionless 2883 2884 if Exists (Dims_Of_N) then 2885 2886 -- Get the corresponding System_Type to know the exact number of 2887 -- dimensions in the system. 2888 2889 System := System_Of (Btyp_Of_L); 2890 2891 -- Generation of a new subtype with the proper dimensions 2892 2893 -- In order to rewrite the operator as a type conversion, a new 2894 -- dimensioned subtype with the resulting dimensions of the 2895 -- exponentiation must be created. 2896 2897 -- Generate: 2898 2899 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L); 2900 -- System : constant System_Id := 2901 -- Get_Dimension_System_Id (Btyp_Of_L); 2902 -- Num_Of_Dims : constant Number_Of_Dimensions := 2903 -- Dimension_Systems.Table (System).Dimension_Count; 2904 2905 -- subtype T is Btyp_Of_L 2906 -- with 2907 -- Dimension => ( 2908 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator, 2909 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator, 2910 -- ... 2911 -- Dims_Of_N (Num_Of_Dims).Numerator / 2912 -- Dims_Of_N (Num_Of_Dims).Denominator); 2913 2914 -- Step 1: Generate the new aggregate for the aspect Dimension 2915 2916 New_Aspects := Empty_List; 2917 2918 List_Of_Dims := New_List; 2919 for Position in Dims_Of_N'First .. System.Count loop 2920 Dim_Power := Dims_Of_N (Position); 2921 Append_To (List_Of_Dims, 2922 Make_Op_Divide (Loc, 2923 Left_Opnd => 2924 Make_Integer_Literal (Loc, Int (Dim_Power.Numerator)), 2925 Right_Opnd => 2926 Make_Integer_Literal (Loc, Int (Dim_Power.Denominator)))); 2927 end loop; 2928 2929 -- Step 2: Create the new Aspect Specification for Aspect Dimension 2930 2931 New_Aspect := 2932 Make_Aspect_Specification (Loc, 2933 Identifier => Make_Identifier (Loc, Name_Dimension), 2934 Expression => Make_Aggregate (Loc, Expressions => List_Of_Dims)); 2935 2936 -- Step 3: Make a temporary identifier for the new subtype 2937 2938 New_Id := Make_Temporary (Loc, 'T'); 2939 Set_Is_Internal (New_Id); 2940 2941 -- Step 4: Declaration of the new subtype 2942 2943 New_Subtyp_Decl_For_L := 2944 Make_Subtype_Declaration (Loc, 2945 Defining_Identifier => New_Id, 2946 Subtype_Indication => New_Occurrence_Of (Btyp_Of_L, Loc)); 2947 2948 Append (New_Aspect, New_Aspects); 2949 Set_Parent (New_Aspects, New_Subtyp_Decl_For_L); 2950 Set_Aspect_Specifications (New_Subtyp_Decl_For_L, New_Aspects); 2951 2952 Analyze (New_Subtyp_Decl_For_L); 2953 2954 -- Case where the operand is dimensionless 2955 2956 else 2957 New_Id := Btyp_Of_L; 2958 end if; 2959 2960 -- Replacement of N by New_N 2961 2962 -- Generate: 2963 2964 -- Actual_1 := Long_Long_Float (L), 2965 2966 -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) / 2967 -- Long_Long_Float (Exponent_Value.Denominator); 2968 2969 -- (T (Expon_LLF (Actual_1, Actual_2))); 2970 2971 -- where T is the subtype declared in step 1 2972 2973 -- The node is rewritten as a type conversion 2974 2975 -- Step 1: Creation of the two parameters of Expon_LLF function call 2976 2977 Actual_1 := 2978 Make_Type_Conversion (Loc, 2979 Subtype_Mark => New_Occurrence_Of (Standard_Long_Long_Float, Loc), 2980 Expression => Relocate_Node (L)); 2981 2982 Actual_2 := 2983 Make_Op_Divide (Loc, 2984 Left_Opnd => 2985 Make_Real_Literal (Loc, 2986 UR_From_Uint (UI_From_Int (Int (Exponent_Value.Numerator)))), 2987 Right_Opnd => 2988 Make_Real_Literal (Loc, 2989 UR_From_Uint (UI_From_Int (Int (Exponent_Value.Denominator))))); 2990 2991 -- Step 2: Creation of New_N 2992 2993 New_N := 2994 Make_Type_Conversion (Loc, 2995 Subtype_Mark => New_Occurrence_Of (New_Id, Loc), 2996 Expression => 2997 Make_Function_Call (Loc, 2998 Name => New_Occurrence_Of (RTE (RE_Expon_LLF), Loc), 2999 Parameter_Associations => New_List ( 3000 Actual_1, Actual_2))); 3001 3002 -- Step 3: Rewrite N with the result 3003 3004 Rewrite (N, New_N); 3005 Set_Etype (N, New_Id); 3006 Analyze_And_Resolve (N, New_Id); 3007 end Eval_Op_Expon_With_Rational_Exponent; 3008 3009 ------------ 3010 -- Exists -- 3011 ------------ 3012 3013 function Exists (Dim : Dimension_Type) return Boolean is 3014 begin 3015 return Dim /= Null_Dimension; 3016 end Exists; 3017 3018 function Exists (Str : String_Id) return Boolean is 3019 begin 3020 return Str /= No_String; 3021 end Exists; 3022 3023 function Exists (Sys : System_Type) return Boolean is 3024 begin 3025 return Sys /= Null_System; 3026 end Exists; 3027 3028 --------------------------------- 3029 -- Expand_Put_Call_With_Symbol -- 3030 --------------------------------- 3031 3032 -- For procedure Put (resp. Put_Dim_Of) and function Image, defined in 3033 -- System.Dim.Float_IO or System.Dim.Integer_IO, the default string 3034 -- parameter is rewritten to include the unit symbol (or the dimension 3035 -- symbols if not a defined quantity) in the output of a dimensioned 3036 -- object. If a value is already supplied by the user for the parameter 3037 -- Symbol, it is used as is. 3038 3039 -- Case 1. Item is dimensionless 3040 3041 -- * Put : Item appears without a suffix 3042 3043 -- * Put_Dim_Of : the output is [] 3044 3045 -- Obj : Mks_Type := 2.6; 3046 -- Put (Obj, 1, 1, 0); 3047 -- Put_Dim_Of (Obj); 3048 3049 -- The corresponding outputs are: 3050 -- $2.6 3051 -- $[] 3052 3053 -- Case 2. Item has a dimension 3054 3055 -- * Put : If the type of Item is a dimensioned subtype whose 3056 -- symbol is not empty, then the symbol appears as a 3057 -- suffix. Otherwise, a new string is created and appears 3058 -- as a suffix of Item. This string results in the 3059 -- successive concatanations between each unit symbol 3060 -- raised by its corresponding dimension power from the 3061 -- dimensions of Item. 3062 3063 -- * Put_Dim_Of : The output is a new string resulting in the successive 3064 -- concatanations between each dimension symbol raised by 3065 -- its corresponding dimension power from the dimensions of 3066 -- Item. 3067 3068 -- subtype Random is Mks_Type 3069 -- with 3070 -- Dimension => ( 3071 -- Meter => 3, 3072 -- Candela => -1, 3073 -- others => 0); 3074 3075 -- Obj : Random := 5.0; 3076 -- Put (Obj); 3077 -- Put_Dim_Of (Obj); 3078 3079 -- The corresponding outputs are: 3080 -- $5.0 m**3.cd**(-1) 3081 -- $[l**3.J**(-1)] 3082 3083 -- The function Image returns the string identical to that produced by 3084 -- a call to Put whose first parameter is a string. 3085 3086 procedure Expand_Put_Call_With_Symbol (N : Node_Id) is 3087 Actuals : constant List_Id := Parameter_Associations (N); 3088 Loc : constant Source_Ptr := Sloc (N); 3089 Name_Call : constant Node_Id := Name (N); 3090 New_Actuals : constant List_Id := New_List; 3091 Actual : Node_Id; 3092 Dims_Of_Actual : Dimension_Type; 3093 Etyp : Entity_Id; 3094 New_Str_Lit : Node_Id := Empty; 3095 Symbols : String_Id; 3096 3097 Is_Put_Dim_Of : Boolean := False; 3098 -- This flag is used in order to differentiate routines Put and 3099 -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of 3100 -- defined in System.Dim.Float_IO or System.Dim.Integer_IO. 3101 3102 function Has_Symbols return Boolean; 3103 -- Return True if the current Put call already has a parameter 3104 -- association for parameter "Symbols" with the correct string of 3105 -- symbols. 3106 3107 function Is_Procedure_Put_Call return Boolean; 3108 -- Return True if the current call is a call of an instantiation of a 3109 -- procedure Put defined in the package System.Dim.Float_IO and 3110 -- System.Dim.Integer_IO. 3111 3112 function Item_Actual return Node_Id; 3113 -- Return the item actual parameter node in the output call 3114 3115 ----------------- 3116 -- Has_Symbols -- 3117 ----------------- 3118 3119 function Has_Symbols return Boolean is 3120 Actual : Node_Id; 3121 Actual_Str : Node_Id; 3122 3123 begin 3124 -- Look for a symbols parameter association in the list of actuals 3125 3126 Actual := First (Actuals); 3127 while Present (Actual) loop 3128 3129 -- Positional parameter association case when the actual is a 3130 -- string literal. 3131 3132 if Nkind (Actual) = N_String_Literal then 3133 Actual_Str := Actual; 3134 3135 -- Named parameter association case when selector name is Symbol 3136 3137 elsif Nkind (Actual) = N_Parameter_Association 3138 and then Chars (Selector_Name (Actual)) = Name_Symbol 3139 then 3140 Actual_Str := Explicit_Actual_Parameter (Actual); 3141 3142 -- Ignore all other cases 3143 3144 else 3145 Actual_Str := Empty; 3146 end if; 3147 3148 if Present (Actual_Str) then 3149 3150 -- Return True if the actual comes from source or if the string 3151 -- of symbols doesn't have the default value (i.e. it is ""), 3152 -- in which case it is used as suffix of the generated string. 3153 3154 if Comes_From_Source (Actual) 3155 or else String_Length (Strval (Actual_Str)) /= 0 3156 then 3157 return True; 3158 3159 else 3160 return False; 3161 end if; 3162 end if; 3163 3164 Next (Actual); 3165 end loop; 3166 3167 -- At this point, the call has no parameter association. Look to the 3168 -- last actual since the symbols parameter is the last one. 3169 3170 return Nkind (Last (Actuals)) = N_String_Literal; 3171 end Has_Symbols; 3172 3173 --------------------------- 3174 -- Is_Procedure_Put_Call -- 3175 --------------------------- 3176 3177 function Is_Procedure_Put_Call return Boolean is 3178 Ent : Entity_Id; 3179 Loc : Source_Ptr; 3180 3181 begin 3182 -- There are three different Put (resp. Put_Dim_Of) routines in each 3183 -- generic dim IO package. Verify the current procedure call is one 3184 -- of them. 3185 3186 if Is_Entity_Name (Name_Call) then 3187 Ent := Entity (Name_Call); 3188 3189 -- Get the original subprogram entity following the renaming chain 3190 3191 if Present (Alias (Ent)) then 3192 Ent := Alias (Ent); 3193 end if; 3194 3195 Loc := Sloc (Ent); 3196 3197 -- Check the name of the entity subprogram is Put (resp. 3198 -- Put_Dim_Of) and verify this entity is located in either 3199 -- System.Dim.Float_IO or System.Dim.Integer_IO. 3200 3201 if Loc > No_Location 3202 and then Is_Dim_IO_Package_Entity 3203 (Cunit_Entity (Get_Source_Unit (Loc))) 3204 then 3205 if Chars (Ent) = Name_Put_Dim_Of then 3206 Is_Put_Dim_Of := True; 3207 return True; 3208 3209 elsif Chars (Ent) = Name_Put 3210 or else Chars (Ent) = Name_Image 3211 then 3212 return True; 3213 end if; 3214 end if; 3215 end if; 3216 3217 return False; 3218 end Is_Procedure_Put_Call; 3219 3220 ----------------- 3221 -- Item_Actual -- 3222 ----------------- 3223 3224 function Item_Actual return Node_Id is 3225 Actual : Node_Id; 3226 3227 begin 3228 -- Look for the item actual as a parameter association 3229 3230 Actual := First (Actuals); 3231 while Present (Actual) loop 3232 if Nkind (Actual) = N_Parameter_Association 3233 and then Chars (Selector_Name (Actual)) = Name_Item 3234 then 3235 return Explicit_Actual_Parameter (Actual); 3236 end if; 3237 3238 Next (Actual); 3239 end loop; 3240 3241 -- Case where the item has been defined without an association 3242 3243 Actual := First (Actuals); 3244 3245 -- Depending on the procedure Put, Item actual could be first or 3246 -- second in the list of actuals. 3247 3248 if Has_Dimension_System (Base_Type (Etype (Actual))) then 3249 return Actual; 3250 else 3251 return Next (Actual); 3252 end if; 3253 end Item_Actual; 3254 3255 -- Start of processing for Expand_Put_Call_With_Symbol 3256 3257 begin 3258 if Is_Procedure_Put_Call and then not Has_Symbols then 3259 Actual := Item_Actual; 3260 Dims_Of_Actual := Dimensions_Of (Actual); 3261 Etyp := Etype (Actual); 3262 3263 -- Put_Dim_Of case 3264 3265 if Is_Put_Dim_Of then 3266 3267 -- Check that the item is not dimensionless 3268 3269 -- Create the new String_Literal with the new String_Id generated 3270 -- by the routine From_Dim_To_Str_Of_Dim_Symbols. 3271 3272 if Exists (Dims_Of_Actual) then 3273 New_Str_Lit := 3274 Make_String_Literal (Loc, 3275 From_Dim_To_Str_Of_Dim_Symbols 3276 (Dims_Of_Actual, System_Of (Base_Type (Etyp)))); 3277 3278 -- If dimensionless, the output is [] 3279 3280 else 3281 New_Str_Lit := 3282 Make_String_Literal (Loc, "[]"); 3283 end if; 3284 3285 -- Put case 3286 3287 else 3288 -- Add the symbol as a suffix of the value if the subtype has a 3289 -- unit symbol or if the parameter is not dimensionless. 3290 3291 if Exists (Symbol_Of (Etyp)) then 3292 Symbols := Symbol_Of (Etyp); 3293 else 3294 Symbols := From_Dim_To_Str_Of_Unit_Symbols 3295 (Dims_Of_Actual, System_Of (Base_Type (Etyp))); 3296 end if; 3297 3298 -- Check Symbols exists 3299 3300 if Exists (Symbols) then 3301 Start_String; 3302 3303 -- Put a space between the value and the dimension 3304 3305 Store_String_Char (' '); 3306 Store_String_Chars (Symbols); 3307 New_Str_Lit := Make_String_Literal (Loc, End_String); 3308 end if; 3309 end if; 3310 3311 if Present (New_Str_Lit) then 3312 3313 -- Insert all actuals in New_Actuals 3314 3315 Actual := First (Actuals); 3316 while Present (Actual) loop 3317 3318 -- Copy every actuals in New_Actuals except the Symbols 3319 -- parameter association. 3320 3321 if Nkind (Actual) = N_Parameter_Association 3322 and then Chars (Selector_Name (Actual)) /= Name_Symbol 3323 then 3324 Append_To (New_Actuals, 3325 Make_Parameter_Association (Loc, 3326 Selector_Name => New_Copy (Selector_Name (Actual)), 3327 Explicit_Actual_Parameter => 3328 New_Copy (Explicit_Actual_Parameter (Actual)))); 3329 3330 elsif Nkind (Actual) /= N_Parameter_Association then 3331 Append_To (New_Actuals, New_Copy (Actual)); 3332 end if; 3333 3334 Next (Actual); 3335 end loop; 3336 3337 -- Create new Symbols param association and append to New_Actuals 3338 3339 Append_To (New_Actuals, 3340 Make_Parameter_Association (Loc, 3341 Selector_Name => Make_Identifier (Loc, Name_Symbol), 3342 Explicit_Actual_Parameter => New_Str_Lit)); 3343 3344 -- Rewrite and analyze the procedure call 3345 3346 if Chars (Name_Call) = Name_Image then 3347 Rewrite (N, 3348 Make_Function_Call (Loc, 3349 Name => New_Copy (Name_Call), 3350 Parameter_Associations => New_Actuals)); 3351 Analyze_And_Resolve (N); 3352 else 3353 Rewrite (N, 3354 Make_Procedure_Call_Statement (Loc, 3355 Name => New_Copy (Name_Call), 3356 Parameter_Associations => New_Actuals)); 3357 Analyze (N); 3358 end if; 3359 3360 end if; 3361 end if; 3362 end Expand_Put_Call_With_Symbol; 3363 3364 ------------------------------------ 3365 -- From_Dim_To_Str_Of_Dim_Symbols -- 3366 ------------------------------------ 3367 3368 -- Given a dimension vector and the corresponding dimension system, create 3369 -- a String_Id to output dimension symbols corresponding to the dimensions 3370 -- Dims. If In_Error_Msg is True, there is a special handling for character 3371 -- asterisk * which is an insertion character in error messages. 3372 3373 function From_Dim_To_Str_Of_Dim_Symbols 3374 (Dims : Dimension_Type; 3375 System : System_Type; 3376 In_Error_Msg : Boolean := False) return String_Id 3377 is 3378 Dim_Power : Rational; 3379 First_Dim : Boolean := True; 3380 3381 procedure Store_String_Oexpon; 3382 -- Store the expon operator symbol "**" in the string. In error 3383 -- messages, asterisk * is a special character and must be quoted 3384 -- to be placed literally into the message. 3385 3386 ------------------------- 3387 -- Store_String_Oexpon -- 3388 ------------------------- 3389 3390 procedure Store_String_Oexpon is 3391 begin 3392 if In_Error_Msg then 3393 Store_String_Chars ("'*'*"); 3394 else 3395 Store_String_Chars ("**"); 3396 end if; 3397 end Store_String_Oexpon; 3398 3399 -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols 3400 3401 begin 3402 -- Initialization of the new String_Id 3403 3404 Start_String; 3405 3406 -- Store the dimension symbols inside boxes 3407 3408 if In_Error_Msg then 3409 Store_String_Chars ("'["); 3410 else 3411 Store_String_Char ('['); 3412 end if; 3413 3414 for Position in Dimension_Type'Range loop 3415 Dim_Power := Dims (Position); 3416 if Dim_Power /= Zero then 3417 3418 if First_Dim then 3419 First_Dim := False; 3420 else 3421 Store_String_Char ('.'); 3422 end if; 3423 3424 Store_String_Chars (System.Dim_Symbols (Position)); 3425 3426 -- Positive dimension case 3427 3428 if Dim_Power.Numerator > 0 then 3429 3430 -- Integer case 3431 3432 if Dim_Power.Denominator = 1 then 3433 if Dim_Power.Numerator /= 1 then 3434 Store_String_Oexpon; 3435 Store_String_Int (Int (Dim_Power.Numerator)); 3436 end if; 3437 3438 -- Rational case when denominator /= 1 3439 3440 else 3441 Store_String_Oexpon; 3442 Store_String_Char ('('); 3443 Store_String_Int (Int (Dim_Power.Numerator)); 3444 Store_String_Char ('/'); 3445 Store_String_Int (Int (Dim_Power.Denominator)); 3446 Store_String_Char (')'); 3447 end if; 3448 3449 -- Negative dimension case 3450 3451 else 3452 Store_String_Oexpon; 3453 Store_String_Char ('('); 3454 Store_String_Char ('-'); 3455 Store_String_Int (Int (-Dim_Power.Numerator)); 3456 3457 -- Integer case 3458 3459 if Dim_Power.Denominator = 1 then 3460 Store_String_Char (')'); 3461 3462 -- Rational case when denominator /= 1 3463 3464 else 3465 Store_String_Char ('/'); 3466 Store_String_Int (Int (Dim_Power.Denominator)); 3467 Store_String_Char (')'); 3468 end if; 3469 end if; 3470 end if; 3471 end loop; 3472 3473 if In_Error_Msg then 3474 Store_String_Chars ("']"); 3475 else 3476 Store_String_Char (']'); 3477 end if; 3478 3479 return End_String; 3480 end From_Dim_To_Str_Of_Dim_Symbols; 3481 3482 ------------------------------------- 3483 -- From_Dim_To_Str_Of_Unit_Symbols -- 3484 ------------------------------------- 3485 3486 -- Given a dimension vector and the corresponding dimension system, 3487 -- create a String_Id to output the unit symbols corresponding to the 3488 -- dimensions Dims. 3489 3490 function From_Dim_To_Str_Of_Unit_Symbols 3491 (Dims : Dimension_Type; 3492 System : System_Type) return String_Id 3493 is 3494 Dim_Power : Rational; 3495 First_Dim : Boolean := True; 3496 3497 begin 3498 -- Return No_String if dimensionless 3499 3500 if not Exists (Dims) then 3501 return No_String; 3502 end if; 3503 3504 -- Initialization of the new String_Id 3505 3506 Start_String; 3507 3508 for Position in Dimension_Type'Range loop 3509 Dim_Power := Dims (Position); 3510 3511 if Dim_Power /= Zero then 3512 if First_Dim then 3513 First_Dim := False; 3514 else 3515 Store_String_Char ('.'); 3516 end if; 3517 3518 Store_String_Chars (System.Unit_Symbols (Position)); 3519 3520 -- Positive dimension case 3521 3522 if Dim_Power.Numerator > 0 then 3523 3524 -- Integer case 3525 3526 if Dim_Power.Denominator = 1 then 3527 if Dim_Power.Numerator /= 1 then 3528 Store_String_Chars ("**"); 3529 Store_String_Int (Int (Dim_Power.Numerator)); 3530 end if; 3531 3532 -- Rational case when denominator /= 1 3533 3534 else 3535 Store_String_Chars ("**"); 3536 Store_String_Char ('('); 3537 Store_String_Int (Int (Dim_Power.Numerator)); 3538 Store_String_Char ('/'); 3539 Store_String_Int (Int (Dim_Power.Denominator)); 3540 Store_String_Char (')'); 3541 end if; 3542 3543 -- Negative dimension case 3544 3545 else 3546 Store_String_Chars ("**"); 3547 Store_String_Char ('('); 3548 Store_String_Char ('-'); 3549 Store_String_Int (Int (-Dim_Power.Numerator)); 3550 3551 -- Integer case 3552 3553 if Dim_Power.Denominator = 1 then 3554 Store_String_Char (')'); 3555 3556 -- Rational case when denominator /= 1 3557 3558 else 3559 Store_String_Char ('/'); 3560 Store_String_Int (Int (Dim_Power.Denominator)); 3561 Store_String_Char (')'); 3562 end if; 3563 end if; 3564 end if; 3565 end loop; 3566 3567 return End_String; 3568 end From_Dim_To_Str_Of_Unit_Symbols; 3569 3570 --------- 3571 -- GCD -- 3572 --------- 3573 3574 function GCD (Left, Right : Whole) return Int is 3575 L : Whole; 3576 R : Whole; 3577 3578 begin 3579 L := Left; 3580 R := Right; 3581 while R /= 0 loop 3582 L := L mod R; 3583 3584 if L = 0 then 3585 return Int (R); 3586 end if; 3587 3588 R := R mod L; 3589 end loop; 3590 3591 return Int (L); 3592 end GCD; 3593 3594 -------------------------- 3595 -- Has_Dimension_System -- 3596 -------------------------- 3597 3598 function Has_Dimension_System (Typ : Entity_Id) return Boolean is 3599 begin 3600 return Exists (System_Of (Typ)); 3601 end Has_Dimension_System; 3602 3603 ------------------------------ 3604 -- Is_Dim_IO_Package_Entity -- 3605 ------------------------------ 3606 3607 function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is 3608 begin 3609 -- Check the package entity corresponds to System.Dim.Float_IO or 3610 -- System.Dim.Integer_IO. 3611 3612 return 3613 Is_RTU (E, System_Dim_Float_IO) 3614 or else 3615 Is_RTU (E, System_Dim_Integer_IO); 3616 end Is_Dim_IO_Package_Entity; 3617 3618 ------------------------------------- 3619 -- Is_Dim_IO_Package_Instantiation -- 3620 ------------------------------------- 3621 3622 function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is 3623 Gen_Id : constant Node_Id := Name (N); 3624 3625 begin 3626 -- Check that the instantiated package is either System.Dim.Float_IO 3627 -- or System.Dim.Integer_IO. 3628 3629 return 3630 Is_Entity_Name (Gen_Id) 3631 and then Is_Dim_IO_Package_Entity (Entity (Gen_Id)); 3632 end Is_Dim_IO_Package_Instantiation; 3633 3634 ---------------- 3635 -- Is_Invalid -- 3636 ---------------- 3637 3638 function Is_Invalid (Position : Dimension_Position) return Boolean is 3639 begin 3640 return Position = Invalid_Position; 3641 end Is_Invalid; 3642 3643 --------------------- 3644 -- Move_Dimensions -- 3645 --------------------- 3646 3647 procedure Move_Dimensions (From, To : Node_Id) is 3648 begin 3649 if Ada_Version < Ada_2012 then 3650 return; 3651 end if; 3652 3653 -- Copy the dimension of 'From to 'To' and remove dimension of 'From' 3654 3655 Copy_Dimensions (From, To); 3656 Remove_Dimensions (From); 3657 end Move_Dimensions; 3658 3659 --------------------------------------- 3660 -- New_Copy_Tree_And_Copy_Dimensions -- 3661 --------------------------------------- 3662 3663 function New_Copy_Tree_And_Copy_Dimensions 3664 (Source : Node_Id; 3665 Map : Elist_Id := No_Elist; 3666 New_Sloc : Source_Ptr := No_Location; 3667 New_Scope : Entity_Id := Empty) return Node_Id 3668 is 3669 New_Copy : constant Node_Id := 3670 New_Copy_Tree (Source, Map, New_Sloc, New_Scope); 3671 3672 begin 3673 -- Move the dimensions of Source to New_Copy 3674 3675 Copy_Dimensions (Source, New_Copy); 3676 return New_Copy; 3677 end New_Copy_Tree_And_Copy_Dimensions; 3678 3679 ------------ 3680 -- Reduce -- 3681 ------------ 3682 3683 function Reduce (X : Rational) return Rational is 3684 begin 3685 if X.Numerator = 0 then 3686 return Zero; 3687 end if; 3688 3689 declare 3690 G : constant Int := GCD (X.Numerator, X.Denominator); 3691 begin 3692 return Rational'(Numerator => Whole (Int (X.Numerator) / G), 3693 Denominator => Whole (Int (X.Denominator) / G)); 3694 end; 3695 end Reduce; 3696 3697 ----------------------- 3698 -- Remove_Dimensions -- 3699 ----------------------- 3700 3701 procedure Remove_Dimensions (N : Node_Id) is 3702 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N); 3703 begin 3704 if Exists (Dims_Of_N) then 3705 Dimension_Table.Remove (N); 3706 end if; 3707 end Remove_Dimensions; 3708 3709 ----------------------------------- 3710 -- Remove_Dimension_In_Statement -- 3711 ----------------------------------- 3712 3713 -- Removal of dimension in statement as part of the Analyze_Statements 3714 -- routine (see package Sem_Ch5). 3715 3716 procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is 3717 begin 3718 if Ada_Version < Ada_2012 then 3719 return; 3720 end if; 3721 3722 -- Remove dimension in parameter specifications for accept statement 3723 3724 if Nkind (Stmt) = N_Accept_Statement then 3725 declare 3726 Param : Node_Id := First (Parameter_Specifications (Stmt)); 3727 begin 3728 while Present (Param) loop 3729 Remove_Dimensions (Param); 3730 Next (Param); 3731 end loop; 3732 end; 3733 3734 -- Remove dimension of name and expression in assignments 3735 3736 elsif Nkind (Stmt) = N_Assignment_Statement then 3737 Remove_Dimensions (Expression (Stmt)); 3738 Remove_Dimensions (Name (Stmt)); 3739 end if; 3740 end Remove_Dimension_In_Statement; 3741 3742 -------------------- 3743 -- Set_Dimensions -- 3744 -------------------- 3745 3746 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is 3747 begin 3748 pragma Assert (OK_For_Dimension (Nkind (N))); 3749 pragma Assert (Exists (Val)); 3750 3751 Dimension_Table.Set (N, Val); 3752 end Set_Dimensions; 3753 3754 ---------------- 3755 -- Set_Symbol -- 3756 ---------------- 3757 3758 procedure Set_Symbol (E : Entity_Id; Val : String_Id) is 3759 begin 3760 Symbol_Table.Set (E, Val); 3761 end Set_Symbol; 3762 3763 --------------------------------- 3764 -- String_From_Numeric_Literal -- 3765 --------------------------------- 3766 3767 function String_From_Numeric_Literal (N : Node_Id) return String_Id is 3768 Loc : constant Source_Ptr := Sloc (N); 3769 Sbuffer : constant Source_Buffer_Ptr := 3770 Source_Text (Get_Source_File_Index (Loc)); 3771 Src_Ptr : Source_Ptr := Loc; 3772 3773 C : Character := Sbuffer (Src_Ptr); 3774 -- Current source program character 3775 3776 function Belong_To_Numeric_Literal (C : Character) return Boolean; 3777 -- Return True if C belongs to a numeric literal 3778 3779 ------------------------------- 3780 -- Belong_To_Numeric_Literal -- 3781 ------------------------------- 3782 3783 function Belong_To_Numeric_Literal (C : Character) return Boolean is 3784 begin 3785 case C is 3786 when '0' .. '9' 3787 | '_' | '.' | 'e' | '#' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F' 3788 => 3789 return True; 3790 3791 -- Make sure '+' or '-' is part of an exponent. 3792 3793 when '+' | '-' => 3794 declare 3795 Prev_C : constant Character := Sbuffer (Src_Ptr - 1); 3796 begin 3797 return Prev_C = 'e' or else Prev_C = 'E'; 3798 end; 3799 3800 -- All other character doesn't belong to a numeric literal 3801 3802 when others => 3803 return False; 3804 end case; 3805 end Belong_To_Numeric_Literal; 3806 3807 -- Start of processing for String_From_Numeric_Literal 3808 3809 begin 3810 Start_String; 3811 while Belong_To_Numeric_Literal (C) loop 3812 Store_String_Char (C); 3813 Src_Ptr := Src_Ptr + 1; 3814 C := Sbuffer (Src_Ptr); 3815 end loop; 3816 3817 return End_String; 3818 end String_From_Numeric_Literal; 3819 3820 --------------- 3821 -- Symbol_Of -- 3822 --------------- 3823 3824 function Symbol_Of (E : Entity_Id) return String_Id is 3825 Subtype_Symbol : constant String_Id := Symbol_Table.Get (E); 3826 begin 3827 if Subtype_Symbol /= No_String then 3828 return Subtype_Symbol; 3829 else 3830 return From_Dim_To_Str_Of_Unit_Symbols 3831 (Dimensions_Of (E), System_Of (Base_Type (E))); 3832 end if; 3833 end Symbol_Of; 3834 3835 ----------------------- 3836 -- Symbol_Table_Hash -- 3837 ----------------------- 3838 3839 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is 3840 begin 3841 return Symbol_Table_Range (Key mod 511); 3842 end Symbol_Table_Hash; 3843 3844 --------------- 3845 -- System_Of -- 3846 --------------- 3847 3848 function System_Of (E : Entity_Id) return System_Type is 3849 Type_Decl : constant Node_Id := Parent (E); 3850 3851 begin 3852 -- Look for Type_Decl in System_Table 3853 3854 for Dim_Sys in 1 .. System_Table.Last loop 3855 if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then 3856 return System_Table.Table (Dim_Sys); 3857 end if; 3858 end loop; 3859 3860 return Null_System; 3861 end System_Of; 3862 3863end Sem_Dim; 3864