1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2013, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Debug
; use Debug
;
27 with Get_Targ
; use Get_Targ
;
29 with Output
; use Output
;
31 with System
; use System
;
32 with System
.OS_Lib
; use System
.OS_Lib
;
34 with Unchecked_Conversion
;
36 package body Set_Targ
is
38 ---------------------------------------------
39 -- Data Used to Read/Write target.atp File --
40 ---------------------------------------------
42 File_Name
: aliased constant String := "target.atp";
43 -- Name of file to read/write
45 -- Table of string names written to file
47 subtype Str
is String;
49 S_Bits_BE
: constant Str
:= "Bits_BE";
50 S_Bits_Per_Unit
: constant Str
:= "Bits_Per_Unit";
51 S_Bits_Per_Word
: constant Str
:= "Bits_Per_Word";
52 S_Bytes_BE
: constant Str
:= "Bytes_BE";
53 S_Char_Size
: constant Str
:= "Char_Size";
54 S_Double_Float_Alignment
: constant Str
:= "Double_Float_Alignment";
55 S_Double_Scalar_Alignment
: constant Str
:= "Double_Scalar_Alignment";
56 S_Double_Size
: constant Str
:= "Double_Size";
57 S_Float_Size
: constant Str
:= "Float_Size";
58 S_Float_Words_BE
: constant Str
:= "Float_Words_BE";
59 S_Int_Size
: constant Str
:= "Int_Size";
60 S_Long_Double_Size
: constant Str
:= "Long_Double_Size";
61 S_Long_Long_Size
: constant Str
:= "Long_Long_Size";
62 S_Long_Size
: constant Str
:= "Long_Size";
63 S_Maximum_Alignment
: constant Str
:= "Maximum_Alignment";
64 S_Max_Unaligned_Field
: constant Str
:= "Max_Unaligned_Field";
65 S_Pointer_Size
: constant Str
:= "Pointer_Size";
66 S_Short_Size
: constant Str
:= "Short_Size";
67 S_Strict_Alignment
: constant Str
:= "Strict_Alignment";
68 S_System_Allocator_Alignment
: constant Str
:= "System_Allocator_Alignment";
69 S_Wchar_T_Size
: constant Str
:= "Wchar_T_Size";
70 S_Words_BE
: constant Str
:= "Words_BE";
74 type AStr
is access all String;
76 DTN
: constant array (Nat
range <>) of AStr
:= (
77 S_Bits_BE
'Unrestricted_Access,
78 S_Bits_Per_Unit 'Unrestricted_Access
,
79 S_Bits_Per_Word
'Unrestricted_Access,
80 S_Bytes_BE 'Unrestricted_Access
,
81 S_Char_Size
'Unrestricted_Access,
82 S_Double_Float_Alignment 'Unrestricted_Access
,
83 S_Double_Scalar_Alignment
'Unrestricted_Access,
84 S_Double_Size 'Unrestricted_Access
,
85 S_Float_Size
'Unrestricted_Access,
86 S_Float_Words_BE 'Unrestricted_Access
,
87 S_Int_Size
'Unrestricted_Access,
88 S_Long_Double_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_Size 'Unrestricted_Access
,
95 S_Strict_Alignment
'Unrestricted_Access,
96 S_System_Allocator_Alignment 'Unrestricted_Access
,
97 S_Wchar_T_Size
'Unrestricted_Access,
98 S_Words_BE 'Unrestricted_Access
);
100 -- Table of corresponding value pointers
102 DTV
: constant array (Nat
range <>) of System
.Address
:= (
104 Bits_Per_Unit 'Address
,
105 Bits_Per_Word
'Address,
108 Double_Float_Alignment 'Address
,
109 Double_Scalar_Alignment
'Address,
110 Double_Size 'Address
,
112 Float_Words_BE 'Address
,
114 Long_Double_Size 'Address
,
115 Long_Long_Size
'Address,
117 Maximum_Alignment
'Address,
118 Max_Unaligned_Field 'Address
,
119 Pointer_Size
'Address,
121 Strict_Alignment
'Address,
122 System_Allocator_Alignment 'Address
,
123 Wchar_T_Size
'Address,
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
129 -----------------------
130 -- Local Subprograms --
131 -----------------------
133 procedure Fail
(E
: String);
134 pragma No_Return
(Fail
);
135 -- Terminate program with fatal error message passed as parameter
137 procedure Register_Float_Type
142 Float_Rep
: Float_Rep_Kind
;
144 Alignment
: Natural);
145 pragma Convention
(C
, Register_Float_Type
);
146 -- Call back to allow the back end to register available types. This call
147 -- back makes entries in the FPT_Mode_Table for any floating point types
148 -- reported by the back end. Name is the name of the type as a normal
149 -- format Null-terminated string. Digs is the number of digits, where 0
150 -- means it is not a fpt type (ignored during registration). Complex is
151 -- non-zero if the type has real and imaginary parts (also ignored during
152 -- registration). Count is the number of elements in a vector type (zero =
153 -- not a vector, registration ignores vectors). Float_Rep shows the kind of
154 -- floating-point type, and Size/Alignment are the size/alignment in bits.
156 -- So to summarize, the only types that are actually registered have Digs
157 -- non-zero, Complex zero (false), and Count zero (not a vector).
163 procedure Fail
(E
: String) is
164 E_Fatal
: constant := 4;
165 -- Code for fatal error
172 -------------------------
173 -- Register_Float_Type --
174 -------------------------
176 procedure Register_Float_Type
181 Float_Rep
: Float_Rep_Kind
;
185 T
: String (1 .. Name
'Length);
189 -- Dump information given by the back end for the type to register
197 Write_Str
("type " & T
(1 .. Last
) & " is ");
200 Write_Str
("array (1 .. ");
201 Write_Int
(Int
(Count
));
204 Write_Str
(", 1 .. 2");
210 Write_Str
("array (1 .. 2) of ");
214 Write_Str
("digits ");
215 Write_Int
(Int
(Digs
));
218 Write_Str
("pragma Float_Representation (");
237 Write_Int
(Int
(Digs
));
240 when AAMP
=> Write_Str
("AAMP");
243 Write_Line
(", " & T
(1 .. Last
) & ");");
246 Write_Str
("mod 2**");
247 Write_Int
(Int
(Size
/ Positive'Max (1, Count
)));
251 Write_Str
("for " & T
(1 .. Last
) & "'Size use ");
252 Write_Int
(Int
(Size
));
255 Write_Str
("for " & T
(1 .. Last
) & "'Alignment use ");
256 Write_Int
(Int
(Alignment
/ 8));
261 -- Start of processing for Register_Float_Type
266 for J
in T
'Range loop
267 T
(J
) := Name
(Name
'First + J
- 1);
269 if T
(J
) = ASCII
.NUL
then
275 -- Dump info if debug flag set
277 if Debug_Flag_Dot_B
then
281 -- Acquire entry if non-vector non-complex fpt type (digits non-zero)
283 if Digs
> 0 and then not Complex
and then Count
= 0 then
284 Num_FPT_Modes
:= Num_FPT_Modes
+ 1;
285 FPT_Mode_Table
(Num_FPT_Modes
) :=
286 (NAME
=> new String'(T (1 .. Last)),
288 FLOAT_REP => Float_Rep,
290 ALIGNMENT => Alignment);
292 end Register_Float_Type;
294 -----------------------------------
295 -- Write_Target_Dependent_Values --
296 -----------------------------------
298 -- We do this at the System.Os_Lib level, since we have to do the read at
299 -- that level anyway, so it is easier and more consistent to follow the
300 -- same path for the write.
302 procedure Write_Target_Dependent_Values is
303 Fdesc : File_Descriptor;
306 Buffer : String (1 .. 80);
308 -- Buffer used to build line one of file
310 type ANat is access all Natural;
311 -- Pointer to Nat or Pos value (it is harmless to treat Pos values and
312 -- Nat values as Natural via Unchecked_Conversion).
314 function To_ANat is new Unchecked_Conversion (Address, ANat);
316 procedure AddC (C : Character);
317 -- Add one character to buffer
319 procedure AddN (N : Natural);
320 -- Add representation of integer N to Buffer, updating Buflen. N
321 -- must be less than 1000, and output is 3 characters with leading
324 procedure Write_Line;
325 -- Output contents of Buffer (1 .. Buflen) followed by a New_Line,
326 -- and set Buflen back to zero, ready to write next line.
332 procedure AddC (C : Character) is
334 Buflen := Buflen + 1;
335 Buffer (Buflen) := C;
342 procedure AddN (N : Natural) is
349 AddC (Character'Val (48 + N / 100));
355 AddC (Character'Val (48 + N / 10 mod 10));
360 AddC (Character'Val (48 + N mod 10));
367 procedure Write_Line is
371 if Buflen /= Write (Fdesc, Buffer'Address, Buflen) then
372 Delete_File (File_Name'Address, OK);
373 Fail ("disk full writing target.atp");
379 -- Start of processing for Write_Target_Dependent_Values
382 Fdesc := Create_File (File_Name'Address, Text);
384 if Fdesc = Invalid_FD then
385 Fail ("cannot create target.atp");
388 -- Loop through values
390 for J in DTN'Range loop
394 Buflen := DTN (J)'Length;
395 Buffer (1 .. Buflen) := DTN (J).all;
399 while Buflen < 26 loop
406 -- Output value and write line
408 AddN (To_ANat (DTV (J)).all);
412 -- Blank line to separate sections
416 -- Write lines for registered FPT types
418 for J in 1 .. Num_FPT_Modes loop
420 E : FPT_Mode_Entry renames FPT_Mode_Table (J);
422 Buflen := E.NAME'Last;
423 Buffer (1 .. Buflen) := E.NAME.all;
425 -- Pad out to line up values
427 while Buflen < 11 loop
462 Fail ("disk full writing target.atp");
464 end Write_Target_Dependent_Values;
466 -- Package Initialization, set target dependent values. This must be done
467 -- early on, before we start accessing various compiler packages, since
468 -- these values are used all over the place.
471 -- First step: see if the -gnateT switch is present. As we have noted,
472 -- this has to be done very early, so can not depend on the normal circuit
473 -- for reading switches and setting switches in opt. The following code
474 -- will set Opt.Target_Dependent_Info_Read if an option starting -gnatet
475 -- is present in the options string.
478 type Arg_Array is array (Nat) of Big_String_Ptr;
479 type Arg_Array_Ptr is access Arg_Array;
480 -- Types to access compiler arguments
483 pragma Import (C, save_argc);
484 -- Saved value of argc (number of arguments), imported from misc.c
486 save_argv : Arg_Array_Ptr;
487 pragma Import (C, save_argv);
488 -- Saved value of argv (argument pointers), imported from misc.c
491 -- Loop through arguments looking for -gnateT, also look for -gnatd.b
493 for Arg in 1 .. save_argc - 1 loop
495 Argv_Ptr : constant Big_String_Ptr := save_argv (Arg);
497 if Argv_Ptr (1 .. 7) = "-gnateT" then
498 Opt.Target_Dependent_Info_Read := True;
499 elsif Argv_Ptr (1 .. 8) = "-gnatd.b" then
500 Debug_Flag_Dot_B := True;
506 -- If the switch is not set, we get all values from the back end
508 if not Opt.Target_Dependent_Info_Read then
510 -- Set values set by direct calls to the back end
512 Bits_BE := Get_Bits_BE;
513 Bits_Per_Unit := Get_Bits_Per_Unit;
514 Bits_Per_Word := Get_Bits_Per_Word;
515 Bytes_BE := Get_Bytes_BE;
516 Char_Size := Get_Char_Size;
517 Double_Float_Alignment := Get_Double_Float_Alignment;
518 Double_Scalar_Alignment := Get_Double_Scalar_Alignment;
519 Double_Size := Get_Double_Size;
520 Float_Size := Get_Float_Size;
521 Float_Words_BE := Get_Float_Words_BE;
522 Int_Size := Get_Int_Size;
523 Long_Double_Size := Get_Long_Double_Size;
524 Long_Long_Size := Get_Long_Long_Size;
525 Long_Size := Get_Long_Size;
526 Maximum_Alignment := Get_Maximum_Alignment;
527 Max_Unaligned_Field := Get_Max_Unaligned_Field;
528 Pointer_Size := Get_Pointer_Size;
529 Short_Size := Get_Short_Size;
530 Strict_Alignment := Get_Strict_Alignment;
531 System_Allocator_Alignment := Get_System_Allocator_Alignment;
532 Wchar_T_Size := Get_Wchar_T_Size;
533 Words_BE := Get_Words_BE;
535 -- Register floating-point types from the back end
537 Register_Back_End_Types (Register_Float_Type'Access);
539 -- Case of reading the target dependent values from target.atp
541 -- This is bit more complex than might be expected, because it has to
542 -- be done very early. All kinds of packages depend on these values,
543 -- and we can't wait till the normal processing of reading command line
544 -- switches etc to read the file. We do this at the System.OS_Lib level
545 -- since it is too early to be using Osint directly.
549 File_Desc : File_Descriptor;
552 type ANat is access all Natural;
553 -- Pointer to Nat or Pos value (it is harmless to treat Pos values
554 -- as Nat via Unchecked_Conversion).
556 function To_ANat is new Unchecked_Conversion (Address, ANat);
560 Buffer : String (1 .. 2000);
562 -- File information and length (2000 easily enough!)
564 Nam_Buf : String (1 .. 40);
567 procedure Check_Spaces;
568 -- Checks that we have one or more spaces and skips them
570 procedure FailN (S : String);
571 -- Calls Fail prefixing "target.atp: " to the start of the given
572 -- string, and " name" to the end where name is the currently
573 -- gathered name in Nam_Buf, surrounded by quotes.
576 -- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls
577 -- Skip_Spaces to skip any following spaces. Note that the name is
578 -- terminated by a sequence of at least two spaces.
580 function Get_Nat return Natural;
581 -- N on entry points to decimal integer, scan out decimal integer
582 -- and return it, leaving N pointing to following space or LF.
584 procedure Skip_Spaces;
591 procedure Check_Spaces is
593 if N > Buflen or else Buffer (N) /= ' ' then
594 FailN ("missing space for");
605 procedure FailN (S : String) is
607 Fail ("target.atp: " & S & " """ & Nam_Buf (1 .. Nam_Len) & '"');
614 procedure Get_Name is
618 -- Scan out name and put it in Nam_Buf
621 if N > Buflen or else Buffer (N) = ASCII.LF then
622 FailN ("incorrectly formatted line
for");
625 -- Name is terminated by two blanks
627 exit when N < Buflen and then Buffer (N .. N + 1) = " ";
629 Nam_Len := Nam_Len + 1;
631 if Nam_Len > Nam_Buf'Last then
632 Fail ("name too long
");
635 Nam_Buf (Nam_Len) := Buffer (N);
646 function Get_Nat return Natural is
647 Result : Natural := 0;
652 or else Buffer (N) not in '0' .. '9'
655 FailN ("bad value
for");
658 Result := Result * 10 + (Character'Pos (Buffer (N)) - 48);
661 exit when N <= Buflen
662 and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' ');
672 procedure Skip_Spaces is
674 while N <= Buflen and Buffer (N) = ' ' loop
679 -- Start of processing for Read_File
682 File_Desc := Open_Read ("target
.atp
", Text);
684 if File_Desc = Invalid_FD then
685 Fail ("cannot read target
.atp file
");
688 Buflen := Read (File_Desc, Buffer'Address, Buffer'Length);
690 if Buflen = Buffer'Length then
691 Fail ("target
.atp file
is too long
");
694 -- Scan through file for properly formatted entries in first section
697 while N <= Buflen and then Buffer (N) /= ASCII.LF loop
700 -- Validate name and get corresponding value pointer
704 for J in DTN'Range loop
705 if DTN (J).all = Nam_Buf (1 .. Nam_Len) then
706 VP := To_ANat (DTV (J));
713 FailN ("unrecognized name
");
720 if N > Buflen or else Buffer (N) /= ASCII.LF then
721 FailN ("misformatted line
for");
724 N := N + 1; -- skip LF
727 -- Fall through this loop when all lines in first section read.
728 -- Check that values have been supplied for all entries.
730 for J in DTR'Range loop
732 Fail ("missing
entry in target
.atp
for " & DTN (J).all);
736 -- Now acquire FPT entries
739 Fail ("target
.atp
is missing entries
for FPT modes
");
742 if Buffer (N) = ASCII.LF then
745 Fail ("target
.atp
is missing blank line
");
749 while N <= Buflen loop
752 Num_FPT_Modes := Num_FPT_Modes + 1;
755 E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes);
758 E.NAME := new String'(Nam_Buf (1 .. Nam_Len));
765 E.FLOAT_REP := IEEE_Binary;
767 E.FLOAT_REP := VAX_Native;
771 FailN ("bad
float rep field
for");
780 E.ALIGNMENT := Get_Nat;
782 if Buffer (N) /= ASCII.LF then
783 FailN ("junk
at end of line
for");