diff mbox

[Ada] Handling of attribute definition clauses for ASIS with GNSA

Message ID 20160502100517.GA1895@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet May 2, 2016, 10:05 a.m. UTC 
This patch introduces new switch -gnatd.H to enabled ASIS_GNSA mode. When
active, this mode disabled the call to gigi. In addition, the patch suppresses
various error checks with respect to attribute definition clauses in ASIS mode.

------------
-- Source --
------------

--  clauses.ads

package Clauses is

   --  Alignment

   type Align_T is tagged record
      Comp : Integer := 1;
   end record;

   for Align_T'Alignment use 7;

   Align_Obj : Align_T;

   for Align_Obj'Alignment use 7;

   --  Component_Size

   type Comp_Siz_T is array (1 .. 5) of Integer;

   for Comp_Siz_T'Component_Size use -1;

   --  Machine_Radix

   type Mach_Rad_T is delta 0.01 digits 15;

   for Mach_Rad_T'Machine_Radix use -1;

   --  Object_Size

   type Obj_Siz_T is record
      Comp : Integer := 1;
   end record;

   for Obj_Siz_T'Object_Size use -1;

   --  Size

   type Siz_Elem_T is new Integer;

   for Siz_Elem_T'Size use -1;

   type Siz_Rec_T is record
      Comp : Integer := 1;
   end record;

   for Siz_Rec_T'Size use -1;

   Siz_Elem_Obj : Siz_Elem_T;

   for Siz_Elem_Obj'Size use -1;

   Siz_Rec_Obj : Siz_Rec_T;

   for Siz_Rec_Obj'Size use -1;

   --  Storage_Size

   task type Stor_Siz_T;

   for Stor_Siz_T'Storage_Size use -1;

   --  Stream_Size

   type Str_Siz_Elem_T is new Integer;

   for Str_Siz_Elem_T'Stream_Size use -1;

   --  Value_Size

   type Val_Siz_T is array (1 .. 5) of Integer;

   for Val_Siz_T'Value_Size use -1;
end Clauses;

----------------------------
-- Compilation and output --
----------------------------

$ gcc -c clauses.ads
$ gcc -c clauses.ads -gnatct -gnatd.H
clauses.ads:9:30: alignment value must be positive
clauses.ads:13:32: alignment value must be positive
clauses.ads:19:38: size for "Integer" too small, minimum allowed is 32
clauses.ads:25:37: machine radix value must be 2 or 10
clauses.ads:33:34: Object_Size must be a multiple of 8
clauses.ads:39:28: size for "Siz_Elem_T" too small, minimum allowed is 32
clauses.ads:49:30: size for "Siz_Elem_T" too small, minimum allowed is 32
clauses.ads:65:04: stream size for elementary type must be a power of 2 and at
  least 8

Tested on x86_64-pc-linux-gnu, committed on trunk

2016-05-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* debug.adb: Document the use of switch -gnatd.H.
	* gnat1drv.adb (Adjust_Global_Switches): Set ASIS_GNSA mode when
	-gnatd.H is present.
	(Gnat1drv): Suppress the call to gigi when ASIS_GNSA mode is active.
	* opt.ads: Add new option ASIS_GNSA_Mode.
	* sem_ch13.adb (Alignment_Error): New routine.
	(Analyze_Attribute_Definition_Clause): Suppress certain errors in
	ASIS mode for attribute clause Alignment, Machine_Radix, Size, and
	Stream_Size.
	(Check_Size): Use routine Size_Too_Small_Error to
	suppress certain errors in ASIS mode.
	(Get_Alignment_Value): Use routine Alignment_Error to suppress certain
	errors in ASIS mode.
	(Size_Too_Small_Error): New routine.
diff mbox

Patch

Index: debug.adb
===================================================================
--- debug.adb	(revision 235710)
+++ debug.adb	(working copy)
@@ -125,7 +125,7 @@ 
    --  d.E  Turn selected errors into warnings
    --  d.F  Debug mode for GNATprove
    --  d.G  Ignore calls through generic formal parameters for elaboration
-   --  d.H
+   --  d.H  GNSA mode for ASIS
    --  d.I  Do not ignore enum representation clauses in CodePeer mode
    --  d.J  Disable parallel SCIL generation mode
    --  d.K
@@ -630,6 +630,9 @@ 
    --       now fixed, but we provide this debug flag to revert to the previous
    --       situation of ignoring such calls to aid in transition.
 
+   --  d.H  Sets ASIS_GNSA_Mode to True. This signals the front end to suppress
+   --       the call to gigi in ASIS_Mode.
+
    --  d.I  Do not ignore enum representation clauses in CodePeer mode.
    --       The default of ignoring representation clauses for enumeration
    --       types in CodePeer is good for the majority of Ada code, but in some
Index: gnat1drv.adb
===================================================================
--- gnat1drv.adb	(revision 235706)
+++ gnat1drv.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -180,6 +180,12 @@ 
       if Operating_Mode = Check_Semantics and then Tree_Output then
          ASIS_Mode := True;
 
+         --  Set ASIS GNSA mode if -gnatd.H is set
+
+         if Debug_Flag_Dot_HH then
+            ASIS_GNSA_Mode := True;
+         end if;
+
          --  Turn off inlining in ASIS mode, since ASIS cannot handle the extra
          --  information in the trees caused by inlining being active.
 
@@ -1054,7 +1060,7 @@ 
       if GNATprove_Mode then
          declare
             Unused_E : constant Entity_Id :=
-              Rtsfind.RTE (Rtsfind.RE_Interrupt_Priority);
+                         Rtsfind.RTE (Rtsfind.RE_Interrupt_Priority);
          begin
             null;
          end;
@@ -1176,13 +1182,11 @@ 
       --  We can generate code for a package declaration or a subprogram
       --  declaration only if it does not required a body.
 
-      elsif Nkind_In (Main_Kind,
-              N_Package_Declaration,
-              N_Subprogram_Declaration)
+      elsif Nkind_In (Main_Kind, N_Package_Declaration,
+                                 N_Subprogram_Declaration)
         and then
           (not Body_Required (Main_Unit_Node)
-             or else
-           Distribution_Stub_Mode = Generate_Caller_Stub_Body)
+             or else Distribution_Stub_Mode = Generate_Caller_Stub_Body)
       then
          Back_End_Mode := Generate_Object;
 
@@ -1247,8 +1251,7 @@ 
 
       if Back_End_Mode = Skip then
          Set_Standard_Error;
-         Write_Str ("cannot generate code for ");
-         Write_Str ("file ");
+         Write_Str ("cannot generate code for file ");
          Write_Name (Unit_File_Name (Main_Unit));
 
          if Subunits_Missing then
@@ -1320,11 +1323,16 @@ 
       --  Annotation is suppressed for targets where front-end layout is
       --  enabled, because the front end determines representations.
 
+      --  The back-end is not invoked in ASIS mode with GNSA because all type
+      --  representation information will be provided by the GNSA back-end, not
+      --  gigi.
+
       if Back_End_Mode = Declarations_Only
         and then
           (not (Back_Annotate_Rep_Info or Generate_SCIL or GNATprove_Mode)
             or else Main_Kind = N_Subunit
-            or else Frontend_Layout_On_Target)
+            or else Frontend_Layout_On_Target
+            or else ASIS_GNSA_Mode)
       then
          Post_Compilation_Validation_Checks;
          Errout.Finalize (Last_Call => True);
Index: opt.ads
===================================================================
--- opt.ads	(revision 235713)
+++ opt.ads	(working copy)
@@ -208,6 +208,11 @@ 
    --  Set to non-null when Bind_Alternate_Main_Name is True. This value
    --  is modified as needed by Gnatbind.Scan_Bind_Arg.
 
+   ASIS_GNSA_Mode : Boolean := False;
+   --  GNAT
+   --  Enable GNSA back-end processing assuming ASIS_Mode is already set to
+   --  True. ASIS_GNSA mode suppresses the call to gigi.
+
    ASIS_Mode : Boolean := False;
    --  GNAT
    --  Enable semantic checks and tree transformations that are important
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 235711)
+++ sem_ch13.adb	(working copy)
@@ -4758,9 +4758,8 @@ 
             elsif Is_Subprogram (U_Ent) then
                if Has_Homonym (U_Ent) then
                   Error_Msg_N
-                    ("address clause cannot be given " &
-                     "for overloaded subprogram",
-                     Nam);
+                    ("address clause cannot be given for overloaded "
+                     & "subprogram", Nam);
                   return;
                end if;
 
@@ -4802,8 +4801,8 @@ 
 
                if Warn_On_Obsolescent_Feature then
                   Error_Msg_N
-                    ("?j?attaching interrupt to task entry is an " &
-                     "obsolescent feature (RM J.7.1)", N);
+                    ("?j?attaching interrupt to task entry is an obsolescent "
+                     & "feature (RM J.7.1)", N);
                   Error_Msg_N
                     ("\?j?use interrupt procedure instead", N);
                end if;
@@ -5022,12 +5021,17 @@ 
                Set_Has_Alignment_Clause (U_Ent);
 
                --  Tagged type case, check for attempt to set alignment to a
-               --  value greater than Max_Align, and reset if so.
+               --  value greater than Max_Align, and reset if so. This error
+               --  is suppressed in ASIS mode to allow for different ASIS
+               --  back-ends or ASIS-based tools to query the illegal clause.
 
-               if Is_Tagged_Type (U_Ent) and then Align > Max_Align then
+               if Is_Tagged_Type (U_Ent)
+                 and then Align > Max_Align
+                 and then not ASIS_Mode
+               then
                   Error_Msg_N
                     ("alignment for & set to Maximum_Aligment??", Nam);
-                     Set_Alignment (U_Ent, Max_Align);
+                  Set_Alignment (U_Ent, Max_Align);
 
                --  All other cases
 
@@ -5100,7 +5104,7 @@ 
             end if;
 
             Btype := Base_Type (U_Ent);
-            Ctyp := Component_Type (Btype);
+            Ctyp  := Component_Type (Btype);
 
             if Duplicate_Clause then
                null;
@@ -5324,8 +5328,8 @@ 
                   Error_Msg_NE
                     ("??non-unique external tag supplied for &", N, U_Ent);
                   Error_Msg_N
-                       ("\??same external tag applies to all "
-                        & "subprogram calls", N);
+                    ("\??same external tag applies to all subprogram calls",
+                     N);
                   Error_Msg_N
                     ("\??corresponding internal tag cannot be obtained", N);
                end if;
@@ -5363,8 +5367,8 @@ 
             if From_Aspect_Specification (N) then
                if not Is_Concurrent_Type (U_Ent) then
                   Error_Msg_N
-                    ("Interrupt_Priority can only be defined for task "
-                     & "and protected object", Nam);
+                    ("Interrupt_Priority can only be defined for task and "
+                     & "protected object", Nam);
 
                elsif Duplicate_Clause then
                   null;
@@ -5456,9 +5460,15 @@ 
 
                if Radix = 2 then
                   null;
+
                elsif Radix = 10 then
                   Set_Machine_Radix_10 (U_Ent);
-               else
+
+               --  The following error is suppressed in ASIS mode to allow for
+               --  different ASIS back-ends or ASIS-based tools to query the
+               --  illegal clause.
+
+               elsif not ASIS_Mode then
                   Error_Msg_N ("machine radix value must be 2 or 10", Expr);
                end if;
             end if;
@@ -5486,7 +5496,14 @@ 
             else
                Check_Size (Expr, U_Ent, Size, Biased);
 
-               if Is_Scalar_Type (U_Ent) then
+               --  The following errors are suppressed in ASIS mode to allow
+               --  for different ASIS back-ends or ASIS-based tools to query
+               --  the illegal clause.
+
+               if ASIS_Mode then
+                  null;
+
+               elsif Is_Scalar_Type (U_Ent) then
                   if Size /= 8 and then Size /= 16 and then Size /= 32
                     and then UI_Mod (Size, 64) /= 0
                   then
@@ -5573,8 +5590,8 @@ 
          begin
             if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then
                Error_Msg_N
-                 ("Scalar_Storage_Order can only be defined for "
-                  & "record or array type", Nam);
+                 ("Scalar_Storage_Order can only be defined for record or "
+                  & "array type", Nam);
 
             elsif Duplicate_Clause then
                null;
@@ -5598,8 +5615,8 @@ 
                      Set_Reverse_Storage_Order (Base_Type (U_Ent), True);
                   else
                      Error_Msg_N
-                       ("non-default Scalar_Storage_Order "
-                        & "not supported on target", Expr);
+                       ("non-default Scalar_Storage_Order not supported on "
+                        & "target", Expr);
                   end if;
                end if;
 
@@ -5696,21 +5713,22 @@ 
                --  For objects, set Esize only
 
                else
-                  if Is_Elementary_Type (Etyp) then
-                     if Size /= System_Storage_Unit
-                          and then
-                        Size /= System_Storage_Unit * 2
-                          and then
-                        Size /= System_Storage_Unit * 4
-                           and then
-                        Size /= System_Storage_Unit * 8
-                     then
-                        Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
-                        Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
-                        Error_Msg_N
-                          ("size for primitive object must be a power of 2"
-                            & " in the range ^-^", N);
-                     end if;
+                  --  The following error is suppressed in ASIS mode to allow
+                  --  for different ASIS back-ends or ASIS-based tools to query
+                  --  the illegal clause.
+
+                  if Is_Elementary_Type (Etyp)
+                    and then Size /= System_Storage_Unit
+                    and then Size /= System_Storage_Unit * 2
+                    and then Size /= System_Storage_Unit * 4
+                    and then Size /= System_Storage_Unit * 8
+                    and then not ASIS_Mode
+                  then
+                     Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
+                     Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
+                     Error_Msg_N
+                       ("size for primitive object must be a power of 2 in "
+                        & "the range ^-^", N);
                   end if;
 
                   Set_Esize (U_Ent, Size);
@@ -5955,8 +5973,8 @@ 
 
                   if Warn_On_Obsolescent_Feature then
                      Error_Msg_N
-                       ("?j?storage size clause for task is an " &
-                        "obsolescent feature (RM J.9)", N);
+                       ("?j?storage size clause for task is an obsolescent "
+                        & "feature (RM J.9)", N);
                      Error_Msg_N ("\?j?use Storage_Size pragma instead", N);
                   end if;
                end if;
@@ -6024,24 +6042,29 @@ 
                null;
 
             elsif Is_Elementary_Type (U_Ent) then
-               if Size /= System_Storage_Unit
-                    and then
-                  Size /= System_Storage_Unit * 2
-                    and then
-                  Size /= System_Storage_Unit * 4
-                     and then
-                  Size /= System_Storage_Unit * 8
+
+               --  The following errors are suppressed in ASIS mode to allow
+               --  for different ASIS back-ends or ASIS-based tools to query
+               --  the illegal clause.
+
+               if ASIS_Mode then
+                  null;
+
+               elsif Size /= System_Storage_Unit
+                 and then Size /= System_Storage_Unit * 2
+                 and then Size /= System_Storage_Unit * 4
+                 and then Size /= System_Storage_Unit * 8
                then
                   Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
                   Error_Msg_N
-                    ("stream size for elementary type must be a"
-                       & " power of 2 and at least ^", N);
+                    ("stream size for elementary type must be a power of 2 "
+                     & "and at least ^", N);
 
                elsif RM_Size (U_Ent) > Size then
                   Error_Msg_Uint_1 := RM_Size (U_Ent);
                   Error_Msg_N
-                    ("stream size for elementary type must be a"
-                       & " power of 2 and at least ^", N);
+                    ("stream size for elementary type must be a power of 2 "
+                     & "and at least ^", N);
                end if;
 
                Set_Has_Stream_Size_Clause (U_Ent);
@@ -6787,12 +6810,10 @@ 
               and then Lbit /= No_Uint
             then
                if Posit < 0 then
-                  Error_Msg_N
-                    ("position cannot be negative", Position (CC));
+                  Error_Msg_N ("position cannot be negative", Position (CC));
 
                elsif Fbit < 0 then
-                  Error_Msg_N
-                    ("first bit cannot be negative", First_Bit (CC));
+                  Error_Msg_N ("first bit cannot be negative", First_Bit (CC));
 
                --  The Last_Bit specified in a component clause must not be
                --  less than the First_Bit minus one (RM-13.5.1(10)).
@@ -6885,8 +6906,8 @@ 
                                                    Intval (Last_Bit (CC))
                            then
                               Error_Msg_N
-                                ("component clause inconsistent "
-                                 & "with representation of ancestor", CC);
+                                ("component clause inconsistent with "
+                                 & "representation of ancestor", CC);
 
                            elsif Warn_On_Redundant_Constructs then
                               Error_Msg_N
@@ -10870,13 +10891,36 @@ 
       Siz    : Uint;
       Biased : out Boolean)
    is
+      procedure Size_Too_Small_Error (Min_Siz : Uint);
+      --  Emit an error concerning illegal size Siz. Min_Siz denotes the
+      --  minimum size.
+
+      --------------------------
+      -- Size_Too_Small_Error --
+      --------------------------
+
+      procedure Size_Too_Small_Error (Min_Siz : Uint) is
+      begin
+         --  This error is suppressed in ASIS mode to allow for different ASIS
+         --  back-ends or ASIS-based tools to query the illegal clause.
+
+         if not ASIS_Mode then
+            Error_Msg_Uint_1 := Min_Siz;
+            Error_Msg_NE ("size for & too small, minimum allowed is ^", N, T);
+         end if;
+      end Size_Too_Small_Error;
+
+      --  Local variables
+
       UT : constant Entity_Id := Underlying_Type (T);
       M  : Uint;
 
+   --  Start of processing for Check_Size
+
    begin
       Biased := False;
 
-      --  Reject patently improper size values.
+      --  Reject patently improper size values
 
       if Is_Elementary_Type (T)
         and then Siz > UI_From_Int (Int'Last)
@@ -10945,9 +10989,7 @@ 
                return;
 
             else
-               Error_Msg_Uint_1 := Asiz;
-               Error_Msg_NE
-                 ("size for& too small, minimum allowed is ^", N, T);
+               Size_Too_Small_Error (Asiz);
                Set_Esize   (T, Asiz);
                Set_RM_Size (T, Asiz);
             end if;
@@ -10962,9 +11004,7 @@ 
       --  since we don't know all the characteristics of the type that can
       --  affect the size (e.g. a specified small) till freeze time.
 
-      elsif Is_Fixed_Point_Type (UT)
-        and then not Is_Frozen (UT)
-      then
+      elsif Is_Fixed_Point_Type (UT) and then not Is_Frozen (UT) then
          null;
 
       --  Cases for which a minimum check is required
@@ -10988,10 +11028,8 @@ 
             M := UI_From_Int (Minimum_Size (UT, Biased => True));
 
             if Siz < M then
-               Error_Msg_Uint_1 := M;
-               Error_Msg_NE
-                 ("size for& too small, minimum allowed is ^", N, T);
-               Set_Esize (T, M);
+               Size_Too_Small_Error (M);
+               Set_Esize   (T, M);
                Set_RM_Size (T, M);
             else
                Biased := True;
@@ -11513,14 +11551,36 @@ 
    -------------------------
 
    function Get_Alignment_Value (Expr : Node_Id) return Uint is
+      procedure Alignment_Error;
+      --  Issue an error concerning a negatize or zero alignment represented by
+      --  expression Expr.
+
+      ---------------------
+      -- Alignment_Error --
+      ---------------------
+
+      procedure Alignment_Error is
+      begin
+         --  This error is suppressed in ASIS mode to allow for different ASIS
+         --  back-ends or ASIS-based tools to query the illegal clause.
+
+         if not ASIS_Mode then
+            Error_Msg_N ("alignment value must be positive", Expr);
+         end if;
+      end Alignment_Error;
+
+      --  Local variables
+
       Align : constant Uint := Static_Integer (Expr);
 
+   --  Start of processing for Get_Alignment_Value
+
    begin
       if Align = No_Uint then
          return No_Uint;
 
       elsif Align <= 0 then
-         Error_Msg_N ("alignment value must be positive", Expr);
+         Alignment_Error;
          return No_Uint;
 
       else
@@ -11532,8 +11592,7 @@ 
                exit when M = Align;
 
                if M > Align then
-                  Error_Msg_N
-                    ("alignment value must be power of 2", Expr);
+                  Alignment_Error;
                   return No_Uint;
                end if;
             end;