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