From 3ccedacc889a1eac92eed26a0006b9cc3eeda19b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 4 Aug 2014 12:57:32 +0200 Subject: [PATCH] [multiple changes] 2014-08-04 Robert Dewar * sem_ch6.adb: Minor reformatting. 2014-08-04 Ed Schonberg * 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 --- gcc/ada/ChangeLog | 15 ++++++ gcc/ada/osint.adb | 41 +++++++++++----- gcc/ada/osint.ads | 8 +++- gcc/ada/sem_case.adb | 4 +- gcc/ada/sem_ch6.adb | 109 +++++++++++++++++++------------------------ gcc/ada/sem_prag.adb | 11 ++++- 6 files changed, 110 insertions(+), 78 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8bed0123c2e..4737fc7a9ac 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2014-08-04 Robert Dewar + + * sem_ch6.adb: Minor reformatting. + +2014-08-04 Ed Schonberg + + * 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 * opt.ads Alphabetize various global flags. New flag diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 93e25501f77..3fd796c4953 100644 --- 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 e281c6a79ad..caddf666b2a 100644 --- 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 005bd95db0a..201855b5e36 100644 --- 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 a6014b14ec6..f7b73754eb8 100644 --- 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 - ("<= 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 d6de6a7d1de..ad51ce326e9 100644 --- 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; -- 2.30.2