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