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