1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ F I X D -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-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 Atree; use Atree; 27with Checks; use Checks; 28with Einfo; use Einfo; 29with Exp_Util; use Exp_Util; 30with Nlists; use Nlists; 31with Nmake; use Nmake; 32with Restrict; use Restrict; 33with Rident; use Rident; 34with Rtsfind; use Rtsfind; 35with Sem; use Sem; 36with Sem_Eval; use Sem_Eval; 37with Sem_Res; use Sem_Res; 38with Sem_Util; use Sem_Util; 39with Sinfo; use Sinfo; 40with Snames; use Snames; 41with Stand; use Stand; 42with Tbuild; use Tbuild; 43with Uintp; use Uintp; 44with Urealp; use Urealp; 45 46package body Exp_Fixd is 47 48 ----------------------- 49 -- Local Subprograms -- 50 ----------------------- 51 52 -- General note; in this unit, a number of routines are driven by the 53 -- types (Etype) of their operands. Since we are dealing with unanalyzed 54 -- expressions as they are constructed, the Etypes would not normally be 55 -- set, but the construction routines that we use in this unit do in fact 56 -- set the Etype values correctly. In addition, setting the Etype ensures 57 -- that the analyzer does not try to redetermine the type when the node 58 -- is analyzed (which would be wrong, since in the case where we set the 59 -- Treat_Fixed_As_Integer or Conversion_OK flags, it would think it was 60 -- still dealing with a normal fixed-point operation and mess it up). 61 62 function Build_Conversion 63 (N : Node_Id; 64 Typ : Entity_Id; 65 Expr : Node_Id; 66 Rchk : Boolean := False; 67 Trunc : Boolean := False) return Node_Id; 68 -- Build an expression that converts the expression Expr to type Typ, 69 -- taking the source location from Sloc (N). If the conversions involve 70 -- fixed-point types, then the Conversion_OK flag will be set so that the 71 -- resulting conversions do not get re-expanded. On return the resulting 72 -- node has its Etype set. If Rchk is set, then Do_Range_Check is set 73 -- in the resulting conversion node. If Trunc is set, then the 74 -- Float_Truncate flag is set on the conversion, which must be from 75 -- a floating-point type to an integer type. 76 77 function Build_Divide (N : Node_Id; L, R : Node_Id) return Node_Id; 78 -- Builds an N_Op_Divide node from the given left and right operand 79 -- expressions, using the source location from Sloc (N). The operands are 80 -- either both Universal_Real, in which case Build_Divide differs from 81 -- Make_Op_Divide only in that the Etype of the resulting node is set (to 82 -- Universal_Real), or they can be integer types. In this case the integer 83 -- types need not be the same, and Build_Divide converts the operand with 84 -- the smaller sized type to match the type of the other operand and sets 85 -- this as the result type. The Rounded_Result flag of the result in this 86 -- case is set from the Rounded_Result flag of node N. On return, the 87 -- resulting node is analyzed, and has its Etype set. 88 89 function Build_Double_Divide 90 (N : Node_Id; 91 X, Y, Z : Node_Id) return Node_Id; 92 -- Returns a node corresponding to the value X/(Y*Z) using the source 93 -- location from Sloc (N). The division is rounded if the Rounded_Result 94 -- flag of N is set. The integer types of X, Y, Z may be different. On 95 -- return the resulting node is analyzed, and has its Etype set. 96 97 procedure Build_Double_Divide_Code 98 (N : Node_Id; 99 X, Y, Z : Node_Id; 100 Qnn, Rnn : out Entity_Id; 101 Code : out List_Id); 102 -- Generates a sequence of code for determining the quotient and remainder 103 -- of the division X/(Y*Z), using the source location from Sloc (N). 104 -- Entities of appropriate types are allocated for the quotient and 105 -- remainder and returned in Qnn and Rnn. The result is rounded if the 106 -- Rounded_Result flag of N is set. The Etype fields of Qnn and Rnn are 107 -- appropriately set on return. 108 109 function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id; 110 -- Builds an N_Op_Multiply node from the given left and right operand 111 -- expressions, using the source location from Sloc (N). The operands are 112 -- either both Universal_Real, in which case Build_Multiply differs from 113 -- Make_Op_Multiply only in that the Etype of the resulting node is set (to 114 -- Universal_Real), or they can be integer types. In this case the integer 115 -- types need not be the same, and Build_Multiply chooses a type long 116 -- enough to hold the product (i.e. twice the size of the longer of the two 117 -- operand types), and both operands are converted to this type. The Etype 118 -- of the result is also set to this value. However, the result can never 119 -- overflow Integer_64, so this is the largest type that is ever generated. 120 -- On return, the resulting node is analyzed and has its Etype set. 121 122 function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id; 123 -- Builds an N_Op_Rem node from the given left and right operand 124 -- expressions, using the source location from Sloc (N). The operands are 125 -- both integer types, which need not be the same. Build_Rem converts the 126 -- operand with the smaller sized type to match the type of the other 127 -- operand and sets this as the result type. The result is never rounded 128 -- (rem operations cannot be rounded in any case). On return, the resulting 129 -- node is analyzed and has its Etype set. 130 131 function Build_Scaled_Divide 132 (N : Node_Id; 133 X, Y, Z : Node_Id) return Node_Id; 134 -- Returns a node corresponding to the value X*Y/Z using the source 135 -- location from Sloc (N). The division is rounded if the Rounded_Result 136 -- flag of N is set. The integer types of X, Y, Z may be different. On 137 -- return the resulting node is analyzed and has is Etype set. 138 139 procedure Build_Scaled_Divide_Code 140 (N : Node_Id; 141 X, Y, Z : Node_Id; 142 Qnn, Rnn : out Entity_Id; 143 Code : out List_Id); 144 -- Generates a sequence of code for determining the quotient and remainder 145 -- of the division X*Y/Z, using the source location from Sloc (N). Entities 146 -- of appropriate types are allocated for the quotient and remainder and 147 -- returned in Qnn and Rrr. The integer types for X, Y, Z may be different. 148 -- The division is rounded if the Rounded_Result flag of N is set. The 149 -- Etype fields of Qnn and Rnn are appropriately set on return. 150 151 procedure Do_Divide_Fixed_Fixed (N : Node_Id); 152 -- Handles expansion of divide for case of two fixed-point operands 153 -- (neither of them universal), with an integer or fixed-point result. 154 -- N is the N_Op_Divide node to be expanded. 155 156 procedure Do_Divide_Fixed_Universal (N : Node_Id); 157 -- Handles expansion of divide for case of a fixed-point operand divided 158 -- by a universal real operand, with an integer or fixed-point result. N 159 -- is the N_Op_Divide node to be expanded. 160 161 procedure Do_Divide_Universal_Fixed (N : Node_Id); 162 -- Handles expansion of divide for case of a universal real operand 163 -- divided by a fixed-point operand, with an integer or fixed-point 164 -- result. N is the N_Op_Divide node to be expanded. 165 166 procedure Do_Multiply_Fixed_Fixed (N : Node_Id); 167 -- Handles expansion of multiply for case of two fixed-point operands 168 -- (neither of them universal), with an integer or fixed-point result. 169 -- N is the N_Op_Multiply node to be expanded. 170 171 procedure Do_Multiply_Fixed_Universal (N : Node_Id; Left, Right : Node_Id); 172 -- Handles expansion of multiply for case of a fixed-point operand 173 -- multiplied by a universal real operand, with an integer or fixed- 174 -- point result. N is the N_Op_Multiply node to be expanded, and 175 -- Left, Right are the operands (which may have been switched). 176 177 procedure Expand_Convert_Fixed_Static (N : Node_Id); 178 -- This routine is called where the node N is a conversion of a literal 179 -- or other static expression of a fixed-point type to some other type. 180 -- In such cases, we simply rewrite the operand as a real literal and 181 -- reanalyze. This avoids problems which would otherwise result from 182 -- attempting to build and fold expressions involving constants. 183 184 function Fpt_Value (N : Node_Id) return Node_Id; 185 -- Given an operand of fixed-point operation, return an expression that 186 -- represents the corresponding Universal_Real value. The expression 187 -- can be of integer type, floating-point type, or fixed-point type. 188 -- The expression returned is neither analyzed and resolved. The Etype 189 -- of the result is properly set (to Universal_Real). 190 191 function Integer_Literal 192 (N : Node_Id; 193 V : Uint; 194 Negative : Boolean := False) return Node_Id; 195 -- Given a non-negative universal integer value, build a typed integer 196 -- literal node, using the smallest applicable standard integer type. If 197 -- and only if Negative is true a negative literal is built. If V exceeds 198 -- 2**63-1, the largest value allowed for perfect result set scaling 199 -- factors (see RM G.2.3(22)), then Empty is returned. The node N provides 200 -- the Sloc value for the constructed literal. The Etype of the resulting 201 -- literal is correctly set, and it is marked as analyzed. 202 203 function Real_Literal (N : Node_Id; V : Ureal) return Node_Id; 204 -- Build a real literal node from the given value, the Etype of the 205 -- returned node is set to Universal_Real, since all floating-point 206 -- arithmetic operations that we construct use Universal_Real 207 208 function Rounded_Result_Set (N : Node_Id) return Boolean; 209 -- Returns True if N is a node that contains the Rounded_Result flag 210 -- and if the flag is true or the target type is an integer type. 211 212 procedure Set_Result 213 (N : Node_Id; 214 Expr : Node_Id; 215 Rchk : Boolean := False; 216 Trunc : Boolean := False); 217 -- N is the node for the current conversion, division or multiplication 218 -- operation, and Expr is an expression representing the result. Expr may 219 -- be of floating-point or integer type. If the operation result is fixed- 220 -- point, then the value of Expr is in units of small of the result type 221 -- (i.e. small's have already been dealt with). The result of the call is 222 -- to replace N by an appropriate conversion to the result type, dealing 223 -- with rounding for the decimal types case. The node is then analyzed and 224 -- resolved using the result type. If Rchk or Trunc are True, then 225 -- respectively Do_Range_Check and Float_Truncate are set in the 226 -- resulting conversion. 227 228 ---------------------- 229 -- Build_Conversion -- 230 ---------------------- 231 232 function Build_Conversion 233 (N : Node_Id; 234 Typ : Entity_Id; 235 Expr : Node_Id; 236 Rchk : Boolean := False; 237 Trunc : Boolean := False) return Node_Id 238 is 239 Loc : constant Source_Ptr := Sloc (N); 240 Result : Node_Id; 241 Rcheck : Boolean := Rchk; 242 243 begin 244 -- A special case, if the expression is an integer literal and the 245 -- target type is an integer type, then just retype the integer 246 -- literal to the desired target type. Don't do this if we need 247 -- a range check. 248 249 if Nkind (Expr) = N_Integer_Literal 250 and then Is_Integer_Type (Typ) 251 and then not Rchk 252 then 253 Result := Expr; 254 255 -- Cases where we end up with a conversion. Note that we do not use the 256 -- Convert_To abstraction here, since we may be decorating the resulting 257 -- conversion with Rounded_Result and/or Conversion_OK, so we want the 258 -- conversion node present, even if it appears to be redundant. 259 260 else 261 -- Remove inner conversion if both inner and outer conversions are 262 -- to integer types, since the inner one serves no purpose (except 263 -- perhaps to set rounding, so we preserve the Rounded_Result flag) 264 -- and also we preserve the range check flag on the inner operand 265 266 if Is_Integer_Type (Typ) 267 and then Is_Integer_Type (Etype (Expr)) 268 and then Nkind (Expr) = N_Type_Conversion 269 then 270 Result := 271 Make_Type_Conversion (Loc, 272 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 273 Expression => Expression (Expr)); 274 Set_Rounded_Result (Result, Rounded_Result_Set (Expr)); 275 Rcheck := Rcheck or Do_Range_Check (Expr); 276 277 -- For all other cases, a simple type conversion will work 278 279 else 280 Result := 281 Make_Type_Conversion (Loc, 282 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 283 Expression => Expr); 284 285 Set_Float_Truncate (Result, Trunc); 286 end if; 287 288 -- Set Conversion_OK if either result or expression type is a 289 -- fixed-point type, since from a semantic point of view, we are 290 -- treating fixed-point values as integers at this stage. 291 292 if Is_Fixed_Point_Type (Typ) 293 or else Is_Fixed_Point_Type (Etype (Expression (Result))) 294 then 295 Set_Conversion_OK (Result); 296 end if; 297 298 -- Set Do_Range_Check if either it was requested by the caller, 299 -- or if an eliminated inner conversion had a range check. 300 301 if Rcheck then 302 Enable_Range_Check (Result); 303 else 304 Set_Do_Range_Check (Result, False); 305 end if; 306 end if; 307 308 Set_Etype (Result, Typ); 309 return Result; 310 end Build_Conversion; 311 312 ------------------ 313 -- Build_Divide -- 314 ------------------ 315 316 function Build_Divide (N : Node_Id; L, R : Node_Id) return Node_Id is 317 Loc : constant Source_Ptr := Sloc (N); 318 Left_Type : constant Entity_Id := Base_Type (Etype (L)); 319 Right_Type : constant Entity_Id := Base_Type (Etype (R)); 320 Result_Type : Entity_Id; 321 Rnode : Node_Id; 322 323 begin 324 -- Deal with floating-point case first 325 326 if Is_Floating_Point_Type (Left_Type) then 327 pragma Assert (Left_Type = Universal_Real); 328 pragma Assert (Right_Type = Universal_Real); 329 330 Rnode := Make_Op_Divide (Loc, L, R); 331 Result_Type := Universal_Real; 332 333 -- Integer and fixed-point cases 334 335 else 336 -- An optimization. If the right operand is the literal 1, then we 337 -- can just return the left hand operand. Putting the optimization 338 -- here allows us to omit the check at the call site. 339 340 if Nkind (R) = N_Integer_Literal and then Intval (R) = 1 then 341 return L; 342 end if; 343 344 -- If left and right types are the same, no conversion needed 345 346 if Left_Type = Right_Type then 347 Result_Type := Left_Type; 348 Rnode := 349 Make_Op_Divide (Loc, 350 Left_Opnd => L, 351 Right_Opnd => R); 352 353 -- Use left type if it is the larger of the two 354 355 elsif Esize (Left_Type) >= Esize (Right_Type) then 356 Result_Type := Left_Type; 357 Rnode := 358 Make_Op_Divide (Loc, 359 Left_Opnd => L, 360 Right_Opnd => Build_Conversion (N, Left_Type, R)); 361 362 -- Otherwise right type is larger of the two, us it 363 364 else 365 Result_Type := Right_Type; 366 Rnode := 367 Make_Op_Divide (Loc, 368 Left_Opnd => Build_Conversion (N, Right_Type, L), 369 Right_Opnd => R); 370 end if; 371 end if; 372 373 -- We now have a divide node built with Result_Type set. First 374 -- set Etype of result, as required for all Build_xxx routines 375 376 Set_Etype (Rnode, Base_Type (Result_Type)); 377 378 -- Set Treat_Fixed_As_Integer if operation on fixed-point type 379 -- since this is a literal arithmetic operation, to be performed 380 -- by Gigi without any consideration of small values. 381 382 if Is_Fixed_Point_Type (Result_Type) then 383 Set_Treat_Fixed_As_Integer (Rnode); 384 end if; 385 386 -- The result is rounded if the target of the operation is decimal 387 -- and Rounded_Result is set, or if the target of the operation 388 -- is an integer type. 389 390 if Is_Integer_Type (Etype (N)) 391 or else Rounded_Result_Set (N) 392 then 393 Set_Rounded_Result (Rnode); 394 end if; 395 396 return Rnode; 397 end Build_Divide; 398 399 ------------------------- 400 -- Build_Double_Divide -- 401 ------------------------- 402 403 function Build_Double_Divide 404 (N : Node_Id; 405 X, Y, Z : Node_Id) return Node_Id 406 is 407 Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y))); 408 Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z))); 409 Expr : Node_Id; 410 411 begin 412 -- If denominator fits in 64 bits, we can build the operations directly 413 -- without causing any intermediate overflow, so that's what we do. 414 415 if Nat'Max (Y_Size, Z_Size) <= 32 then 416 return 417 Build_Divide (N, X, Build_Multiply (N, Y, Z)); 418 419 -- Otherwise we use the runtime routine 420 421 -- [Qnn : Interfaces.Integer_64, 422 -- Rnn : Interfaces.Integer_64; 423 -- Double_Divide (X, Y, Z, Qnn, Rnn, Round); 424 -- Qnn] 425 426 else 427 declare 428 Loc : constant Source_Ptr := Sloc (N); 429 Qnn : Entity_Id; 430 Rnn : Entity_Id; 431 Code : List_Id; 432 433 pragma Warnings (Off, Rnn); 434 435 begin 436 Build_Double_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code); 437 Insert_Actions (N, Code); 438 Expr := New_Occurrence_Of (Qnn, Loc); 439 440 -- Set type of result in case used elsewhere (see note at start) 441 442 Set_Etype (Expr, Etype (Qnn)); 443 444 -- Set result as analyzed (see note at start on build routines) 445 446 return Expr; 447 end; 448 end if; 449 end Build_Double_Divide; 450 451 ------------------------------ 452 -- Build_Double_Divide_Code -- 453 ------------------------------ 454 455 -- If the denominator can be computed in 64-bits, we build 456 457 -- [Nnn : constant typ := typ (X); 458 -- Dnn : constant typ := typ (Y) * typ (Z) 459 -- Qnn : constant typ := Nnn / Dnn; 460 -- Rnn : constant typ := Nnn / Dnn; 461 462 -- If the numerator cannot be computed in 64 bits, we build 463 464 -- [Qnn : typ; 465 -- Rnn : typ; 466 -- Double_Divide (X, Y, Z, Qnn, Rnn, Round);] 467 468 procedure Build_Double_Divide_Code 469 (N : Node_Id; 470 X, Y, Z : Node_Id; 471 Qnn, Rnn : out Entity_Id; 472 Code : out List_Id) 473 is 474 Loc : constant Source_Ptr := Sloc (N); 475 476 X_Size : constant Nat := UI_To_Int (Esize (Etype (X))); 477 Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y))); 478 Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z))); 479 480 QR_Siz : Nat; 481 QR_Typ : Entity_Id; 482 483 Nnn : Entity_Id; 484 Dnn : Entity_Id; 485 486 Quo : Node_Id; 487 Rnd : Entity_Id; 488 489 begin 490 -- Find type that will allow computation of numerator 491 492 QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size)); 493 494 if QR_Siz <= 16 then 495 QR_Typ := Standard_Integer_16; 496 elsif QR_Siz <= 32 then 497 QR_Typ := Standard_Integer_32; 498 elsif QR_Siz <= 64 then 499 QR_Typ := Standard_Integer_64; 500 501 -- For more than 64, bits, we use the 64-bit integer defined in 502 -- Interfaces, so that it can be handled by the runtime routine. 503 504 else 505 QR_Typ := RTE (RE_Integer_64); 506 end if; 507 508 -- Define quotient and remainder, and set their Etypes, so 509 -- that they can be picked up by Build_xxx routines. 510 511 Qnn := Make_Temporary (Loc, 'S'); 512 Rnn := Make_Temporary (Loc, 'R'); 513 514 Set_Etype (Qnn, QR_Typ); 515 Set_Etype (Rnn, QR_Typ); 516 517 -- Case that we can compute the denominator in 64 bits 518 519 if QR_Siz <= 64 then 520 521 -- Create temporaries for numerator and denominator and set Etypes, 522 -- so that New_Occurrence_Of picks them up for Build_xxx calls. 523 524 Nnn := Make_Temporary (Loc, 'N'); 525 Dnn := Make_Temporary (Loc, 'D'); 526 527 Set_Etype (Nnn, QR_Typ); 528 Set_Etype (Dnn, QR_Typ); 529 530 Code := New_List ( 531 Make_Object_Declaration (Loc, 532 Defining_Identifier => Nnn, 533 Object_Definition => New_Occurrence_Of (QR_Typ, Loc), 534 Constant_Present => True, 535 Expression => Build_Conversion (N, QR_Typ, X)), 536 537 Make_Object_Declaration (Loc, 538 Defining_Identifier => Dnn, 539 Object_Definition => New_Occurrence_Of (QR_Typ, Loc), 540 Constant_Present => True, 541 Expression => 542 Build_Multiply (N, 543 Build_Conversion (N, QR_Typ, Y), 544 Build_Conversion (N, QR_Typ, Z)))); 545 546 Quo := 547 Build_Divide (N, 548 New_Occurrence_Of (Nnn, Loc), 549 New_Occurrence_Of (Dnn, Loc)); 550 551 Set_Rounded_Result (Quo, Rounded_Result_Set (N)); 552 553 Append_To (Code, 554 Make_Object_Declaration (Loc, 555 Defining_Identifier => Qnn, 556 Object_Definition => New_Occurrence_Of (QR_Typ, Loc), 557 Constant_Present => True, 558 Expression => Quo)); 559 560 Append_To (Code, 561 Make_Object_Declaration (Loc, 562 Defining_Identifier => Rnn, 563 Object_Definition => New_Occurrence_Of (QR_Typ, Loc), 564 Constant_Present => True, 565 Expression => 566 Build_Rem (N, 567 New_Occurrence_Of (Nnn, Loc), 568 New_Occurrence_Of (Dnn, Loc)))); 569 570 -- Case where denominator does not fit in 64 bits, so we have to 571 -- call the runtime routine to compute the quotient and remainder 572 573 else 574 Rnd := Boolean_Literals (Rounded_Result_Set (N)); 575 576 Code := New_List ( 577 Make_Object_Declaration (Loc, 578 Defining_Identifier => Qnn, 579 Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), 580 581 Make_Object_Declaration (Loc, 582 Defining_Identifier => Rnn, 583 Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), 584 585 Make_Procedure_Call_Statement (Loc, 586 Name => New_Occurrence_Of (RTE (RE_Double_Divide), Loc), 587 Parameter_Associations => New_List ( 588 Build_Conversion (N, QR_Typ, X), 589 Build_Conversion (N, QR_Typ, Y), 590 Build_Conversion (N, QR_Typ, Z), 591 New_Occurrence_Of (Qnn, Loc), 592 New_Occurrence_Of (Rnn, Loc), 593 New_Occurrence_Of (Rnd, Loc)))); 594 end if; 595 end Build_Double_Divide_Code; 596 597 -------------------- 598 -- Build_Multiply -- 599 -------------------- 600 601 function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id is 602 Loc : constant Source_Ptr := Sloc (N); 603 Left_Type : constant Entity_Id := Etype (L); 604 Right_Type : constant Entity_Id := Etype (R); 605 Left_Size : Int; 606 Right_Size : Int; 607 Rsize : Int; 608 Result_Type : Entity_Id; 609 Rnode : Node_Id; 610 611 begin 612 -- Deal with floating-point case first 613 614 if Is_Floating_Point_Type (Left_Type) then 615 pragma Assert (Left_Type = Universal_Real); 616 pragma Assert (Right_Type = Universal_Real); 617 618 Result_Type := Universal_Real; 619 Rnode := Make_Op_Multiply (Loc, L, R); 620 621 -- Integer and fixed-point cases 622 623 else 624 -- An optimization. If the right operand is the literal 1, then we 625 -- can just return the left hand operand. Putting the optimization 626 -- here allows us to omit the check at the call site. Similarly, if 627 -- the left operand is the integer 1 we can return the right operand. 628 629 if Nkind (R) = N_Integer_Literal and then Intval (R) = 1 then 630 return L; 631 elsif Nkind (L) = N_Integer_Literal and then Intval (L) = 1 then 632 return R; 633 end if; 634 635 -- Otherwise we need to figure out the correct result type size 636 -- First figure out the effective sizes of the operands. Normally 637 -- the effective size of an operand is the RM_Size of the operand. 638 -- But a special case arises with operands whose size is known at 639 -- compile time. In this case, we can use the actual value of the 640 -- operand to get its size if it would fit signed in 8 or 16 bits. 641 642 Left_Size := UI_To_Int (RM_Size (Left_Type)); 643 644 if Compile_Time_Known_Value (L) then 645 declare 646 Val : constant Uint := Expr_Value (L); 647 begin 648 if Val < Int'(2 ** 7) then 649 Left_Size := 8; 650 elsif Val < Int'(2 ** 15) then 651 Left_Size := 16; 652 end if; 653 end; 654 end if; 655 656 Right_Size := UI_To_Int (RM_Size (Right_Type)); 657 658 if Compile_Time_Known_Value (R) then 659 declare 660 Val : constant Uint := Expr_Value (R); 661 begin 662 if Val <= Int'(2 ** 7) then 663 Right_Size := 8; 664 elsif Val <= Int'(2 ** 15) then 665 Right_Size := 16; 666 end if; 667 end; 668 end if; 669 670 -- Now the result size must be at least twice the longer of 671 -- the two sizes, to accommodate all possible results. 672 673 Rsize := 2 * Int'Max (Left_Size, Right_Size); 674 675 if Rsize <= 8 then 676 Result_Type := Standard_Integer_8; 677 678 elsif Rsize <= 16 then 679 Result_Type := Standard_Integer_16; 680 681 elsif Rsize <= 32 then 682 Result_Type := Standard_Integer_32; 683 684 else 685 Result_Type := Standard_Integer_64; 686 end if; 687 688 Rnode := 689 Make_Op_Multiply (Loc, 690 Left_Opnd => Build_Conversion (N, Result_Type, L), 691 Right_Opnd => Build_Conversion (N, Result_Type, R)); 692 end if; 693 694 -- We now have a multiply node built with Result_Type set. First 695 -- set Etype of result, as required for all Build_xxx routines 696 697 Set_Etype (Rnode, Base_Type (Result_Type)); 698 699 -- Set Treat_Fixed_As_Integer if operation on fixed-point type 700 -- since this is a literal arithmetic operation, to be performed 701 -- by Gigi without any consideration of small values. 702 703 if Is_Fixed_Point_Type (Result_Type) then 704 Set_Treat_Fixed_As_Integer (Rnode); 705 end if; 706 707 return Rnode; 708 end Build_Multiply; 709 710 --------------- 711 -- Build_Rem -- 712 --------------- 713 714 function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id is 715 Loc : constant Source_Ptr := Sloc (N); 716 Left_Type : constant Entity_Id := Etype (L); 717 Right_Type : constant Entity_Id := Etype (R); 718 Result_Type : Entity_Id; 719 Rnode : Node_Id; 720 721 begin 722 if Left_Type = Right_Type then 723 Result_Type := Left_Type; 724 Rnode := 725 Make_Op_Rem (Loc, 726 Left_Opnd => L, 727 Right_Opnd => R); 728 729 -- If left size is larger, we do the remainder operation using the 730 -- size of the left type (i.e. the larger of the two integer types). 731 732 elsif Esize (Left_Type) >= Esize (Right_Type) then 733 Result_Type := Left_Type; 734 Rnode := 735 Make_Op_Rem (Loc, 736 Left_Opnd => L, 737 Right_Opnd => Build_Conversion (N, Left_Type, R)); 738 739 -- Similarly, if the right size is larger, we do the remainder 740 -- operation using the right type. 741 742 else 743 Result_Type := Right_Type; 744 Rnode := 745 Make_Op_Rem (Loc, 746 Left_Opnd => Build_Conversion (N, Right_Type, L), 747 Right_Opnd => R); 748 end if; 749 750 -- We now have an N_Op_Rem node built with Result_Type set. First 751 -- set Etype of result, as required for all Build_xxx routines 752 753 Set_Etype (Rnode, Base_Type (Result_Type)); 754 755 -- Set Treat_Fixed_As_Integer if operation on fixed-point type 756 -- since this is a literal arithmetic operation, to be performed 757 -- by Gigi without any consideration of small values. 758 759 if Is_Fixed_Point_Type (Result_Type) then 760 Set_Treat_Fixed_As_Integer (Rnode); 761 end if; 762 763 -- One more check. We did the rem operation using the larger of the 764 -- two types, which is reasonable. However, in the case where the 765 -- two types have unequal sizes, it is impossible for the result of 766 -- a remainder operation to be larger than the smaller of the two 767 -- types, so we can put a conversion round the result to keep the 768 -- evolving operation size as small as possible. 769 770 if Esize (Left_Type) >= Esize (Right_Type) then 771 Rnode := Build_Conversion (N, Right_Type, Rnode); 772 elsif Esize (Right_Type) >= Esize (Left_Type) then 773 Rnode := Build_Conversion (N, Left_Type, Rnode); 774 end if; 775 776 return Rnode; 777 end Build_Rem; 778 779 ------------------------- 780 -- Build_Scaled_Divide -- 781 ------------------------- 782 783 function Build_Scaled_Divide 784 (N : Node_Id; 785 X, Y, Z : Node_Id) return Node_Id 786 is 787 X_Size : constant Nat := UI_To_Int (Esize (Etype (X))); 788 Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y))); 789 Expr : Node_Id; 790 791 begin 792 -- If numerator fits in 64 bits, we can build the operations directly 793 -- without causing any intermediate overflow, so that's what we do. 794 795 if Nat'Max (X_Size, Y_Size) <= 32 then 796 return 797 Build_Divide (N, Build_Multiply (N, X, Y), Z); 798 799 -- Otherwise we use the runtime routine 800 801 -- [Qnn : Integer_64, 802 -- Rnn : Integer_64; 803 -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round); 804 -- Qnn] 805 806 else 807 declare 808 Loc : constant Source_Ptr := Sloc (N); 809 Qnn : Entity_Id; 810 Rnn : Entity_Id; 811 Code : List_Id; 812 813 pragma Warnings (Off, Rnn); 814 815 begin 816 Build_Scaled_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code); 817 Insert_Actions (N, Code); 818 Expr := New_Occurrence_Of (Qnn, Loc); 819 820 -- Set type of result in case used elsewhere (see note at start) 821 822 Set_Etype (Expr, Etype (Qnn)); 823 return Expr; 824 end; 825 end if; 826 end Build_Scaled_Divide; 827 828 ------------------------------ 829 -- Build_Scaled_Divide_Code -- 830 ------------------------------ 831 832 -- If the numerator can be computed in 64-bits, we build 833 834 -- [Nnn : constant typ := typ (X) * typ (Y); 835 -- Dnn : constant typ := typ (Z) 836 -- Qnn : constant typ := Nnn / Dnn; 837 -- Rnn : constant typ := Nnn / Dnn; 838 839 -- If the numerator cannot be computed in 64 bits, we build 840 841 -- [Qnn : Interfaces.Integer_64; 842 -- Rnn : Interfaces.Integer_64; 843 -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round);] 844 845 procedure Build_Scaled_Divide_Code 846 (N : Node_Id; 847 X, Y, Z : Node_Id; 848 Qnn, Rnn : out Entity_Id; 849 Code : out List_Id) 850 is 851 Loc : constant Source_Ptr := Sloc (N); 852 853 X_Size : constant Nat := UI_To_Int (Esize (Etype (X))); 854 Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y))); 855 Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z))); 856 857 QR_Siz : Nat; 858 QR_Typ : Entity_Id; 859 860 Nnn : Entity_Id; 861 Dnn : Entity_Id; 862 863 Quo : Node_Id; 864 Rnd : Entity_Id; 865 866 begin 867 -- Find type that will allow computation of numerator 868 869 QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size)); 870 871 if QR_Siz <= 16 then 872 QR_Typ := Standard_Integer_16; 873 elsif QR_Siz <= 32 then 874 QR_Typ := Standard_Integer_32; 875 elsif QR_Siz <= 64 then 876 QR_Typ := Standard_Integer_64; 877 878 -- For more than 64, bits, we use the 64-bit integer defined in 879 -- Interfaces, so that it can be handled by the runtime routine. 880 881 else 882 QR_Typ := RTE (RE_Integer_64); 883 end if; 884 885 -- Define quotient and remainder, and set their Etypes, so 886 -- that they can be picked up by Build_xxx routines. 887 888 Qnn := Make_Temporary (Loc, 'S'); 889 Rnn := Make_Temporary (Loc, 'R'); 890 891 Set_Etype (Qnn, QR_Typ); 892 Set_Etype (Rnn, QR_Typ); 893 894 -- Case that we can compute the numerator in 64 bits 895 896 if QR_Siz <= 64 then 897 Nnn := Make_Temporary (Loc, 'N'); 898 Dnn := Make_Temporary (Loc, 'D'); 899 900 -- Set Etypes, so that they can be picked up by New_Occurrence_Of 901 902 Set_Etype (Nnn, QR_Typ); 903 Set_Etype (Dnn, QR_Typ); 904 905 Code := New_List ( 906 Make_Object_Declaration (Loc, 907 Defining_Identifier => Nnn, 908 Object_Definition => New_Occurrence_Of (QR_Typ, Loc), 909 Constant_Present => True, 910 Expression => 911 Build_Multiply (N, 912 Build_Conversion (N, QR_Typ, X), 913 Build_Conversion (N, QR_Typ, Y))), 914 915 Make_Object_Declaration (Loc, 916 Defining_Identifier => Dnn, 917 Object_Definition => New_Occurrence_Of (QR_Typ, Loc), 918 Constant_Present => True, 919 Expression => Build_Conversion (N, QR_Typ, Z))); 920 921 Quo := 922 Build_Divide (N, 923 New_Occurrence_Of (Nnn, Loc), 924 New_Occurrence_Of (Dnn, Loc)); 925 926 Append_To (Code, 927 Make_Object_Declaration (Loc, 928 Defining_Identifier => Qnn, 929 Object_Definition => New_Occurrence_Of (QR_Typ, Loc), 930 Constant_Present => True, 931 Expression => Quo)); 932 933 Append_To (Code, 934 Make_Object_Declaration (Loc, 935 Defining_Identifier => Rnn, 936 Object_Definition => New_Occurrence_Of (QR_Typ, Loc), 937 Constant_Present => True, 938 Expression => 939 Build_Rem (N, 940 New_Occurrence_Of (Nnn, Loc), 941 New_Occurrence_Of (Dnn, Loc)))); 942 943 -- Case where numerator does not fit in 64 bits, so we have to 944 -- call the runtime routine to compute the quotient and remainder 945 946 else 947 Rnd := Boolean_Literals (Rounded_Result_Set (N)); 948 949 Code := New_List ( 950 Make_Object_Declaration (Loc, 951 Defining_Identifier => Qnn, 952 Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), 953 954 Make_Object_Declaration (Loc, 955 Defining_Identifier => Rnn, 956 Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), 957 958 Make_Procedure_Call_Statement (Loc, 959 Name => New_Occurrence_Of (RTE (RE_Scaled_Divide), Loc), 960 Parameter_Associations => New_List ( 961 Build_Conversion (N, QR_Typ, X), 962 Build_Conversion (N, QR_Typ, Y), 963 Build_Conversion (N, QR_Typ, Z), 964 New_Occurrence_Of (Qnn, Loc), 965 New_Occurrence_Of (Rnn, Loc), 966 New_Occurrence_Of (Rnd, Loc)))); 967 end if; 968 969 -- Set type of result, for use in caller 970 971 Set_Etype (Qnn, QR_Typ); 972 end Build_Scaled_Divide_Code; 973 974 --------------------------- 975 -- Do_Divide_Fixed_Fixed -- 976 --------------------------- 977 978 -- We have: 979 980 -- (Result_Value * Result_Small) = 981 -- (Left_Value * Left_Small) / (Right_Value * Right_Small) 982 983 -- Result_Value = (Left_Value / Right_Value) * 984 -- (Left_Small / (Right_Small * Result_Small)); 985 986 -- we can do the operation in integer arithmetic if this fraction is an 987 -- integer or the reciprocal of an integer, as detailed in (RM G.2.3(21)). 988 -- Otherwise the result is in the close result set and our approach is to 989 -- use floating-point to compute this close result. 990 991 procedure Do_Divide_Fixed_Fixed (N : Node_Id) is 992 Left : constant Node_Id := Left_Opnd (N); 993 Right : constant Node_Id := Right_Opnd (N); 994 Left_Type : constant Entity_Id := Etype (Left); 995 Right_Type : constant Entity_Id := Etype (Right); 996 Result_Type : constant Entity_Id := Etype (N); 997 Right_Small : constant Ureal := Small_Value (Right_Type); 998 Left_Small : constant Ureal := Small_Value (Left_Type); 999 1000 Result_Small : Ureal; 1001 Frac : Ureal; 1002 Frac_Num : Uint; 1003 Frac_Den : Uint; 1004 Lit_Int : Node_Id; 1005 1006 begin 1007 -- Rounding is required if the result is integral 1008 1009 if Is_Integer_Type (Result_Type) then 1010 Set_Rounded_Result (N); 1011 end if; 1012 1013 -- Get result small. If the result is an integer, treat it as though 1014 -- it had a small of 1.0, all other processing is identical. 1015 1016 if Is_Integer_Type (Result_Type) then 1017 Result_Small := Ureal_1; 1018 else 1019 Result_Small := Small_Value (Result_Type); 1020 end if; 1021 1022 -- Get small ratio 1023 1024 Frac := Left_Small / (Right_Small * Result_Small); 1025 Frac_Num := Norm_Num (Frac); 1026 Frac_Den := Norm_Den (Frac); 1027 1028 -- If the fraction is an integer, then we get the result by multiplying 1029 -- the left operand by the integer, and then dividing by the right 1030 -- operand (the order is important, if we did the divide first, we 1031 -- would lose precision). 1032 1033 if Frac_Den = 1 then 1034 Lit_Int := Integer_Literal (N, Frac_Num); -- always positive 1035 1036 if Present (Lit_Int) then 1037 Set_Result (N, Build_Scaled_Divide (N, Left, Lit_Int, Right)); 1038 return; 1039 end if; 1040 1041 -- If the fraction is the reciprocal of an integer, then we get the 1042 -- result by first multiplying the divisor by the integer, and then 1043 -- doing the division with the adjusted divisor. 1044 1045 -- Note: this is much better than doing two divisions: multiplications 1046 -- are much faster than divisions (and certainly faster than rounded 1047 -- divisions), and we don't get inaccuracies from double rounding. 1048 1049 elsif Frac_Num = 1 then 1050 Lit_Int := Integer_Literal (N, Frac_Den); -- always positive 1051 1052 if Present (Lit_Int) then 1053 Set_Result (N, Build_Double_Divide (N, Left, Right, Lit_Int)); 1054 return; 1055 end if; 1056 end if; 1057 1058 -- If we fall through, we use floating-point to compute the result 1059 1060 Set_Result (N, 1061 Build_Multiply (N, 1062 Build_Divide (N, Fpt_Value (Left), Fpt_Value (Right)), 1063 Real_Literal (N, Frac))); 1064 end Do_Divide_Fixed_Fixed; 1065 1066 ------------------------------- 1067 -- Do_Divide_Fixed_Universal -- 1068 ------------------------------- 1069 1070 -- We have: 1071 1072 -- (Result_Value * Result_Small) = (Left_Value * Left_Small) / Lit_Value; 1073 -- Result_Value = Left_Value * Left_Small /(Lit_Value * Result_Small); 1074 1075 -- The result is required to be in the perfect result set if the literal 1076 -- can be factored so that the resulting small ratio is an integer or the 1077 -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed 1078 -- analysis of these RM requirements: 1079 1080 -- We must factor the literal, finding an integer K: 1081 1082 -- Lit_Value = K * Right_Small 1083 -- Right_Small = Lit_Value / K 1084 1085 -- such that the small ratio: 1086 1087 -- Left_Small 1088 -- ------------------------------ 1089 -- (Lit_Value / K) * Result_Small 1090 1091 -- Left_Small 1092 -- = ------------------------ * K 1093 -- Lit_Value * Result_Small 1094 1095 -- is an integer or the reciprocal of an integer, and for 1096 -- implementation efficiency we need the smallest such K. 1097 1098 -- First we reduce the left fraction to lowest terms 1099 1100 -- If numerator = 1, then for K = 1, the small ratio is the reciprocal 1101 -- of an integer, and this is clearly the minimum K case, so set K = 1, 1102 -- Right_Small = Lit_Value. 1103 1104 -- If numerator > 1, then set K to the denominator of the fraction so 1105 -- that the resulting small ratio is an integer (the numerator value). 1106 1107 procedure Do_Divide_Fixed_Universal (N : Node_Id) is 1108 Left : constant Node_Id := Left_Opnd (N); 1109 Right : constant Node_Id := Right_Opnd (N); 1110 Left_Type : constant Entity_Id := Etype (Left); 1111 Result_Type : constant Entity_Id := Etype (N); 1112 Left_Small : constant Ureal := Small_Value (Left_Type); 1113 Lit_Value : constant Ureal := Realval (Right); 1114 1115 Result_Small : Ureal; 1116 Frac : Ureal; 1117 Frac_Num : Uint; 1118 Frac_Den : Uint; 1119 Lit_K : Node_Id; 1120 Lit_Int : Node_Id; 1121 1122 begin 1123 -- Get result small. If the result is an integer, treat it as though 1124 -- it had a small of 1.0, all other processing is identical. 1125 1126 if Is_Integer_Type (Result_Type) then 1127 Result_Small := Ureal_1; 1128 else 1129 Result_Small := Small_Value (Result_Type); 1130 end if; 1131 1132 -- Determine if literal can be rewritten successfully 1133 1134 Frac := Left_Small / (Lit_Value * Result_Small); 1135 Frac_Num := Norm_Num (Frac); 1136 Frac_Den := Norm_Den (Frac); 1137 1138 -- Case where fraction is the reciprocal of an integer (K = 1, integer 1139 -- = denominator). If this integer is not too large, this is the case 1140 -- where the result can be obtained by dividing by this integer value. 1141 1142 if Frac_Num = 1 then 1143 Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac)); 1144 1145 if Present (Lit_Int) then 1146 Set_Result (N, Build_Divide (N, Left, Lit_Int)); 1147 return; 1148 end if; 1149 1150 -- Case where we choose K to make fraction an integer (K = denominator 1151 -- of fraction, integer = numerator of fraction). If both K and the 1152 -- numerator are small enough, this is the case where the result can 1153 -- be obtained by first multiplying by the integer value and then 1154 -- dividing by K (the order is important, if we divided first, we 1155 -- would lose precision). 1156 1157 else 1158 Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac)); 1159 Lit_K := Integer_Literal (N, Frac_Den, False); 1160 1161 if Present (Lit_Int) and then Present (Lit_K) then 1162 Set_Result (N, Build_Scaled_Divide (N, Left, Lit_Int, Lit_K)); 1163 return; 1164 end if; 1165 end if; 1166 1167 -- Fall through if the literal cannot be successfully rewritten, or if 1168 -- the small ratio is out of range of integer arithmetic. In the former 1169 -- case it is fine to use floating-point to get the close result set, 1170 -- and in the latter case, it means that the result is zero or raises 1171 -- constraint error, and we can do that accurately in floating-point. 1172 1173 -- If we end up using floating-point, then we take the right integer 1174 -- to be one, and its small to be the value of the original right real 1175 -- literal. That way, we need only one floating-point multiplication. 1176 1177 Set_Result (N, 1178 Build_Multiply (N, Fpt_Value (Left), Real_Literal (N, Frac))); 1179 end Do_Divide_Fixed_Universal; 1180 1181 ------------------------------- 1182 -- Do_Divide_Universal_Fixed -- 1183 ------------------------------- 1184 1185 -- We have: 1186 1187 -- (Result_Value * Result_Small) = 1188 -- Lit_Value / (Right_Value * Right_Small) 1189 -- Result_Value = 1190 -- (Lit_Value / (Right_Small * Result_Small)) / Right_Value 1191 1192 -- The result is required to be in the perfect result set if the literal 1193 -- can be factored so that the resulting small ratio is an integer or the 1194 -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed 1195 -- analysis of these RM requirements: 1196 1197 -- We must factor the literal, finding an integer K: 1198 1199 -- Lit_Value = K * Left_Small 1200 -- Left_Small = Lit_Value / K 1201 1202 -- such that the small ratio: 1203 1204 -- (Lit_Value / K) 1205 -- -------------------------- 1206 -- Right_Small * Result_Small 1207 1208 -- Lit_Value 1 1209 -- = -------------------------- * - 1210 -- Right_Small * Result_Small K 1211 1212 -- is an integer or the reciprocal of an integer, and for 1213 -- implementation efficiency we need the smallest such K. 1214 1215 -- First we reduce the left fraction to lowest terms 1216 1217 -- If denominator = 1, then for K = 1, the small ratio is an integer 1218 -- (the numerator) and this is clearly the minimum K case, so set K = 1, 1219 -- and Left_Small = Lit_Value. 1220 1221 -- If denominator > 1, then set K to the numerator of the fraction so 1222 -- that the resulting small ratio is the reciprocal of an integer (the 1223 -- numerator value). 1224 1225 procedure Do_Divide_Universal_Fixed (N : Node_Id) is 1226 Left : constant Node_Id := Left_Opnd (N); 1227 Right : constant Node_Id := Right_Opnd (N); 1228 Right_Type : constant Entity_Id := Etype (Right); 1229 Result_Type : constant Entity_Id := Etype (N); 1230 Right_Small : constant Ureal := Small_Value (Right_Type); 1231 Lit_Value : constant Ureal := Realval (Left); 1232 1233 Result_Small : Ureal; 1234 Frac : Ureal; 1235 Frac_Num : Uint; 1236 Frac_Den : Uint; 1237 Lit_K : Node_Id; 1238 Lit_Int : Node_Id; 1239 1240 begin 1241 -- Get result small. If the result is an integer, treat it as though 1242 -- it had a small of 1.0, all other processing is identical. 1243 1244 if Is_Integer_Type (Result_Type) then 1245 Result_Small := Ureal_1; 1246 else 1247 Result_Small := Small_Value (Result_Type); 1248 end if; 1249 1250 -- Determine if literal can be rewritten successfully 1251 1252 Frac := Lit_Value / (Right_Small * Result_Small); 1253 Frac_Num := Norm_Num (Frac); 1254 Frac_Den := Norm_Den (Frac); 1255 1256 -- Case where fraction is an integer (K = 1, integer = numerator). If 1257 -- this integer is not too large, this is the case where the result 1258 -- can be obtained by dividing this integer by the right operand. 1259 1260 if Frac_Den = 1 then 1261 Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac)); 1262 1263 if Present (Lit_Int) then 1264 Set_Result (N, Build_Divide (N, Lit_Int, Right)); 1265 return; 1266 end if; 1267 1268 -- Case where we choose K to make the fraction the reciprocal of an 1269 -- integer (K = numerator of fraction, integer = numerator of fraction). 1270 -- If both K and the integer are small enough, this is the case where 1271 -- the result can be obtained by multiplying the right operand by K 1272 -- and then dividing by the integer value. The order of the operations 1273 -- is important (if we divided first, we would lose precision). 1274 1275 else 1276 Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac)); 1277 Lit_K := Integer_Literal (N, Frac_Num, False); 1278 1279 if Present (Lit_Int) and then Present (Lit_K) then 1280 Set_Result (N, Build_Double_Divide (N, Lit_K, Right, Lit_Int)); 1281 return; 1282 end if; 1283 end if; 1284 1285 -- Fall through if the literal cannot be successfully rewritten, or if 1286 -- the small ratio is out of range of integer arithmetic. In the former 1287 -- case it is fine to use floating-point to get the close result set, 1288 -- and in the latter case, it means that the result is zero or raises 1289 -- constraint error, and we can do that accurately in floating-point. 1290 1291 -- If we end up using floating-point, then we take the right integer 1292 -- to be one, and its small to be the value of the original right real 1293 -- literal. That way, we need only one floating-point division. 1294 1295 Set_Result (N, 1296 Build_Divide (N, Real_Literal (N, Frac), Fpt_Value (Right))); 1297 end Do_Divide_Universal_Fixed; 1298 1299 ----------------------------- 1300 -- Do_Multiply_Fixed_Fixed -- 1301 ----------------------------- 1302 1303 -- We have: 1304 1305 -- (Result_Value * Result_Small) = 1306 -- (Left_Value * Left_Small) * (Right_Value * Right_Small) 1307 1308 -- Result_Value = (Left_Value * Right_Value) * 1309 -- (Left_Small * Right_Small) / Result_Small; 1310 1311 -- we can do the operation in integer arithmetic if this fraction is an 1312 -- integer or the reciprocal of an integer, as detailed in (RM G.2.3(21)). 1313 -- Otherwise the result is in the close result set and our approach is to 1314 -- use floating-point to compute this close result. 1315 1316 procedure Do_Multiply_Fixed_Fixed (N : Node_Id) is 1317 Left : constant Node_Id := Left_Opnd (N); 1318 Right : constant Node_Id := Right_Opnd (N); 1319 1320 Left_Type : constant Entity_Id := Etype (Left); 1321 Right_Type : constant Entity_Id := Etype (Right); 1322 Result_Type : constant Entity_Id := Etype (N); 1323 Right_Small : constant Ureal := Small_Value (Right_Type); 1324 Left_Small : constant Ureal := Small_Value (Left_Type); 1325 1326 Result_Small : Ureal; 1327 Frac : Ureal; 1328 Frac_Num : Uint; 1329 Frac_Den : Uint; 1330 Lit_Int : Node_Id; 1331 1332 begin 1333 -- Get result small. If the result is an integer, treat it as though 1334 -- it had a small of 1.0, all other processing is identical. 1335 1336 if Is_Integer_Type (Result_Type) then 1337 Result_Small := Ureal_1; 1338 else 1339 Result_Small := Small_Value (Result_Type); 1340 end if; 1341 1342 -- Get small ratio 1343 1344 Frac := (Left_Small * Right_Small) / Result_Small; 1345 Frac_Num := Norm_Num (Frac); 1346 Frac_Den := Norm_Den (Frac); 1347 1348 -- If the fraction is an integer, then we get the result by multiplying 1349 -- the operands, and then multiplying the result by the integer value. 1350 1351 if Frac_Den = 1 then 1352 Lit_Int := Integer_Literal (N, Frac_Num); -- always positive 1353 1354 if Present (Lit_Int) then 1355 Set_Result (N, 1356 Build_Multiply (N, Build_Multiply (N, Left, Right), 1357 Lit_Int)); 1358 return; 1359 end if; 1360 1361 -- If the fraction is the reciprocal of an integer, then we get the 1362 -- result by multiplying the operands, and then dividing the result by 1363 -- the integer value. The order of the operations is important, if we 1364 -- divided first, we would lose precision. 1365 1366 elsif Frac_Num = 1 then 1367 Lit_Int := Integer_Literal (N, Frac_Den); -- always positive 1368 1369 if Present (Lit_Int) then 1370 Set_Result (N, Build_Scaled_Divide (N, Left, Right, Lit_Int)); 1371 return; 1372 end if; 1373 end if; 1374 1375 -- If we fall through, we use floating-point to compute the result 1376 1377 Set_Result (N, 1378 Build_Multiply (N, 1379 Build_Multiply (N, Fpt_Value (Left), Fpt_Value (Right)), 1380 Real_Literal (N, Frac))); 1381 end Do_Multiply_Fixed_Fixed; 1382 1383 --------------------------------- 1384 -- Do_Multiply_Fixed_Universal -- 1385 --------------------------------- 1386 1387 -- We have: 1388 1389 -- (Result_Value * Result_Small) = (Left_Value * Left_Small) * Lit_Value; 1390 -- Result_Value = Left_Value * (Left_Small * Lit_Value) / Result_Small; 1391 1392 -- The result is required to be in the perfect result set if the literal 1393 -- can be factored so that the resulting small ratio is an integer or the 1394 -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed 1395 -- analysis of these RM requirements: 1396 1397 -- We must factor the literal, finding an integer K: 1398 1399 -- Lit_Value = K * Right_Small 1400 -- Right_Small = Lit_Value / K 1401 1402 -- such that the small ratio: 1403 1404 -- Left_Small * (Lit_Value / K) 1405 -- ---------------------------- 1406 -- Result_Small 1407 1408 -- Left_Small * Lit_Value 1 1409 -- = ---------------------- * - 1410 -- Result_Small K 1411 1412 -- is an integer or the reciprocal of an integer, and for 1413 -- implementation efficiency we need the smallest such K. 1414 1415 -- First we reduce the left fraction to lowest terms 1416 1417 -- If denominator = 1, then for K = 1, the small ratio is an integer, and 1418 -- this is clearly the minimum K case, so set 1419 1420 -- K = 1, Right_Small = Lit_Value 1421 1422 -- If denominator > 1, then set K to the numerator of the fraction, so 1423 -- that the resulting small ratio is the reciprocal of the integer (the 1424 -- denominator value). 1425 1426 procedure Do_Multiply_Fixed_Universal 1427 (N : Node_Id; 1428 Left, Right : Node_Id) 1429 is 1430 Left_Type : constant Entity_Id := Etype (Left); 1431 Result_Type : constant Entity_Id := Etype (N); 1432 Left_Small : constant Ureal := Small_Value (Left_Type); 1433 Lit_Value : constant Ureal := Realval (Right); 1434 1435 Result_Small : Ureal; 1436 Frac : Ureal; 1437 Frac_Num : Uint; 1438 Frac_Den : Uint; 1439 Lit_K : Node_Id; 1440 Lit_Int : Node_Id; 1441 1442 begin 1443 -- Get result small. If the result is an integer, treat it as though 1444 -- it had a small of 1.0, all other processing is identical. 1445 1446 if Is_Integer_Type (Result_Type) then 1447 Result_Small := Ureal_1; 1448 else 1449 Result_Small := Small_Value (Result_Type); 1450 end if; 1451 1452 -- Determine if literal can be rewritten successfully 1453 1454 Frac := (Left_Small * Lit_Value) / Result_Small; 1455 Frac_Num := Norm_Num (Frac); 1456 Frac_Den := Norm_Den (Frac); 1457 1458 -- Case where fraction is an integer (K = 1, integer = numerator). If 1459 -- this integer is not too large, this is the case where the result can 1460 -- be obtained by multiplying by this integer value. 1461 1462 if Frac_Den = 1 then 1463 Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac)); 1464 1465 if Present (Lit_Int) then 1466 Set_Result (N, Build_Multiply (N, Left, Lit_Int)); 1467 return; 1468 end if; 1469 1470 -- Case where we choose K to make fraction the reciprocal of an integer 1471 -- (K = numerator of fraction, integer = denominator of fraction). If 1472 -- both K and the denominator are small enough, this is the case where 1473 -- the result can be obtained by first multiplying by K, and then 1474 -- dividing by the integer value. 1475 1476 else 1477 Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac)); 1478 Lit_K := Integer_Literal (N, Frac_Num); 1479 1480 if Present (Lit_Int) and then Present (Lit_K) then 1481 Set_Result (N, Build_Scaled_Divide (N, Left, Lit_K, Lit_Int)); 1482 return; 1483 end if; 1484 end if; 1485 1486 -- Fall through if the literal cannot be successfully rewritten, or if 1487 -- the small ratio is out of range of integer arithmetic. In the former 1488 -- case it is fine to use floating-point to get the close result set, 1489 -- and in the latter case, it means that the result is zero or raises 1490 -- constraint error, and we can do that accurately in floating-point. 1491 1492 -- If we end up using floating-point, then we take the right integer 1493 -- to be one, and its small to be the value of the original right real 1494 -- literal. That way, we need only one floating-point multiplication. 1495 1496 Set_Result (N, 1497 Build_Multiply (N, Fpt_Value (Left), Real_Literal (N, Frac))); 1498 end Do_Multiply_Fixed_Universal; 1499 1500 --------------------------------- 1501 -- Expand_Convert_Fixed_Static -- 1502 --------------------------------- 1503 1504 procedure Expand_Convert_Fixed_Static (N : Node_Id) is 1505 begin 1506 Rewrite (N, 1507 Convert_To (Etype (N), 1508 Make_Real_Literal (Sloc (N), Expr_Value_R (Expression (N))))); 1509 Analyze_And_Resolve (N); 1510 end Expand_Convert_Fixed_Static; 1511 1512 ----------------------------------- 1513 -- Expand_Convert_Fixed_To_Fixed -- 1514 ----------------------------------- 1515 1516 -- We have: 1517 1518 -- Result_Value * Result_Small = Source_Value * Source_Small 1519 -- Result_Value = Source_Value * (Source_Small / Result_Small) 1520 1521 -- If the small ratio (Source_Small / Result_Small) is a sufficiently small 1522 -- integer, then the perfect result set is obtained by a single integer 1523 -- multiplication. 1524 1525 -- If the small ratio is the reciprocal of a sufficiently small integer, 1526 -- then the perfect result set is obtained by a single integer division. 1527 1528 -- In other cases, we obtain the close result set by calculating the 1529 -- result in floating-point. 1530 1531 procedure Expand_Convert_Fixed_To_Fixed (N : Node_Id) is 1532 Rng_Check : constant Boolean := Do_Range_Check (N); 1533 Expr : constant Node_Id := Expression (N); 1534 Result_Type : constant Entity_Id := Etype (N); 1535 Source_Type : constant Entity_Id := Etype (Expr); 1536 Small_Ratio : Ureal; 1537 Ratio_Num : Uint; 1538 Ratio_Den : Uint; 1539 Lit : Node_Id; 1540 1541 begin 1542 if Is_OK_Static_Expression (Expr) then 1543 Expand_Convert_Fixed_Static (N); 1544 return; 1545 end if; 1546 1547 Small_Ratio := Small_Value (Source_Type) / Small_Value (Result_Type); 1548 Ratio_Num := Norm_Num (Small_Ratio); 1549 Ratio_Den := Norm_Den (Small_Ratio); 1550 1551 if Ratio_Den = 1 then 1552 if Ratio_Num = 1 then 1553 Set_Result (N, Expr); 1554 return; 1555 1556 else 1557 Lit := Integer_Literal (N, Ratio_Num); 1558 1559 if Present (Lit) then 1560 Set_Result (N, Build_Multiply (N, Expr, Lit)); 1561 return; 1562 end if; 1563 end if; 1564 1565 elsif Ratio_Num = 1 then 1566 Lit := Integer_Literal (N, Ratio_Den); 1567 1568 if Present (Lit) then 1569 Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); 1570 return; 1571 end if; 1572 end if; 1573 1574 -- Fall through to use floating-point for the close result set case 1575 -- either as a result of the small ratio not being an integer or the 1576 -- reciprocal of an integer, or if the integer is out of range. 1577 1578 Set_Result (N, 1579 Build_Multiply (N, 1580 Fpt_Value (Expr), 1581 Real_Literal (N, Small_Ratio)), 1582 Rng_Check); 1583 end Expand_Convert_Fixed_To_Fixed; 1584 1585 ----------------------------------- 1586 -- Expand_Convert_Fixed_To_Float -- 1587 ----------------------------------- 1588 1589 -- If the small of the fixed type is 1.0, then we simply convert the 1590 -- integer value directly to the target floating-point type, otherwise 1591 -- we first have to multiply by the small, in Universal_Real, and then 1592 -- convert the result to the target floating-point type. 1593 1594 procedure Expand_Convert_Fixed_To_Float (N : Node_Id) is 1595 Rng_Check : constant Boolean := Do_Range_Check (N); 1596 Expr : constant Node_Id := Expression (N); 1597 Source_Type : constant Entity_Id := Etype (Expr); 1598 Small : constant Ureal := Small_Value (Source_Type); 1599 1600 begin 1601 if Is_OK_Static_Expression (Expr) then 1602 Expand_Convert_Fixed_Static (N); 1603 return; 1604 end if; 1605 1606 if Small = Ureal_1 then 1607 Set_Result (N, Expr); 1608 1609 else 1610 Set_Result (N, 1611 Build_Multiply (N, 1612 Fpt_Value (Expr), 1613 Real_Literal (N, Small)), 1614 Rng_Check); 1615 end if; 1616 end Expand_Convert_Fixed_To_Float; 1617 1618 ------------------------------------- 1619 -- Expand_Convert_Fixed_To_Integer -- 1620 ------------------------------------- 1621 1622 -- We have: 1623 1624 -- Result_Value = Source_Value * Source_Small 1625 1626 -- If the small value is a sufficiently small integer, then the perfect 1627 -- result set is obtained by a single integer multiplication. 1628 1629 -- If the small value is the reciprocal of a sufficiently small integer, 1630 -- then the perfect result set is obtained by a single integer division. 1631 1632 -- In other cases, we obtain the close result set by calculating the 1633 -- result in floating-point. 1634 1635 procedure Expand_Convert_Fixed_To_Integer (N : Node_Id) is 1636 Rng_Check : constant Boolean := Do_Range_Check (N); 1637 Expr : constant Node_Id := Expression (N); 1638 Source_Type : constant Entity_Id := Etype (Expr); 1639 Small : constant Ureal := Small_Value (Source_Type); 1640 Small_Num : constant Uint := Norm_Num (Small); 1641 Small_Den : constant Uint := Norm_Den (Small); 1642 Lit : Node_Id; 1643 1644 begin 1645 if Is_OK_Static_Expression (Expr) then 1646 Expand_Convert_Fixed_Static (N); 1647 return; 1648 end if; 1649 1650 if Small_Den = 1 then 1651 Lit := Integer_Literal (N, Small_Num); 1652 1653 if Present (Lit) then 1654 Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check); 1655 return; 1656 end if; 1657 1658 elsif Small_Num = 1 then 1659 Lit := Integer_Literal (N, Small_Den); 1660 1661 if Present (Lit) then 1662 Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); 1663 return; 1664 end if; 1665 end if; 1666 1667 -- Fall through to use floating-point for the close result set case 1668 -- either as a result of the small value not being an integer or the 1669 -- reciprocal of an integer, or if the integer is out of range. 1670 1671 Set_Result (N, 1672 Build_Multiply (N, 1673 Fpt_Value (Expr), 1674 Real_Literal (N, Small)), 1675 Rng_Check); 1676 end Expand_Convert_Fixed_To_Integer; 1677 1678 ----------------------------------- 1679 -- Expand_Convert_Float_To_Fixed -- 1680 ----------------------------------- 1681 1682 -- We have 1683 1684 -- Result_Value * Result_Small = Operand_Value 1685 1686 -- so compute: 1687 1688 -- Result_Value = Operand_Value * (1.0 / Result_Small) 1689 1690 -- We do the small scaling in floating-point, and we do a multiplication 1691 -- rather than a division, since it is accurate enough for the perfect 1692 -- result cases, and faster. 1693 1694 procedure Expand_Convert_Float_To_Fixed (N : Node_Id) is 1695 Expr : constant Node_Id := Expression (N); 1696 Orig_N : constant Node_Id := Original_Node (N); 1697 Result_Type : constant Entity_Id := Etype (N); 1698 Rng_Check : constant Boolean := Do_Range_Check (N); 1699 Small : constant Ureal := Small_Value (Result_Type); 1700 Truncate : Boolean; 1701 1702 begin 1703 -- Optimize small = 1, where we can avoid the multiply completely 1704 1705 if Small = Ureal_1 then 1706 Set_Result (N, Expr, Rng_Check, Trunc => True); 1707 1708 -- Normal case where multiply is required. Rounding is truncating 1709 -- for decimal fixed point types only, see RM 4.6(29), except if the 1710 -- conversion comes from an attribute reference 'Round (RM 3.5.10 (14)): 1711 -- The attribute is implemented by means of a conversion that must 1712 -- round. 1713 1714 else 1715 if Is_Decimal_Fixed_Point_Type (Result_Type) then 1716 Truncate := 1717 Nkind (Orig_N) /= N_Attribute_Reference 1718 or else Get_Attribute_Id 1719 (Attribute_Name (Orig_N)) /= Attribute_Round; 1720 else 1721 Truncate := False; 1722 end if; 1723 1724 Set_Result 1725 (N => N, 1726 Expr => 1727 Build_Multiply 1728 (N => N, 1729 L => Fpt_Value (Expr), 1730 R => Real_Literal (N, Ureal_1 / Small)), 1731 Rchk => Rng_Check, 1732 Trunc => Truncate); 1733 end if; 1734 end Expand_Convert_Float_To_Fixed; 1735 1736 ------------------------------------- 1737 -- Expand_Convert_Integer_To_Fixed -- 1738 ------------------------------------- 1739 1740 -- We have 1741 1742 -- Result_Value * Result_Small = Operand_Value 1743 -- Result_Value = Operand_Value / Result_Small 1744 1745 -- If the small value is a sufficiently small integer, then the perfect 1746 -- result set is obtained by a single integer division. 1747 1748 -- If the small value is the reciprocal of a sufficiently small integer, 1749 -- the perfect result set is obtained by a single integer multiplication. 1750 1751 -- In other cases, we obtain the close result set by calculating the 1752 -- result in floating-point using a multiplication by the reciprocal 1753 -- of the Result_Small. 1754 1755 procedure Expand_Convert_Integer_To_Fixed (N : Node_Id) is 1756 Rng_Check : constant Boolean := Do_Range_Check (N); 1757 Expr : constant Node_Id := Expression (N); 1758 Result_Type : constant Entity_Id := Etype (N); 1759 Small : constant Ureal := Small_Value (Result_Type); 1760 Small_Num : constant Uint := Norm_Num (Small); 1761 Small_Den : constant Uint := Norm_Den (Small); 1762 Lit : Node_Id; 1763 1764 begin 1765 if Small_Den = 1 then 1766 Lit := Integer_Literal (N, Small_Num); 1767 1768 if Present (Lit) then 1769 Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); 1770 return; 1771 end if; 1772 1773 elsif Small_Num = 1 then 1774 Lit := Integer_Literal (N, Small_Den); 1775 1776 if Present (Lit) then 1777 Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check); 1778 return; 1779 end if; 1780 end if; 1781 1782 -- Fall through to use floating-point for the close result set case 1783 -- either as a result of the small value not being an integer or the 1784 -- reciprocal of an integer, or if the integer is out of range. 1785 1786 Set_Result (N, 1787 Build_Multiply (N, 1788 Fpt_Value (Expr), 1789 Real_Literal (N, Ureal_1 / Small)), 1790 Rng_Check); 1791 end Expand_Convert_Integer_To_Fixed; 1792 1793 -------------------------------- 1794 -- Expand_Decimal_Divide_Call -- 1795 -------------------------------- 1796 1797 -- We have four operands 1798 1799 -- Dividend 1800 -- Divisor 1801 -- Quotient 1802 -- Remainder 1803 1804 -- All of which are decimal types, and which thus have associated 1805 -- decimal scales. 1806 1807 -- Computing the quotient is a similar problem to that faced by the 1808 -- normal fixed-point division, except that it is simpler, because 1809 -- we always have compatible smalls. 1810 1811 -- Quotient = (Dividend / Divisor) * 10**q 1812 1813 -- where 10 ** q = Dividend'Small / (Divisor'Small * Quotient'Small) 1814 -- so q = Divisor'Scale + Quotient'Scale - Dividend'Scale 1815 1816 -- For q >= 0, we compute 1817 1818 -- Numerator := Dividend * 10 ** q 1819 -- Denominator := Divisor 1820 -- Quotient := Numerator / Denominator 1821 1822 -- For q < 0, we compute 1823 1824 -- Numerator := Dividend 1825 -- Denominator := Divisor * 10 ** q 1826 -- Quotient := Numerator / Denominator 1827 1828 -- Both these divisions are done in truncated mode, and the remainder 1829 -- from these divisions is used to compute the result Remainder. This 1830 -- remainder has the effective scale of the numerator of the division, 1831 1832 -- For q >= 0, the remainder scale is Dividend'Scale + q 1833 -- For q < 0, the remainder scale is Dividend'Scale 1834 1835 -- The result Remainder is then computed by a normal truncating decimal 1836 -- conversion from this scale to the scale of the remainder, i.e. by a 1837 -- division or multiplication by the appropriate power of 10. 1838 1839 procedure Expand_Decimal_Divide_Call (N : Node_Id) is 1840 Loc : constant Source_Ptr := Sloc (N); 1841 1842 Dividend : Node_Id := First_Actual (N); 1843 Divisor : Node_Id := Next_Actual (Dividend); 1844 Quotient : Node_Id := Next_Actual (Divisor); 1845 Remainder : Node_Id := Next_Actual (Quotient); 1846 1847 Dividend_Type : constant Entity_Id := Etype (Dividend); 1848 Divisor_Type : constant Entity_Id := Etype (Divisor); 1849 Quotient_Type : constant Entity_Id := Etype (Quotient); 1850 Remainder_Type : constant Entity_Id := Etype (Remainder); 1851 1852 Dividend_Scale : constant Uint := Scale_Value (Dividend_Type); 1853 Divisor_Scale : constant Uint := Scale_Value (Divisor_Type); 1854 Quotient_Scale : constant Uint := Scale_Value (Quotient_Type); 1855 Remainder_Scale : constant Uint := Scale_Value (Remainder_Type); 1856 1857 Q : Uint; 1858 Numerator_Scale : Uint; 1859 Stmts : List_Id; 1860 Qnn : Entity_Id; 1861 Rnn : Entity_Id; 1862 Computed_Remainder : Node_Id; 1863 Adjusted_Remainder : Node_Id; 1864 Scale_Adjust : Uint; 1865 1866 begin 1867 -- Relocate the operands, since they are now list elements, and we 1868 -- need to reference them separately as operands in the expanded code. 1869 1870 Dividend := Relocate_Node (Dividend); 1871 Divisor := Relocate_Node (Divisor); 1872 Quotient := Relocate_Node (Quotient); 1873 Remainder := Relocate_Node (Remainder); 1874 1875 -- Now compute Q, the adjustment scale 1876 1877 Q := Divisor_Scale + Quotient_Scale - Dividend_Scale; 1878 1879 -- If Q is non-negative then we need a scaled divide 1880 1881 if Q >= 0 then 1882 Build_Scaled_Divide_Code 1883 (N, 1884 Dividend, 1885 Integer_Literal (N, Uint_10 ** Q), 1886 Divisor, 1887 Qnn, Rnn, Stmts); 1888 1889 Numerator_Scale := Dividend_Scale + Q; 1890 1891 -- If Q is negative, then we need a double divide 1892 1893 else 1894 Build_Double_Divide_Code 1895 (N, 1896 Dividend, 1897 Divisor, 1898 Integer_Literal (N, Uint_10 ** (-Q)), 1899 Qnn, Rnn, Stmts); 1900 1901 Numerator_Scale := Dividend_Scale; 1902 end if; 1903 1904 -- Add statement to set quotient value 1905 1906 -- Quotient := quotient-type!(Qnn); 1907 1908 Append_To (Stmts, 1909 Make_Assignment_Statement (Loc, 1910 Name => Quotient, 1911 Expression => 1912 Unchecked_Convert_To (Quotient_Type, 1913 Build_Conversion (N, Quotient_Type, 1914 New_Occurrence_Of (Qnn, Loc))))); 1915 1916 -- Now we need to deal with computing and setting the remainder. The 1917 -- scale of the remainder is in Numerator_Scale, and the desired 1918 -- scale is the scale of the given Remainder argument. There are 1919 -- three cases: 1920 1921 -- Numerator_Scale > Remainder_Scale 1922 1923 -- in this case, there are extra digits in the computed remainder 1924 -- which must be eliminated by an extra division: 1925 1926 -- computed-remainder := Numerator rem Denominator 1927 -- scale_adjust = Numerator_Scale - Remainder_Scale 1928 -- adjusted-remainder := computed-remainder / 10 ** scale_adjust 1929 1930 -- Numerator_Scale = Remainder_Scale 1931 1932 -- in this case, the we have the remainder we need 1933 1934 -- computed-remainder := Numerator rem Denominator 1935 -- adjusted-remainder := computed-remainder 1936 1937 -- Numerator_Scale < Remainder_Scale 1938 1939 -- in this case, we have insufficient digits in the computed 1940 -- remainder, which must be eliminated by an extra multiply 1941 1942 -- computed-remainder := Numerator rem Denominator 1943 -- scale_adjust = Remainder_Scale - Numerator_Scale 1944 -- adjusted-remainder := computed-remainder * 10 ** scale_adjust 1945 1946 -- Finally we assign the adjusted-remainder to the result Remainder 1947 -- with conversions to get the proper fixed-point type representation. 1948 1949 Computed_Remainder := New_Occurrence_Of (Rnn, Loc); 1950 1951 if Numerator_Scale > Remainder_Scale then 1952 Scale_Adjust := Numerator_Scale - Remainder_Scale; 1953 Adjusted_Remainder := 1954 Build_Divide 1955 (N, Computed_Remainder, Integer_Literal (N, 10 ** Scale_Adjust)); 1956 1957 elsif Numerator_Scale = Remainder_Scale then 1958 Adjusted_Remainder := Computed_Remainder; 1959 1960 else -- Numerator_Scale < Remainder_Scale 1961 Scale_Adjust := Remainder_Scale - Numerator_Scale; 1962 Adjusted_Remainder := 1963 Build_Multiply 1964 (N, Computed_Remainder, Integer_Literal (N, 10 ** Scale_Adjust)); 1965 end if; 1966 1967 -- Assignment of remainder result 1968 1969 Append_To (Stmts, 1970 Make_Assignment_Statement (Loc, 1971 Name => Remainder, 1972 Expression => 1973 Unchecked_Convert_To (Remainder_Type, Adjusted_Remainder))); 1974 1975 -- Final step is to rewrite the call with a block containing the 1976 -- above sequence of constructed statements for the divide operation. 1977 1978 Rewrite (N, 1979 Make_Block_Statement (Loc, 1980 Handled_Statement_Sequence => 1981 Make_Handled_Sequence_Of_Statements (Loc, 1982 Statements => Stmts))); 1983 1984 Analyze (N); 1985 end Expand_Decimal_Divide_Call; 1986 1987 ----------------------------------------------- 1988 -- Expand_Divide_Fixed_By_Fixed_Giving_Fixed -- 1989 ----------------------------------------------- 1990 1991 procedure Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N : Node_Id) is 1992 Left : constant Node_Id := Left_Opnd (N); 1993 Right : constant Node_Id := Right_Opnd (N); 1994 1995 begin 1996 -- Suppress expansion of a fixed-by-fixed division if the 1997 -- operation is supported directly by the target. 1998 1999 if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then 2000 return; 2001 end if; 2002 2003 if Etype (Left) = Universal_Real then 2004 Do_Divide_Universal_Fixed (N); 2005 2006 elsif Etype (Right) = Universal_Real then 2007 Do_Divide_Fixed_Universal (N); 2008 2009 else 2010 Do_Divide_Fixed_Fixed (N); 2011 2012 -- A focused optimization: if after constant folding the 2013 -- expression is of the form: T ((Exp * D) / D), where D is 2014 -- a static constant, return T (Exp). This form will show up 2015 -- when D is the denominator of the static expression for the 2016 -- 'small of fixed-point types involved. This transformation 2017 -- removes a division that may be expensive on some targets. 2018 2019 if Nkind (N) = N_Type_Conversion 2020 and then Nkind (Expression (N)) = N_Op_Divide 2021 then 2022 declare 2023 Num : constant Node_Id := Left_Opnd (Expression (N)); 2024 Den : constant Node_Id := Right_Opnd (Expression (N)); 2025 2026 begin 2027 if Nkind (Den) = N_Integer_Literal 2028 and then Nkind (Num) = N_Op_Multiply 2029 and then Nkind (Right_Opnd (Num)) = N_Integer_Literal 2030 and then Intval (Den) = Intval (Right_Opnd (Num)) 2031 then 2032 Rewrite (Expression (N), Left_Opnd (Num)); 2033 end if; 2034 end; 2035 end if; 2036 end if; 2037 end Expand_Divide_Fixed_By_Fixed_Giving_Fixed; 2038 2039 ----------------------------------------------- 2040 -- Expand_Divide_Fixed_By_Fixed_Giving_Float -- 2041 ----------------------------------------------- 2042 2043 -- The division is done in Universal_Real, and the result is multiplied 2044 -- by the small ratio, which is Small (Right) / Small (Left). Special 2045 -- treatment is required for universal operands, which represent their 2046 -- own value and do not require conversion. 2047 2048 procedure Expand_Divide_Fixed_By_Fixed_Giving_Float (N : Node_Id) is 2049 Left : constant Node_Id := Left_Opnd (N); 2050 Right : constant Node_Id := Right_Opnd (N); 2051 2052 Left_Type : constant Entity_Id := Etype (Left); 2053 Right_Type : constant Entity_Id := Etype (Right); 2054 2055 begin 2056 -- Case of left operand is universal real, the result we want is: 2057 2058 -- Left_Value / (Right_Value * Right_Small) 2059 2060 -- so we compute this as: 2061 2062 -- (Left_Value / Right_Small) / Right_Value 2063 2064 if Left_Type = Universal_Real then 2065 Set_Result (N, 2066 Build_Divide (N, 2067 Real_Literal (N, Realval (Left) / Small_Value (Right_Type)), 2068 Fpt_Value (Right))); 2069 2070 -- Case of right operand is universal real, the result we want is 2071 2072 -- (Left_Value * Left_Small) / Right_Value 2073 2074 -- so we compute this as: 2075 2076 -- Left_Value * (Left_Small / Right_Value) 2077 2078 -- Note we invert to a multiplication since usually floating-point 2079 -- multiplication is much faster than floating-point division. 2080 2081 elsif Right_Type = Universal_Real then 2082 Set_Result (N, 2083 Build_Multiply (N, 2084 Fpt_Value (Left), 2085 Real_Literal (N, Small_Value (Left_Type) / Realval (Right)))); 2086 2087 -- Both operands are fixed, so the value we want is 2088 2089 -- (Left_Value * Left_Small) / (Right_Value * Right_Small) 2090 2091 -- which we compute as: 2092 2093 -- (Left_Value / Right_Value) * (Left_Small / Right_Small) 2094 2095 else 2096 Set_Result (N, 2097 Build_Multiply (N, 2098 Build_Divide (N, Fpt_Value (Left), Fpt_Value (Right)), 2099 Real_Literal (N, 2100 Small_Value (Left_Type) / Small_Value (Right_Type)))); 2101 end if; 2102 end Expand_Divide_Fixed_By_Fixed_Giving_Float; 2103 2104 ------------------------------------------------- 2105 -- Expand_Divide_Fixed_By_Fixed_Giving_Integer -- 2106 ------------------------------------------------- 2107 2108 procedure Expand_Divide_Fixed_By_Fixed_Giving_Integer (N : Node_Id) is 2109 Left : constant Node_Id := Left_Opnd (N); 2110 Right : constant Node_Id := Right_Opnd (N); 2111 begin 2112 if Etype (Left) = Universal_Real then 2113 Do_Divide_Universal_Fixed (N); 2114 elsif Etype (Right) = Universal_Real then 2115 Do_Divide_Fixed_Universal (N); 2116 else 2117 Do_Divide_Fixed_Fixed (N); 2118 end if; 2119 end Expand_Divide_Fixed_By_Fixed_Giving_Integer; 2120 2121 ------------------------------------------------- 2122 -- Expand_Divide_Fixed_By_Integer_Giving_Fixed -- 2123 ------------------------------------------------- 2124 2125 -- Since the operand and result fixed-point type is the same, this is 2126 -- a straight divide by the right operand, the small can be ignored. 2127 2128 procedure Expand_Divide_Fixed_By_Integer_Giving_Fixed (N : Node_Id) is 2129 Left : constant Node_Id := Left_Opnd (N); 2130 Right : constant Node_Id := Right_Opnd (N); 2131 begin 2132 Set_Result (N, Build_Divide (N, Left, Right)); 2133 end Expand_Divide_Fixed_By_Integer_Giving_Fixed; 2134 2135 ------------------------------------------------- 2136 -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed -- 2137 ------------------------------------------------- 2138 2139 procedure Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N : Node_Id) is 2140 Left : constant Node_Id := Left_Opnd (N); 2141 Right : constant Node_Id := Right_Opnd (N); 2142 2143 procedure Rewrite_Non_Static_Universal (Opnd : Node_Id); 2144 -- The operand may be a non-static universal value, such an 2145 -- exponentiation with a non-static exponent. In that case, treat 2146 -- as a fixed * fixed multiplication, and convert the argument to 2147 -- the target fixed type. 2148 2149 ---------------------------------- 2150 -- Rewrite_Non_Static_Universal -- 2151 ---------------------------------- 2152 2153 procedure Rewrite_Non_Static_Universal (Opnd : Node_Id) is 2154 Loc : constant Source_Ptr := Sloc (N); 2155 begin 2156 Rewrite (Opnd, 2157 Make_Type_Conversion (Loc, 2158 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), 2159 Expression => Expression (Opnd))); 2160 Analyze_And_Resolve (Opnd, Etype (N)); 2161 end Rewrite_Non_Static_Universal; 2162 2163 -- Start of processing for Expand_Multiply_Fixed_By_Fixed_Giving_Fixed 2164 2165 begin 2166 -- Suppress expansion of a fixed-by-fixed multiplication if the 2167 -- operation is supported directly by the target. 2168 2169 if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then 2170 return; 2171 end if; 2172 2173 if Etype (Left) = Universal_Real then 2174 if Nkind (Left) = N_Real_Literal then 2175 Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left); 2176 2177 elsif Nkind (Left) = N_Type_Conversion then 2178 Rewrite_Non_Static_Universal (Left); 2179 Do_Multiply_Fixed_Fixed (N); 2180 end if; 2181 2182 elsif Etype (Right) = Universal_Real then 2183 if Nkind (Right) = N_Real_Literal then 2184 Do_Multiply_Fixed_Universal (N, Left, Right); 2185 2186 elsif Nkind (Right) = N_Type_Conversion then 2187 Rewrite_Non_Static_Universal (Right); 2188 Do_Multiply_Fixed_Fixed (N); 2189 end if; 2190 2191 else 2192 Do_Multiply_Fixed_Fixed (N); 2193 end if; 2194 end Expand_Multiply_Fixed_By_Fixed_Giving_Fixed; 2195 2196 ------------------------------------------------- 2197 -- Expand_Multiply_Fixed_By_Fixed_Giving_Float -- 2198 ------------------------------------------------- 2199 2200 -- The multiply is done in Universal_Real, and the result is multiplied 2201 -- by the adjustment for the smalls which is Small (Right) * Small (Left). 2202 -- Special treatment is required for universal operands. 2203 2204 procedure Expand_Multiply_Fixed_By_Fixed_Giving_Float (N : Node_Id) is 2205 Left : constant Node_Id := Left_Opnd (N); 2206 Right : constant Node_Id := Right_Opnd (N); 2207 2208 Left_Type : constant Entity_Id := Etype (Left); 2209 Right_Type : constant Entity_Id := Etype (Right); 2210 2211 begin 2212 -- Case of left operand is universal real, the result we want is 2213 2214 -- Left_Value * (Right_Value * Right_Small) 2215 2216 -- so we compute this as: 2217 2218 -- (Left_Value * Right_Small) * Right_Value; 2219 2220 if Left_Type = Universal_Real then 2221 Set_Result (N, 2222 Build_Multiply (N, 2223 Real_Literal (N, Realval (Left) * Small_Value (Right_Type)), 2224 Fpt_Value (Right))); 2225 2226 -- Case of right operand is universal real, the result we want is 2227 2228 -- (Left_Value * Left_Small) * Right_Value 2229 2230 -- so we compute this as: 2231 2232 -- Left_Value * (Left_Small * Right_Value) 2233 2234 elsif Right_Type = Universal_Real then 2235 Set_Result (N, 2236 Build_Multiply (N, 2237 Fpt_Value (Left), 2238 Real_Literal (N, Small_Value (Left_Type) * Realval (Right)))); 2239 2240 -- Both operands are fixed, so the value we want is 2241 2242 -- (Left_Value * Left_Small) * (Right_Value * Right_Small) 2243 2244 -- which we compute as: 2245 2246 -- (Left_Value * Right_Value) * (Right_Small * Left_Small) 2247 2248 else 2249 Set_Result (N, 2250 Build_Multiply (N, 2251 Build_Multiply (N, Fpt_Value (Left), Fpt_Value (Right)), 2252 Real_Literal (N, 2253 Small_Value (Right_Type) * Small_Value (Left_Type)))); 2254 end if; 2255 end Expand_Multiply_Fixed_By_Fixed_Giving_Float; 2256 2257 --------------------------------------------------- 2258 -- Expand_Multiply_Fixed_By_Fixed_Giving_Integer -- 2259 --------------------------------------------------- 2260 2261 procedure Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N : Node_Id) is 2262 Loc : constant Source_Ptr := Sloc (N); 2263 Left : constant Node_Id := Left_Opnd (N); 2264 Right : constant Node_Id := Right_Opnd (N); 2265 2266 begin 2267 if Etype (Left) = Universal_Real then 2268 Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left); 2269 2270 elsif Etype (Right) = Universal_Real then 2271 Do_Multiply_Fixed_Universal (N, Left, Right); 2272 2273 -- If both types are equal and we need to avoid floating point 2274 -- instructions, it's worth introducing a temporary with the 2275 -- common type, because it may be evaluated more simply without 2276 -- the need for run-time use of floating point. 2277 2278 elsif Etype (Right) = Etype (Left) 2279 and then Restriction_Active (No_Floating_Point) 2280 then 2281 declare 2282 Temp : constant Entity_Id := Make_Temporary (Loc, 'F'); 2283 Mult : constant Node_Id := Make_Op_Multiply (Loc, Left, Right); 2284 Decl : constant Node_Id := 2285 Make_Object_Declaration (Loc, 2286 Defining_Identifier => Temp, 2287 Object_Definition => New_Occurrence_Of (Etype (Right), Loc), 2288 Expression => Mult); 2289 2290 begin 2291 Insert_Action (N, Decl); 2292 Rewrite (N, 2293 OK_Convert_To (Etype (N), New_Occurrence_Of (Temp, Loc))); 2294 Analyze_And_Resolve (N, Standard_Integer); 2295 end; 2296 2297 else 2298 Do_Multiply_Fixed_Fixed (N); 2299 end if; 2300 end Expand_Multiply_Fixed_By_Fixed_Giving_Integer; 2301 2302 --------------------------------------------------- 2303 -- Expand_Multiply_Fixed_By_Integer_Giving_Fixed -- 2304 --------------------------------------------------- 2305 2306 -- Since the operand and result fixed-point type is the same, this is 2307 -- a straight multiply by the right operand, the small can be ignored. 2308 2309 procedure Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N : Node_Id) is 2310 begin 2311 Set_Result (N, 2312 Build_Multiply (N, Left_Opnd (N), Right_Opnd (N))); 2313 end Expand_Multiply_Fixed_By_Integer_Giving_Fixed; 2314 2315 --------------------------------------------------- 2316 -- Expand_Multiply_Integer_By_Fixed_Giving_Fixed -- 2317 --------------------------------------------------- 2318 2319 -- Since the operand and result fixed-point type is the same, this is 2320 -- a straight multiply by the right operand, the small can be ignored. 2321 2322 procedure Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N : Node_Id) is 2323 begin 2324 Set_Result (N, 2325 Build_Multiply (N, Left_Opnd (N), Right_Opnd (N))); 2326 end Expand_Multiply_Integer_By_Fixed_Giving_Fixed; 2327 2328 --------------- 2329 -- Fpt_Value -- 2330 --------------- 2331 2332 function Fpt_Value (N : Node_Id) return Node_Id is 2333 Typ : constant Entity_Id := Etype (N); 2334 2335 begin 2336 if Is_Integer_Type (Typ) 2337 or else Is_Floating_Point_Type (Typ) 2338 then 2339 return Build_Conversion (N, Universal_Real, N); 2340 2341 -- Fixed-point case, must get integer value first 2342 2343 else 2344 return Build_Conversion (N, Universal_Real, N); 2345 end if; 2346 end Fpt_Value; 2347 2348 --------------------- 2349 -- Integer_Literal -- 2350 --------------------- 2351 2352 function Integer_Literal 2353 (N : Node_Id; 2354 V : Uint; 2355 Negative : Boolean := False) return Node_Id 2356 is 2357 T : Entity_Id; 2358 L : Node_Id; 2359 2360 begin 2361 if V < Uint_2 ** 7 then 2362 T := Standard_Integer_8; 2363 2364 elsif V < Uint_2 ** 15 then 2365 T := Standard_Integer_16; 2366 2367 elsif V < Uint_2 ** 31 then 2368 T := Standard_Integer_32; 2369 2370 elsif V < Uint_2 ** 63 then 2371 T := Standard_Integer_64; 2372 2373 else 2374 return Empty; 2375 end if; 2376 2377 if Negative then 2378 L := Make_Integer_Literal (Sloc (N), UI_Negate (V)); 2379 else 2380 L := Make_Integer_Literal (Sloc (N), V); 2381 end if; 2382 2383 -- Set type of result in case used elsewhere (see note at start) 2384 2385 Set_Etype (L, T); 2386 Set_Is_Static_Expression (L); 2387 2388 -- We really need to set Analyzed here because we may be creating a 2389 -- very strange beast, namely an integer literal typed as fixed-point 2390 -- and the analyzer won't like that. Probably we should allow the 2391 -- Treat_Fixed_As_Integer flag to appear on integer literal nodes 2392 -- and teach the analyzer how to handle them ??? 2393 2394 Set_Analyzed (L); 2395 return L; 2396 end Integer_Literal; 2397 2398 ------------------ 2399 -- Real_Literal -- 2400 ------------------ 2401 2402 function Real_Literal (N : Node_Id; V : Ureal) return Node_Id is 2403 L : Node_Id; 2404 2405 begin 2406 L := Make_Real_Literal (Sloc (N), V); 2407 2408 -- Set type of result in case used elsewhere (see note at start) 2409 2410 Set_Etype (L, Universal_Real); 2411 return L; 2412 end Real_Literal; 2413 2414 ------------------------ 2415 -- Rounded_Result_Set -- 2416 ------------------------ 2417 2418 function Rounded_Result_Set (N : Node_Id) return Boolean is 2419 K : constant Node_Kind := Nkind (N); 2420 begin 2421 if (K = N_Type_Conversion or else 2422 K = N_Op_Divide or else 2423 K = N_Op_Multiply) 2424 and then 2425 (Rounded_Result (N) or else Is_Integer_Type (Etype (N))) 2426 then 2427 return True; 2428 else 2429 return False; 2430 end if; 2431 end Rounded_Result_Set; 2432 2433 ---------------- 2434 -- Set_Result -- 2435 ---------------- 2436 2437 procedure Set_Result 2438 (N : Node_Id; 2439 Expr : Node_Id; 2440 Rchk : Boolean := False; 2441 Trunc : Boolean := False) 2442 is 2443 Cnode : Node_Id; 2444 2445 Expr_Type : constant Entity_Id := Etype (Expr); 2446 Result_Type : constant Entity_Id := Etype (N); 2447 2448 begin 2449 -- No conversion required if types match and no range check or truncate 2450 2451 if Result_Type = Expr_Type and then not (Rchk or Trunc) then 2452 Cnode := Expr; 2453 2454 -- Else perform required conversion 2455 2456 else 2457 Cnode := Build_Conversion (N, Result_Type, Expr, Rchk, Trunc); 2458 end if; 2459 2460 Rewrite (N, Cnode); 2461 Analyze_And_Resolve (N, Result_Type); 2462 end Set_Result; 2463 2464end Exp_Fixd; 2465