]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ V F P T -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
b5c84c3c | 9 | -- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- |
70482933 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
70482933 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | with Atree; use Atree; | |
27 | with Einfo; use Einfo; | |
28 | with Nlists; use Nlists; | |
29 | with Nmake; use Nmake; | |
30 | with Rtsfind; use Rtsfind; | |
31 | with Sem_Res; use Sem_Res; | |
32 | with Sinfo; use Sinfo; | |
70482933 RK |
33 | with Stand; use Stand; |
34 | with Tbuild; use Tbuild; | |
35 | with Ttypef; use Ttypef; | |
36 | with Uintp; use Uintp; | |
37 | with Urealp; use Urealp; | |
38 | ||
39 | package body Exp_VFpt is | |
40 | ||
41 | ---------------------- | |
42 | -- Expand_Vax_Arith -- | |
43 | ---------------------- | |
44 | ||
45 | procedure Expand_Vax_Arith (N : Node_Id) is | |
46 | Loc : constant Source_Ptr := Sloc (N); | |
47 | Typ : constant Entity_Id := Base_Type (Etype (N)); | |
48 | Typc : Character; | |
49 | Atyp : Entity_Id; | |
50 | Func : RE_Id; | |
51 | Args : List_Id; | |
52 | ||
53 | begin | |
54 | -- Get arithmetic type, note that we do D stuff in G | |
55 | ||
56 | if Digits_Value (Typ) = VAXFF_Digits then | |
57 | Typc := 'F'; | |
58 | Atyp := RTE (RE_F); | |
59 | else | |
60 | Typc := 'G'; | |
61 | Atyp := RTE (RE_G); | |
62 | end if; | |
63 | ||
64 | case Nkind (N) is | |
65 | ||
66 | when N_Op_Abs => | |
67 | if Typc = 'F' then | |
68 | Func := RE_Abs_F; | |
69 | else | |
70 | Func := RE_Abs_G; | |
71 | end if; | |
72 | ||
73 | when N_Op_Add => | |
74 | if Typc = 'F' then | |
75 | Func := RE_Add_F; | |
76 | else | |
77 | Func := RE_Add_G; | |
78 | end if; | |
79 | ||
80 | when N_Op_Divide => | |
81 | if Typc = 'F' then | |
82 | Func := RE_Div_F; | |
83 | else | |
84 | Func := RE_Div_G; | |
85 | end if; | |
86 | ||
87 | when N_Op_Multiply => | |
88 | if Typc = 'F' then | |
89 | Func := RE_Mul_F; | |
90 | else | |
91 | Func := RE_Mul_G; | |
92 | end if; | |
93 | ||
94 | when N_Op_Minus => | |
95 | if Typc = 'F' then | |
96 | Func := RE_Neg_F; | |
97 | else | |
98 | Func := RE_Neg_G; | |
99 | end if; | |
100 | ||
101 | when N_Op_Subtract => | |
102 | if Typc = 'F' then | |
103 | Func := RE_Sub_F; | |
104 | else | |
105 | Func := RE_Sub_G; | |
106 | end if; | |
107 | ||
108 | when others => | |
109 | Func := RE_Null; | |
110 | raise Program_Error; | |
111 | ||
112 | end case; | |
113 | ||
114 | Args := New_List; | |
115 | ||
116 | if Nkind (N) in N_Binary_Op then | |
117 | Append_To (Args, | |
118 | Convert_To (Atyp, Left_Opnd (N))); | |
119 | end if; | |
120 | ||
121 | Append_To (Args, | |
122 | Convert_To (Atyp, Right_Opnd (N))); | |
123 | ||
124 | Rewrite (N, | |
125 | Convert_To (Typ, | |
126 | Make_Function_Call (Loc, | |
127 | Name => New_Occurrence_Of (RTE (Func), Loc), | |
128 | Parameter_Associations => Args))); | |
129 | ||
130 | Analyze_And_Resolve (N, Typ, Suppress => All_Checks); | |
131 | end Expand_Vax_Arith; | |
132 | ||
133 | --------------------------- | |
134 | -- Expand_Vax_Comparison -- | |
135 | --------------------------- | |
136 | ||
137 | procedure Expand_Vax_Comparison (N : Node_Id) is | |
138 | Loc : constant Source_Ptr := Sloc (N); | |
139 | Typ : constant Entity_Id := Base_Type (Etype (Left_Opnd (N))); | |
140 | Typc : Character; | |
141 | Func : RE_Id; | |
142 | Atyp : Entity_Id; | |
143 | Revrs : Boolean := False; | |
144 | Args : List_Id; | |
145 | ||
146 | begin | |
147 | -- Get arithmetic type, note that we do D stuff in G | |
148 | ||
149 | if Digits_Value (Typ) = VAXFF_Digits then | |
150 | Typc := 'F'; | |
151 | Atyp := RTE (RE_F); | |
152 | else | |
153 | Typc := 'G'; | |
154 | Atyp := RTE (RE_G); | |
155 | end if; | |
156 | ||
157 | case Nkind (N) is | |
158 | ||
159 | when N_Op_Eq => | |
160 | if Typc = 'F' then | |
161 | Func := RE_Eq_F; | |
162 | else | |
163 | Func := RE_Eq_G; | |
164 | end if; | |
165 | ||
166 | when N_Op_Ge => | |
167 | if Typc = 'F' then | |
168 | Func := RE_Le_F; | |
169 | else | |
170 | Func := RE_Le_G; | |
171 | end if; | |
172 | ||
173 | Revrs := True; | |
174 | ||
175 | when N_Op_Gt => | |
176 | if Typc = 'F' then | |
177 | Func := RE_Lt_F; | |
178 | else | |
179 | Func := RE_Lt_G; | |
180 | end if; | |
181 | ||
182 | Revrs := True; | |
183 | ||
184 | when N_Op_Le => | |
185 | if Typc = 'F' then | |
186 | Func := RE_Le_F; | |
187 | else | |
188 | Func := RE_Le_G; | |
189 | end if; | |
190 | ||
191 | when N_Op_Lt => | |
192 | if Typc = 'F' then | |
193 | Func := RE_Lt_F; | |
194 | else | |
195 | Func := RE_Lt_G; | |
196 | end if; | |
197 | ||
0d268911 RD |
198 | when N_Op_Ne => |
199 | if Typc = 'F' then | |
200 | Func := RE_Ne_F; | |
201 | else | |
202 | Func := RE_Ne_G; | |
203 | end if; | |
204 | ||
70482933 RK |
205 | when others => |
206 | Func := RE_Null; | |
207 | raise Program_Error; | |
208 | ||
209 | end case; | |
210 | ||
211 | if not Revrs then | |
212 | Args := New_List ( | |
213 | Convert_To (Atyp, Left_Opnd (N)), | |
214 | Convert_To (Atyp, Right_Opnd (N))); | |
215 | ||
216 | else | |
217 | Args := New_List ( | |
218 | Convert_To (Atyp, Right_Opnd (N)), | |
219 | Convert_To (Atyp, Left_Opnd (N))); | |
220 | end if; | |
221 | ||
222 | Rewrite (N, | |
223 | Make_Function_Call (Loc, | |
224 | Name => New_Occurrence_Of (RTE (Func), Loc), | |
225 | Parameter_Associations => Args)); | |
226 | ||
227 | Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); | |
228 | end Expand_Vax_Comparison; | |
229 | ||
230 | --------------------------- | |
231 | -- Expand_Vax_Conversion -- | |
232 | --------------------------- | |
233 | ||
234 | procedure Expand_Vax_Conversion (N : Node_Id) is | |
235 | Loc : constant Source_Ptr := Sloc (N); | |
236 | Expr : constant Node_Id := Expression (N); | |
237 | S_Typ : constant Entity_Id := Base_Type (Etype (Expr)); | |
238 | T_Typ : constant Entity_Id := Base_Type (Etype (N)); | |
239 | ||
240 | CallS : RE_Id; | |
241 | CallT : RE_Id; | |
242 | Func : RE_Id; | |
243 | ||
244 | function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id; | |
245 | -- Given one of the two types T, determines the coresponding call | |
246 | -- type, i.e. the type to be used for the call (or the result of | |
247 | -- the call). The actual operand is converted to (or from) this type. | |
248 | -- Otyp is the other type, which is useful in figuring out the result. | |
249 | -- The result returned is the RE_Id value for the type entity. | |
250 | ||
251 | function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id; | |
252 | -- Find the predefined integer type that has the same size as the | |
253 | -- fixed-point type T, for use in fixed/float conversions. | |
254 | ||
255 | --------------- | |
256 | -- Call_Type -- | |
257 | --------------- | |
258 | ||
259 | function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is | |
260 | begin | |
261 | -- Vax float formats | |
262 | ||
263 | if Vax_Float (T) then | |
264 | if Digits_Value (T) = VAXFF_Digits then | |
265 | return RE_F; | |
266 | ||
267 | elsif Digits_Value (T) = VAXGF_Digits then | |
268 | return RE_G; | |
269 | ||
270 | -- For D_Float, leave it as D float if the other operand is | |
271 | -- G_Float, since this is the one conversion that is properly | |
272 | -- supported for D_Float, but otherwise, use G_Float. | |
273 | ||
274 | else pragma Assert (Digits_Value (T) = VAXDF_Digits); | |
275 | ||
276 | if Vax_Float (Otyp) | |
277 | and then Digits_Value (Otyp) = VAXGF_Digits | |
278 | then | |
279 | return RE_D; | |
280 | else | |
281 | return RE_G; | |
282 | end if; | |
283 | end if; | |
284 | ||
285 | -- For all discrete types, use 64-bit integer | |
286 | ||
287 | elsif Is_Discrete_Type (T) then | |
288 | return RE_Q; | |
289 | ||
290 | -- For all real types (other than Vax float format), we use the | |
291 | -- IEEE float-type which corresponds in length to the other type | |
292 | -- (which is Vax Float). | |
293 | ||
294 | else pragma Assert (Is_Real_Type (T)); | |
295 | ||
296 | if Digits_Value (Otyp) = VAXFF_Digits then | |
297 | return RE_S; | |
298 | else | |
299 | return RE_T; | |
300 | end if; | |
301 | end if; | |
302 | end Call_Type; | |
303 | ||
0d268911 RD |
304 | ------------------------------------------------- |
305 | -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed -- | |
306 | ------------------------------------------------- | |
307 | ||
70482933 RK |
308 | function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is |
309 | begin | |
310 | if Esize (T) = Esize (Standard_Long_Long_Integer) then | |
311 | return Standard_Long_Long_Integer; | |
70482933 RK |
312 | elsif Esize (T) = Esize (Standard_Long_Integer) then |
313 | return Standard_Long_Integer; | |
70482933 RK |
314 | else |
315 | return Standard_Integer; | |
316 | end if; | |
317 | end Equivalent_Integer_Type; | |
318 | ||
70482933 RK |
319 | -- Start of processing for Expand_Vax_Conversion; |
320 | ||
321 | begin | |
322 | -- If input and output are the same Vax type, we change the | |
323 | -- conversion to be an unchecked conversion and that's it. | |
324 | ||
325 | if Vax_Float (S_Typ) and then Vax_Float (T_Typ) | |
326 | and then Digits_Value (S_Typ) = Digits_Value (T_Typ) | |
327 | then | |
328 | Rewrite (N, | |
329 | Unchecked_Convert_To (T_Typ, Expr)); | |
330 | ||
0d268911 RD |
331 | -- Case of conversion of fixed-point type to Vax_Float type |
332 | ||
70482933 RK |
333 | elsif Is_Fixed_Point_Type (S_Typ) then |
334 | ||
0d268911 RD |
335 | -- If Conversion_OK set, then we introduce an intermediate IEEE |
336 | -- target type since we are expecting the code generator to handle | |
337 | -- the case of integer to IEEE float. | |
70482933 | 338 | |
0d268911 RD |
339 | if Conversion_OK (N) then |
340 | Rewrite (N, | |
341 | Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr))); | |
342 | ||
343 | -- Otherwise, convert the scaled integer value to the target type, | |
344 | -- and multiply by 'Small of type. | |
345 | ||
346 | else | |
347 | Rewrite (N, | |
348 | Make_Op_Multiply (Loc, | |
349 | Left_Opnd => | |
350 | Make_Type_Conversion (Loc, | |
351 | Subtype_Mark => New_Occurrence_Of (T_Typ, Loc), | |
352 | Expression => | |
353 | Unchecked_Convert_To ( | |
354 | Equivalent_Integer_Type (S_Typ), Expr)), | |
355 | Right_Opnd => | |
356 | Make_Real_Literal (Loc, Realval => Small_Value (S_Typ)))); | |
357 | end if; | |
358 | ||
359 | -- Case of conversion of Vax_Float type to fixed-point type | |
70482933 RK |
360 | |
361 | elsif Is_Fixed_Point_Type (T_Typ) then | |
362 | ||
0d268911 RD |
363 | -- If Conversion_OK set, then we introduce an intermediate IEEE |
364 | -- target type, since we are expecting the code generator to handle | |
365 | -- the case of IEEE float to integer. | |
70482933 | 366 | |
0d268911 RD |
367 | if Conversion_OK (N) then |
368 | Rewrite (N, | |
369 | OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr))); | |
370 | ||
371 | -- Otherwise, multiply value by 'small of type, and convert to the | |
372 | -- corresponding integer type. | |
373 | ||
374 | else | |
375 | Rewrite (N, | |
376 | Unchecked_Convert_To (T_Typ, | |
377 | Make_Type_Conversion (Loc, | |
378 | Subtype_Mark => | |
379 | New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc), | |
380 | Expression => | |
381 | Make_Op_Multiply (Loc, | |
382 | Left_Opnd => Expr, | |
383 | Right_Opnd => | |
384 | Make_Real_Literal (Loc, | |
385 | Realval => Ureal_1 / Small_Value (T_Typ)))))); | |
386 | end if; | |
70482933 | 387 | |
0f716470 | 388 | -- All other cases |
70482933 RK |
389 | |
390 | else | |
391 | -- Compute types for call | |
392 | ||
393 | CallS := Call_Type (S_Typ, T_Typ); | |
394 | CallT := Call_Type (T_Typ, S_Typ); | |
395 | ||
396 | -- Get function and its types | |
397 | ||
398 | if CallS = RE_D and then CallT = RE_G then | |
399 | Func := RE_D_To_G; | |
400 | ||
401 | elsif CallS = RE_G and then CallT = RE_D then | |
402 | Func := RE_G_To_D; | |
403 | ||
404 | elsif CallS = RE_G and then CallT = RE_F then | |
405 | Func := RE_G_To_F; | |
406 | ||
407 | elsif CallS = RE_F and then CallT = RE_G then | |
408 | Func := RE_F_To_G; | |
409 | ||
410 | elsif CallS = RE_F and then CallT = RE_S then | |
411 | Func := RE_F_To_S; | |
412 | ||
413 | elsif CallS = RE_S and then CallT = RE_F then | |
414 | Func := RE_S_To_F; | |
415 | ||
416 | elsif CallS = RE_G and then CallT = RE_T then | |
417 | Func := RE_G_To_T; | |
418 | ||
419 | elsif CallS = RE_T and then CallT = RE_G then | |
420 | Func := RE_T_To_G; | |
421 | ||
422 | elsif CallS = RE_F and then CallT = RE_Q then | |
423 | Func := RE_F_To_Q; | |
424 | ||
425 | elsif CallS = RE_Q and then CallT = RE_F then | |
426 | Func := RE_Q_To_F; | |
427 | ||
428 | elsif CallS = RE_G and then CallT = RE_Q then | |
429 | Func := RE_G_To_Q; | |
430 | ||
431 | else pragma Assert (CallS = RE_Q and then CallT = RE_G); | |
432 | Func := RE_Q_To_G; | |
433 | end if; | |
434 | ||
435 | Rewrite (N, | |
436 | Convert_To (T_Typ, | |
437 | Make_Function_Call (Loc, | |
438 | Name => New_Occurrence_Of (RTE (Func), Loc), | |
439 | Parameter_Associations => New_List ( | |
440 | Convert_To (RTE (CallS), Expr))))); | |
441 | end if; | |
442 | ||
443 | Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks); | |
444 | end Expand_Vax_Conversion; | |
445 | ||
446 | ----------------------------- | |
447 | -- Expand_Vax_Real_Literal -- | |
448 | ----------------------------- | |
449 | ||
450 | procedure Expand_Vax_Real_Literal (N : Node_Id) is | |
451 | Loc : constant Source_Ptr := Sloc (N); | |
452 | Typ : constant Entity_Id := Etype (N); | |
453 | Btyp : constant Entity_Id := Base_Type (Typ); | |
454 | Stat : constant Boolean := Is_Static_Expression (N); | |
455 | Nod : Node_Id; | |
456 | ||
457 | RE_Source : RE_Id; | |
458 | RE_Target : RE_Id; | |
459 | RE_Fncall : RE_Id; | |
460 | -- Entities for source, target and function call in conversion | |
461 | ||
462 | begin | |
463 | -- We do not know how to convert Vax format real literals, so what | |
464 | -- we do is to convert these to be IEEE literals, and introduce the | |
465 | -- necessary conversion operation. | |
466 | ||
467 | if Vax_Float (Btyp) then | |
468 | -- What we want to construct here is | |
469 | ||
470 | -- x!(y_to_z (1.0E0)) | |
471 | ||
472 | -- where | |
473 | ||
474 | -- x is the base type of the literal (Btyp) | |
475 | ||
476 | -- y_to_z is | |
477 | ||
478 | -- s_to_f for F_Float | |
479 | -- t_to_g for G_Float | |
480 | -- t_to_d for D_Float | |
481 | ||
482 | -- The literal is typed as S (for F_Float) or T otherwise | |
483 | ||
484 | -- We do all our own construction, analysis, and expansion here, | |
485 | -- since things are at too low a level to use Analyze or Expand | |
486 | -- to get this built (we get circularities and other strange | |
487 | -- problems if we try!) | |
488 | ||
489 | if Digits_Value (Btyp) = VAXFF_Digits then | |
490 | RE_Source := RE_S; | |
491 | RE_Target := RE_F; | |
492 | RE_Fncall := RE_S_To_F; | |
493 | ||
494 | elsif Digits_Value (Btyp) = VAXDF_Digits then | |
495 | RE_Source := RE_T; | |
496 | RE_Target := RE_D; | |
497 | RE_Fncall := RE_T_To_D; | |
498 | ||
499 | else pragma Assert (Digits_Value (Btyp) = VAXGF_Digits); | |
500 | RE_Source := RE_T; | |
501 | RE_Target := RE_G; | |
502 | RE_Fncall := RE_T_To_G; | |
503 | end if; | |
504 | ||
505 | Nod := Relocate_Node (N); | |
506 | ||
507 | Set_Etype (Nod, RTE (RE_Source)); | |
508 | Set_Analyzed (Nod, True); | |
509 | ||
510 | Nod := | |
511 | Make_Function_Call (Loc, | |
512 | Name => New_Occurrence_Of (RTE (RE_Fncall), Loc), | |
513 | Parameter_Associations => New_List (Nod)); | |
514 | ||
515 | Set_Etype (Nod, RTE (RE_Target)); | |
516 | Set_Analyzed (Nod, True); | |
517 | ||
518 | Nod := | |
519 | Make_Unchecked_Type_Conversion (Loc, | |
520 | Subtype_Mark => New_Occurrence_Of (Typ, Loc), | |
521 | Expression => Nod); | |
522 | ||
523 | Set_Etype (Nod, Typ); | |
524 | Set_Analyzed (Nod, True); | |
525 | Rewrite (N, Nod); | |
526 | ||
527 | -- This odd expression is still a static expression. Note that | |
528 | -- the routine Sem_Eval.Expr_Value_R understands this. | |
529 | ||
530 | Set_Is_Static_Expression (N, Stat); | |
531 | end if; | |
532 | end Expand_Vax_Real_Literal; | |
533 | ||
0f716470 RD |
534 | ---------------------- |
535 | -- Expand_Vax_Valid -- | |
536 | ---------------------- | |
537 | ||
538 | procedure Expand_Vax_Valid (N : Node_Id) is | |
539 | Loc : constant Source_Ptr := Sloc (N); | |
540 | Pref : constant Node_Id := Prefix (N); | |
541 | Ptyp : constant Entity_Id := Root_Type (Etype (Pref)); | |
542 | Rtyp : constant Entity_Id := Etype (N); | |
543 | Vtyp : RE_Id; | |
544 | Func : RE_Id; | |
545 | ||
546 | begin | |
547 | if Digits_Value (Ptyp) = VAXFF_Digits then | |
548 | Func := RE_Valid_F; | |
549 | Vtyp := RE_F; | |
550 | elsif Digits_Value (Ptyp) = VAXDF_Digits then | |
551 | Func := RE_Valid_D; | |
552 | Vtyp := RE_D; | |
553 | else pragma Assert (Digits_Value (Ptyp) = VAXGF_Digits); | |
554 | Func := RE_Valid_G; | |
555 | Vtyp := RE_G; | |
556 | end if; | |
557 | ||
558 | Rewrite (N, | |
559 | Convert_To (Rtyp, | |
560 | Make_Function_Call (Loc, | |
561 | Name => New_Occurrence_Of (RTE (Func), Loc), | |
562 | Parameter_Associations => New_List ( | |
563 | Convert_To (RTE (Vtyp), Pref))))); | |
564 | ||
565 | Analyze_And_Resolve (N); | |
566 | end Expand_Vax_Valid; | |
567 | ||
70482933 | 568 | end Exp_VFpt; |