1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                  O P T                                   --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2019, 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.                                     --
17--                                                                          --
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.               --
21--                                                                          --
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/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32with Gnatvsn; use Gnatvsn;
33with System;  use System;
34with Tree_IO; use Tree_IO;
35
36package body Opt is
37
38   SU : constant := Storage_Unit;
39   --  Shorthand for System.Storage_Unit
40
41   -------------------------
42   -- Back_End_Exceptions --
43   -------------------------
44
45   function Back_End_Exceptions return Boolean is
46   begin
47      return
48        Exception_Mechanism = Back_End_SJLJ
49          or else
50        Exception_Mechanism = Back_End_ZCX;
51   end Back_End_Exceptions;
52
53   -------------------------
54   -- Front_End_Exceptions --
55   -------------------------
56
57   function Front_End_Exceptions return Boolean is
58   begin
59      return Exception_Mechanism = Front_End_SJLJ;
60   end Front_End_Exceptions;
61
62   --------------------
63   -- SJLJ_Exceptions --
64   --------------------
65
66   function SJLJ_Exceptions return Boolean is
67   begin
68      return
69        Exception_Mechanism = Back_End_SJLJ
70          or else
71        Exception_Mechanism = Front_End_SJLJ;
72   end SJLJ_Exceptions;
73
74   --------------------
75   -- ZCX_Exceptions --
76   --------------------
77
78   function ZCX_Exceptions return Boolean is
79   begin
80      return Exception_Mechanism = Back_End_ZCX;
81   end ZCX_Exceptions;
82
83   ------------------------------
84   -- Register_Config_Switches --
85   ------------------------------
86
87   procedure Register_Config_Switches is
88   begin
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;
115
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.
119
120      Optimize_Alignment_Local := False;
121   end Register_Config_Switches;
122
123   -----------------------------
124   -- Restore_Config_Switches --
125   -----------------------------
126
127   procedure Restore_Config_Switches (Save : Config_Switches_Type) is
128   begin
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;
156
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.
161
162      Init_Or_Norm_Scalars := Initialize_Scalars or Normalize_Scalars;
163   end Restore_Config_Switches;
164
165   --------------------------
166   -- Save_Config_Switches --
167   --------------------------
168
169   function Save_Config_Switches return Config_Switches_Type is
170   begin
171      return
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;
201
202   -------------------------
203   -- Set_Config_Switches --
204   -------------------------
205
206   procedure Set_Config_Switches
207     (Internal_Unit : Boolean;
208      Main_Unit     : Boolean)
209   is
210   begin
211      --  Case of internal unit
212
213      if Internal_Unit then
214
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.
218
219         Ada_Version                 := Ada_Version_Runtime;
220         Ada_Version_Pragma          := Empty;
221         Default_SSO                 := ' ';
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;
231         Uneval_Old                  := 'E';
232         Use_VADS_Size               := False;
233
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.
236
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.
242
243         if Main_Unit then
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;
249
250         else
251            if GNAT_Mode_Config then
252               Assertions_Enabled    := Assertions_Enabled_Config;
253            else
254               Assertions_Enabled    := False;
255            end if;
256
257            Assume_No_Invalid_Values := False;
258            Check_Policy_List        := Empty;
259            SPARK_Mode               := None;
260            SPARK_Mode_Pragma        := Empty;
261         end if;
262
263      --  Case of non-internal unit
264
265      else
266         Ada_Version                 := Ada_Version_Config;
267         Ada_Version_Pragma          := Ada_Version_Pragma_Config;
268         Ada_Version_Explicit        := Ada_Version_Explicit_Config;
269         Assertions_Enabled          := Assertions_Enabled_Config;
270         Assume_No_Invalid_Values    := Assume_No_Invalid_Values_Config;
271         Check_Float_Overflow        := Check_Float_Overflow_Config;
272         Check_Policy_List           := Check_Policy_List_Config;
273         Default_SSO                 := Default_SSO_Config;
274         Dynamic_Elaboration_Checks  := Dynamic_Elaboration_Checks_Config;
275         Extensions_Allowed          := Extensions_Allowed_Config;
276         External_Name_Exp_Casing    := External_Name_Exp_Casing_Config;
277         External_Name_Imp_Casing    := External_Name_Imp_Casing_Config;
278         Fast_Math                   := Fast_Math_Config;
279         Initialize_Scalars          := Initialize_Scalars_Config;
280         No_Component_Reordering     := No_Component_Reordering_Config;
281         Optimize_Alignment          := Optimize_Alignment_Config;
282         Optimize_Alignment_Local    := False;
283         Persistent_BSS_Mode         := Persistent_BSS_Mode_Config;
284         Prefix_Exception_Messages   := Prefix_Exception_Messages_Config;
285         SPARK_Mode                  := SPARK_Mode_Config;
286         SPARK_Mode_Pragma           := SPARK_Mode_Pragma_Config;
287         Uneval_Old                  := Uneval_Old_Config;
288         Use_VADS_Size               := Use_VADS_Size_Config;
289         Warnings_As_Errors_Count    := Warnings_As_Errors_Count_Config;
290
291         --  Update consistently the value of Init_Or_Norm_Scalars. The value
292         --  of Normalize_Scalars is not saved/restored because once set to
293         --  True its value is never changed. That is, if a compilation unit
294         --  has pragma Normalize_Scalars then it forces that value for all
295         --  with'ed units.
296
297         Init_Or_Norm_Scalars := Initialize_Scalars or Normalize_Scalars;
298      end if;
299
300      --  Values set for all units
301
302      Default_Pool                   := Default_Pool_Config;
303      Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config;
304      Fast_Math                      := Fast_Math_Config;
305      Polling_Required               := Polling_Required_Config;
306   end Set_Config_Switches;
307
308   ---------------
309   -- Tree_Read --
310   ---------------
311
312   procedure Tree_Read is
313      Tree_Version_String_Len         : Nat;
314      Ada_Version_Config_Val          : Nat;
315      Ada_Version_Explicit_Config_Val : Nat;
316      Assertions_Enabled_Config_Val   : Nat;
317
318   begin
319      Tree_Read_Int  (Tree_ASIS_Version_Number);
320
321      Tree_Read_Bool (Address_Is_Private);
322      Tree_Read_Bool (Brief_Output);
323      Tree_Read_Bool (GNAT_Mode);
324      Tree_Read_Char (Identifier_Character_Set);
325      Tree_Read_Bool (Ignore_Rep_Clauses);
326      Tree_Read_Bool (Ignore_Style_Checks_Pragmas);
327      Tree_Read_Int  (Maximum_File_Name_Length);
328      Tree_Read_Data (Suppress_Options'Address,
329                      (Suppress_Options'Size + SU - 1) / SU);
330      Tree_Read_Bool (Verbose_Mode);
331      Tree_Read_Data (Warning_Mode'Address,
332                      (Warning_Mode'Size + SU - 1) / SU);
333      Tree_Read_Int  (Ada_Version_Config_Val);
334      Tree_Read_Int  (Ada_Version_Explicit_Config_Val);
335      Tree_Read_Int  (Assertions_Enabled_Config_Val);
336      Tree_Read_Bool (All_Errors_Mode);
337      Tree_Read_Bool (Assertions_Enabled);
338      Tree_Read_Bool (Check_Float_Overflow);
339      Tree_Read_Int  (Int (Check_Policy_List));
340      Tree_Read_Int  (Int (Default_Pool));
341      Tree_Read_Bool (Full_List);
342
343      Ada_Version_Config :=
344        Ada_Version_Type'Val (Ada_Version_Config_Val);
345      Ada_Version_Explicit_Config :=
346        Ada_Version_Type'Val (Ada_Version_Explicit_Config_Val);
347      Assertions_Enabled_Config :=
348        Boolean'Val (Assertions_Enabled_Config_Val);
349
350      --  Read version string: we have to get the length first
351
352      Tree_Read_Int (Tree_Version_String_Len);
353
354      declare
355         Tmp : String (1 .. Integer (Tree_Version_String_Len));
356      begin
357         Tree_Read_Data
358           (Tmp'Address, Tree_Version_String_Len);
359         System.Strings.Free (Tree_Version_String);
360         Free (Tree_Version_String);
361         Tree_Version_String := new String'(Tmp);
362      end;
363
364      Tree_Read_Data (Distribution_Stub_Mode'Address,
365                      (Distribution_Stub_Mode'Size + SU - 1) / Storage_Unit);
366      Tree_Read_Bool (Inline_Active);
367      Tree_Read_Bool (Inline_Processing_Required);
368      Tree_Read_Bool (List_Units);
369      Tree_Read_Int  (Multiple_Unit_Index);
370      Tree_Read_Bool (Configurable_Run_Time_Mode);
371      Tree_Read_Data (Operating_Mode'Address,
372                      (Operating_Mode'Size + SU - 1) / Storage_Unit);
373      Tree_Read_Bool (Suppress_Checks);
374      Tree_Read_Bool (Try_Semantics);
375      Tree_Read_Data (Wide_Character_Encoding_Method'Address,
376                      (Wide_Character_Encoding_Method'Size + SU - 1) / SU);
377      Tree_Read_Bool (Upper_Half_Encoding);
378      Tree_Read_Bool (Force_ALI_Tree_File);
379   end Tree_Read;
380
381   ----------------
382   -- Tree_Write --
383   ----------------
384
385   procedure Tree_Write is
386      Version_String : String := Gnat_Version_String;
387
388   begin
389      Tree_Write_Int  (ASIS_Version_Number);
390
391      Tree_Write_Bool (Address_Is_Private);
392      Tree_Write_Bool (Brief_Output);
393      Tree_Write_Bool (GNAT_Mode);
394      Tree_Write_Char (Identifier_Character_Set);
395      Tree_Write_Bool (Ignore_Rep_Clauses);
396      Tree_Write_Bool (Ignore_Style_Checks_Pragmas);
397      Tree_Write_Int  (Maximum_File_Name_Length);
398      Tree_Write_Data (Suppress_Options'Address,
399                       (Suppress_Options'Size + SU - 1) / SU);
400      Tree_Write_Bool (Verbose_Mode);
401      Tree_Write_Data (Warning_Mode'Address,
402                       (Warning_Mode'Size + SU - 1) / Storage_Unit);
403      Tree_Write_Int  (Ada_Version_Type'Pos (Ada_Version_Config));
404      Tree_Write_Int  (Ada_Version_Type'Pos (Ada_Version_Explicit_Config));
405      Tree_Write_Int  (Boolean'Pos (Assertions_Enabled_Config));
406      Tree_Write_Bool (All_Errors_Mode);
407      Tree_Write_Bool (Assertions_Enabled);
408      Tree_Write_Bool (Check_Float_Overflow);
409      Tree_Write_Int  (Int (Check_Policy_List));
410      Tree_Write_Int  (Int (Default_Pool));
411      Tree_Write_Bool (Full_List);
412      Tree_Write_Int  (Int (Version_String'Length));
413      Tree_Write_Data (Version_String'Address, Version_String'Length);
414      Tree_Write_Data (Distribution_Stub_Mode'Address,
415                       (Distribution_Stub_Mode'Size + SU - 1) / SU);
416      Tree_Write_Bool (Inline_Active);
417      Tree_Write_Bool (Inline_Processing_Required);
418      Tree_Write_Bool (List_Units);
419      Tree_Write_Int  (Multiple_Unit_Index);
420      Tree_Write_Bool (Configurable_Run_Time_Mode);
421      Tree_Write_Data (Operating_Mode'Address,
422                       (Operating_Mode'Size + SU - 1) / SU);
423      Tree_Write_Bool (Suppress_Checks);
424      Tree_Write_Bool (Try_Semantics);
425      Tree_Write_Data (Wide_Character_Encoding_Method'Address,
426                       (Wide_Character_Encoding_Method'Size + SU - 1) / SU);
427      Tree_Write_Bool (Upper_Half_Encoding);
428      Tree_Write_Bool (Force_ALI_Tree_File);
429   end Tree_Write;
430
431end Opt;
432