opt.ads, opt.adb: Add new switches Debug_Pragmas_Enabled[_Config]

2005-09-01  Robert Dewar  <dewar@adacore.com>

	* opt.ads, opt.adb: Add new switches Debug_Pragmas_Enabled[_Config]

	* par-prag.adb: Implement new pragma Debug_Policy

	* sem_prag.adb Implement new pragma Debug_Policy
	(Analyze_Pragma, case Pack): do not let pragma Pack override an explicit
	Component_Size attribute specification. Give warning for ignored pragma
	Pack.

	* snames.h, snames.ads, snames.adb: Introduce entries in
	Preset_Names for Name_Disp_Asynchronous_Select,
	Name_Disp_Conditional_Select, Name_Disp_Get_Prim_Op_Kind,
	Name_Disp_Timed_Select.
	New pragma Debug_Policy

	* switch-c.adb (Scan_Front_End_Switches): Set Ada 2005 mode
	explicitly.
	Switch -gnata also sets Debug_Pragmas_Enabled

	* sem.adb, par.adb (Set_Opt_Config_Switch): Add parameter Main_Unit to
	handle an explicit -gnata when compiling predefined files.

From-SVN: r103873

gcc/ada/opt.adb

@@ -31,7 +31,6 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Gnatvsn; use Gnatvsn;
 with System;  use System;
 with Tree_IO; use Tree_IO;
 
@@ -52,6 +51,7 @@ package body Opt is
       Ada_Version_Config                    := Ada_Version;
       Ada_Version_Explicit_Config           := Ada_Version_Explicit;
       Assertions_Enabled_Config             := Assertions_Enabled;
+      Debug_Pragmas_Enabled_Config          := Debug_Pragmas_Enabled;
       Dynamic_Elaboration_Checks_Config     := Dynamic_Elaboration_Checks;
       Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed;
       Extensions_Allowed_Config             := Extensions_Allowed;
@@ -71,6 +71,7 @@ package body Opt is
       Ada_Version                    := Save.Ada_Version;
       Ada_Version_Explicit           := Save.Ada_Version_Explicit;
       Assertions_Enabled             := Save.Assertions_Enabled;
+      Debug_Pragmas_Enabled          := Save.Debug_Pragmas_Enabled;
       Dynamic_Elaboration_Checks     := Save.Dynamic_Elaboration_Checks;
       Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed;
       Extensions_Allowed             := Save.Extensions_Allowed;
@@ -90,6 +91,7 @@ package body Opt is
       Save.Ada_Version                    := Ada_Version;
       Save.Ada_Version_Explicit           := Ada_Version_Explicit;
       Save.Assertions_Enabled             := Assertions_Enabled;
+      Save.Debug_Pragmas_Enabled          := Debug_Pragmas_Enabled;
       Save.Dynamic_Elaboration_Checks     := Dynamic_Elaboration_Checks;
       Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed;
       Save.Extensions_Allowed             := Extensions_Allowed;
@@ -104,11 +106,15 @@ package body Opt is
    -- Set_Opt_Config_Switches --
    -----------------------------
 
-   procedure Set_Opt_Config_Switches (Internal_Unit : Boolean) is
+   procedure Set_Opt_Config_Switches
+     (Internal_Unit : Boolean;
+      Main_Unit     : Boolean)
+   is
    begin
+      --  Case of internal unit
+
       if Internal_Unit then
          Ada_Version                := Ada_Version_Runtime;
-         Assertions_Enabled         := False;
          Dynamic_Elaboration_Checks := False;
          Extensions_Allowed         := True;
          External_Name_Exp_Casing   := As_Is;
@@ -116,9 +122,23 @@ package body Opt is
          Persistent_BSS_Mode        := False;
          Use_VADS_Size              := False;
 
+         --  For an internal unit, assertions/debug pragmas are off unless this
+         --  is the main unit and they were explicitly enabled.
+
+         if Main_Unit then
+            Assertions_Enabled := Assertions_Enabled_Config;
+            Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config;
+         else
+            Assertions_Enabled := False;
+            Debug_Pragmas_Enabled := False;
+         end if;
+
+      --  Case of non-internal unit
+
       else
          Ada_Version                := Ada_Version_Config;
          Assertions_Enabled         := Assertions_Enabled_Config;
+         Debug_Pragmas_Enabled      := Debug_Pragmas_Enabled_Config;
          Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config;
          Extensions_Allowed         := Extensions_Allowed_Config;
          External_Name_Exp_Casing   := External_Name_Exp_Casing_Config;
@@ -158,6 +178,7 @@ package body Opt is
       Tree_Read_Int  (Assertions_Enabled_Config_Val);
       Tree_Read_Bool (All_Errors_Mode);
       Tree_Read_Bool (Assertions_Enabled);
+      Tree_Read_Bool (Debug_Pragmas_Enabled);
       Tree_Read_Bool (Enable_Overflow_Checks);
       Tree_Read_Bool (Full_List);
 
@@ -226,6 +247,7 @@ package body Opt is
       Tree_Write_Int  (Boolean'Pos (Assertions_Enabled_Config));
       Tree_Write_Bool (All_Errors_Mode);
       Tree_Write_Bool (Assertions_Enabled);
+      Tree_Write_Bool (Debug_Pragmas_Enabled);
       Tree_Write_Bool (Enable_Overflow_Checks);
       Tree_Write_Bool (Full_List);
       Tree_Write_Int  (Int (Version_String'Length));

gcc/ada/opt.ads

@@ -272,6 +272,10 @@ package Opt is
    --  Set to True (-C switch) to indicate that gnatmake will invoke
    --  the compiler with a mapping file (-gnatem compiler switch).
 
+   Debug_Pragmas_Enabled : Boolean := False;
+   --  GNAT
+   --  Enable debug statements from pragma Debug
+
    subtype Debug_Level_Value is Nat range 0 .. 3;
    Debugger_Level : Debug_Level_Value := 0;
    --  GNATBIND
@@ -367,31 +371,19 @@ package Opt is
       --  the code generator). AT END handlers are converted into
       --  exception handlers by the front end in this mode.
 
-      Front_End_ZCX_Exceptions,
-      --  Exceptions use the zero cost table mechanism with explicit
-      --  tables and exception regions generated by the front end.
-      --  AT END handlers are converted into exception handlers by
-      --  the front end in this mode.
-
-      Back_End_ZCX_Exceptions);
+      Back_End_Exceptions);
       --  Exceptions are handled by the back end. The front end simply
       --  generates the handlers as they appear in the source, and AT
       --  END handlers are left untouched (they are not converted into
-      --  exception handlers when operating in this mode. Note that the
-      --  name includes ZCX, since the expectation is that the back end
-      --  mechanism will in fact be a ZCX approach, but nothing in the
-      --  compiler depends on this, so for example if GNAT is run with
-      --  a version of GCC configured for setjmp/longjmp exception handling,
-      --  then everything will work fine.
+      --  exception handlers when operating in this mode.
    pragma Convention (C, Exception_Mechanism_Type);
 
    Exception_Mechanism : Exception_Mechanism_Type :=
                            Front_End_Setjmp_Longjmp_Exceptions;
    --  GNAT
    --  Set to the appropriate value depending on the default as given in
-   --  system.ads (ZCX_By_Default, GCC_ZCX_Support, Front_End_ZCX_Support) and
-   --  the use of -gnatL -gnatZ (and -gnatdX). The C convention is there to
-   --  make this variable accessible to gigi.
+   --  system.ads (ZCX_By_Default, GCC_ZCX_Support).
+   --  The C convention is there to make this variable accessible to gigi.
 
    Exception_Tracebacks : Boolean := False;
    --  GNATBIND
@@ -1122,14 +1114,6 @@ package Opt is
    --  GNAT
    --  Set if cross-referencing is enabled (i.e. xref info in ALI files)
 
-   Zero_Cost_Exceptions_Val : Boolean;
-   Zero_Cost_Exceptions_Set : Boolean := False;
-   --  GNAT
-   --  These values are to record the setting of the zero cost exception
-   --  handling mode set by argument switches (-gnatZ/-gnatL). If the value is
-   --  set by one of these switches, then Zero_Cost_Exceptions_Set is set to
-   --  True, and Zero_Cost_Exceptions_Val indicates the setting.
-
    ----------------------------
    -- Configuration Settings --
    ----------------------------
@@ -1160,6 +1144,12 @@ package Opt is
    --  mode, as possibly set by the command line switch -gnata, and possibly
    --  modified by the use of the configuration pragma Assertion_Policy.
 
+   Debug_Pragmas_Enabled_Config : Boolean;
+   --  GNAT
+   --  This is the value of the configuration switch for debug pragmas enabled
+   --  mode, as possibly set by the command line switch -gnata and possibly
+   --  modified by the use of the configuration pragma Debug_Policy.
+
    Dynamic_Elaboration_Checks_Config : Boolean := False;
    --  GNAT
    --  Set True for dynamic elaboration checking mode, as set by the -gnatE
@@ -1234,10 +1224,16 @@ package Opt is
    --  initialized from the above Config values, and then resets these switches
    --  according to the Config value settings.
 
-   procedure Set_Opt_Config_Switches (Internal_Unit : Boolean);
+   procedure Set_Opt_Config_Switches
+     (Internal_Unit : Boolean;
+      Main_Unit     : Boolean);
    --  This procedure sets the switches to the appropriate initial values. The
    --  parameter Internal_Unit is True for an internal or predefined unit, and
-   --  affects the way the switches are set (see above).
+   --  affects the way the switches are set (see above). Main_Unit is true if
+   --  switches are being set for the main unit (this affects setting of the
+   --  assert/debug pragm switches, which are normally set false by default for
+   --  an internal unit, except when the internal unit is the main unit, in
+   --  which case we use the command line settings).
 
    procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type);
    --  This procedure restores a set of switch values previously saved by a
@@ -1302,6 +1298,7 @@ private
       Ada_Version                    : Ada_Version_Type;
       Ada_Version_Explicit           : Ada_Version_Type;
       Assertions_Enabled             : Boolean;
+      Debug_Pragmas_Enabled          : Boolean;
       Dynamic_Elaboration_Checks     : Boolean;
       Exception_Locations_Suppressed : Boolean;
       Extensions_Allowed             : Boolean;

gcc/ada/par-prag.adb

@@ -1011,6 +1011,7 @@ begin
            Pragma_Component_Alignment          |
            Pragma_Controlled                   |
            Pragma_Convention                   |
+           Pragma_Debug_Policy                 |
            Pragma_Detect_Blocking              |
            Pragma_Discard_Names                |
            Pragma_Eliminate                    |

gcc/ada/par.adb

@@ -1275,7 +1275,8 @@ begin
 
       for Ucount in Pos loop
          Set_Opt_Config_Switches
-           (Is_Internal_File_Name (File_Name (Current_Source_File)));
+           (Is_Internal_File_Name (File_Name (Current_Source_File)),
+            Current_Source_Unit = Main_Unit);
 
          --  Initialize scope table and other parser control variables
 

gcc/ada/sem.adb

@@ -27,7 +27,6 @@
 with Atree;    use Atree;
 with Debug;    use Debug;
 with Debug_A;  use Debug_A;
-with Einfo;    use Einfo;
 with Errout;   use Errout;
 with Expander; use Expander;
 with Fname;    use Fname;
@@ -35,7 +34,6 @@ with HLO;      use HLO;
 with Lib;      use Lib;
 with Lib.Load; use Lib.Load;
 with Nlists;   use Nlists;
-with Opt;      use Opt;
 with Sem_Attr; use Sem_Attr;
 with Sem_Ch2;  use Sem_Ch2;
 with Sem_Ch3;  use Sem_Ch3;
@@ -1299,7 +1297,8 @@ package body Sem is
       Set_Comes_From_Source_Default (False);
       Save_Opt_Config_Switches (Save_Config_Switches);
       Set_Opt_Config_Switches
-        (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)));
+        (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)),
+         Current_Sem_Unit = Main_Unit);
 
       --  Only do analysis of unit that has not already been analyzed
 

gcc/ada/sem_prag.adb

@@ -5571,12 +5571,24 @@ package body Sem_Prag is
 
             Rewrite (N, Make_Implicit_If_Statement (N,
               Condition => New_Occurrence_Of (Boolean_Literals (
-                Assertions_Enabled and Expander_Active), Loc),
+                Debug_Pragmas_Enabled and Expander_Active), Loc),
               Then_Statements => New_List (
                 Relocate_Node (Debug_Statement (N)))));
             Analyze (N);
          end Debug;
 
+         ------------------
+         -- Debug_Policy --
+         ------------------
+
+         --  pragma Debug_Policy (Check | Ignore)
+
+         when Pragma_Debug_Policy =>
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
+            Debug_Pragmas_Enabled := Chars (Expression (Arg1)) = Name_Check;
+
          ---------------------
          -- Detect_Blocking --
          ---------------------
@@ -6519,7 +6531,9 @@ package body Sem_Prag is
          -- Float_Representation --
          --------------------------
 
-         --  pragma Float_Representation (VAX_Float | IEEE_Float);
+         --  pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
+
+         --  FLOAT_REP ::= VAX_Float | IEEE_Float
 
          when Pragma_Float_Representation => Float_Representation : declare
             Argx : Node_Id;
@@ -6552,9 +6566,7 @@ package body Sem_Prag is
             --  One argument case
 
             if Arg_Count = 1 then
-
                if Chars (Expression (Arg1)) = Name_VAX_Float then
-
                   if Opt.Float_Format = 'I' then
                      Error_Pragma ("'I'E'E'E format previously specified");
                   end if;
@@ -6590,7 +6602,6 @@ package body Sem_Prag is
                --  Two arguments, VAX_Float case
 
                if Chars (Expression (Arg1)) = Name_VAX_Float then
-
                   case Digs is
                      when  6 => Set_F_Float (Ent);
                      when  9 => Set_D_Float (Ent);
@@ -8091,6 +8102,8 @@ package body Sem_Prag is
          -- No_Strict_Aliasing --
          ------------------------
 
+         --  pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
+
          when Pragma_No_Strict_Aliasing => No_Strict_Alias : declare
             E_Id : Entity_Id;
 
@@ -8324,15 +8337,12 @@ package body Sem_Prag is
             if Has_Pragma_Pack (Typ) then
                Error_Pragma ("duplicate pragma%, only one allowed");
 
-            --  Array type. We set the Has_Pragma_Pack flag, and Is_Packed,
-            --  but not Has_Non_Standard_Rep, because we don't actually know
-            --  till freeze time if the array can have packed representation.
-            --  That's because in the general case we do not know enough about
-            --  the component type until it in turn is frozen, which certainly
-            --  happens before the array type is frozen, but not necessarily
-            --  till that point (i.e. right now it may be unfrozen).
+            --  Array type
 
             elsif Is_Array_Type (Typ) then
+
+               --  Pack not allowed for aliased or atomic components
+
                if Has_Aliased_Components (Base_Type (Typ)) then
                   Error_Pragma
                     ("pragma% ignored, cannot pack aliased components?");
@@ -8341,15 +8351,36 @@ package body Sem_Prag is
                  or else Is_Atomic (Component_Type (Typ))
                then
                   Error_Pragma
-                    ("?pragma% ignored, cannot pack atomic components");
+                       ("?pragma% ignored, cannot pack atomic components");
+               end if;
 
-               elsif not Rep_Item_Too_Late (Typ, N) then
-                  Set_Is_Packed            (Base_Type (Typ));
-                  Set_Has_Pragma_Pack      (Base_Type (Typ));
-                  Set_Has_Non_Standard_Rep (Base_Type (Typ));
+               --  If we had an explicit component size given, then we do not
+               --  let Pack override this given size. We also give a warning
+               --  that Pack is being ignored unless we can tell for sure that
+               --  the Pack would not have had any effect anyway.
+
+               if Has_Component_Size_Clause (Typ) then
+                  if Known_Static_RM_Size (Component_Type (Typ))
+                    and then
+                      RM_Size (Component_Type (Typ)) = Component_Size (Typ)
+                  then
+                     null;
+                  else
+                     Error_Pragma
+                       ("?pragma% ignored, explicit component size given");
+                  end if;
+
+               --  If no prior array component size given, Pack is effective
+
+               else
+                  if not Rep_Item_Too_Late (Typ, N) then
+                     Set_Is_Packed            (Base_Type (Typ));
+                     Set_Has_Pragma_Pack      (Base_Type (Typ));
+                     Set_Has_Non_Standard_Rep (Base_Type (Typ));
+                  end if;
                end if;
 
-            --  Record type. For record types, the pack is always effective
+            --  For record types, the pack is always effective
 
             else pragma Assert (Is_Record_Type (Typ));
                if not Rep_Item_Too_Late (Typ, N) then
@@ -10563,6 +10594,7 @@ package body Sem_Prag is
       Pragma_Convention                   =>  0,
       Pragma_Convention_Identifier        =>  0,
       Pragma_Debug                        => -1,
+      Pragma_Debug_Policy                 =>  0,
       Pragma_Detect_Blocking              => -1,
       Pragma_Discard_Names                =>  0,
       Pragma_Elaborate                    => -1,

gcc/ada/snames.adb

@@ -89,6 +89,10 @@ package body Snames is
      "_task_info#" &
      "_task_name#" &
      "_trace_sp#" &
+     "_disp_asynchronous_select#" &
+     "_disp_conditional_select#" &
+     "_disp_get_prim_op_kind#" &
+     "_disp_timed_select#" &
      "initialize#" &
      "adjust#" &
      "finalize#" &
@@ -174,6 +178,7 @@ package body Snames is
      "compile_time_warning#" &
      "component_alignment#" &
      "convention_identifier#" &
+     "debug_policy#" &
      "detect_blocking#" &
      "discard_names#" &
      "elaboration_checks#" &

gcc/ada/switch-c.adb

@@ -31,7 +31,6 @@ with Lib;      use Lib;
 with Osint;    use Osint;
 with Opt;      use Opt;
 with Prepcomp; use Prepcomp;
-with Types;    use Types;
 with Validsw;  use Validsw;
 with Stylesw;  use Stylesw;
 
@@ -192,6 +191,7 @@ package body Switch.C is
             when 'a' =>
                Ptr := Ptr + 1;
                Assertions_Enabled := True;
+               Debug_Pragmas_Enabled := True;
 
             --  Processing for A switch
 
@@ -265,14 +265,6 @@ package body Switch.C is
                   end if;
                end loop;
 
-               --  Make sure Zero_Cost_Exceptions is set if gnatdX set. This
-               --  is for backwards compatibility with old versions and usage.
-
-               if Debug_Flag_XX then
-                  Zero_Cost_Exceptions_Set := True;
-                  Zero_Cost_Exceptions_Val := True;
-               end if;
-
                return;
 
             --  Processing for D switch
@@ -485,6 +477,13 @@ package body Switch.C is
                System_Extend_Unit := Empty;
                Warning_Mode := Treat_As_Error;
 
+               --  Set Ada 2005 mode explicitly. We don't want to rely on the
+               --  implicit setting here, since for example, we want
+               --  Preelaborate_05 treated as Preelaborate
+
+               Ada_Version := Ada_05;
+               Ada_Version_Explicit := Ada_Version;
+
                --  Set default warnings for -gnatg (same set as -gnatwa)
 
                Check_Unreferenced           := True;
@@ -564,8 +563,8 @@ package body Switch.C is
 
             when 'L' =>
                Ptr := Ptr + 1;
-               Zero_Cost_Exceptions_Set := True;
-               Zero_Cost_Exceptions_Val := False;
+               Osint.Fail
+                 ("-gnatL is no longer supported: consider using --RTS=sjlj");
 
             --  Processing for m switch
 
@@ -1059,8 +1058,8 @@ package body Switch.C is
 
             when 'Z' =>
                Ptr := Ptr + 1;
-               Zero_Cost_Exceptions_Set := True;
-               Zero_Cost_Exceptions_Val := True;
+               Osint.Fail
+                 ("-gnatZ is no longer supported: consider using --RTS=zcx");
 
             --  Processing for 83 switch