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