1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Gnatvsn
; use Gnatvsn
;
33 with System
; use System
;
34 with Tree_IO
; use Tree_IO
;
38 SU
: constant := Storage_Unit
;
39 -- Shorthand for System.Storage_Unit
41 -------------------------
42 -- Back_End_Exceptions --
43 -------------------------
45 function Back_End_Exceptions
return Boolean is
48 Exception_Mechanism
= Back_End_SJLJ
50 Exception_Mechanism
= Back_End_ZCX
;
51 end Back_End_Exceptions
;
53 -------------------------
54 -- Front_End_Exceptions --
55 -------------------------
57 function Front_End_Exceptions
return Boolean is
59 return Exception_Mechanism
= Front_End_SJLJ
;
60 end Front_End_Exceptions
;
66 function SJLJ_Exceptions
return Boolean is
69 Exception_Mechanism
= Back_End_SJLJ
71 Exception_Mechanism
= Front_End_SJLJ
;
78 function ZCX_Exceptions
return Boolean is
80 return Exception_Mechanism
= Back_End_ZCX
;
83 ------------------------------
84 -- Register_Config_Switches --
85 ------------------------------
87 procedure Register_Config_Switches
is
89 Ada_Version_Config
:= Ada_Version
;
90 Ada_Version_Pragma_Config
:= Ada_Version_Pragma
;
91 Ada_Version_Explicit_Config
:= Ada_Version_Explicit
;
92 Assertions_Enabled_Config
:= Assertions_Enabled
;
93 Assume_No_Invalid_Values_Config
:= Assume_No_Invalid_Values
;
94 Check_Float_Overflow_Config
:= Check_Float_Overflow
;
95 Check_Policy_List_Config
:= Check_Policy_List
;
96 Default_Pool_Config
:= Default_Pool
;
97 Default_SSO_Config
:= Default_SSO
;
98 Dynamic_Elaboration_Checks_Config
:= Dynamic_Elaboration_Checks
;
99 Exception_Locations_Suppressed_Config
:= Exception_Locations_Suppressed
;
100 Extensions_Allowed_Config
:= Extensions_Allowed
;
101 External_Name_Exp_Casing_Config
:= External_Name_Exp_Casing
;
102 External_Name_Imp_Casing_Config
:= External_Name_Imp_Casing
;
103 Fast_Math_Config
:= Fast_Math
;
104 Initialize_Scalars_Config
:= Initialize_Scalars
;
105 No_Component_Reordering_Config
:= No_Component_Reordering
;
106 Optimize_Alignment_Config
:= Optimize_Alignment
;
107 Persistent_BSS_Mode_Config
:= Persistent_BSS_Mode
;
108 Polling_Required_Config
:= Polling_Required
;
109 Prefix_Exception_Messages_Config
:= Prefix_Exception_Messages
;
110 SPARK_Mode_Config
:= SPARK_Mode
;
111 SPARK_Mode_Pragma_Config
:= SPARK_Mode_Pragma
;
112 Uneval_Old_Config
:= Uneval_Old
;
113 Use_VADS_Size_Config
:= Use_VADS_Size
;
114 Warnings_As_Errors_Count_Config
:= Warnings_As_Errors_Count
;
116 -- Reset the indication that Optimize_Alignment was set locally, since
117 -- if we had a pragma in the config file, it would set this flag True,
118 -- but that's not a local setting.
120 Optimize_Alignment_Local
:= False;
121 end Register_Config_Switches
;
123 -----------------------------
124 -- Restore_Config_Switches --
125 -----------------------------
127 procedure Restore_Config_Switches
(Save
: Config_Switches_Type
) is
129 Ada_Version
:= Save
.Ada_Version
;
130 Ada_Version_Pragma
:= Save
.Ada_Version_Pragma
;
131 Ada_Version_Explicit
:= Save
.Ada_Version_Explicit
;
132 Assertions_Enabled
:= Save
.Assertions_Enabled
;
133 Assume_No_Invalid_Values
:= Save
.Assume_No_Invalid_Values
;
134 Check_Float_Overflow
:= Save
.Check_Float_Overflow
;
135 Check_Policy_List
:= Save
.Check_Policy_List
;
136 Default_Pool
:= Save
.Default_Pool
;
137 Default_SSO
:= Save
.Default_SSO
;
138 Dynamic_Elaboration_Checks
:= Save
.Dynamic_Elaboration_Checks
;
139 Exception_Locations_Suppressed
:= Save
.Exception_Locations_Suppressed
;
140 Extensions_Allowed
:= Save
.Extensions_Allowed
;
141 External_Name_Exp_Casing
:= Save
.External_Name_Exp_Casing
;
142 External_Name_Imp_Casing
:= Save
.External_Name_Imp_Casing
;
143 Fast_Math
:= Save
.Fast_Math
;
144 Initialize_Scalars
:= Save
.Initialize_Scalars
;
145 No_Component_Reordering
:= Save
.No_Component_Reordering
;
146 Optimize_Alignment
:= Save
.Optimize_Alignment
;
147 Optimize_Alignment_Local
:= Save
.Optimize_Alignment_Local
;
148 Persistent_BSS_Mode
:= Save
.Persistent_BSS_Mode
;
149 Polling_Required
:= Save
.Polling_Required
;
150 Prefix_Exception_Messages
:= Save
.Prefix_Exception_Messages
;
151 SPARK_Mode
:= Save
.SPARK_Mode
;
152 SPARK_Mode_Pragma
:= Save
.SPARK_Mode_Pragma
;
153 Uneval_Old
:= Save
.Uneval_Old
;
154 Use_VADS_Size
:= Save
.Use_VADS_Size
;
155 Warnings_As_Errors_Count
:= Save
.Warnings_As_Errors_Count
;
157 -- Update consistently the value of Init_Or_Norm_Scalars. The value of
158 -- Normalize_Scalars is not saved/restored because after set to True its
159 -- value is never changed. That is, if a compilation unit has pragma
160 -- Normalize_Scalars then it forces that value for all with'ed units.
162 Init_Or_Norm_Scalars
:= Initialize_Scalars
or Normalize_Scalars
;
163 end Restore_Config_Switches
;
165 --------------------------
166 -- Save_Config_Switches --
167 --------------------------
169 function Save_Config_Switches
return Config_Switches_Type
is
172 (Ada_Version
=> Ada_Version
,
173 Ada_Version_Pragma
=> Ada_Version_Pragma
,
174 Ada_Version_Explicit
=> Ada_Version_Explicit
,
175 Assertions_Enabled
=> Assertions_Enabled
,
176 Assume_No_Invalid_Values
=> Assume_No_Invalid_Values
,
177 Check_Float_Overflow
=> Check_Float_Overflow
,
178 Check_Policy_List
=> Check_Policy_List
,
179 Default_Pool
=> Default_Pool
,
180 Default_SSO
=> Default_SSO
,
181 Dynamic_Elaboration_Checks
=> Dynamic_Elaboration_Checks
,
182 Exception_Locations_Suppressed
=> Exception_Locations_Suppressed
,
183 Extensions_Allowed
=> Extensions_Allowed
,
184 External_Name_Exp_Casing
=> External_Name_Exp_Casing
,
185 External_Name_Imp_Casing
=> External_Name_Imp_Casing
,
186 Fast_Math
=> Fast_Math
,
187 Initialize_Scalars
=> Initialize_Scalars
,
188 No_Component_Reordering
=> No_Component_Reordering
,
189 Normalize_Scalars
=> Normalize_Scalars
,
190 Optimize_Alignment
=> Optimize_Alignment
,
191 Optimize_Alignment_Local
=> Optimize_Alignment_Local
,
192 Persistent_BSS_Mode
=> Persistent_BSS_Mode
,
193 Polling_Required
=> Polling_Required
,
194 Prefix_Exception_Messages
=> Prefix_Exception_Messages
,
195 SPARK_Mode
=> SPARK_Mode
,
196 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
,
197 Uneval_Old
=> Uneval_Old
,
198 Use_VADS_Size
=> Use_VADS_Size
,
199 Warnings_As_Errors_Count
=> Warnings_As_Errors_Count
);
200 end Save_Config_Switches
;
202 -------------------------
203 -- Set_Config_Switches --
204 -------------------------
206 procedure Set_Config_Switches
207 (Internal_Unit
: Boolean;
211 -- Case of internal unit
213 if Internal_Unit
then
215 -- Set standard switches. Note we do NOT set Ada_Version_Explicit
216 -- since the whole point of this is that it still properly indicates
217 -- the configuration setting even in a run time unit.
219 Ada_Version
:= Ada_Version_Runtime
;
220 Ada_Version_Pragma
:= Empty
;
222 Dynamic_Elaboration_Checks
:= False;
223 Extensions_Allowed
:= True;
224 External_Name_Exp_Casing
:= As_Is
;
225 External_Name_Imp_Casing
:= Lowercase
;
226 No_Component_Reordering
:= False;
227 Optimize_Alignment
:= 'O';
228 Optimize_Alignment_Local
:= True;
229 Persistent_BSS_Mode
:= False;
230 Prefix_Exception_Messages
:= True;
232 Use_VADS_Size
:= False;
234 -- Note: we do not need to worry about Warnings_As_Errors_Count since
235 -- we do not expect to get any warnings from compiling such a unit.
237 -- For an internal unit, assertions/debug pragmas are off unless this
238 -- is the main unit and they were explicitly enabled, or unless the
239 -- main unit was compiled in GNAT mode. We also make sure we do not
240 -- assume that values are necessarily valid and that SPARK_Mode is
241 -- set to its configuration value.
244 Assertions_Enabled
:= Assertions_Enabled_Config
;
245 Assume_No_Invalid_Values
:= Assume_No_Invalid_Values_Config
;
246 Check_Policy_List
:= Check_Policy_List_Config
;
247 SPARK_Mode
:= SPARK_Mode_Config
;
248 SPARK_Mode_Pragma
:= SPARK_Mode_Pragma_Config
;
251 -- In GNATprove mode assertions should be always enabled, even
252 -- when analysing internal units.
254 if GNATprove_Mode
then
255 pragma Assert
(Assertions_Enabled
);
258 elsif GNAT_Mode_Config
then
259 Assertions_Enabled
:= Assertions_Enabled_Config
;
261 Assertions_Enabled
:= False;
264 Assume_No_Invalid_Values
:= False;
265 Check_Policy_List
:= Empty
;
267 SPARK_Mode_Pragma
:= Empty
;
270 -- Case of non-internal unit
273 Ada_Version
:= Ada_Version_Config
;
274 Ada_Version_Pragma
:= Ada_Version_Pragma_Config
;
275 Ada_Version_Explicit
:= Ada_Version_Explicit_Config
;
276 Assertions_Enabled
:= Assertions_Enabled_Config
;
277 Assume_No_Invalid_Values
:= Assume_No_Invalid_Values_Config
;
278 Check_Float_Overflow
:= Check_Float_Overflow_Config
;
279 Check_Policy_List
:= Check_Policy_List_Config
;
280 Default_SSO
:= Default_SSO_Config
;
281 Dynamic_Elaboration_Checks
:= Dynamic_Elaboration_Checks_Config
;
282 Extensions_Allowed
:= Extensions_Allowed_Config
;
283 External_Name_Exp_Casing
:= External_Name_Exp_Casing_Config
;
284 External_Name_Imp_Casing
:= External_Name_Imp_Casing_Config
;
285 Fast_Math
:= Fast_Math_Config
;
286 Initialize_Scalars
:= Initialize_Scalars_Config
;
287 No_Component_Reordering
:= No_Component_Reordering_Config
;
288 Optimize_Alignment
:= Optimize_Alignment_Config
;
289 Optimize_Alignment_Local
:= False;
290 Persistent_BSS_Mode
:= Persistent_BSS_Mode_Config
;
291 Prefix_Exception_Messages
:= Prefix_Exception_Messages_Config
;
292 SPARK_Mode
:= SPARK_Mode_Config
;
293 SPARK_Mode_Pragma
:= SPARK_Mode_Pragma_Config
;
294 Uneval_Old
:= Uneval_Old_Config
;
295 Use_VADS_Size
:= Use_VADS_Size_Config
;
296 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count_Config
;
298 -- Update consistently the value of Init_Or_Norm_Scalars. The value
299 -- of Normalize_Scalars is not saved/restored because once set to
300 -- True its value is never changed. That is, if a compilation unit
301 -- has pragma Normalize_Scalars then it forces that value for all
304 Init_Or_Norm_Scalars
:= Initialize_Scalars
or Normalize_Scalars
;
307 -- Values set for all units
309 Default_Pool
:= Default_Pool_Config
;
310 Exception_Locations_Suppressed
:= Exception_Locations_Suppressed_Config
;
311 Fast_Math
:= Fast_Math_Config
;
312 Polling_Required
:= Polling_Required_Config
;
313 end Set_Config_Switches
;
319 procedure Tree_Read
is
320 Tree_Version_String_Len
: Nat
;
321 Ada_Version_Config_Val
: Nat
;
322 Ada_Version_Explicit_Config_Val
: Nat
;
323 Assertions_Enabled_Config_Val
: Nat
;
326 Tree_Read_Int
(Tree_ASIS_Version_Number
);
328 Tree_Read_Bool
(Address_Is_Private
);
329 Tree_Read_Bool
(Brief_Output
);
330 Tree_Read_Bool
(GNAT_Mode
);
331 Tree_Read_Char
(Identifier_Character_Set
);
332 Tree_Read_Bool
(Ignore_Rep_Clauses
);
333 Tree_Read_Bool
(Ignore_Style_Checks_Pragmas
);
334 Tree_Read_Int
(Maximum_File_Name_Length
);
335 Tree_Read_Data
(Suppress_Options
'Address,
336 (Suppress_Options
'Size + SU
- 1) / SU
);
337 Tree_Read_Bool
(Verbose_Mode
);
338 Tree_Read_Data
(Warning_Mode
'Address,
339 (Warning_Mode
'Size + SU
- 1) / SU
);
340 Tree_Read_Int
(Ada_Version_Config_Val
);
341 Tree_Read_Int
(Ada_Version_Explicit_Config_Val
);
342 Tree_Read_Int
(Assertions_Enabled_Config_Val
);
343 Tree_Read_Bool
(All_Errors_Mode
);
344 Tree_Read_Bool
(Assertions_Enabled
);
345 Tree_Read_Bool
(Check_Float_Overflow
);
346 Tree_Read_Int
(Int
(Check_Policy_List
));
347 Tree_Read_Int
(Int
(Default_Pool
));
348 Tree_Read_Bool
(Full_List
);
350 Ada_Version_Config
:=
351 Ada_Version_Type
'Val (Ada_Version_Config_Val
);
352 Ada_Version_Explicit_Config
:=
353 Ada_Version_Type
'Val (Ada_Version_Explicit_Config_Val
);
354 Assertions_Enabled_Config
:=
355 Boolean'Val (Assertions_Enabled_Config_Val
);
357 -- Read version string: we have to get the length first
359 Tree_Read_Int
(Tree_Version_String_Len
);
362 Tmp
: String (1 .. Integer (Tree_Version_String_Len
));
365 (Tmp
'Address, Tree_Version_String_Len
);
366 System
.Strings
.Free
(Tree_Version_String
);
367 Free
(Tree_Version_String
);
368 Tree_Version_String
:= new String'(Tmp);
371 Tree_Read_Data (Distribution_Stub_Mode'Address,
372 (Distribution_Stub_Mode'Size + SU - 1) / Storage_Unit);
373 Tree_Read_Bool (Inline_Active);
374 Tree_Read_Bool (Inline_Processing_Required);
375 Tree_Read_Bool (List_Units);
376 Tree_Read_Int (Multiple_Unit_Index);
377 Tree_Read_Bool (Configurable_Run_Time_Mode);
378 Tree_Read_Data (Operating_Mode'Address,
379 (Operating_Mode'Size + SU - 1) / Storage_Unit);
380 Tree_Read_Bool (Suppress_Checks);
381 Tree_Read_Bool (Try_Semantics);
382 Tree_Read_Data (Wide_Character_Encoding_Method'Address,
383 (Wide_Character_Encoding_Method'Size + SU - 1) / SU);
384 Tree_Read_Bool (Upper_Half_Encoding);
385 Tree_Read_Bool (Force_ALI_Tree_File);
392 procedure Tree_Write is
393 Version_String : String := Gnat_Version_String;
396 Tree_Write_Int (ASIS_Version_Number);
398 Tree_Write_Bool (Address_Is_Private);
399 Tree_Write_Bool (Brief_Output);
400 Tree_Write_Bool (GNAT_Mode);
401 Tree_Write_Char (Identifier_Character_Set);
402 Tree_Write_Bool (Ignore_Rep_Clauses);
403 Tree_Write_Bool (Ignore_Style_Checks_Pragmas);
404 Tree_Write_Int (Maximum_File_Name_Length);
405 Tree_Write_Data (Suppress_Options'Address,
406 (Suppress_Options'Size + SU - 1) / SU);
407 Tree_Write_Bool (Verbose_Mode);
408 Tree_Write_Data (Warning_Mode'Address,
409 (Warning_Mode'Size + SU - 1) / Storage_Unit);
410 Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Config));
411 Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Explicit_Config));
412 Tree_Write_Int (Boolean'Pos (Assertions_Enabled_Config));
413 Tree_Write_Bool (All_Errors_Mode);
414 Tree_Write_Bool (Assertions_Enabled);
415 Tree_Write_Bool (Check_Float_Overflow);
416 Tree_Write_Int (Int (Check_Policy_List));
417 Tree_Write_Int (Int (Default_Pool));
418 Tree_Write_Bool (Full_List);
419 Tree_Write_Int (Int (Version_String'Length));
420 Tree_Write_Data (Version_String'Address, Version_String'Length);
421 Tree_Write_Data (Distribution_Stub_Mode'Address,
422 (Distribution_Stub_Mode'Size + SU - 1) / SU);
423 Tree_Write_Bool (Inline_Active);
424 Tree_Write_Bool (Inline_Processing_Required);
425 Tree_Write_Bool (List_Units);
426 Tree_Write_Int (Multiple_Unit_Index);
427 Tree_Write_Bool (Configurable_Run_Time_Mode);
428 Tree_Write_Data (Operating_Mode'Address,
429 (Operating_Mode'Size + SU - 1) / SU);
430 Tree_Write_Bool (Suppress_Checks);
431 Tree_Write_Bool (Try_Semantics);
432 Tree_Write_Data (Wide_Character_Encoding_Method'Address,
433 (Wide_Character_Encoding_Method'Size + SU - 1) / SU);
434 Tree_Write_Bool (Upper_Half_Encoding);
435 Tree_Write_Bool (Force_ALI_Tree_File);