[multiple changes]

2014-08-04  Robert Dewar  <dewar@adacore.com>

	* sem_ch6.adb: Minor reformatting.

2014-08-04  Ed Schonberg  <schonberg@adacore.com>

	* sem_prag.adb (Analyze_Pragma, case Assert and related pragmas):
	Before normalizing these pragmas into a pragma Check, preanalyze
	the optional Message argument, (which is subsequently copied)
	so that it has the proper semantic information for ASIS use.
	* sem_case.adb: Initialize flag earlier.
	* osint.adb, osint.ads (Find_File): Add parameter Full_Name, used when
	the full source path of a configuration file is requested.
	(Read_Source_File): Use Full_Name parameter..

From-SVN: r213571

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8bed012..4737fc7 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,18 @@
+2014-08-04  Robert Dewar  <dewar@adacore.com>
+
+       * sem_ch6.adb: Minor reformatting.
+
+2014-08-04  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_prag.adb (Analyze_Pragma, case Assert and related pragmas):
+       Before normalizing these pragmas into a pragma Check, preanalyze
+       the optional Message argument, (which is subsequently copied)
+       so that it has the proper semantic information for ASIS use.
+       * sem_case.adb: Initialize flag earlier.
+       * osint.adb, osint.ads (Find_File): Add parameter Full_Name, used when
+       the full source path of a configuration file is requested.
+       (Read_Source_File): Use Full_Name parameter..
+
 2014-08-04  Hristian Kirtchev  <kirtchev@adacore.com>
 
        * opt.ads Alphabetize various global flags. New flag

diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb
index 93e2550..3fd796c 100644 (file)
--- a/gcc/ada/osint.adb
+++ b/gcc/ada/osint.adb
@@ -119,10 +119,11 @@ package body Osint is
    --  failure
 
    procedure Find_File
-     (N     : File_Name_Type;
-      T     : File_Type;
-      Found : out File_Name_Type;
-      Attr  : access File_Attributes);
+     (N         : File_Name_Type;
+      T         : File_Type;
+      Found     : out File_Name_Type;
+      Attr      : access File_Attributes;
+      Full_Name : Boolean := False);
    --  A version of Find_File that also returns a cache of the file attributes
    --  for later reuse
 
@@ -1153,13 +1154,14 @@ package body Osint is
    ---------------
 
    function Find_File
-     (N : File_Name_Type;
-      T : File_Type) return File_Name_Type
+     (N         : File_Name_Type;
+      T         : File_Type;
+      Full_Name : Boolean := False) return File_Name_Type
    is
       Attr  : aliased File_Attributes;
       Found : File_Name_Type;
    begin
-      Find_File (N, T, Found, Attr'Access);
+      Find_File (N, T, Found, Attr'Access, Full_Name);
       return Found;
    end Find_File;
 
@@ -1168,10 +1170,11 @@ package body Osint is
    ---------------
 
    procedure Find_File
-     (N     : File_Name_Type;
-      T     : File_Type;
-      Found : out File_Name_Type;
-      Attr  : access File_Attributes) is
+     (N         : File_Name_Type;
+      T         : File_Type;
+      Found     : out File_Name_Type;
+      Attr      : access File_Attributes;
+      Full_Name : Boolean := False) is
    begin
       Get_Name_String (N);
 
@@ -1193,6 +1196,20 @@ package body Osint is
          then
             Found := N;
             Attr.all  := Unknown_Attributes;
+
+            if T = Config and then Full_Name then
+               declare
+                  Full_Path : constant String :=
+                           Normalize_Pathname (Get_Name_String (N));
+                  Full_Size : constant Natural := Full_Path'Length;
+
+               begin
+                  Name_Buffer (1 .. Full_Size) := Full_Path;
+                  Name_Len := Full_Size;
+                  Found := Name_Find;
+               end;
+            end if;
+
             return;
 
          --  If we are trying to find the current main file just look in the
@@ -2591,7 +2608,7 @@ package body Osint is
       --  For the call to Close
 
    begin
-      Current_Full_Source_Name  := Find_File (N, T);
+      Current_Full_Source_Name  := Find_File (N, T, Full_Name => True);
       Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
 
       if Current_Full_Source_Name = No_File then

diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads
index e281c6a..caddf66 100644 (file)
--- a/gcc/ada/osint.ads
+++ b/gcc/ada/osint.ads
@@ -63,8 +63,9 @@ package Osint is
    type File_Type is (Source, Library, Config, Definition, Preprocessing_Data);
 
    function Find_File
-     (N : File_Name_Type;
-      T : File_Type) return File_Name_Type;
+     (N         : File_Name_Type;
+      T         : File_Type;
+      Full_Name : Boolean := False) return File_Name_Type;
    --  Finds a source, library or config file depending on the value of T
    --  following the directory search order rules unless N is the name of the
    --  file just read with Next_Main_File and already contains directory
@@ -76,6 +77,9 @@ package Osint is
    --  set and the file name ends in ".dg", in which case we look for the
    --  generated file only in the current directory, since that is where it is
    --  always built.
+   --  In the case of configuration files, full path names are needed for some
+   --  ASIS queries. The flag Full_Name indicates that the name of the file
+   --  should be normalized to include a full path.
 
    function Get_File_Names_Case_Sensitive return Int;
    pragma Import (C, Get_File_Names_Case_Sensitive,

diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index 005bd95..201855b 100644 (file)
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -735,6 +735,8 @@ package body Sem_Case is
          return;
       end if;
 
+      Predicate_Error := False;
+
       --  Choice_Table must start at 0 which is an unused location used by the
       --  sorting algorithm. However the first valid position for a discrete
       --  choice is 1.
@@ -762,8 +764,6 @@ package body Sem_Case is
       --  expression is static, independently of whether the aspect mentions
       --  Static explicitly.
 
-      Predicate_Error := False;
-
       if Has_Predicate then
          Pred    := First (Static_Discrete_Predicate (Bounds_Type));
          Prev_Lo := Uint_Minus_1;

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index a6014b1..f7b7375 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -632,8 +632,8 @@ package body Sem_Ch6 is
               and then not GNAT_Mode
             then
                Error_Msg_N
-                 ("(Ada 2005) cannot copy object of a limited type " &
-                  "(RM-2005 6.5(5.5/2))", Expr);
+                 ("(Ada 2005) cannot copy object of a limited type "
+                  & "(RM-2005 6.5(5.5/2))", Expr);
 
                if Is_Limited_View (R_Type) then
                   Error_Msg_N
@@ -723,7 +723,7 @@ package body Sem_Ch6 is
             if not Predicates_Match (R_Stm_Type, R_Type) then
                Error_Msg_Node_2 := R_Type;
                Error_Msg_NE
-                 ("\predicate of & does not match predicate of &",
+                 ("\predicate of& does not match predicate of&",
                   N, R_Stm_Type);
             end if;
          end Error_No_Match;
@@ -774,8 +774,8 @@ package body Sem_Ch6 is
          elsif R_Stm_Type_Is_Anon_Access
            and then not R_Type_Is_Anon_Access
          then
-            Error_Msg_N ("anonymous access not allowed for function with " &
-                         "named access result", Subtype_Ind);
+            Error_Msg_N ("anonymous access not allowed for function with "
+                         & "named access result", Subtype_Ind);
 
          --  Subtype indication case: check that the return object's type is
          --  covered by the result type, and that the subtypes statically match
@@ -942,8 +942,8 @@ package body Sem_Ch6 is
                      & "in Ada 2012??", N);
 
                elsif not Is_Limited_View (R_Type) then
-                  Error_Msg_N ("aliased only allowed for limited"
-                     & " return objects", N);
+                  Error_Msg_N
+                    ("aliased only allowed for limited return objects", N);
                end if;
             end if;
          end;
@@ -1013,8 +1013,8 @@ package body Sem_Ch6 is
                  Subprogram_Access_Level (Scope_Id)
             then
                Error_Msg_N
-                 ("level of return expression type is deeper than " &
-                  "class-wide function!", Expr);
+                 ("level of return expression type is deeper than "
+                  & "class-wide function!", Expr);
             end if;
          end if;
 
@@ -1807,8 +1807,8 @@ package body Sem_Ch6 is
 
             else
                Error_Msg_N
-                 ("return nested in extended return statement cannot return " &
-                  "value (use `RETURN;`)", N);
+                 ("return nested in extended return statement cannot return "
+                  & "value (use `RETURN;`)", N);
             end if;
          end if;
 
@@ -2128,7 +2128,7 @@ package body Sem_Ch6 is
            and then Contains_Refined_State (Prag)
          then
             Error_Msg_NE
-              ("body of subprogram & requires global refinement",
+              ("body of subprogram& requires global refinement",
                Body_Decl, Spec_Id);
          end if;
       end if;
@@ -2151,7 +2151,7 @@ package body Sem_Ch6 is
            and then Contains_Refined_State (Prag)
          then
             Error_Msg_NE
-              ("body of subprogram & requires dependance refinement",
+              ("body of subprogram& requires dependance refinement",
                Body_Decl, Spec_Id);
          end if;
       end if;
@@ -2952,7 +2952,7 @@ package body Sem_Ch6 is
               and then  Operator_Matches_Spec (Spec_Id, Spec_Id)
             then
                Error_Msg_NE
-                 ("subprogram & overrides predefined operator ",
+                 ("subprogram& overrides predefined operator ",
                     Body_Spec, Spec_Id);
 
             --  Overriding indicators aren't allowed for protected subprogram
@@ -2963,18 +2963,16 @@ package body Sem_Ch6 is
                Error_Msg_Warn := Error_To_Warning;
 
                Error_Msg_N
-                 ("<<overriding indicator not allowed " &
-                  "for protected subprogram body",
-                  Body_Spec);
+                 ("<<overriding indicator not allowed "
+                  & "for protected subprogram body", Body_Spec);
 
             --  If this is not a primitive operation, then the overriding
             --  indicator is altogether illegal.
 
             elsif not Is_Primitive (Spec_Id) then
                Error_Msg_N
-                 ("overriding indicator only allowed " &
-                  "if subprogram is primitive",
-                  Body_Spec);
+                 ("overriding indicator only allowed "
+                  & "if subprogram is primitive", Body_Spec);
             end if;
 
          --  If checking the style rule and the operation overrides, then
@@ -3764,7 +3762,7 @@ package body Sem_Ch6 is
 
          else
             Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id));
-            Error_Msg_N ("incorrect application of SPARK_Mode#", N);
+            Error_Msg_N ("incorrect application of SPARK_Mode #", N);
             Error_Msg_Sloc := Sloc (Spec_Id);
             Error_Msg_NE
               ("\no value was set for SPARK_Mode on & #", N, Spec_Id);
@@ -4746,7 +4744,7 @@ package body Sem_Ch6 is
             --  this before checking that the types of the formals match.
 
             if Chars (Old_Formal) /= Chars (New_Formal) then
-               Conformance_Error ("\name & does not match!", New_Formal);
+               Conformance_Error ("\name& does not match!", New_Formal);
 
                --  Set error posted flag on new formal as well to stop
                --  junk cascaded messages in some cases.
@@ -4769,7 +4767,7 @@ package body Sem_Ch6 is
                   Comes_From_Source (New_Formal)
                then
                   Conformance_Error
-                    ("\null exclusion for & does not match", New_Formal);
+                    ("\null exclusion for& does not match", New_Formal);
 
                   --  Mark error posted on the new formal to avoid duplicated
                   --  complaint about types not matching.
@@ -4905,8 +4903,7 @@ package body Sem_Ch6 is
                   declare
                      T : constant  Entity_Id := Find_Dispatching_Type (New_Id);
                   begin
-                     if Is_Protected_Type
-                          (Corresponding_Concurrent_Type (T))
+                     if Is_Protected_Type (Corresponding_Concurrent_Type (T))
                      then
                         Error_Msg_PT (T, New_Id);
                      else
@@ -4979,9 +4976,9 @@ package body Sem_Ch6 is
                      if Is_Controlling_Formal (New_Formal) then
                         Error_Msg_Node_2 := Scope (New_Formal);
                         Conformance_Error
-                         ("\controlling formal& of& excludes null, "
-                           & "declaration must exclude null as well",
-                            New_Formal);
+                         ("\controlling formal & of & excludes null, "
+                          & "declaration must exclude null as well",
+                          New_Formal);
 
                      --  Normal case (couldn't we give more detail here???)
 
@@ -5175,23 +5172,21 @@ package body Sem_Ch6 is
                         Error_Msg_N ("\\primitive % defined #", Typ);
                      else
                         Error_Msg_N
-                          ("\\overriding operation % with " &
-                           "convention % defined #", Typ);
+                          ("\\overriding operation % with "
+                           & "convention % defined #", Typ);
                      end if;
 
                   else pragma Assert (Present (Alias (Op)));
                      Error_Msg_Sloc := Sloc (Alias (Op));
-                     Error_Msg_N
-                       ("\\inherited operation % with " &
-                        "convention % defined #", Typ);
+                     Error_Msg_N ("\\inherited operation % with "
+                                  & "convention % defined #", Typ);
                   end if;
 
                   Error_Msg_Name_1 := Chars (Op);
                   Error_Msg_Name_2 := Get_Convention_Name (Iface_Conv);
                   Error_Msg_Sloc   := Sloc (Iface_Prim);
-                  Error_Msg_N
-                    ("\\overridden operation % with " &
-                     "convention % defined #", Typ);
+                  Error_Msg_N ("\\overridden operation % with "
+                               & "convention % defined #", Typ);
 
                   --  Avoid cascading errors
 
@@ -5722,9 +5717,8 @@ package body Sem_Ch6 is
             if not Is_Primitive
               and then Ekind (Scope (Subp)) /= E_Protected_Type
             then
-               Error_Msg_N
-                 ("overriding indicator only allowed "
-                  & "if subprogram is primitive", Subp);
+               Error_Msg_N ("overriding indicator only allowed "
+                            & "if subprogram is primitive", Subp);
 
             elsif Can_Override_Operator (Subp) then
                Error_Msg_NE
@@ -7085,7 +7079,7 @@ package body Sem_Ch6 is
             then
                if Scope (E) /= Standard_Standard then
                   Error_Msg_Sloc := Sloc (E);
-                  Error_Msg_N ("declaration of & hides one#?h?", S);
+                  Error_Msg_N ("declaration of & hides one #?h?", S);
 
                elsif Nkind (S) = N_Defining_Operator_Symbol
                  and then
@@ -7159,7 +7153,7 @@ package body Sem_Ch6 is
          else
             if Ada_Version >= Ada_2012 then
                Error_Msg_NE
-                 ("equality operator must be declared before type& is "
+                 ("equality operator must be declared before type & is "
                   & "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op, Typ);
 
                --  In Ada 2012 mode with error turned to warning, output one
@@ -8395,8 +8389,8 @@ package body Sem_Ch6 is
                then
                   Error_Msg_Node_2 := F_Typ;
                   Error_Msg_NE
-                    ("private operation& in generic unit does not override " &
-                     "any primitive operation of& (RM 12.3 (18))??",
+                    ("private operation& in generic unit does not override "
+                     & "any primitive operation of& (RM 12.3 (18))??",
                      New_E, New_E);
                end if;
 
@@ -8429,13 +8423,11 @@ package body Sem_Ch6 is
 
                   if Class_Present (P) and then not Split_PPC (P) then
                      if Pragma_Name (P) = Name_Precondition then
-                        Error_Msg_N
-                          ("info: & inherits `Pre''Class` aspect from #?L?",
-                           E);
+                        Error_Msg_N ("info: & inherits `Pre''Class` aspect "
+                                     & "from #?L?", E);
                      else
-                        Error_Msg_N
-                          ("info: & inherits `Post''Class` aspect from #?L?",
-                           E);
+                        Error_Msg_N ("info: & inherits `Post''Class` aspect "
+                                     & "from #?L?", E);
                      end if;
                   end if;
 
@@ -8663,18 +8655,15 @@ package body Sem_Ch6 is
                  and then (not Is_Overriding
                             or else not Is_Abstract_Subprogram (E))
                then
-                  Error_Msg_N
-                    ("abstract subprograms must be visible "
-                     & "(RM 3.9.3(10))!", S);
+                  Error_Msg_N ("abstract subprograms must be visible "
+                               & "(RM 3.9.3(10))!", S);
 
                elsif Ekind (S) = E_Function and then not Is_Overriding then
                   if Is_Tagged_Type (T) and then T = Base_Type (Etype (S)) then
-                     Error_Msg_N
-                       ("private function with tagged result must"
-                        & " override visible-part function", S);
-                     Error_Msg_N
-                       ("\move subprogram to the visible part"
-                        & " (RM 3.9.3(10))", S);
+                     Error_Msg_N ("private function with tagged result must"
+                                  & " override visible-part function", S);
+                     Error_Msg_N ("\move subprogram to the visible part"
+                                  & " (RM 3.9.3(10))", S);
 
                   --  AI05-0073: extend this test to the case of a function
                   --  with a controlling access result.
@@ -8687,10 +8676,10 @@ package body Sem_Ch6 is
                   then
                      Error_Msg_N
                        ("private function with controlling access result "
-                          & "must override visible-part function", S);
+                        & "must override visible-part function", S);
                      Error_Msg_N
                        ("\move subprogram to the visible part"
-                          & " (RM 3.9.3(10))", S);
+                        & " (RM 3.9.3(10))", S);
                   end if;
                end if;
             end if;

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index d6de6a7..ad51ce3 100644 (file)
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -11010,6 +11010,11 @@ package body Sem_Prag is
 
             if Arg_Count > 1 then
                Check_Optional_Identifier (Arg2, Name_Message);
+
+               --  Provide semantic annnotations for optional argument, for
+               --  ASIS use, before rewriting.
+
+               Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
                Append_To (Newa, New_Copy_Tree (Arg2));
             end if;
 
@@ -19319,7 +19324,6 @@ package body Sem_Prag is
 
                else
                   Spec_Id := Defining_Entity (Unit (Context));
-                  Inst_Id := Related_Instance (Spec_Id);
                   Check_Library_Level_Entity (Spec_Id);
                   Check_Pragma_Conformance
                     (Context_Pragma => SPARK_Mode_Pragma,
@@ -19329,7 +19333,10 @@ package body Sem_Prag is
                   Set_SPARK_Pragma           (Spec_Id, N);
                   Set_SPARK_Pragma_Inherited (Spec_Id, False);
 
-                  if Present (Inst_Id) then
+                  if Ekind (Spec_Id) = E_Package
+                    and then Present (Related_Instance (Spec_Id))
+                  then
+                     Inst_Id := Related_Instance (Spec_Id);
                      Set_SPARK_Pragma           (Inst_Id, N);
                      Set_SPARK_Pragma_Inherited (Inst_Id, False);
                   end if;