From: charlet Date: Thu, 25 Mar 2004 15:59:29 +0000 (+0000) Subject: 2004-03-25 Vasiliy Fofanov X-Git-Url: http://git.sourceforge.jp/view?a=commitdiff_plain;h=03e3a723257e49661df9511a349b6b2f2f0747a9;p=pf3gnuchains%2Fgcc-fork.git 2004-03-25 Vasiliy Fofanov * memtrack.adb: Log realloc calls, which are treated as free followed by alloc. 2004-03-25 Vincent Celier * prj-makr.adb (Process_Directories): Detect when a file contains several units. Do not include such files in the config pragmas or in the naming scheme. * prj-nmsc.adb (Record_Source): New parameter Trusted_Mode. Resolve links only when not in Trusted_Mode. (Find_Sources, Recursive_Find_Dirs, Find_Source_Dirs, Locate_Directory): Do not resolve links for the display names. * prj-part.adb (Parse_Single_Project, Project_Path_Name_Of): Do not resolve links when computing the display names. 2004-03-25 Thomas Quinot * sem_attr.adb (Check_Dereference): When the prefix of a 'Tag attribute reference does not denote a subtype, it can be any expression that has a classwide type, potentially after an implicit dereference. In particular, the prefix can be a view conversion for a classwide type (for which Is_Object_Reference holds), but it can also be a value conversion for an access-to-classwide type. In the latter case, there is an implicit dereference, and the original node for the prefix does not verify Is_Object_Reference. * sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): A view conversion of a discriminant-dependent component of a mutable object is one itself. 2004-03-25 Ed Schonberg * freeze.adb (Freeze_Entity): When an inherited subprogram is inherited, has convention C, and has unconstrained array parameters, place the corresponding warning on the derived type declaration rather than the original subprogram. * sem_ch12.adb (Instantiate_Formal_Subprogram): Set From_Default indication on renaming declaration, if formal has a box and actual is absent. * sem_ch8.adb (Analyze_Subprogram_Renaming): Use From_Default flag to determine whether to generate an implicit or explicit reference to the renamed entity. * sinfo.ads, sinfo.adb: New flag From_Default, to indicate that a subprogram renaming comes from a defaulted formal subprogram in an instance. 2004-03-25 Gary Dismukes * sem_elab.adb (Check_Elab_Call): Refine loop that checks for default value expressions to ensure that calls within a component definition will be checked (since those are evaluated during the record type's elaboration). 2004-03-25 Arnaud Charlet * s-tpobop.adb: Code clean up: (Requeue_Call): Extract from PO_Service_Entries to remove duplicated code. (PO_Do_Or_Queue): Remove duplicated code and use Requeue_Call. 2004-03-25 Jose Ruiz * Makefile.in: Clean up in the ravenscar run time. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@79953 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index edb3e7b0a48..1229cfa3907 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,74 @@ +2004-03-25 Vasiliy Fofanov + + * memtrack.adb: Log realloc calls, which are treated as free followed + by alloc. + +2004-03-25 Vincent Celier + + * prj-makr.adb (Process_Directories): Detect when a file contains + several units. Do not include such files in the config pragmas or + in the naming scheme. + + * prj-nmsc.adb (Record_Source): New parameter Trusted_Mode. + Resolve links only when not in Trusted_Mode. + (Find_Sources, Recursive_Find_Dirs, Find_Source_Dirs, Locate_Directory): + Do not resolve links for the display names. + + * prj-part.adb (Parse_Single_Project, Project_Path_Name_Of): Do not + resolve links when computing the display names. + +2004-03-25 Thomas Quinot + + * sem_attr.adb (Check_Dereference): When the prefix of a 'Tag + attribute reference does not denote a subtype, it can be any + expression that has a classwide type, potentially after an implicit + dereference. In particular, the prefix can be a view conversion for + a classwide type (for which Is_Object_Reference holds), but it can + also be a value conversion for an access-to-classwide type. In the + latter case, there is an implicit dereference, and the original node + for the prefix does not verify Is_Object_Reference. + + * sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): A view + conversion of a discriminant-dependent component of a mutable object + is one itself. + +2004-03-25 Ed Schonberg + + * freeze.adb (Freeze_Entity): When an inherited subprogram is + inherited, has convention C, and has unconstrained array parameters, + place the corresponding warning on the derived type declaration rather + than the original subprogram. + + * sem_ch12.adb (Instantiate_Formal_Subprogram): Set From_Default + indication on renaming declaration, if formal has a box and actual + is absent. + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Use From_Default flag to + determine whether to generate an implicit or explicit reference to + the renamed entity. + + * sinfo.ads, sinfo.adb: New flag From_Default, to indicate that a + subprogram renaming comes from a defaulted formal subprogram in an + instance. + +2004-03-25 Gary Dismukes + + * sem_elab.adb (Check_Elab_Call): Refine loop that checks for default + value expressions to ensure that calls within a component definition + will be checked (since those are evaluated during the record type's + elaboration). + +2004-03-25 Arnaud Charlet + + * s-tpobop.adb: Code clean up: + (Requeue_Call): Extract from PO_Service_Entries to remove duplicated + code. + (PO_Do_Or_Queue): Remove duplicated code and use Requeue_Call. + +2004-03-25 Jose Ruiz + + * Makefile.in: Clean up in the ravenscar run time. + 2004-03-23 Richard Kenner * decl.c (gnat_to_gnu_entity, case E_Access_Type): Pass value diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 910411058e7..3fd157b4e59 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -567,6 +567,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) s-interr.adb<1sinterr.adb \ s-taskin.ads<1staskin.ads \ s-taskin.adb<1staskin.adb \ + s-taspri.ads<1staspri.ads \ s-tarest.adb<1starest.adb \ s-tposen.ads<1stposen.ads \ s-tposen.adb<1stposen.adb \ diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index be1eb29658b..bb4b3f93e24 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1868,10 +1868,8 @@ package body Freeze is -- It is improper to freeze an external entity within a generic -- because its freeze node will appear in a non-valid context. - -- ??? We should probably freeze the entity at that point and insert - -- the freeze node in a proper place but this proper place is not - -- easy to find, and the proper scope is not easy to restore. For - -- now, just wait to get out of the generic to freeze ??? + -- The entity will be frozen in the proper scope after the current + -- generic is analyzed. elsif Inside_A_Generic and then External_Ref_In_Generic (E) then return No_List; @@ -2005,7 +2003,8 @@ package body Freeze is if Is_Subprogram (E) then if not Is_Internal (E) then declare - F_Type : Entity_Id; + F_Type : Entity_Id; + Warn_Node : Node_Id; function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean; -- Determines if given type entity is a fat pointer type @@ -2082,12 +2081,30 @@ package body Freeze is and then Warn_On_Export_Import then Error_Msg_Qual_Level := 1; - Error_Msg_N + + -- If this is an inherited operation, place the + -- warning on the derived type declaration, rather + -- than on the original subprogram. + + if Nkind (Original_Node (Parent (E))) = + N_Full_Type_Declaration + then + Warn_Node := Parent (E); + + if Formal = First_Formal (E) then + Error_Msg_NE + ("?in inherited operation&!", Warn_Node, E); + end if; + else + Warn_Node := Formal; + end if; + + Error_Msg_NE ("?type of argument& is unconstrained array", - Formal); - Error_Msg_N + Warn_Node, Formal); + Error_Msg_NE ("?foreign caller must pass bounds explicitly", - Formal); + Warn_Node, Formal); Error_Msg_Qual_Level := 0; end if; diff --git a/gcc/ada/memtrack.adb b/gcc/ada/memtrack.adb index 2531702cb7b..39ffb82eafb 100644 --- a/gcc/ada/memtrack.adb +++ b/gcc/ada/memtrack.adb @@ -297,15 +297,68 @@ package body System.Memory is function Realloc (Ptr : System.Address; Size : size_t) return System.Address is - Result : System.Address; + Addr : aliased constant System.Address := Ptr; + Result : aliased System.Address; begin + -- For the purposes of allocations logging, we treat realloc as a free + -- followed by malloc. This is not exactly accurate, but is a good way + -- to fit it into malloc/free-centered reports. + if Size = size_t'Last then Raise_Exception (Storage_Error'Identity, "object too large"); end if; Abort_Defer.all; - Result := c_realloc (Ptr, Size); + Lock_Task.all; + + if First_Call then + + First_Call := False; + + -- We first log deallocation call + + Gmem_Initialize; + Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls, + Skip_Frames => 2); + fputc (Character'Pos ('D'), Gmemfile); + fwrite (Addr'Address, Address_Size, 1, Gmemfile); + fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, + Gmemfile); + + for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop + declare + Ptr : System.Address := PC_For (Tracebk (J)); + begin + fwrite (Ptr'Address, Address_Size, 1, Gmemfile); + end; + end loop; + + -- Now perform actual realloc + + Result := c_realloc (Ptr, Size); + + -- Log allocation call using the same backtrace + + fputc (Character'Pos ('A'), Gmemfile); + fwrite (Result'Address, Address_Size, 1, Gmemfile); + fwrite (Size'Address, size_t'Max_Size_In_Storage_Elements, 1, + Gmemfile); + fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, + Gmemfile); + + for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop + declare + Ptr : System.Address := PC_For (Tracebk (J)); + begin + fwrite (Ptr'Address, Address_Size, 1, Gmemfile); + end; + end loop; + + First_Call := True; + end if; + + Unlock_Task.all; Abort_Undefer.all; if Result = System.Null_Address then diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index dd16d034bcf..bed3415e9e7 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -43,6 +43,8 @@ with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Regexp; use GNAT.Regexp; +with System.Case_Util; use System.Case_Util; + package body Prj.Makr is function Dup (Fd : File_Descriptor) return File_Descriptor; @@ -134,8 +136,8 @@ package body Prj.Makr is Args : Argument_List (1 .. Preproc_Switches'Length + 6); type SFN_Pragma is record - Unit : String_Access; - File : String_Access; + Unit : Name_Id; + File : Name_Id; Spec : Boolean; end record; @@ -165,8 +167,14 @@ package body Prj.Makr is Temp_File_Name : String_Access := null; + Save_Last_Pragma_Index : Natural := 0; + + File_Name_Id : Name_Id := No_Name; + + SFN_Prag : SFN_Pragma; + begin - -- Avoid processing several times the same directory. + -- Avoid processing the same directory more than once for Index in 1 .. Processed_Directories.Last loop if Processed_Directories.Table (Index).all = Dir_Name then @@ -199,15 +207,19 @@ package body Prj.Makr is -- Process each regular file in the directory - loop + File_Loop : loop Read (Dir, Str, Last); - exit when Last = 0; + exit File_Loop when Last = 0; if Is_Regular_File (Dir_Name & Directory_Separator & Str (1 .. Last)) then Matched := True; + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Str (1 .. Last); + File_Name_Id := Name_Find; + -- First, check if the file name matches at least one of -- the excluded expressions; @@ -256,7 +268,7 @@ package body Prj.Makr is Saved_Error : File_Descriptor; begin - -- If we don't have yet the path of the compiler, + -- If we don't have the path of the compiler yet, -- get it now. if Gcc_Path = null then @@ -302,8 +314,7 @@ package body Prj.Makr is Saved_Output := Dup (Standout); Saved_Error := Dup (Standerr); - -- Set the standard output and error to the temporary - -- file. + -- Set standard output and error to the temporary file Dup2 (FD, Standout); Dup2 (FD, Standerr); @@ -313,6 +324,7 @@ package body Prj.Makr is Spawn (Gcc_Path.all, Args, Success); -- Restore the standard output and error + Dup2 (Saved_Output, Standout); Dup2 (Saved_Error, Standerr); @@ -329,11 +341,11 @@ package body Prj.Makr is -- Now that standard output is restored, check if -- the compiler ran correctly. - -- Read the first line of the temporary file: - -- it should contain the kind and name of the unit. + -- Read the lines of the temporary file: + -- they should contain the kind and name of the unit. declare - File : Text_File; + File : Text_File; Text_Line : String (1 .. 1_000); Text_Last : Natural; @@ -345,173 +357,180 @@ package body Prj.Makr is ("could not read temporary file"); end if; + Save_Last_Pragma_Index := SFN_Pragmas.Last; + if End_Of_File (File) then if Opt.Verbose_Mode then if not Success then Output.Write_Str ("(process died) "); end if; + end if; + else + Line_Loop : while not End_Of_File (File) loop + Get_Line (File, Text_Line, Text_Last); + + -- Find the first closing parenthesis + Char_Loop : for J in 1 .. Text_Last loop + if Text_Line (J) = ')' then + if J >= 13 and then + Text_Line (1 .. 4) = "Unit" + then + -- Add an entry in the SFN_Pragmas + -- table. + + Name_Len := J - 12; + Name_Buffer (1 .. Name_Len) := + Text_Line (6 .. J - 7); + SFN_Prag := + (Unit => Name_Find, + File => File_Name_Id, + Spec => Text_Line (J - 5 .. J) = + "(spec)"); + + SFN_Pragmas.Increment_Last; + SFN_Pragmas.Table + (SFN_Pragmas.Last) := SFN_Prag; + end if; + exit Char_Loop; + end if; + end loop Char_Loop; + end loop Line_Loop; + end if; + + if Save_Last_Pragma_Index = SFN_Pragmas.Last then + if Opt.Verbose_Mode then Output.Write_Line ("not a unit"); end if; - else - Get_Line (File, Text_Line, Text_Last); - Close (File); + elsif SFN_Pragmas.Last > + Save_Last_Pragma_Index + 1 + then + SFN_Pragmas.Set_Last (Save_Last_Pragma_Index); - -- Now that we have read the line, delete the - -- temporary file, it is not needed anymore. - -- On VMS, this avoids several version of the - -- file, if it were only delete after all - -- sources were parsed. + if Opt.Verbose_Mode then + Output.Write_Line + ("file contains multiple units"); + end if; - Delete_File (Temp_File_Name.all, Success); + else + SFN_Prag := SFN_Pragmas.Table + (SFN_Pragmas.Last); - -- Find the first closing parenthesis + if Opt.Verbose_Mode then + if SFN_Prag.Spec then + Output.Write_Str ("spec of "); - for J in 1 .. Text_Last loop - if Text_Line (J) = ')' then - Text_Last := J; - exit; + else + Output.Write_Str ("body of "); end if; - end loop; - declare - S : constant String := - Text_Line (1 .. Text_Last); + Output.Write_Line + (Get_Name_String (SFN_Prag.Unit)); + end if; - begin - if S'Length >= 13 - and then S (S'First .. S'First + 3) = "Unit" - then - if Opt.Verbose_Mode then - Output.Write_Str - (S (S'Last - 4 .. S'Last - 1)); - Output.Write_Str (" of "); - Output.Write_Line - (S (S'First + 5 .. S'Last - 7)); + if Project_File then + + -- Add the corresponding attribute in + -- the Naming package of the naming + -- project. + + declare + Decl_Item : constant Project_Node_Id + := Default_Project_Node + (Of_Kind => + N_Declarative_Item); + + Attribute : constant Project_Node_Id + := Default_Project_Node + (Of_Kind => + N_Attribute_Declaration); + + Expression : constant Project_Node_Id + := Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => Single); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + And_Expr_Kind => Single); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Literal_String, + And_Expr_Kind => + Single); + + begin + Set_Next_Declarative_Item + (Decl_Item, + To => First_Declarative_Item_Of + (Naming_Package)); + Set_First_Declarative_Item_Of + (Naming_Package, To => Decl_Item); + Set_Current_Item_Node + (Decl_Item, To => Attribute); + + -- Is it a spec or a body? + + if SFN_Prag.Spec then + Set_Name_Of + (Attribute, To => Name_Spec); + else + Set_Name_Of + (Attribute, + To => Name_Body); end if; - if Project_File then - - -- Add the corresponding attribute in - -- the Naming package of the naming - -- project. - - declare - Decl_Item : constant Project_Node_Id - := Default_Project_Node - (Of_Kind => - N_Declarative_Item); - - Attribute : constant Project_Node_Id - := Default_Project_Node - (Of_Kind => - N_Attribute_Declaration); - - Expression : constant Project_Node_Id - := Default_Project_Node - (Of_Kind => N_Expression, - And_Expr_Kind => Single); - - Term : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Term, - And_Expr_Kind => Single); - - Value : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => - N_Literal_String, - And_Expr_Kind => - Single); - - begin - Set_Next_Declarative_Item - (Decl_Item, - To => First_Declarative_Item_Of - (Naming_Package)); - Set_First_Declarative_Item_Of - (Naming_Package, To => Decl_Item); - Set_Current_Item_Node - (Decl_Item, To => Attribute); - - -- Is it a spec or a body? - - if S (S'Last - 5 .. S'Last) = - "(spec)" - then - Set_Name_Of - (Attribute, To => Name_Spec); - else - Set_Name_Of - (Attribute, - To => Name_Body); - end if; - - -- Get the name of the unit - - Name_Len := S'Last - S'First - 11; - Name_Buffer (1 .. Name_Len) := - (To_Lower - (S (S'First + 5 .. - S'Last - 7))); - Set_Associative_Array_Index_Of - (Attribute, To => Name_Find); + -- Get the name of the unit - Set_Expression_Of - (Attribute, To => Expression); - Set_First_Term - (Expression, To => Term); - Set_Current_Term (Term, To => Value); + Get_Name_String (SFN_Prag.Unit); + To_Lower (Name_Buffer (1 .. Name_Len)); + Set_Associative_Array_Index_Of + (Attribute, To => Name_Find); - -- And set the name of the file + Set_Expression_Of + (Attribute, To => Expression); + Set_First_Term + (Expression, To => Term); + Set_Current_Term (Term, To => Value); - Name_Len := Last; - Name_Buffer (1 .. Name_Len) := - Str (1 .. Last); - Set_String_Value_Of - (Value, To => Name_Find); - end; + -- And set the name of the file - -- Add source file name to source list - -- file. + Set_String_Value_Of + (Value, To => File_Name_Id); + end; - Last := Last + 1; - Str (Last) := ASCII.LF; + -- Add source file name to source list + -- file. - if Write (Source_List_FD, - Str (1)'Address, - Last) /= Last - then - Prj.Com.Fail ("disk full"); - end if; - else - -- Add an entry in the SFN_Pragmas - -- table. - - SFN_Pragmas.Increment_Last; - SFN_Pragmas.Table (SFN_Pragmas.Last) := - (Unit => new String' - (S (S'First + 5 .. S'Last - 7)), - File => new String'(Str (1 .. Last)), - Spec => S (S'Last - 5 .. S'Last) - = "(spec)"); - end if; + Last := Last + 1; + Str (Last) := ASCII.LF; - else - if Opt.Verbose_Mode then - Output.Write_Line ("not a unit"); - end if; + if Write (Source_List_FD, + Str (1)'Address, + Last) /= Last + then + Prj.Com.Fail ("disk full"); end if; - end; + end if; end if; + + Close (File); + + Delete_File (Temp_File_Name.all, Success); end; end; + -- File name matches none of the regular expressions + else - if Matched = False then - -- Look if this is a foreign source + -- If the file is not excluded, look if this is a foreign + -- source. + if Matched /= Excluded then for Index in Foreign_Expressions'Range loop if Match (Str (1 .. Last), Foreign_Expressions (Index)) @@ -551,7 +570,7 @@ package body Prj.Makr is end if; end if; end if; - end loop; + end loop File_Loop; Close (Dir); end if; @@ -718,7 +737,6 @@ package body Prj.Makr is declare Discard : Boolean; - begin Delete_File (Source_List_Path (1 .. Source_List_Last), @@ -753,7 +771,6 @@ package body Prj.Makr is begin Excluded_Expressions (Index) := Compile (Pattern => Excluded_Patterns (Index).all, Glob => True); - exception when Error_In_Regexp => Prj.Com.Fail @@ -773,7 +790,6 @@ package body Prj.Makr is begin Foreign_Expressions (Index) := Compile (Pattern => Foreign_Patterns (Index).all, Glob => True); - exception when Error_In_Regexp => Prj.Com.Fail @@ -823,8 +839,8 @@ package body Prj.Makr is end if; Part.Parse - (Project => Project_Node, - Project_File_Name => Output_Name (1 .. Output_Name_Last), + (Project => Project_Node, + Project_File_Name => Output_Name (1 .. Output_Name_Last), Always_Errout_Finalize => False); -- If parsing was successful, remove the components that are @@ -837,7 +853,7 @@ package body Prj.Makr is declare With_Clause : Project_Node_Id := - First_With_Clause_Of (Project_Node); + First_With_Clause_Of (Project_Node); Previous : Project_Node_Id := Empty_Node; begin @@ -1248,7 +1264,8 @@ package body Prj.Makr is Write_A_String ("pragma Source_File_Name"); Write_Eol; Write_A_String (" ("); - Write_A_String (SFN_Pragmas.Table (Index).Unit.all); + Write_A_String + (Get_Name_String (SFN_Pragmas.Table (Index).Unit)); Write_A_String (","); Write_Eol; @@ -1259,7 +1276,8 @@ package body Prj.Makr is Write_A_String (" Body_File_Name => """); end if; - Write_A_String (SFN_Pragmas.Table (Index).File.all); + Write_A_String + (Get_Name_String (SFN_Pragmas.Table (Index).File)); Write_A_String (""");"); Write_Eol; end loop; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 51d5e0e8253..5b09f849127 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -136,7 +136,8 @@ package body Prj.Nmsc is Data : in out Project_Data; Location : Source_Ptr; Current_Source : in out String_List_Id; - Source_Recorded : in out Boolean); + Source_Recorded : in out Boolean; + Trusted_Mode : Boolean); -- Put a unit in the list of units of a project, if the file name -- corresponds to a valid unit name. @@ -703,7 +704,8 @@ package body Prj.Nmsc is (Name => Name_Buffer (1 .. Name_Len), Directory => Source_Directory (Source_Directory'First .. Dir_Last), - Resolve_Links => not Trusted_Mode); + Resolve_Links => False, + Case_Sensitive => True); Path_Name : Name_Id; begin @@ -725,7 +727,8 @@ package body Prj.Nmsc is Data => Data, Location => No_Location, Current_Source => Current_Source, - Source_Recorded => Source_Recorded); + Source_Recorded => Source_Recorded, + Trusted_Mode => Trusted_Mode); end if; end; end loop; @@ -841,7 +844,8 @@ package body Prj.Nmsc is Data => Data, Location => NL.Location, Current_Source => Current_Source, - Source_Recorded => Source_Recorded); + Source_Recorded => Source_Recorded, + Trusted_Mode => Trusted_Mode); end if; end loop; @@ -2591,7 +2595,7 @@ package body Prj.Nmsc is The_Path : constant String := Normalize_Pathname (Get_Name_String (Path)) & - Directory_Separator; + Directory_Separator; The_Path_Last : constant Natural := Compute_Directory_Last (The_Path); @@ -2692,7 +2696,9 @@ package body Prj.Nmsc is (Name => Name (1 .. Last), Directory => The_Path - (The_Path'First .. The_Path_Last)); + (The_Path'First .. The_Path_Last), + Resolve_Links => False, + Case_Sensitive => True); begin if Is_Directory (Path_Name) then @@ -2761,7 +2767,9 @@ package body Prj.Nmsc is Normalize_Pathname (Name => Get_Name_String (Base_Dir), Directory => - Get_Name_String (Data.Display_Directory)); + Get_Name_String (Data.Display_Directory), + Resolve_Links => False, + Case_Sensitive => True); begin if Root_Dir'Length = 0 then @@ -3544,13 +3552,24 @@ package body Prj.Nmsc is if Is_Directory (The_Name) then declare Normed : constant String := - Normalize_Pathname (The_Name); + Normalize_Pathname + (The_Name, + Resolve_Links => False, + Case_Sensitive => True); + + Canonical_Path : constant String := + Normalize_Pathname + (Normed, + Resolve_Links => True, + Case_Sensitive => False); begin Name_Len := Normed'Length; Name_Buffer (1 .. Name_Len) := Normed; Display := Name_Find; - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + + Name_Len := Canonical_Path'Length; + Name_Buffer (1 .. Name_Len) := Canonical_Path; Dir := Name_Find; end; end if; @@ -3565,13 +3584,24 @@ package body Prj.Nmsc is if Is_Directory (Full_Path) then declare Normed : constant String := - Normalize_Pathname (Full_Path); + Normalize_Pathname + (Full_Path, + Resolve_Links => False, + Case_Sensitive => True); + + Canonical_Path : constant String := + Normalize_Pathname + (Normed, + Resolve_Links => True, + Case_Sensitive => False); begin Name_Len := Normed'Length; Name_Buffer (1 .. Name_Len) := Normed; Display := Name_Find; - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + + Name_Len := Canonical_Path'Length; + Name_Buffer (1 .. Name_Len) := Canonical_Path; Dir := Name_Find; end; end if; @@ -3637,7 +3667,8 @@ package body Prj.Nmsc is Data : in out Project_Data; Location : Source_Ptr; Current_Source : in out String_List_Id; - Source_Recorded : in out Boolean) + Source_Recorded : in out Boolean; + Trusted_Mode : Boolean) is Canonical_File_Name : Name_Id; Canonical_Path_Name : Name_Id; @@ -3655,9 +3686,18 @@ package body Prj.Nmsc is Get_Name_String (File_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Canonical_File_Name := Name_Find; - Get_Name_String (Path_Name); - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Canonical_Path_Name := Name_Find; + + declare + Canonical_Path : constant String := + Normalize_Pathname + (Get_Name_String (Path_Name), + Resolve_Links => not Trusted_Mode, + Case_Sensitive => False); + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Canonical_Path); + Canonical_Path_Name := Name_Find; + end; -- Find out the unit name, the unit kind and if it needs -- a specific SFN pragma. diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 61826c90507..b381bacab09 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -863,14 +863,17 @@ package body Prj.Part is Extends_All := False; declare - Normed : String := Normalize_Pathname (Path_Name); + Normed_Path : constant String := Normalize_Pathname + (Path_Name, Resolve_Links => False, Case_Sensitive => True); + Canonical_Path : constant String := Normalize_Pathname + (Normed_Path, Resolve_Links => True, Case_Sensitive => False); + begin - Name_Len := Normed'Length; - Name_Buffer (1 .. Name_Len) := Normed; + Name_Len := Normed_Path'Length; + Name_Buffer (1 .. Name_Len) := Normed_Path; Normed_Path_Name := Name_Find; - Canonical_Case_File_Name (Normed); - Name_Len := Normed'Length; - Name_Buffer (1 .. Name_Len) := Normed; + Name_Len := Canonical_Path'Length; + Name_Buffer (1 .. Name_Len) := Canonical_Path; Canonical_Path_Name := Name_Find; end; @@ -1670,7 +1673,10 @@ package body Prj.Part is else declare Final_Result : constant String := - GNAT.OS_Lib.Normalize_Pathname (Result.all); + GNAT.OS_Lib.Normalize_Pathname + (Result.all, + Resolve_Links => False, + Case_Sensitive => True); begin Free (Result); return Final_Result; diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 5bbe18ebcca..fde749e9eef 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -119,6 +119,15 @@ package body System.Tasking.Protected_Objects.Operations is -- Call this only while holding the PO's lock. -- It returns with the PO's lock still held. + procedure Requeue_Call + (Self_Id : Task_ID; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link; + With_Abort : Boolean); + -- Handle requeue of Entry_Call. + -- In particular, queue the call if needed, or service it immediately + -- if possible. + --------------------------------- -- Cancel_Protected_Entry_Call -- --------------------------------- @@ -288,11 +297,9 @@ package body System.Tasking.Protected_Objects.Operations is Entry_Call : Entry_Call_Link; With_Abort : Boolean) is - E : Protected_Entry_Index := Protected_Entry_Index (Entry_Call.E); - New_Object : Protection_Entries_Access; - Ceiling_Violation : Boolean; - Barrier_Value : Boolean; - Result : Boolean; + E : constant Protected_Entry_Index := + Protected_Entry_Index (Entry_Call.E); + Barrier_Value : Boolean; begin -- When the Action procedure for an entry body returns, it is either @@ -339,75 +346,7 @@ package body System.Tasking.Protected_Objects.Operations is end if; else - -- Body of current entry requeued the call - New_Object := To_Protection (Entry_Call.Called_PO); - - if New_Object = null then - - -- Call was requeued to a task - - if Single_Lock then - STPO.Lock_RTS; - end if; - - Result := Rendezvous.Task_Do_Or_Queue - (Self_ID, Entry_Call, - With_Abort => Entry_Call.Requeue_With_Abort); - - if not Result then - Queuing.Broadcast_Program_Error - (Self_ID, Object, Entry_Call, RTS_Locked => True); - end if; - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - return; - end if; - - if Object /= New_Object then - -- Requeue is on a different object - - Lock_Entries (New_Object, Ceiling_Violation); - - if Ceiling_Violation then - Object.Call_In_Progress := null; - Queuing.Broadcast_Program_Error - (Self_ID, Object, Entry_Call); - - else - PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, With_Abort); - PO_Service_Entries (Self_ID, New_Object); - end if; - - else - -- Requeue is on same protected object - - if Entry_Call.Requeue_With_Abort - and then Entry_Call.Cancellation_Attempted - then - -- If this is a requeue with abort and someone tried - -- to cancel this call, cancel it at this point. - - Entry_Call.State := Cancelled; - return; - end if; - - if not With_Abort or else - Entry_Call.Mode /= Conditional_Call - then - E := Protected_Entry_Index (Entry_Call.E); - Queuing.Enqueue - (New_Object.Entry_Queues (E), Entry_Call); - Update_For_Queue_To_PO (Entry_Call, With_Abort); - - else - -- Can we convert this recursion to a loop??? - - PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, With_Abort); - end if; - end if; + Requeue_Call (Self_ID, Object, Entry_Call, With_Abort); end if; elsif Entry_Call.Mode /= Conditional_Call @@ -447,105 +386,9 @@ package body System.Tasking.Protected_Objects.Operations is Object : Entries.Protection_Entries_Access; Unlock_Object : Boolean := True) is - procedure Requeue_Call - (Entry_Call : Entry_Call_Link; - Call_Cancelled : out Boolean); - -- Handle requeue of Entry_Call. - -- Call_Cancelled is set to True of call was cancelled. - - ------------------ - -- Requeue_Call -- - ------------------ - - procedure Requeue_Call - (Entry_Call : Entry_Call_Link; - Call_Cancelled : out Boolean) - is - New_Object : Protection_Entries_Access; - Ceiling_Violation : Boolean; - Result : Boolean; - E : Protected_Entry_Index; - - begin - Call_Cancelled := False; - New_Object := To_Protection (Entry_Call.Called_PO); - - if New_Object = null then - - -- Call is to be requeued to a task entry - - if Single_Lock then - STPO.Lock_RTS; - end if; - - Result := Rendezvous.Task_Do_Or_Queue - (Self_ID, Entry_Call, - With_Abort => Entry_Call.Requeue_With_Abort); - - if not Result then - Queuing.Broadcast_Program_Error - (Self_ID, Object, Entry_Call, RTS_Locked => True); - end if; - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - else - -- Call should be requeued to a PO - - if Object /= New_Object then - - -- Requeue is to different PO - - Lock_Entries (New_Object, Ceiling_Violation); - - if Ceiling_Violation then - Object.Call_In_Progress := null; - Queuing.Broadcast_Program_Error - (Self_ID, Object, Entry_Call); - - else - PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, - Entry_Call.Requeue_With_Abort); - PO_Service_Entries (Self_ID, New_Object); - end if; - - else - -- Requeue is to same protected object - - if Entry_Call.Requeue_With_Abort - and then Entry_Call.Cancellation_Attempted - then - -- If this is a requeue with abort and someone tried - -- to cancel this call, cancel it at this point. - - Entry_Call.State := Cancelled; - Call_Cancelled := True; - return; - end if; - - if not Entry_Call.Requeue_With_Abort or else - Entry_Call.Mode /= Conditional_Call - then - E := Protected_Entry_Index (Entry_Call.E); - Queuing.Enqueue - (New_Object.Entry_Queues (E), Entry_Call); - Update_For_Queue_To_PO (Entry_Call, - Entry_Call.Requeue_With_Abort); - - else - PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, - Entry_Call.Requeue_With_Abort); - end if; - end if; - end if; - end Requeue_Call; - E : Protected_Entry_Index; Caller : Task_ID; Entry_Call : Entry_Call_Link; - Cancelled : Boolean; begin loop @@ -581,8 +424,9 @@ package body System.Tasking.Protected_Objects.Operations is end; if Object.Call_In_Progress = null then - Requeue_Call (Entry_Call, Cancelled); - exit when Cancelled; + Requeue_Call + (Self_ID, Object, Entry_Call, Entry_Call.Requeue_With_Abort); + exit when Entry_Call.State = Cancelled; else Object.Call_In_Progress := null; @@ -804,6 +648,92 @@ package body System.Tasking.Protected_Objects.Operations is Entry_Calls.Check_Exception (Self_ID, Entry_Call); end Protected_Entry_Call; + ------------------ + -- Requeue_Call -- + ------------------ + + procedure Requeue_Call + (Self_Id : Task_ID; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link; + With_Abort : Boolean) + is + New_Object : Protection_Entries_Access; + Ceiling_Violation : Boolean; + Result : Boolean; + E : Protected_Entry_Index; + + begin + New_Object := To_Protection (Entry_Call.Called_PO); + + if New_Object = null then + + -- Call is to be requeued to a task entry + + if Single_Lock then + STPO.Lock_RTS; + end if; + + Result := Rendezvous.Task_Do_Or_Queue + (Self_Id, Entry_Call, + With_Abort => Entry_Call.Requeue_With_Abort); + + if not Result then + Queuing.Broadcast_Program_Error + (Self_Id, Object, Entry_Call, RTS_Locked => True); + end if; + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + else + -- Call should be requeued to a PO + + if Object /= New_Object then + + -- Requeue is to different PO + + Lock_Entries (New_Object, Ceiling_Violation); + + if Ceiling_Violation then + Object.Call_In_Progress := null; + Queuing.Broadcast_Program_Error + (Self_Id, Object, Entry_Call); + + else + PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call, With_Abort); + PO_Service_Entries (Self_Id, New_Object); + end if; + + else + -- Requeue is to same protected object + + if Entry_Call.Requeue_With_Abort + and then Entry_Call.Cancellation_Attempted + then + -- If this is a requeue with abort and someone tried + -- to cancel this call, cancel it at this point. + + Entry_Call.State := Cancelled; + return; + end if; + + if not With_Abort + or else Entry_Call.Mode /= Conditional_Call + then + E := Protected_Entry_Index (Entry_Call.E); + Queuing.Enqueue + (New_Object.Entry_Queues (E), Entry_Call); + Update_For_Queue_To_PO (Entry_Call, With_Abort); + + else + PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call, With_Abort); + end if; + end if; + end if; + end Requeue_Call; + ---------------------------- -- Protected_Entry_Caller -- ---------------------------- diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index fe0389b6bf9..370bc1df999 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -861,9 +861,19 @@ package body Sem_Attr is procedure Check_Dereference is begin - if Is_Object_Reference (P) - and then Is_Access_Type (P_Type) + + -- Case of a subtype mark + + if Is_Entity_Name (P) + and then Is_Type (Entity (P)) then + return; + end if; + + -- Case of an expression + + Resolve (P); + if Is_Access_Type (P_Type) then Rewrite (P, Make_Explicit_Dereference (Sloc (P), Prefix => Relocate_Node (P))); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 90f285c029f..94e02cb1504 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6672,6 +6672,10 @@ package body Sem_Ch12 is Specification => New_Spec, Name => Nam); + if No (Actual) and then Box_Present (Formal) then + Set_From_Default (Decl_Node); + end if; + -- Gather possible interpretations for the actual before analyzing the -- instance. If overloaded, it will be resolved when analyzing the -- renaming declaration. diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 31b2a4aa6a1..9a61938b035 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1356,7 +1356,7 @@ package body Sem_Ch8 is if Old_S /= Any_Id then if Is_Actual - and then Box_Present (Inst_Node) + and then From_Default (N) then -- This is an implicit reference to the default actual diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 13cf050faec..78b5663c118 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -963,7 +963,10 @@ package body Sem_Elab is -- will be doing the actual call later, not now, and it -- is at the time of the actual call (statically speaking) -- that we must do our static check, not at the time of - -- its initial analysis). + -- its initial analysis). However, we have to check calls + -- within component definitions (e.g., a function call + -- that determines an array component bound), so we + -- terminate the loop in that case. P := Parent (N); while Present (P) loop @@ -972,6 +975,13 @@ package body Sem_Elab is Nkind (P) = N_Component_Declaration then return; + + -- The call occurs within the constraint of a component, + -- so it must be checked. + + elsif Nkind (P) = N_Component_Definition then + exit; + else P := Parent (P); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 02190ca20cc..4f6e2779e2f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3330,6 +3330,13 @@ package body Sem_Util is or else Nkind (Object) = N_Slice then return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); + + elsif Nkind (Object) = N_Type_Conversion then + -- A type conversion that Is_Variable is a view conversion: + -- go back to the denoted object. + return Is_Dependent_Component_Of_Mutable_Object + (Expression (Object)); + end if; end if; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index c7133d22e48..03d5b13f924 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1193,6 +1193,14 @@ package body Sinfo is return Flag4 (N); end From_At_Mod; + function From_Default + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration); + return Flag6 (N); + end From_Default; + function Generic_Associations (N : Node_Id) return List_Id is begin @@ -3641,6 +3649,14 @@ package body Sinfo is Set_Flag4 (N, Val); end Set_From_At_Mod; + procedure Set_From_Default + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration); + Set_Flag6 (N, Val); + end Set_From_Default; + procedure Set_Generic_Associations (N : Node_Id; Val : List_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index e090cb54148..434ad7172ae 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -968,6 +968,13 @@ package Sinfo is -- and the representation clause is considered to be type specific -- instead of subtype specific. + -- From_Default (Flag6-Sem) + -- This flag is set on the subprogram renaming declaration created in + -- an instance for a formal subprogram, when the formal is declared + -- with a box, and there is no explicit actual. If the flag is present, + -- the declaration is treated as an implicit reference to the formal in + -- the ali file. + -- Generic_Parent (Node5-Sem) -- Generic_parent is defined on declaration nodes that are instances. -- The value of Generic_Parent is the generic entity from which the @@ -4341,6 +4348,7 @@ package Sinfo is -- Name (Node2) -- Parent_Spec (Node4-Sem) -- Corresponding_Spec (Node5-Sem) + -- From_Default (Flag6-Sem) ----------------------------------------- -- 8.5.5 Generic Renaming Declaration -- @@ -6356,20 +6364,19 @@ package Sinfo is -- The front end also deals with specific cases that are not allowed -- e.g. involving unconstrained array types. - -- However, some checks, e.g. the check for suspicious aliasing - -- when converting to a pointer type, can more conveniently be - -- performed in the back end where alias sets are known. + -- For the case of the standard gigi backend, this means that all + -- checks are done in the front-end. - -- In addition, for specialized back ends, notably the JVM-based - -- back end for JGNAT, additional requirements and restrictions apply + -- However, in the case of specialized back-ends, notably the JVM + -- backend for JGNAT, additional requirements and restrictions apply -- to unchecked conversion, and these are most conveniently performed -- in the specialized back-end. - -- To accommodate this requirement, the following special node is - -- generated recording an unchecked conversion that needs to be - -- validated. The back end should post an appropriate error message - -- error message if the unchecked conversion is invalid or a warning - -- message if a special warning is warranted. + -- To accommodate this requirement, for such back ends, the following + -- special node is generated recording an unchecked conversion that + -- needs to be validated. The back end should post an appropriate + -- error message if the unchecked conversion is invalid or warrants + -- a special warning message. -- Source_Type and Target_Type point to the entities for the two -- types involved in the unchecked conversion instantiation that @@ -7230,6 +7237,9 @@ package Sinfo is function From_At_Mod (N : Node_Id) return Boolean; -- Flag4 + function From_Default + (N : Node_Id) return Boolean; -- Flag6 + function Generic_Associations (N : Node_Id) return List_Id; -- List3 @@ -8013,6 +8023,9 @@ package Sinfo is procedure Set_From_At_Mod (N : Node_Id; Val : Boolean := True); -- Flag4 + procedure Set_From_Default + (N : Node_Id; Val : Boolean := True); -- Flag6 + procedure Set_Generic_Associations (N : Node_Id; Val : List_Id); -- List3 @@ -8579,6 +8592,7 @@ package Sinfo is pragma Inline (Formal_Type_Definition); pragma Inline (Forwards_OK); pragma Inline (From_At_Mod); + pragma Inline (From_Default); pragma Inline (Generic_Associations); pragma Inline (Generic_Formal_Declarations); pragma Inline (Generic_Parent); @@ -8837,6 +8851,7 @@ package Sinfo is pragma Inline (Set_Formal_Type_Definition); pragma Inline (Set_Forwards_OK); pragma Inline (Set_From_At_Mod); + pragma Inline (Set_From_Default); pragma Inline (Set_Generic_Associations); pragma Inline (Set_Generic_Formal_Declarations); pragma Inline (Set_Generic_Parent);