?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Add mi_thunk support for vcalls on hppa.
[official-gcc.git] / gcc / ada / set_targ.adb
blobb8578f5c376cafb28b16f44c440c1aa30d83ba20
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E T _ T A R G --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2013-2020, 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 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
38 --------------------------------------------------------
39 -- Data Used to Read/Write Target Dependent Info File --
40 --------------------------------------------------------
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";
58 S_Long_Long_Long_Size : constant Str := "Long_Long_Long_Size";
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";
64 S_Short_Enums : constant Str := "Short_Enums";
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,
88 S_Long_Long_Long_Size 'Unrestricted_Access,
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,
94 S_Short_Enums 'Unrestricted_Access,
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,
116 Long_Long_Long_Size 'Address,
117 Long_Long_Size 'Address,
118 Long_Size 'Address,
119 Maximum_Alignment 'Address,
120 Max_Unaligned_Field 'Address,
121 Pointer_Size 'Address,
122 Short_Enums 'Address,
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
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
140 procedure Fail (E : String);
141 pragma No_Return (Fail);
142 -- Terminate program with fatal error message passed as parameter
143
144 procedure Register_Float_Type
145 (Name : C_String;
146 Digs : Natural;
147 Complex : Boolean;
148 Count : Natural;
149 Float_Rep : Float_Rep_Kind;
150 Precision : Positive;
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
162 -- floating-point type, and Precision, Size and Alignment are the precision
163 -- size and alignment in bits.
164 --
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;
171 -- Once all the floating point types have been registered, the index in
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
209 when S_Float
210 | S_Short_Float
211 =>
212 return "float";
213
214 when S_Long_Float =>
215 return "double";
216
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;
227
228 ----------
229 -- Fail --
230 ----------
231
232 procedure Fail (E : String) is
233 E_Fatal : constant := 4;
234 -- Code for fatal error
235
236 begin
237 Write_Str (E);
238 Write_Eol;
239 OS_Exit (E_Fatal);
240 end Fail;
241
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
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;
272 Precision : Positive;
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
312 when AAMP => Write_Str ("AAMP");
313 when IEEE_Binary => Write_Str ("IEEE");
314 end case;
315
316 Write_Line (", " & T (1 .. Last) & ");");
317
318 else
319 Write_Str ("mod 2**");
320 Write_Int (Int (Precision / Positive'Max (1, Count)));
321 Write_Line (";");
322 end if;
323
324 if Precision = Size then
325 Write_Str ("for " & T (1 .. Last) & "'Size use ");
326 Write_Int (Int (Size));
327 Write_Line (";");
328
329 else
330 Write_Str ("for " & T (1 .. Last) & "'Value_Size use ");
331 Write_Int (Int (Precision));
332 Write_Line (";");
333
334 Write_Str ("for " & T (1 .. Last) & "'Object_Size use ");
335 Write_Int (Int (Size));
336 Write_Line (";");
337 end if;
338
339 Write_Str ("for " & T (1 .. Last) & "'Alignment use ");
340 Write_Int (Int (Alignment / 8));
341 Write_Line (";");
342 Write_Eol;
343 end Dump;
344
345 -- Start of processing for Register_Float_Type
346
347 begin
348 -- Acquire name
349
350 for J in T'Range loop
351 T (J) := Name (Name'First + J - 1);
352
353 if T (J) = ASCII.NUL then
354 Last := J - 1;
355 exit;
356 end if;
357 end loop;
358
359 -- Dump info if debug flag set
360
361 if Debug_Flag_Dot_B then
362 Dump;
363 end if;
364
365 -- Acquire entry if non-vector non-complex fpt type (digits non-zero)
366
367 if Digs > 0 and then not Complex and then Count = 0 then
368
369 declare
370 This_Name : constant String := T (1 .. Last);
371 begin
372 Num_FPT_Modes := Num_FPT_Modes + 1;
373 FPT_Mode_Table (Num_FPT_Modes) :=
374 (NAME => new String'(This_Name),
375 DIGS => Digs,
376 FLOAT_REP => Float_Rep,
377 PRECISION => Precision,
378 SIZE => Size,
379 ALIGNMENT => Alignment);
380
381 if Long_Double_Index < 0 and then This_Name = "long double" then
382 Long_Double_Index := Num_FPT_Modes;
383 end if;
384 end;
385 end if;
386 end Register_Float_Type;
387
388 -----------------------------------
389 -- Write_Target_Dependent_Values --
390 -----------------------------------
391
392 -- We do this at the System.Os_Lib level, since we have to do the read at
393 -- that level anyway, so it is easier and more consistent to follow the
394 -- same path for the write.
395
396 procedure Write_Target_Dependent_Values is
397 Fdesc : File_Descriptor;
398 OK : Boolean;
399
400 Buffer : String (1 .. 80);
401 Buflen : Natural;
402 -- Buffer used to build line one of file
403
404 type ANat is access all Natural;
405 -- Pointer to Nat or Pos value (it is harmless to treat Pos values and
406 -- Nat values as Natural via Unchecked_Conversion).
407
408 function To_ANat is new Unchecked_Conversion (Address, ANat);
409
410 procedure AddC (C : Character);
411 -- Add one character to buffer
412
413 procedure AddN (N : Natural);
414 -- Add representation of integer N to Buffer, updating Buflen. N
415 -- must be less than 1000, and output is 3 characters with leading
416 -- spaces as needed.
417
418 procedure Write_Line;
419 -- Output contents of Buffer (1 .. Buflen) followed by a New_Line,
420 -- and set Buflen back to zero, ready to write next line.
421
422 ----------
423 -- AddC --
424 ----------
425
426 procedure AddC (C : Character) is
427 begin
428 Buflen := Buflen + 1;
429 Buffer (Buflen) := C;
430 end AddC;
431
432 ----------
433 -- AddN --
434 ----------
435
436 procedure AddN (N : Natural) is
437 begin
438 if N > 999 then
439 raise Program_Error;
440 end if;
441
442 if N > 99 then
443 AddC (Character'Val (48 + N / 100));
444 else
445 AddC (' ');
446 end if;
447
448 if N > 9 then
449 AddC (Character'Val (48 + N / 10 mod 10));
450 else
451 AddC (' ');
452 end if;
453
454 AddC (Character'Val (48 + N mod 10));
455 end AddN;
456
457 ----------------
458 -- Write_Line --
459 ----------------
460
461 procedure Write_Line is
462 begin
463 AddC (ASCII.LF);
464
465 if Buflen /= Write (Fdesc, Buffer'Address, Buflen) then
466 Delete_File (Target_Dependent_Info_Write_Name.all, OK);
467 Fail ("disk full writing file "
468 & Target_Dependent_Info_Write_Name.all);
469 end if;
470
471 Buflen := 0;
472 end Write_Line;
473
474 -- Start of processing for Write_Target_Dependent_Values
475
476 begin
477 Fdesc :=
478 Create_File (Target_Dependent_Info_Write_Name.all, Text);
479
480 if Fdesc = Invalid_FD then
481 Fail ("cannot create file " & Target_Dependent_Info_Write_Name.all);
482 end if;
483
484 -- Loop through values
485
486 for J in DTN'Range loop
487
488 -- Output name
489
490 Buflen := DTN (J)'Length;
491 Buffer (1 .. Buflen) := DTN (J).all;
492
493 -- Line up values
494
495 while Buflen < 26 loop
496 AddC (' ');
497 end loop;
498
499 AddC (' ');
500 AddC (' ');
501
502 -- Output value and write line
503
504 AddN (To_ANat (DTV (J)).all);
505 Write_Line;
506 end loop;
507
508 -- Blank line to separate sections
509
510 Write_Line;
511
512 -- Write lines for registered FPT types
513
514 for J in 1 .. Num_FPT_Modes loop
515 declare
516 E : FPT_Mode_Entry renames FPT_Mode_Table (J);
517 begin
518 Buflen := E.NAME'Last;
519 Buffer (1 .. Buflen) := E.NAME.all;
520
521 -- Pad out to line up values
522
523 while Buflen < 11 loop
524 AddC (' ');
525 end loop;
526
527 AddC (' ');
528 AddC (' ');
529
530 AddN (E.DIGS);
531 AddC (' ');
532 AddC (' ');
533
534 case E.FLOAT_REP is
535 when AAMP => AddC ('A');
536 when IEEE_Binary => AddC ('I');
537 end case;
538
539 AddC (' ');
540
541 AddN (E.PRECISION);
542 AddC (' ');
543
544 AddN (E.ALIGNMENT);
545 Write_Line;
546 end;
547 end loop;
548
549 -- Close file
550
551 Close (Fdesc, OK);
552
553 if not OK then
554 Fail ("disk full writing file "
555 & Target_Dependent_Info_Write_Name.all);
556 end if;
557 end Write_Target_Dependent_Values;
558
559 ----------------------------------
560 -- Read_Target_Dependent_Values --
561 ----------------------------------
562
563 procedure Read_Target_Dependent_Values (File_Name : String) is
564 File_Desc : File_Descriptor;
565 N : Natural;
566
567 type ANat is access all Natural;
568 -- Pointer to Nat or Pos value (it is harmless to treat Pos values
569 -- as Nat via Unchecked_Conversion).
570
571 function To_ANat is new Unchecked_Conversion (Address, ANat);
572
573 VP : ANat;
574
575 Buffer : String (1 .. 2000);
576 Buflen : Natural;
577 -- File information and length (2000 easily enough)
578
579 Nam_Buf : String (1 .. 40);
580 Nam_Len : Natural;
581
582 procedure Check_Spaces;
583 -- Checks that we have one or more spaces and skips them
584
585 procedure FailN (S : String);
586 pragma No_Return (FailN);
587 -- Calls Fail adding " name in file xxx", where name is the currently
588 -- gathered name in Nam_Buf, surrounded by quotes, and xxx is the
589 -- name of the file.
590
591 procedure Get_Name;
592 -- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls
593 -- Skip_Spaces to skip any following spaces. Note that the name is
594 -- terminated by a sequence of at least two spaces.
595
596 function Get_Nat return Natural;
597 -- N on entry points to decimal integer, scan out decimal integer
598 -- and return it, leaving N pointing to following space or LF.
599
600 procedure Skip_Spaces;
601 -- Skip past spaces
602
603 ------------------
604 -- Check_Spaces --
605 ------------------
606
607 procedure Check_Spaces is
608 begin
609 if N > Buflen or else Buffer (N) /= ' ' then
610 FailN ("missing space for");
611 end if;
612
613 Skip_Spaces;
614 return;
615 end Check_Spaces;
616
617 -----------
618 -- FailN --
619 -----------
620
621 procedure FailN (S : String) is
622 begin
623 Fail (S & " """ & Nam_Buf (1 .. Nam_Len) & """ in file "
624 & File_Name);
625 end FailN;
626
627 --------------
628 -- Get_Name --
629 --------------
630
631 procedure Get_Name is
632 begin
633 Nam_Len := 0;
634
635 -- Scan out name and put it in Nam_Buf
636
637 loop
638 if N > Buflen or else Buffer (N) = ASCII.LF then
639 FailN ("incorrectly formatted line for");
640 end if;
641
642 -- Name is terminated by two blanks
643
644 exit when N < Buflen and then Buffer (N .. N + 1) = " ";
645
646 Nam_Len := Nam_Len + 1;
647
648 if Nam_Len > Nam_Buf'Last then
649 Fail ("name too long");
650 end if;
651
652 Nam_Buf (Nam_Len) := Buffer (N);
653 N := N + 1;
654 end loop;
655
656 Check_Spaces;
657 end Get_Name;
658
659 -------------
660 -- Get_Nat --
661 -------------
662
663 function Get_Nat return Natural is
664 Result : Natural := 0;
665
666 begin
667 loop
668 if N > Buflen
669 or else Buffer (N) not in '0' .. '9'
670 or else Result > 999
671 then
672 FailN ("bad value for");
673 end if;
674
675 Result := Result * 10 + (Character'Pos (Buffer (N)) - 48);
676 N := N + 1;
677
678 exit when N <= Buflen
679 and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' ');
680 end loop;
681
682 return Result;
683 end Get_Nat;
684
685 -----------------
686 -- Skip_Spaces --
687 -----------------
688
689 procedure Skip_Spaces is
690 begin
691 while N <= Buflen and Buffer (N) = ' ' loop
692 N := N + 1;
693 end loop;
694 end Skip_Spaces;
695
696 -- Start of processing for Read_Target_Dependent_Values
697
698 begin
699 File_Desc := Open_Read (File_Name, Text);
700
701 if File_Desc = Invalid_FD then
702 Fail ("cannot read file " & File_Name);
703 end if;
704
705 Buflen := Read (File_Desc, Buffer'Address, Buffer'Length);
706
707 Close (File_Desc);
708
709 if Buflen = Buffer'Length then
710 Fail ("file is too long: " & File_Name);
711 end if;
712
713 -- Scan through file for properly formatted entries in first section
714
715 N := 1;
716 while N <= Buflen and then Buffer (N) /= ASCII.LF loop
717 Get_Name;
718
719 -- Validate name and get corresponding value pointer
720
721 VP := null;
722
723 for J in DTN'Range loop
724 if DTN (J).all = Nam_Buf (1 .. Nam_Len) then
725 VP := To_ANat (DTV (J));
726 DTR (J) := True;
727 exit;
728 end if;
729 end loop;
730
731 if VP = null then
732 FailN ("unrecognized name");
733 end if;
734
735 -- Scan out value
736
737 VP.all := Get_Nat;
738
739 if N > Buflen or else Buffer (N) /= ASCII.LF then
740 FailN ("misformatted line for");
741 end if;
742
743 N := N + 1; -- skip LF
744 end loop;
745
746 -- Fall through this loop when all lines in first section read.
747 -- Check that values have been supplied for all entries.
748
749 for J in DTR'Range loop
750 if not DTR (J) then
751 -- Make an exception for Long_Long_Long_Size???
752
753 if DTN (J) = S_Long_Long_Long_Size'Unrestricted_Access then
754 Long_Long_Long_Size := Long_Long_Size;
755
756 else
757 Fail ("missing entry for " & DTN (J).all & " in file "
758 & File_Name);
759 end if;
760 end if;
761 end loop;
762
763 -- Now acquire FPT entries
764
765 if N >= Buflen then
766 Fail ("missing entries for FPT modes in file " & File_Name);
767 end if;
768
769 if Buffer (N) = ASCII.LF then
770 N := N + 1;
771 else
772 Fail ("missing blank line in file " & File_Name);
773 end if;
774
775 Num_FPT_Modes := 0;
776 while N <= Buflen loop
777 Get_Name;
778
779 Num_FPT_Modes := Num_FPT_Modes + 1;
780
781 declare
782 E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes);
783
784 begin
785 E.NAME := new String'(Nam_Buf (1 .. Nam_Len));
786
787 if Long_Double_Index < 0 and then E.NAME.all = "long double" then
788 Long_Double_Index := Num_FPT_Modes;
789 end if;
790
791 E.DIGS := Get_Nat;
792 Check_Spaces;
793
794 case Buffer (N) is
795 when 'I' =>
796 E.FLOAT_REP := IEEE_Binary;
797
798 when 'A' =>
799 E.FLOAT_REP := AAMP;
800
801 when others =>
802 FailN ("bad float rep field for");
803 end case;
804
805 N := N + 1;
806 Check_Spaces;
807
808 E.PRECISION := Get_Nat;
809 Check_Spaces;
810
811 E.ALIGNMENT := Get_Nat;
812
813 if Buffer (N) /= ASCII.LF then
814 FailN ("junk at end of line for");
815 end if;
816
817 -- ??? We do not read E.SIZE, see Write_Target_Dependent_Values
818
819 E.SIZE :=
820 (E.PRECISION + E.ALIGNMENT - 1) / E.ALIGNMENT * E.ALIGNMENT;
821
822 N := N + 1;
823 end;
824 end loop;
825 end Read_Target_Dependent_Values;
826
827 -- Package Initialization, set target dependent values. This must be done
828 -- early on, before we start accessing various compiler packages, since
829 -- these values are used all over the place.
830
831 begin
832 -- First step: see if the -gnateT switch is present. As we have noted,
833 -- this has to be done very early, so cannot depend on the normal circuit
834 -- for reading switches and setting switches in Opt. The following code
835 -- will set Opt.Target_Dependent_Info_Read_Name if the switch -gnateT=name
836 -- is present in the options string.
837
838 declare
839 type Arg_Array is array (Nat) of Big_String_Ptr;
840 type Arg_Array_Ptr is access Arg_Array;
841 -- Types to access compiler arguments
842
843 save_argc : Nat;
844 pragma Import (C, save_argc);
845 -- Saved value of argc (number of arguments), imported from misc.c
846
847 save_argv : Arg_Array_Ptr;
848 pragma Import (C, save_argv);
849 -- Saved value of argv (argument pointers), imported from misc.c
850
851 gnat_argc : Nat;
852 gnat_argv : Arg_Array_Ptr;
853 pragma Import (C, gnat_argc);
854 pragma Import (C, gnat_argv);
855 -- If save_argv is not set, default to gnat_argc/argv
856
857 argc : Nat;
858 argv : Arg_Array_Ptr;
859
860 function Len_Arg (Arg : Big_String_Ptr) return Nat;
861 -- Determine length of argument Arg (a nul terminated C string).
862
863 -------------
864 -- Len_Arg --
865 -------------
866
867 function Len_Arg (Arg : Big_String_Ptr) return Nat is
868 begin
869 for J in 1 .. Nat'Last loop
870 if Arg (Natural (J)) = ASCII.NUL then
871 return J - 1;
872 end if;
873 end loop;
874
875 raise Program_Error;
876 end Len_Arg;
877
878 begin
879 if save_argv /= null then
880 argv := save_argv;
881 argc := save_argc;
882 else
883 -- Case of a non gcc compiler, e.g. gnat2why or gnat2scil
884 argv := gnat_argv;
885 argc := gnat_argc;
886 end if;
887
888 -- Loop through arguments looking for -gnateT, also look for -gnatd.b
889
890 for Arg in 1 .. argc - 1 loop
891 declare
892 Argv_Ptr : constant Big_String_Ptr := argv (Arg);
893 Argv_Len : constant Nat := Len_Arg (Argv_Ptr);
894
895 begin
896 if Argv_Len > 8
897 and then Argv_Ptr (1 .. 8) = "-gnateT="
898 then
899 Opt.Target_Dependent_Info_Read_Name :=
900 new String'(Argv_Ptr (9 .. Natural (Argv_Len)));
901
902 elsif Argv_Len >= 8
903 and then Argv_Ptr (1 .. 8) = "-gnatd.b"
904 then
905 Debug_Flag_Dot_B := True;
906 end if;
907 end;
908 end loop;
909 end;
910
911 -- Case of reading the target dependent values from file
912
913 -- This is bit more complex than might be expected, because it has to be
914 -- done very early. All kinds of packages depend on these values, and we
915 -- can't wait till the normal processing of reading command line switches
916 -- etc to read the file. We do this at the System.OS_Lib level since it is
917 -- too early to be using Osint directly.
918
919 if Opt.Target_Dependent_Info_Read_Name /= null then
920 Read_Target_Dependent_Values (Target_Dependent_Info_Read_Name.all);
921 else
922 -- If the back-end comes with a target config file, then use it
923 -- to set the values
924
925 declare
926 Back_End_Config_File : constant String_Ptr :=
927 Get_Back_End_Config_File;
928 begin
929 if Back_End_Config_File /= null then
930 pragma Gnat_Annotate
931 (CodePeer, Intentional, "test always false",
932 "some variant body will return non null");
933 Read_Target_Dependent_Values (Back_End_Config_File.all);
934
935 -- Otherwise we get all values from the back end directly
936
937 else
938 Bits_BE := Get_Bits_BE;
939 Bits_Per_Unit := Get_Bits_Per_Unit;
940 Bits_Per_Word := Get_Bits_Per_Word;
941 Bytes_BE := Get_Bytes_BE;
942 Char_Size := Get_Char_Size;
943 Double_Float_Alignment := Get_Double_Float_Alignment;
944 Double_Scalar_Alignment := Get_Double_Scalar_Alignment;
945 Float_Words_BE := Get_Float_Words_BE;
946 Int_Size := Get_Int_Size;
947 Long_Long_Long_Size := Get_Long_Long_Long_Size;
948 Long_Long_Size := Get_Long_Long_Size;
949 Long_Size := Get_Long_Size;
950 Maximum_Alignment := Get_Maximum_Alignment;
951 Max_Unaligned_Field := Get_Max_Unaligned_Field;
952 Pointer_Size := Get_Pointer_Size;
953 Short_Enums := Get_Short_Enums;
954 Short_Size := Get_Short_Size;
955 Strict_Alignment := Get_Strict_Alignment;
956 System_Allocator_Alignment := Get_System_Allocator_Alignment;
957 Wchar_T_Size := Get_Wchar_T_Size;
958 Words_BE := Get_Words_BE;
959
960 -- Let the back-end register its floating point types and compute
961 -- the sizes of our standard types from there:
962
963 Num_FPT_Modes := 0;
964 Register_Back_End_Types (Register_Float_Type'Access);
965
966 declare
967 T : FPT_Mode_Entry renames
968 FPT_Mode_Table (FPT_Mode_Index_For (S_Float));
969 begin
970 Float_Size := Pos (T.SIZE);
971 end;
972
973 declare
974 T : FPT_Mode_Entry renames
975 FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Float));
976 begin
977 Double_Size := Pos (T.SIZE);
978 end;
979
980 declare
981 T : FPT_Mode_Entry renames
982 FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Long_Float));
983 begin
984 Long_Double_Size := Pos (T.SIZE);
985 end;
986
987 end if;
988 end;
989 end if;
990 end Set_Targ;
Mirror of the offical gcc git repository hosted at gcc.gnu.org