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