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