]>
Commit | Line | Data |
---|---|---|
752b81d9 AC |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E T _ T A R G -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
8d0d46f4 | 9 | -- Copyright (C) 2013-2021, Free Software Foundation, Inc. -- |
752b81d9 AC |
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 Debug; use Debug; | |
27 | with Get_Targ; use Get_Targ; | |
28 | with Opt; use Opt; | |
29 | with Output; use Output; | |
30 | ||
31 | with System; use System; | |
32 | with System.OS_Lib; use System.OS_Lib; | |
33 | ||
34 | with Unchecked_Conversion; | |
35 | ||
36 | package body Set_Targ is | |
37 | ||
340772c0 RD |
38 | -------------------------------------------------------- |
39 | -- Data Used to Read/Write Target Dependent Info File -- | |
40 | -------------------------------------------------------- | |
752b81d9 AC |
41 | |
42 | -- Table of string names written to file | |
43 | ||
44 | subtype Str is String; | |
45 | ||
46 | S_Bits_BE : constant Str := "Bits_BE"; | |
47 | S_Bits_Per_Unit : constant Str := "Bits_Per_Unit"; | |
48 | S_Bits_Per_Word : constant Str := "Bits_Per_Word"; | |
49 | S_Bytes_BE : constant Str := "Bytes_BE"; | |
50 | S_Char_Size : constant Str := "Char_Size"; | |
51 | S_Double_Float_Alignment : constant Str := "Double_Float_Alignment"; | |
52 | S_Double_Scalar_Alignment : constant Str := "Double_Scalar_Alignment"; | |
53 | S_Double_Size : constant Str := "Double_Size"; | |
54 | S_Float_Size : constant Str := "Float_Size"; | |
55 | S_Float_Words_BE : constant Str := "Float_Words_BE"; | |
56 | S_Int_Size : constant Str := "Int_Size"; | |
57 | S_Long_Double_Size : constant Str := "Long_Double_Size"; | |
a5476382 | 58 | S_Long_Long_Long_Size : constant Str := "Long_Long_Long_Size"; |
752b81d9 AC |
59 | S_Long_Long_Size : constant Str := "Long_Long_Size"; |
60 | S_Long_Size : constant Str := "Long_Size"; | |
61 | S_Maximum_Alignment : constant Str := "Maximum_Alignment"; | |
62 | S_Max_Unaligned_Field : constant Str := "Max_Unaligned_Field"; | |
63 | S_Pointer_Size : constant Str := "Pointer_Size"; | |
f27ad2b2 | 64 | S_Short_Enums : constant Str := "Short_Enums"; |
752b81d9 AC |
65 | S_Short_Size : constant Str := "Short_Size"; |
66 | S_Strict_Alignment : constant Str := "Strict_Alignment"; | |
67 | S_System_Allocator_Alignment : constant Str := "System_Allocator_Alignment"; | |
68 | S_Wchar_T_Size : constant Str := "Wchar_T_Size"; | |
69 | S_Words_BE : constant Str := "Words_BE"; | |
70 | ||
71 | -- Table of names | |
72 | ||
73 | type AStr is access all String; | |
74 | ||
75 | DTN : constant array (Nat range <>) of AStr := ( | |
76 | S_Bits_BE 'Unrestricted_Access, | |
77 | S_Bits_Per_Unit 'Unrestricted_Access, | |
78 | S_Bits_Per_Word 'Unrestricted_Access, | |
79 | S_Bytes_BE 'Unrestricted_Access, | |
80 | S_Char_Size 'Unrestricted_Access, | |
81 | S_Double_Float_Alignment 'Unrestricted_Access, | |
82 | S_Double_Scalar_Alignment 'Unrestricted_Access, | |
83 | S_Double_Size 'Unrestricted_Access, | |
84 | S_Float_Size 'Unrestricted_Access, | |
85 | S_Float_Words_BE 'Unrestricted_Access, | |
86 | S_Int_Size 'Unrestricted_Access, | |
87 | S_Long_Double_Size 'Unrestricted_Access, | |
a219511d | 88 | S_Long_Long_Long_Size 'Unrestricted_Access, |
752b81d9 AC |
89 | S_Long_Long_Size 'Unrestricted_Access, |
90 | S_Long_Size 'Unrestricted_Access, | |
91 | S_Maximum_Alignment 'Unrestricted_Access, | |
92 | S_Max_Unaligned_Field 'Unrestricted_Access, | |
93 | S_Pointer_Size 'Unrestricted_Access, | |
f27ad2b2 | 94 | S_Short_Enums 'Unrestricted_Access, |
752b81d9 AC |
95 | S_Short_Size 'Unrestricted_Access, |
96 | S_Strict_Alignment 'Unrestricted_Access, | |
97 | S_System_Allocator_Alignment 'Unrestricted_Access, | |
98 | S_Wchar_T_Size 'Unrestricted_Access, | |
99 | S_Words_BE 'Unrestricted_Access); | |
100 | ||
101 | -- Table of corresponding value pointers | |
102 | ||
103 | DTV : constant array (Nat range <>) of System.Address := ( | |
104 | Bits_BE 'Address, | |
105 | Bits_Per_Unit 'Address, | |
106 | Bits_Per_Word 'Address, | |
107 | Bytes_BE 'Address, | |
108 | Char_Size 'Address, | |
109 | Double_Float_Alignment 'Address, | |
110 | Double_Scalar_Alignment 'Address, | |
111 | Double_Size 'Address, | |
112 | Float_Size 'Address, | |
113 | Float_Words_BE 'Address, | |
114 | Int_Size 'Address, | |
115 | Long_Double_Size 'Address, | |
a5476382 | 116 | Long_Long_Long_Size 'Address, |
752b81d9 AC |
117 | Long_Long_Size 'Address, |
118 | Long_Size 'Address, | |
119 | Maximum_Alignment 'Address, | |
120 | Max_Unaligned_Field 'Address, | |
121 | Pointer_Size 'Address, | |
f27ad2b2 | 122 | Short_Enums 'Address, |
752b81d9 AC |
123 | Short_Size 'Address, |
124 | Strict_Alignment 'Address, | |
125 | System_Allocator_Alignment 'Address, | |
126 | Wchar_T_Size 'Address, | |
127 | Words_BE 'Address); | |
128 | ||
129 | DTR : array (Nat range DTV'Range) of Boolean := (others => False); | |
130 | -- Table of flags used to validate that all values are present in file | |
131 | ||
132 | ----------------------- | |
133 | -- Local Subprograms -- | |
134 | ----------------------- | |
135 | ||
1ebc2612 AC |
136 | procedure Read_Target_Dependent_Values (File_Name : String); |
137 | -- Read target dependent values from File_Name, and set the target | |
138 | -- dependent values (global variables) declared in this package. | |
139 | ||
752b81d9 AC |
140 | procedure Fail (E : String); |
141 | pragma No_Return (Fail); | |
142 | -- Terminate program with fatal error message passed as parameter | |
143 | ||
752b81d9 AC |
144 | procedure Register_Float_Type |
145 | (Name : C_String; | |
146 | Digs : Natural; | |
147 | Complex : Boolean; | |
148 | Count : Natural; | |
149 | Float_Rep : Float_Rep_Kind; | |
00c5acd3 | 150 | Precision : Positive; |
752b81d9 AC |
151 | Size : Positive; |
152 | Alignment : Natural); | |
153 | pragma Convention (C, Register_Float_Type); | |
154 | -- Call back to allow the back end to register available types. This call | |
155 | -- back makes entries in the FPT_Mode_Table for any floating point types | |
156 | -- reported by the back end. Name is the name of the type as a normal | |
157 | -- format Null-terminated string. Digs is the number of digits, where 0 | |
158 | -- means it is not a fpt type (ignored during registration). Complex is | |
159 | -- non-zero if the type has real and imaginary parts (also ignored during | |
160 | -- registration). Count is the number of elements in a vector type (zero = | |
161 | -- not a vector, registration ignores vectors). Float_Rep shows the kind of | |
00c5acd3 EB |
162 | -- floating-point type, and Precision, Size and Alignment are the precision |
163 | -- size and alignment in bits. | |
752b81d9 | 164 | -- |
72eaa365 AC |
165 | -- The only types that are actually registered have Digs non-zero, Complex |
166 | -- zero (false), and Count zero (not a vector). The Long_Double_Index | |
167 | -- variable below is updated to indicate the index at which a "long double" | |
168 | -- type can be found if it gets registered at all. | |
169 | ||
170 | Long_Double_Index : Integer := -1; | |
28fa5430 | 171 | -- Once all the floating point types have been registered, the index in |
72eaa365 AC |
172 | -- FPT_Mode_Table at which "long double" can be found, if anywhere. A |
173 | -- negative value means that no "long double" has been registered. This | |
174 | -- is useful to know whether we have a "long double" available at all and | |
175 | -- get at it's characteristics without having to search the FPT_Mode_Table | |
176 | -- when we need to decide which C type should be used as the basis for | |
177 | -- Long_Long_Float in Ada. | |
178 | ||
179 | function FPT_Mode_Index_For (Name : String) return Natural; | |
180 | -- Return the index in FPT_Mode_Table that designates the entry | |
181 | -- corresponding to the C type named Name. Raise Program_Error if | |
182 | -- there is no such entry. | |
183 | ||
184 | function FPT_Mode_Index_For (T : S_Float_Types) return Natural; | |
185 | -- Return the index in FPT_Mode_Table that designates the entry for | |
186 | -- a back-end type suitable as a basis to construct the standard Ada | |
187 | -- floating point type identified by T. | |
188 | ||
189 | ---------------- | |
190 | -- C_Type_For -- | |
191 | ---------------- | |
192 | ||
193 | function C_Type_For (T : S_Float_Types) return String is | |
194 | ||
195 | -- ??? For now, we don't have a good way to tell the widest float | |
196 | -- type with hardware support. Basically, GCC knows the size of that | |
197 | -- type, but on x86-64 there often are two or three 128-bit types, | |
198 | -- one double extended that has 18 decimal digits, a 128-bit quad | |
199 | -- precision type with 33 digits and possibly a 128-bit decimal float | |
200 | -- type with 34 digits. As a workaround, we define Long_Long_Float as | |
201 | -- C's "long double" if that type exists and has at most 18 digits, | |
202 | -- or otherwise the same as Long_Float. | |
203 | ||
204 | Max_HW_Digs : constant := 18; | |
205 | -- Maximum hardware digits supported | |
206 | ||
207 | begin | |
208 | case T is | |
d8f43ee6 HK |
209 | when S_Float |
210 | | S_Short_Float | |
211 | => | |
72eaa365 | 212 | return "float"; |
d8f43ee6 | 213 | |
72eaa365 AC |
214 | when S_Long_Float => |
215 | return "double"; | |
d8f43ee6 | 216 | |
72eaa365 AC |
217 | when S_Long_Long_Float => |
218 | if Long_Double_Index >= 0 | |
219 | and then FPT_Mode_Table (Long_Double_Index).DIGS <= Max_HW_Digs | |
220 | then | |
221 | return "long double"; | |
222 | else | |
223 | return "double"; | |
224 | end if; | |
225 | end case; | |
226 | end C_Type_For; | |
752b81d9 AC |
227 | |
228 | ---------- | |
229 | -- Fail -- | |
230 | ---------- | |
231 | ||
232 | procedure Fail (E : String) is | |
233 | E_Fatal : constant := 4; | |
234 | -- Code for fatal error | |
72eaa365 | 235 | |
752b81d9 AC |
236 | begin |
237 | Write_Str (E); | |
238 | Write_Eol; | |
239 | OS_Exit (E_Fatal); | |
240 | end Fail; | |
241 | ||
72eaa365 AC |
242 | ------------------------ |
243 | -- FPT_Mode_Index_For -- | |
244 | ------------------------ | |
245 | ||
246 | function FPT_Mode_Index_For (Name : String) return Natural is | |
247 | begin | |
248 | for J in FPT_Mode_Table'First .. Num_FPT_Modes loop | |
249 | if FPT_Mode_Table (J).NAME.all = Name then | |
250 | return J; | |
251 | end if; | |
252 | end loop; | |
253 | ||
254 | raise Program_Error; | |
255 | end FPT_Mode_Index_For; | |
256 | ||
257 | function FPT_Mode_Index_For (T : S_Float_Types) return Natural is | |
258 | begin | |
259 | return FPT_Mode_Index_For (C_Type_For (T)); | |
260 | end FPT_Mode_Index_For; | |
261 | ||
752b81d9 AC |
262 | ------------------------- |
263 | -- Register_Float_Type -- | |
264 | ------------------------- | |
265 | ||
266 | procedure Register_Float_Type | |
267 | (Name : C_String; | |
268 | Digs : Natural; | |
269 | Complex : Boolean; | |
270 | Count : Natural; | |
271 | Float_Rep : Float_Rep_Kind; | |
00c5acd3 | 272 | Precision : Positive; |
752b81d9 AC |
273 | Size : Positive; |
274 | Alignment : Natural) | |
275 | is | |
276 | T : String (1 .. Name'Length); | |
277 | Last : Natural := 0; | |
278 | ||
279 | procedure Dump; | |
280 | -- Dump information given by the back end for the type to register | |
281 | ||
282 | ---------- | |
283 | -- Dump -- | |
284 | ---------- | |
285 | ||
286 | procedure Dump is | |
287 | begin | |
288 | Write_Str ("type " & T (1 .. Last) & " is "); | |
289 | ||
290 | if Count > 0 then | |
291 | Write_Str ("array (1 .. "); | |
292 | Write_Int (Int (Count)); | |
293 | ||
294 | if Complex then | |
295 | Write_Str (", 1 .. 2"); | |
296 | end if; | |
297 | ||
298 | Write_Str (") of "); | |
299 | ||
300 | elsif Complex then | |
301 | Write_Str ("array (1 .. 2) of "); | |
302 | end if; | |
303 | ||
304 | if Digs > 0 then | |
305 | Write_Str ("digits "); | |
306 | Write_Int (Int (Digs)); | |
307 | Write_Line (";"); | |
308 | ||
309 | Write_Str ("pragma Float_Representation ("); | |
310 | ||
311 | case Float_Rep is | |
d8f43ee6 | 312 | when IEEE_Binary => Write_Str ("IEEE"); |
752b81d9 AC |
313 | end case; |
314 | ||
315 | Write_Line (", " & T (1 .. Last) & ");"); | |
316 | ||
317 | else | |
318 | Write_Str ("mod 2**"); | |
00c5acd3 | 319 | Write_Int (Int (Precision / Positive'Max (1, Count))); |
752b81d9 AC |
320 | Write_Line (";"); |
321 | end if; | |
322 | ||
00c5acd3 EB |
323 | if Precision = Size then |
324 | Write_Str ("for " & T (1 .. Last) & "'Size use "); | |
325 | Write_Int (Int (Size)); | |
326 | Write_Line (";"); | |
327 | ||
328 | else | |
329 | Write_Str ("for " & T (1 .. Last) & "'Value_Size use "); | |
330 | Write_Int (Int (Precision)); | |
331 | Write_Line (";"); | |
332 | ||
333 | Write_Str ("for " & T (1 .. Last) & "'Object_Size use "); | |
334 | Write_Int (Int (Size)); | |
335 | Write_Line (";"); | |
336 | end if; | |
752b81d9 AC |
337 | |
338 | Write_Str ("for " & T (1 .. Last) & "'Alignment use "); | |
339 | Write_Int (Int (Alignment / 8)); | |
340 | Write_Line (";"); | |
341 | Write_Eol; | |
342 | end Dump; | |
343 | ||
344 | -- Start of processing for Register_Float_Type | |
345 | ||
346 | begin | |
347 | -- Acquire name | |
348 | ||
349 | for J in T'Range loop | |
350 | T (J) := Name (Name'First + J - 1); | |
351 | ||
352 | if T (J) = ASCII.NUL then | |
353 | Last := J - 1; | |
354 | exit; | |
355 | end if; | |
356 | end loop; | |
357 | ||
358 | -- Dump info if debug flag set | |
359 | ||
360 | if Debug_Flag_Dot_B then | |
361 | Dump; | |
362 | end if; | |
363 | ||
364 | -- Acquire entry if non-vector non-complex fpt type (digits non-zero) | |
365 | ||
366 | if Digs > 0 and then not Complex and then Count = 0 then | |
72eaa365 AC |
367 | |
368 | declare | |
369 | This_Name : constant String := T (1 .. Last); | |
370 | begin | |
371 | Num_FPT_Modes := Num_FPT_Modes + 1; | |
372 | FPT_Mode_Table (Num_FPT_Modes) := | |
373 | (NAME => new String'(This_Name), | |
374 | DIGS => Digs, | |
375 | FLOAT_REP => Float_Rep, | |
376 | PRECISION => Precision, | |
377 | SIZE => Size, | |
378 | ALIGNMENT => Alignment); | |
379 | ||
380 | if Long_Double_Index < 0 and then This_Name = "long double" then | |
381 | Long_Double_Index := Num_FPT_Modes; | |
382 | end if; | |
383 | end; | |
752b81d9 AC |
384 | end if; |
385 | end Register_Float_Type; | |
386 | ||
387 | ----------------------------------- | |
388 | -- Write_Target_Dependent_Values -- | |
389 | ----------------------------------- | |
390 | ||
391 | -- We do this at the System.Os_Lib level, since we have to do the read at | |
392 | -- that level anyway, so it is easier and more consistent to follow the | |
393 | -- same path for the write. | |
394 | ||
395 | procedure Write_Target_Dependent_Values is | |
396 | Fdesc : File_Descriptor; | |
397 | OK : Boolean; | |
398 | ||
399 | Buffer : String (1 .. 80); | |
400 | Buflen : Natural; | |
401 | -- Buffer used to build line one of file | |
402 | ||
403 | type ANat is access all Natural; | |
404 | -- Pointer to Nat or Pos value (it is harmless to treat Pos values and | |
405 | -- Nat values as Natural via Unchecked_Conversion). | |
406 | ||
407 | function To_ANat is new Unchecked_Conversion (Address, ANat); | |
408 | ||
409 | procedure AddC (C : Character); | |
410 | -- Add one character to buffer | |
411 | ||
412 | procedure AddN (N : Natural); | |
413 | -- Add representation of integer N to Buffer, updating Buflen. N | |
414 | -- must be less than 1000, and output is 3 characters with leading | |
415 | -- spaces as needed. | |
416 | ||
417 | procedure Write_Line; | |
418 | -- Output contents of Buffer (1 .. Buflen) followed by a New_Line, | |
289a994b | 419 | -- and set Buflen back to zero, ready to write next line. |
752b81d9 AC |
420 | |
421 | ---------- | |
422 | -- AddC -- | |
423 | ---------- | |
424 | ||
425 | procedure AddC (C : Character) is | |
426 | begin | |
427 | Buflen := Buflen + 1; | |
428 | Buffer (Buflen) := C; | |
429 | end AddC; | |
430 | ||
431 | ---------- | |
432 | -- AddN -- | |
433 | ---------- | |
434 | ||
435 | procedure AddN (N : Natural) is | |
436 | begin | |
437 | if N > 999 then | |
438 | raise Program_Error; | |
439 | end if; | |
440 | ||
441 | if N > 99 then | |
442 | AddC (Character'Val (48 + N / 100)); | |
443 | else | |
444 | AddC (' '); | |
445 | end if; | |
446 | ||
447 | if N > 9 then | |
448 | AddC (Character'Val (48 + N / 10 mod 10)); | |
449 | else | |
450 | AddC (' '); | |
451 | end if; | |
452 | ||
453 | AddC (Character'Val (48 + N mod 10)); | |
454 | end AddN; | |
455 | ||
456 | ---------------- | |
457 | -- Write_Line -- | |
458 | ---------------- | |
459 | ||
460 | procedure Write_Line is | |
461 | begin | |
462 | AddC (ASCII.LF); | |
463 | ||
464 | if Buflen /= Write (Fdesc, Buffer'Address, Buflen) then | |
a9bbfbd0 | 465 | Delete_File (Target_Dependent_Info_Write_Name.all, OK); |
340772c0 RD |
466 | Fail ("disk full writing file " |
467 | & Target_Dependent_Info_Write_Name.all); | |
752b81d9 AC |
468 | end if; |
469 | ||
470 | Buflen := 0; | |
471 | end Write_Line; | |
472 | ||
473 | -- Start of processing for Write_Target_Dependent_Values | |
474 | ||
475 | begin | |
340772c0 | 476 | Fdesc := |
a9bbfbd0 | 477 | Create_File (Target_Dependent_Info_Write_Name.all, Text); |
752b81d9 AC |
478 | |
479 | if Fdesc = Invalid_FD then | |
340772c0 | 480 | Fail ("cannot create file " & Target_Dependent_Info_Write_Name.all); |
752b81d9 AC |
481 | end if; |
482 | ||
483 | -- Loop through values | |
484 | ||
485 | for J in DTN'Range loop | |
486 | ||
487 | -- Output name | |
488 | ||
489 | Buflen := DTN (J)'Length; | |
490 | Buffer (1 .. Buflen) := DTN (J).all; | |
491 | ||
492 | -- Line up values | |
493 | ||
494 | while Buflen < 26 loop | |
495 | AddC (' '); | |
496 | end loop; | |
497 | ||
498 | AddC (' '); | |
499 | AddC (' '); | |
500 | ||
501 | -- Output value and write line | |
502 | ||
503 | AddN (To_ANat (DTV (J)).all); | |
504 | Write_Line; | |
505 | end loop; | |
506 | ||
507 | -- Blank line to separate sections | |
508 | ||
509 | Write_Line; | |
510 | ||
511 | -- Write lines for registered FPT types | |
512 | ||
513 | for J in 1 .. Num_FPT_Modes loop | |
514 | declare | |
515 | E : FPT_Mode_Entry renames FPT_Mode_Table (J); | |
516 | begin | |
517 | Buflen := E.NAME'Last; | |
518 | Buffer (1 .. Buflen) := E.NAME.all; | |
519 | ||
520 | -- Pad out to line up values | |
521 | ||
522 | while Buflen < 11 loop | |
523 | AddC (' '); | |
524 | end loop; | |
525 | ||
526 | AddC (' '); | |
527 | AddC (' '); | |
528 | ||
529 | AddN (E.DIGS); | |
530 | AddC (' '); | |
531 | AddC (' '); | |
532 | ||
533 | case E.FLOAT_REP is | |
d8f43ee6 | 534 | when IEEE_Binary => AddC ('I'); |
752b81d9 AC |
535 | end case; |
536 | ||
537 | AddC (' '); | |
538 | ||
00c5acd3 | 539 | AddN (E.PRECISION); |
752b81d9 AC |
540 | AddC (' '); |
541 | ||
542 | AddN (E.ALIGNMENT); | |
543 | Write_Line; | |
544 | end; | |
545 | end loop; | |
546 | ||
547 | -- Close file | |
548 | ||
549 | Close (Fdesc, OK); | |
550 | ||
551 | if not OK then | |
340772c0 RD |
552 | Fail ("disk full writing file " |
553 | & Target_Dependent_Info_Write_Name.all); | |
752b81d9 AC |
554 | end if; |
555 | end Write_Target_Dependent_Values; | |
556 | ||
1ebc2612 AC |
557 | ---------------------------------- |
558 | -- Read_Target_Dependent_Values -- | |
559 | ---------------------------------- | |
560 | ||
561 | procedure Read_Target_Dependent_Values (File_Name : String) is | |
562 | File_Desc : File_Descriptor; | |
563 | N : Natural; | |
564 | ||
565 | type ANat is access all Natural; | |
566 | -- Pointer to Nat or Pos value (it is harmless to treat Pos values | |
567 | -- as Nat via Unchecked_Conversion). | |
568 | ||
569 | function To_ANat is new Unchecked_Conversion (Address, ANat); | |
570 | ||
571 | VP : ANat; | |
572 | ||
573 | Buffer : String (1 .. 2000); | |
574 | Buflen : Natural; | |
575 | -- File information and length (2000 easily enough) | |
576 | ||
577 | Nam_Buf : String (1 .. 40); | |
578 | Nam_Len : Natural; | |
579 | ||
580 | procedure Check_Spaces; | |
581 | -- Checks that we have one or more spaces and skips them | |
582 | ||
583 | procedure FailN (S : String); | |
dcd5fd67 | 584 | pragma No_Return (FailN); |
1ebc2612 AC |
585 | -- Calls Fail adding " name in file xxx", where name is the currently |
586 | -- gathered name in Nam_Buf, surrounded by quotes, and xxx is the | |
587 | -- name of the file. | |
588 | ||
589 | procedure Get_Name; | |
590 | -- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls | |
591 | -- Skip_Spaces to skip any following spaces. Note that the name is | |
592 | -- terminated by a sequence of at least two spaces. | |
593 | ||
594 | function Get_Nat return Natural; | |
595 | -- N on entry points to decimal integer, scan out decimal integer | |
596 | -- and return it, leaving N pointing to following space or LF. | |
597 | ||
598 | procedure Skip_Spaces; | |
599 | -- Skip past spaces | |
600 | ||
601 | ------------------ | |
602 | -- Check_Spaces -- | |
603 | ------------------ | |
604 | ||
605 | procedure Check_Spaces is | |
606 | begin | |
607 | if N > Buflen or else Buffer (N) /= ' ' then | |
608 | FailN ("missing space for"); | |
609 | end if; | |
610 | ||
611 | Skip_Spaces; | |
612 | return; | |
613 | end Check_Spaces; | |
614 | ||
615 | ----------- | |
616 | -- FailN -- | |
617 | ----------- | |
618 | ||
619 | procedure FailN (S : String) is | |
620 | begin | |
621 | Fail (S & " """ & Nam_Buf (1 .. Nam_Len) & """ in file " | |
622 | & File_Name); | |
623 | end FailN; | |
624 | ||
625 | -------------- | |
626 | -- Get_Name -- | |
627 | -------------- | |
628 | ||
629 | procedure Get_Name is | |
630 | begin | |
631 | Nam_Len := 0; | |
632 | ||
633 | -- Scan out name and put it in Nam_Buf | |
634 | ||
635 | loop | |
636 | if N > Buflen or else Buffer (N) = ASCII.LF then | |
637 | FailN ("incorrectly formatted line for"); | |
638 | end if; | |
639 | ||
640 | -- Name is terminated by two blanks | |
641 | ||
642 | exit when N < Buflen and then Buffer (N .. N + 1) = " "; | |
643 | ||
644 | Nam_Len := Nam_Len + 1; | |
645 | ||
646 | if Nam_Len > Nam_Buf'Last then | |
647 | Fail ("name too long"); | |
648 | end if; | |
649 | ||
650 | Nam_Buf (Nam_Len) := Buffer (N); | |
651 | N := N + 1; | |
652 | end loop; | |
653 | ||
654 | Check_Spaces; | |
655 | end Get_Name; | |
656 | ||
657 | ------------- | |
658 | -- Get_Nat -- | |
659 | ------------- | |
660 | ||
661 | function Get_Nat return Natural is | |
662 | Result : Natural := 0; | |
663 | ||
664 | begin | |
665 | loop | |
666 | if N > Buflen | |
667 | or else Buffer (N) not in '0' .. '9' | |
668 | or else Result > 999 | |
669 | then | |
670 | FailN ("bad value for"); | |
671 | end if; | |
672 | ||
673 | Result := Result * 10 + (Character'Pos (Buffer (N)) - 48); | |
674 | N := N + 1; | |
675 | ||
676 | exit when N <= Buflen | |
677 | and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' '); | |
678 | end loop; | |
679 | ||
680 | return Result; | |
681 | end Get_Nat; | |
682 | ||
683 | ----------------- | |
684 | -- Skip_Spaces -- | |
685 | ----------------- | |
686 | ||
687 | procedure Skip_Spaces is | |
688 | begin | |
689 | while N <= Buflen and Buffer (N) = ' ' loop | |
690 | N := N + 1; | |
691 | end loop; | |
692 | end Skip_Spaces; | |
693 | ||
694 | -- Start of processing for Read_Target_Dependent_Values | |
695 | ||
696 | begin | |
697 | File_Desc := Open_Read (File_Name, Text); | |
698 | ||
699 | if File_Desc = Invalid_FD then | |
700 | Fail ("cannot read file " & File_Name); | |
701 | end if; | |
702 | ||
703 | Buflen := Read (File_Desc, Buffer'Address, Buffer'Length); | |
704 | ||
e379beb5 AC |
705 | Close (File_Desc); |
706 | ||
1ebc2612 AC |
707 | if Buflen = Buffer'Length then |
708 | Fail ("file is too long: " & File_Name); | |
709 | end if; | |
710 | ||
711 | -- Scan through file for properly formatted entries in first section | |
712 | ||
713 | N := 1; | |
714 | while N <= Buflen and then Buffer (N) /= ASCII.LF loop | |
715 | Get_Name; | |
716 | ||
717 | -- Validate name and get corresponding value pointer | |
718 | ||
719 | VP := null; | |
720 | ||
721 | for J in DTN'Range loop | |
722 | if DTN (J).all = Nam_Buf (1 .. Nam_Len) then | |
723 | VP := To_ANat (DTV (J)); | |
724 | DTR (J) := True; | |
725 | exit; | |
726 | end if; | |
727 | end loop; | |
728 | ||
729 | if VP = null then | |
730 | FailN ("unrecognized name"); | |
731 | end if; | |
732 | ||
733 | -- Scan out value | |
734 | ||
735 | VP.all := Get_Nat; | |
736 | ||
737 | if N > Buflen or else Buffer (N) /= ASCII.LF then | |
738 | FailN ("misformatted line for"); | |
739 | end if; | |
740 | ||
741 | N := N + 1; -- skip LF | |
742 | end loop; | |
743 | ||
744 | -- Fall through this loop when all lines in first section read. | |
745 | -- Check that values have been supplied for all entries. | |
746 | ||
747 | for J in DTR'Range loop | |
748 | if not DTR (J) then | |
a219511d EB |
749 | -- Make an exception for Long_Long_Long_Size??? |
750 | ||
751 | if DTN (J) = S_Long_Long_Long_Size'Unrestricted_Access then | |
752 | Long_Long_Long_Size := Long_Long_Size; | |
753 | ||
754 | else | |
755 | Fail ("missing entry for " & DTN (J).all & " in file " | |
756 | & File_Name); | |
757 | end if; | |
1ebc2612 AC |
758 | end if; |
759 | end loop; | |
760 | ||
761 | -- Now acquire FPT entries | |
762 | ||
763 | if N >= Buflen then | |
764 | Fail ("missing entries for FPT modes in file " & File_Name); | |
765 | end if; | |
766 | ||
767 | if Buffer (N) = ASCII.LF then | |
768 | N := N + 1; | |
769 | else | |
770 | Fail ("missing blank line in file " & File_Name); | |
771 | end if; | |
772 | ||
773 | Num_FPT_Modes := 0; | |
774 | while N <= Buflen loop | |
775 | Get_Name; | |
776 | ||
777 | Num_FPT_Modes := Num_FPT_Modes + 1; | |
778 | ||
779 | declare | |
780 | E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes); | |
781 | ||
782 | begin | |
783 | E.NAME := new String'(Nam_Buf (1 .. Nam_Len)); | |
784 | ||
28fa5430 AC |
785 | if Long_Double_Index < 0 and then E.NAME.all = "long double" then |
786 | Long_Double_Index := Num_FPT_Modes; | |
787 | end if; | |
788 | ||
1ebc2612 AC |
789 | E.DIGS := Get_Nat; |
790 | Check_Spaces; | |
791 | ||
792 | case Buffer (N) is | |
793 | when 'I' => | |
794 | E.FLOAT_REP := IEEE_Binary; | |
d8f43ee6 | 795 | |
1ebc2612 AC |
796 | when others => |
797 | FailN ("bad float rep field for"); | |
798 | end case; | |
799 | ||
800 | N := N + 1; | |
801 | Check_Spaces; | |
802 | ||
803 | E.PRECISION := Get_Nat; | |
804 | Check_Spaces; | |
805 | ||
806 | E.ALIGNMENT := Get_Nat; | |
807 | ||
808 | if Buffer (N) /= ASCII.LF then | |
809 | FailN ("junk at end of line for"); | |
810 | end if; | |
811 | ||
812 | -- ??? We do not read E.SIZE, see Write_Target_Dependent_Values | |
813 | ||
814 | E.SIZE := | |
815 | (E.PRECISION + E.ALIGNMENT - 1) / E.ALIGNMENT * E.ALIGNMENT; | |
816 | ||
817 | N := N + 1; | |
818 | end; | |
819 | end loop; | |
820 | end Read_Target_Dependent_Values; | |
821 | ||
752b81d9 AC |
822 | -- Package Initialization, set target dependent values. This must be done |
823 | -- early on, before we start accessing various compiler packages, since | |
824 | -- these values are used all over the place. | |
825 | ||
826 | begin | |
827 | -- First step: see if the -gnateT switch is present. As we have noted, | |
67914693 | 828 | -- this has to be done very early, so cannot depend on the normal circuit |
a96157e6 | 829 | -- for reading switches and setting switches in Opt. The following code |
340772c0 | 830 | -- will set Opt.Target_Dependent_Info_Read_Name if the switch -gnateT=name |
752b81d9 AC |
831 | -- is present in the options string. |
832 | ||
833 | declare | |
834 | type Arg_Array is array (Nat) of Big_String_Ptr; | |
835 | type Arg_Array_Ptr is access Arg_Array; | |
836 | -- Types to access compiler arguments | |
837 | ||
838 | save_argc : Nat; | |
839 | pragma Import (C, save_argc); | |
840 | -- Saved value of argc (number of arguments), imported from misc.c | |
841 | ||
842 | save_argv : Arg_Array_Ptr; | |
843 | pragma Import (C, save_argv); | |
844 | -- Saved value of argv (argument pointers), imported from misc.c | |
845 | ||
c2658843 AC |
846 | gnat_argc : Nat; |
847 | gnat_argv : Arg_Array_Ptr; | |
848 | pragma Import (C, gnat_argc); | |
849 | pragma Import (C, gnat_argv); | |
850 | -- If save_argv is not set, default to gnat_argc/argv | |
851 | ||
852 | argc : Nat; | |
853 | argv : Arg_Array_Ptr; | |
854 | ||
855 | function Len_Arg (Arg : Big_String_Ptr) return Nat; | |
856 | -- Determine length of argument Arg (a nul terminated C string). | |
fce68ebe AC |
857 | |
858 | ------------- | |
859 | -- Len_Arg -- | |
860 | ------------- | |
861 | ||
c2658843 | 862 | function Len_Arg (Arg : Big_String_Ptr) return Nat is |
fce68ebe AC |
863 | begin |
864 | for J in 1 .. Nat'Last loop | |
c2658843 | 865 | if Arg (Natural (J)) = ASCII.NUL then |
fce68ebe AC |
866 | return J - 1; |
867 | end if; | |
868 | end loop; | |
869 | ||
870 | raise Program_Error; | |
871 | end Len_Arg; | |
872 | ||
752b81d9 | 873 | begin |
c2658843 AC |
874 | if save_argv /= null then |
875 | argv := save_argv; | |
876 | argc := save_argc; | |
877 | else | |
9324e07d | 878 | -- Case of a non-GCC compiler, e.g. gnat2why or gnat2scil |
c2658843 AC |
879 | argv := gnat_argv; |
880 | argc := gnat_argc; | |
881 | end if; | |
882 | ||
752b81d9 AC |
883 | -- Loop through arguments looking for -gnateT, also look for -gnatd.b |
884 | ||
c2658843 | 885 | for Arg in 1 .. argc - 1 loop |
752b81d9 | 886 | declare |
c2658843 AC |
887 | Argv_Ptr : constant Big_String_Ptr := argv (Arg); |
888 | Argv_Len : constant Nat := Len_Arg (Argv_Ptr); | |
340772c0 | 889 | |
752b81d9 | 890 | begin |
340772c0 RD |
891 | if Argv_Len > 8 |
892 | and then Argv_Ptr (1 .. 8) = "-gnateT=" | |
fce68ebe | 893 | then |
340772c0 RD |
894 | Opt.Target_Dependent_Info_Read_Name := |
895 | new String'(Argv_Ptr (9 .. Natural (Argv_Len))); | |
896 | ||
fce68ebe AC |
897 | elsif Argv_Len >= 8 |
898 | and then Argv_Ptr (1 .. 8) = "-gnatd.b" | |
899 | then | |
752b81d9 AC |
900 | Debug_Flag_Dot_B := True; |
901 | end if; | |
902 | end; | |
903 | end loop; | |
904 | end; | |
905 | ||
340772c0 | 906 | -- Case of reading the target dependent values from file |
752b81d9 | 907 | |
a96157e6 AC |
908 | -- This is bit more complex than might be expected, because it has to be |
909 | -- done very early. All kinds of packages depend on these values, and we | |
910 | -- can't wait till the normal processing of reading command line switches | |
911 | -- etc to read the file. We do this at the System.OS_Lib level since it is | |
912 | -- too early to be using Osint directly. | |
752b81d9 | 913 | |
1ebc2612 AC |
914 | if Opt.Target_Dependent_Info_Read_Name /= null then |
915 | Read_Target_Dependent_Values (Target_Dependent_Info_Read_Name.all); | |
752b81d9 | 916 | else |
1ebc2612 AC |
917 | -- If the back-end comes with a target config file, then use it |
918 | -- to set the values | |
752b81d9 | 919 | |
1ebc2612 AC |
920 | declare |
921 | Back_End_Config_File : constant String_Ptr := | |
922 | Get_Back_End_Config_File; | |
752b81d9 | 923 | begin |
1ebc2612 | 924 | if Back_End_Config_File /= null then |
83fadfd9 AC |
925 | pragma Gnat_Annotate |
926 | (CodePeer, Intentional, "test always false", | |
927 | "some variant body will return non null"); | |
1ebc2612 | 928 | Read_Target_Dependent_Values (Back_End_Config_File.all); |
752b81d9 | 929 | |
1ebc2612 | 930 | -- Otherwise we get all values from the back end directly |
752b81d9 | 931 | |
752b81d9 | 932 | else |
1ebc2612 AC |
933 | Bits_BE := Get_Bits_BE; |
934 | Bits_Per_Unit := Get_Bits_Per_Unit; | |
935 | Bits_Per_Word := Get_Bits_Per_Word; | |
936 | Bytes_BE := Get_Bytes_BE; | |
937 | Char_Size := Get_Char_Size; | |
938 | Double_Float_Alignment := Get_Double_Float_Alignment; | |
939 | Double_Scalar_Alignment := Get_Double_Scalar_Alignment; | |
1ebc2612 AC |
940 | Float_Words_BE := Get_Float_Words_BE; |
941 | Int_Size := Get_Int_Size; | |
a5476382 | 942 | Long_Long_Long_Size := Get_Long_Long_Long_Size; |
1ebc2612 AC |
943 | Long_Long_Size := Get_Long_Long_Size; |
944 | Long_Size := Get_Long_Size; | |
945 | Maximum_Alignment := Get_Maximum_Alignment; | |
946 | Max_Unaligned_Field := Get_Max_Unaligned_Field; | |
947 | Pointer_Size := Get_Pointer_Size; | |
948 | Short_Enums := Get_Short_Enums; | |
949 | Short_Size := Get_Short_Size; | |
950 | Strict_Alignment := Get_Strict_Alignment; | |
951 | System_Allocator_Alignment := Get_System_Allocator_Alignment; | |
952 | Wchar_T_Size := Get_Wchar_T_Size; | |
953 | Words_BE := Get_Words_BE; | |
954 | ||
28fa5430 AC |
955 | -- Let the back-end register its floating point types and compute |
956 | -- the sizes of our standard types from there: | |
957 | ||
958 | Num_FPT_Modes := 0; | |
959 | Register_Back_End_Types (Register_Float_Type'Access); | |
72eaa365 AC |
960 | |
961 | declare | |
962 | T : FPT_Mode_Entry renames | |
963 | FPT_Mode_Table (FPT_Mode_Index_For (S_Float)); | |
964 | begin | |
e90e9503 | 965 | Float_Size := Pos (T.SIZE); |
72eaa365 AC |
966 | end; |
967 | ||
968 | declare | |
969 | T : FPT_Mode_Entry renames | |
970 | FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Float)); | |
971 | begin | |
e90e9503 | 972 | Double_Size := Pos (T.SIZE); |
72eaa365 AC |
973 | end; |
974 | ||
975 | declare | |
976 | T : FPT_Mode_Entry renames | |
977 | FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Long_Float)); | |
978 | begin | |
e90e9503 | 979 | Long_Double_Size := Pos (T.SIZE); |
72eaa365 | 980 | end; |
1ebc2612 | 981 | |
752b81d9 | 982 | end if; |
1ebc2612 | 983 | end; |
752b81d9 AC |
984 | end if; |
985 | end Set_Targ; |