Skip to content

R
riscv-gcc-1
Commit 6d11af89 by Arnaud Charlet
Options

[multiple changes] 

2004-03-25  Vasiliy Fofanov  <fofanov@act-europe.fr>

	* memtrack.adb: Log realloc calls, which are treated as free followed
	by alloc.

2004-03-25  Vincent Celier  <celier@gnat.com>

	* 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  <quinot@act-europe.fr>

	* 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  <schonberg@gnat.com>

	* 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  <dismukes@gnat.com>

	* 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  <charlet@act-europe.fr>

	* 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  <ruiz@act-europe.fr>

	* Makefile.in: Clean up in the ravenscar run time.

From-SVN: r79953
parent 9728c9d1
Showing with 572 additions and 374 deletions
gcc/ada/ChangeLog
2004-03-25 Vasiliy Fofanov <fofanov@act-europe.fr>
* memtrack.adb: Log realloc calls, which are treated as free followed
by alloc.
2004-03-25 Vincent Celier <celier@gnat.com>
* 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 <quinot@act-europe.fr>
* 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 <schonberg@gnat.com>
* 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 <dismukes@gnat.com>
* 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 <charlet@act-europe.fr>
* 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 <ruiz@act-europe.fr>
* Makefile.in: Clean up in the ravenscar run time.
2004-03-23 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> 2004-03-23 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (gnat_to_gnu_entity, case E_Access_Type): Pass value * decl.c (gnat_to_gnu_entity, case E_Access_Type): Pass value
......
gcc/ada/Makefile.in
...@@ -567,6 +567,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) ...@@ -567,6 +567,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
s-interr.adb<1sinterr.adb \ s-interr.adb<1sinterr.adb \
s-taskin.ads<1staskin.ads \ s-taskin.ads<1staskin.ads \
s-taskin.adb<1staskin.adb \ s-taskin.adb<1staskin.adb \
s-taspri.ads<1staspri.ads \
s-tarest.adb<1starest.adb \ s-tarest.adb<1starest.adb \
s-tposen.ads<1stposen.ads \ s-tposen.ads<1stposen.ads \
s-tposen.adb<1stposen.adb \ s-tposen.adb<1stposen.adb \
......
gcc/ada/freeze.adb
...@@ -1868,10 +1868,8 @@ package body Freeze is ...@@ -1868,10 +1868,8 @@ package body Freeze is
-- It is improper to freeze an external entity within a generic -- It is improper to freeze an external entity within a generic
-- because its freeze node will appear in a non-valid context. -- because its freeze node will appear in a non-valid context.
-- ??? We should probably freeze the entity at that point and insert -- The entity will be frozen in the proper scope after the current
-- the freeze node in a proper place but this proper place is not -- generic is analyzed.
-- easy to find, and the proper scope is not easy to restore. For
-- now, just wait to get out of the generic to freeze ???
elsif Inside_A_Generic and then External_Ref_In_Generic (E) then elsif Inside_A_Generic and then External_Ref_In_Generic (E) then
return No_List; return No_List;
...@@ -2005,7 +2003,8 @@ package body Freeze is ...@@ -2005,7 +2003,8 @@ package body Freeze is
if Is_Subprogram (E) then if Is_Subprogram (E) then
if not Is_Internal (E) then if not Is_Internal (E) then
declare declare
F_Type : Entity_Id; F_Type : Entity_Id;
Warn_Node : Node_Id;
function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean; function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean;
-- Determines if given type entity is a fat pointer type -- Determines if given type entity is a fat pointer type
...@@ -2082,12 +2081,30 @@ package body Freeze is ...@@ -2082,12 +2081,30 @@ package body Freeze is
and then Warn_On_Export_Import and then Warn_On_Export_Import
then then
Error_Msg_Qual_Level := 1; 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", ("?type of argument& is unconstrained array",
Formal); Warn_Node, Formal);
Error_Msg_N Error_Msg_NE
("?foreign caller must pass bounds explicitly", ("?foreign caller must pass bounds explicitly",
Formal); Warn_Node, Formal);
Error_Msg_Qual_Level := 0; Error_Msg_Qual_Level := 0;
end if; end if;
......
gcc/ada/memtrack.adb
...@@ -297,15 +297,68 @@ package body System.Memory is ...@@ -297,15 +297,68 @@ package body System.Memory is
function Realloc function Realloc
(Ptr : System.Address; Size : size_t) return System.Address (Ptr : System.Address; Size : size_t) return System.Address
is is
Result : System.Address; Addr : aliased constant System.Address := Ptr;
Result : aliased System.Address;
begin 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 if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large"); Raise_Exception (Storage_Error'Identity, "object too large");
end if; end if;
Abort_Defer.all; 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; Abort_Undefer.all;
if Result = System.Null_Address then if Result = System.Null_Address then
......
gcc/ada/prj-makr.adb
...@@ -43,6 +43,8 @@ with GNAT.Directory_Operations; use GNAT.Directory_Operations; ...@@ -43,6 +43,8 @@ with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Regexp; use GNAT.Regexp; with GNAT.Regexp; use GNAT.Regexp;
with System.Case_Util; use System.Case_Util;
package body Prj.Makr is package body Prj.Makr is
function Dup (Fd : File_Descriptor) return File_Descriptor; function Dup (Fd : File_Descriptor) return File_Descriptor;
...@@ -134,8 +136,8 @@ package body Prj.Makr is ...@@ -134,8 +136,8 @@ package body Prj.Makr is
Args : Argument_List (1 .. Preproc_Switches'Length + 6); Args : Argument_List (1 .. Preproc_Switches'Length + 6);
type SFN_Pragma is record type SFN_Pragma is record
Unit : String_Access; Unit : Name_Id;
File : String_Access; File : Name_Id;
Spec : Boolean; Spec : Boolean;
end record; end record;
...@@ -165,8 +167,14 @@ package body Prj.Makr is ...@@ -165,8 +167,14 @@ package body Prj.Makr is
Temp_File_Name : String_Access := null; Temp_File_Name : String_Access := null;
Save_Last_Pragma_Index : Natural := 0;
File_Name_Id : Name_Id := No_Name;
SFN_Prag : SFN_Pragma;
begin begin
-- Avoid processing several times the same directory. -- Avoid processing the same directory more than once
for Index in 1 .. Processed_Directories.Last loop for Index in 1 .. Processed_Directories.Last loop
if Processed_Directories.Table (Index).all = Dir_Name then if Processed_Directories.Table (Index).all = Dir_Name then
...@@ -199,15 +207,19 @@ package body Prj.Makr is ...@@ -199,15 +207,19 @@ package body Prj.Makr is
-- Process each regular file in the directory -- Process each regular file in the directory
loop File_Loop : loop
Read (Dir, Str, Last); Read (Dir, Str, Last);
exit when Last = 0; exit File_Loop when Last = 0;
if Is_Regular_File if Is_Regular_File
(Dir_Name & Directory_Separator & Str (1 .. Last)) (Dir_Name & Directory_Separator & Str (1 .. Last))
then then
Matched := True; 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 -- First, check if the file name matches at least one of
-- the excluded expressions; -- the excluded expressions;
...@@ -256,7 +268,7 @@ package body Prj.Makr is ...@@ -256,7 +268,7 @@ package body Prj.Makr is
Saved_Error : File_Descriptor; Saved_Error : File_Descriptor;
begin 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. -- get it now.
if Gcc_Path = null then if Gcc_Path = null then
...@@ -302,8 +314,7 @@ package body Prj.Makr is ...@@ -302,8 +314,7 @@ package body Prj.Makr is
Saved_Output := Dup (Standout); Saved_Output := Dup (Standout);
Saved_Error := Dup (Standerr); Saved_Error := Dup (Standerr);
-- Set the standard output and error to the temporary -- Set standard output and error to the temporary file
-- file.
Dup2 (FD, Standout); Dup2 (FD, Standout);
Dup2 (FD, Standerr); Dup2 (FD, Standerr);
...@@ -313,6 +324,7 @@ package body Prj.Makr is ...@@ -313,6 +324,7 @@ package body Prj.Makr is
Spawn (Gcc_Path.all, Args, Success); Spawn (Gcc_Path.all, Args, Success);
-- Restore the standard output and error -- Restore the standard output and error
Dup2 (Saved_Output, Standout); Dup2 (Saved_Output, Standout);
Dup2 (Saved_Error, Standerr); Dup2 (Saved_Error, Standerr);
...@@ -329,11 +341,11 @@ package body Prj.Makr is ...@@ -329,11 +341,11 @@ package body Prj.Makr is
-- Now that standard output is restored, check if -- Now that standard output is restored, check if
-- the compiler ran correctly. -- the compiler ran correctly.
-- Read the first line of the temporary file: -- Read the lines of the temporary file:
-- it should contain the kind and name of the unit. -- they should contain the kind and name of the unit.
declare declare
File : Text_File; File : Text_File;
Text_Line : String (1 .. 1_000); Text_Line : String (1 .. 1_000);
Text_Last : Natural; Text_Last : Natural;
...@@ -345,173 +357,180 @@ package body Prj.Makr is ...@@ -345,173 +357,180 @@ package body Prj.Makr is
("could not read temporary file"); ("could not read temporary file");
end if; end if;
Save_Last_Pragma_Index := SFN_Pragmas.Last;
if End_Of_File (File) then if End_Of_File (File) then
if Opt.Verbose_Mode then if Opt.Verbose_Mode then
if not Success then if not Success then
Output.Write_Str ("(process died) "); Output.Write_Str ("(process died) ");
end if; 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"); Output.Write_Line ("not a unit");
end if; end if;
else elsif SFN_Pragmas.Last >
Get_Line (File, Text_Line, Text_Last); Save_Last_Pragma_Index + 1
Close (File); then
SFN_Pragmas.Set_Last (Save_Last_Pragma_Index);
-- Now that we have read the line, delete the if Opt.Verbose_Mode then
-- temporary file, it is not needed anymore. Output.Write_Line
-- On VMS, this avoids several version of the ("file contains multiple units");
-- file, if it were only delete after all end if;
-- sources were parsed.
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 else
if Text_Line (J) = ')' then Output.Write_Str ("body of ");
Text_Last := J;
exit;
end if; end if;
end loop;
declare Output.Write_Line
S : constant String := (Get_Name_String (SFN_Prag.Unit));
Text_Line (1 .. Text_Last); end if;
begin if Project_File then
if S'Length >= 13
and then S (S'First .. S'First + 3) = "Unit" -- Add the corresponding attribute in
then -- the Naming package of the naming
if Opt.Verbose_Mode then -- project.
Output.Write_Str
(S (S'Last - 4 .. S'Last - 1)); declare
Output.Write_Str (" of "); Decl_Item : constant Project_Node_Id
Output.Write_Line := Default_Project_Node
(S (S'First + 5 .. S'Last - 7)); (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; end if;
if Project_File then -- Get the name of the unit
-- 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);
Set_Expression_Of Get_Name_String (SFN_Prag.Unit);
(Attribute, To => Expression); To_Lower (Name_Buffer (1 .. Name_Len));
Set_First_Term Set_Associative_Array_Index_Of
(Expression, To => Term); (Attribute, To => Name_Find);
Set_Current_Term (Term, To => Value);
-- 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; -- And set the name of the file
Name_Buffer (1 .. Name_Len) :=
Str (1 .. Last);
Set_String_Value_Of
(Value, To => Name_Find);
end;
-- Add source file name to source list Set_String_Value_Of
-- file. (Value, To => File_Name_Id);
end;
Last := Last + 1; -- Add source file name to source list
Str (Last) := ASCII.LF; -- file.
if Write (Source_List_FD, Last := Last + 1;
Str (1)'Address, Str (Last) := ASCII.LF;
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;
else if Write (Source_List_FD,
if Opt.Verbose_Mode then Str (1)'Address,
Output.Write_Line ("not a unit"); Last) /= Last
end if; then
Prj.Com.Fail ("disk full");
end if; end if;
end; end if;
end if; end if;
Close (File);
Delete_File (Temp_File_Name.all, Success);
end; end;
end; end;
-- File name matches none of the regular expressions
else else
if Matched = False then -- If the file is not excluded, look if this is a foreign
-- Look if this is a foreign source -- source.
if Matched /= Excluded then
for Index in Foreign_Expressions'Range loop for Index in Foreign_Expressions'Range loop
if Match (Str (1 .. Last), if Match (Str (1 .. Last),
Foreign_Expressions (Index)) Foreign_Expressions (Index))
...@@ -551,7 +570,7 @@ package body Prj.Makr is ...@@ -551,7 +570,7 @@ package body Prj.Makr is
end if; end if;
end if; end if;
end if; end if;
end loop; end loop File_Loop;
Close (Dir); Close (Dir);
end if; end if;
...@@ -718,7 +737,6 @@ package body Prj.Makr is ...@@ -718,7 +737,6 @@ package body Prj.Makr is
declare declare
Discard : Boolean; Discard : Boolean;
begin begin
Delete_File Delete_File
(Source_List_Path (1 .. Source_List_Last), (Source_List_Path (1 .. Source_List_Last),
...@@ -753,7 +771,6 @@ package body Prj.Makr is ...@@ -753,7 +771,6 @@ package body Prj.Makr is
begin begin
Excluded_Expressions (Index) := Excluded_Expressions (Index) :=
Compile (Pattern => Excluded_Patterns (Index).all, Glob => True); Compile (Pattern => Excluded_Patterns (Index).all, Glob => True);
exception exception
when Error_In_Regexp => when Error_In_Regexp =>
Prj.Com.Fail Prj.Com.Fail
...@@ -773,7 +790,6 @@ package body Prj.Makr is ...@@ -773,7 +790,6 @@ package body Prj.Makr is
begin begin
Foreign_Expressions (Index) := Foreign_Expressions (Index) :=
Compile (Pattern => Foreign_Patterns (Index).all, Glob => True); Compile (Pattern => Foreign_Patterns (Index).all, Glob => True);
exception exception
when Error_In_Regexp => when Error_In_Regexp =>
Prj.Com.Fail Prj.Com.Fail
...@@ -823,8 +839,8 @@ package body Prj.Makr is ...@@ -823,8 +839,8 @@ package body Prj.Makr is
end if; end if;
Part.Parse Part.Parse
(Project => Project_Node, (Project => Project_Node,
Project_File_Name => Output_Name (1 .. Output_Name_Last), Project_File_Name => Output_Name (1 .. Output_Name_Last),
Always_Errout_Finalize => False); Always_Errout_Finalize => False);
-- If parsing was successful, remove the components that are -- If parsing was successful, remove the components that are
...@@ -837,7 +853,7 @@ package body Prj.Makr is ...@@ -837,7 +853,7 @@ package body Prj.Makr is
declare declare
With_Clause : Project_Node_Id := With_Clause : Project_Node_Id :=
First_With_Clause_Of (Project_Node); First_With_Clause_Of (Project_Node);
Previous : Project_Node_Id := Empty_Node; Previous : Project_Node_Id := Empty_Node;
begin begin
...@@ -1248,7 +1264,8 @@ package body Prj.Makr is ...@@ -1248,7 +1264,8 @@ package body Prj.Makr is
Write_A_String ("pragma Source_File_Name"); Write_A_String ("pragma Source_File_Name");
Write_Eol; Write_Eol;
Write_A_String (" ("); 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_A_String (",");
Write_Eol; Write_Eol;
...@@ -1259,7 +1276,8 @@ package body Prj.Makr is ...@@ -1259,7 +1276,8 @@ package body Prj.Makr is
Write_A_String (" Body_File_Name => """); Write_A_String (" Body_File_Name => """);
end if; 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_A_String (""");");
Write_Eol; Write_Eol;
end loop; end loop;
......
gcc/ada/prj-nmsc.adb
...@@ -136,7 +136,8 @@ package body Prj.Nmsc is ...@@ -136,7 +136,8 @@ package body Prj.Nmsc is
Data : in out Project_Data; Data : in out Project_Data;
Location : Source_Ptr; Location : Source_Ptr;
Current_Source : in out String_List_Id; 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 -- Put a unit in the list of units of a project, if the file name
-- corresponds to a valid unit name. -- corresponds to a valid unit name.
...@@ -703,7 +704,8 @@ package body Prj.Nmsc is ...@@ -703,7 +704,8 @@ package body Prj.Nmsc is
(Name => Name_Buffer (1 .. Name_Len), (Name => Name_Buffer (1 .. Name_Len),
Directory => Source_Directory Directory => Source_Directory
(Source_Directory'First .. Dir_Last), (Source_Directory'First .. Dir_Last),
Resolve_Links => not Trusted_Mode); Resolve_Links => False,
Case_Sensitive => True);
Path_Name : Name_Id; Path_Name : Name_Id;
begin begin
...@@ -725,7 +727,8 @@ package body Prj.Nmsc is ...@@ -725,7 +727,8 @@ package body Prj.Nmsc is
Data => Data, Data => Data,
Location => No_Location, Location => No_Location,
Current_Source => Current_Source, Current_Source => Current_Source,
Source_Recorded => Source_Recorded); Source_Recorded => Source_Recorded,
Trusted_Mode => Trusted_Mode);
end if; end if;
end; end;
end loop; end loop;
...@@ -841,7 +844,8 @@ package body Prj.Nmsc is ...@@ -841,7 +844,8 @@ package body Prj.Nmsc is
Data => Data, Data => Data,
Location => NL.Location, Location => NL.Location,
Current_Source => Current_Source, Current_Source => Current_Source,
Source_Recorded => Source_Recorded); Source_Recorded => Source_Recorded,
Trusted_Mode => Trusted_Mode);
end if; end if;
end loop; end loop;
...@@ -2591,7 +2595,7 @@ package body Prj.Nmsc is ...@@ -2591,7 +2595,7 @@ package body Prj.Nmsc is
The_Path : constant String := The_Path : constant String :=
Normalize_Pathname (Get_Name_String (Path)) & Normalize_Pathname (Get_Name_String (Path)) &
Directory_Separator; Directory_Separator;
The_Path_Last : constant Natural := The_Path_Last : constant Natural :=
Compute_Directory_Last (The_Path); Compute_Directory_Last (The_Path);
...@@ -2692,7 +2696,9 @@ package body Prj.Nmsc is ...@@ -2692,7 +2696,9 @@ package body Prj.Nmsc is
(Name => Name (1 .. Last), (Name => Name (1 .. Last),
Directory => Directory =>
The_Path The_Path
(The_Path'First .. The_Path_Last)); (The_Path'First .. The_Path_Last),
Resolve_Links => False,
Case_Sensitive => True);
begin begin
if Is_Directory (Path_Name) then if Is_Directory (Path_Name) then
...@@ -2761,7 +2767,9 @@ package body Prj.Nmsc is ...@@ -2761,7 +2767,9 @@ package body Prj.Nmsc is
Normalize_Pathname Normalize_Pathname
(Name => Get_Name_String (Base_Dir), (Name => Get_Name_String (Base_Dir),
Directory => Directory =>
Get_Name_String (Data.Display_Directory)); Get_Name_String (Data.Display_Directory),
Resolve_Links => False,
Case_Sensitive => True);
begin begin
if Root_Dir'Length = 0 then if Root_Dir'Length = 0 then
...@@ -3544,13 +3552,24 @@ package body Prj.Nmsc is ...@@ -3544,13 +3552,24 @@ package body Prj.Nmsc is
if Is_Directory (The_Name) then if Is_Directory (The_Name) then
declare declare
Normed : constant String := 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 begin
Name_Len := Normed'Length; Name_Len := Normed'Length;
Name_Buffer (1 .. Name_Len) := Normed; Name_Buffer (1 .. Name_Len) := Normed;
Display := Name_Find; 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; Dir := Name_Find;
end; end;
end if; end if;
...@@ -3565,13 +3584,24 @@ package body Prj.Nmsc is ...@@ -3565,13 +3584,24 @@ package body Prj.Nmsc is
if Is_Directory (Full_Path) then if Is_Directory (Full_Path) then
declare declare
Normed : constant String := 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 begin
Name_Len := Normed'Length; Name_Len := Normed'Length;
Name_Buffer (1 .. Name_Len) := Normed; Name_Buffer (1 .. Name_Len) := Normed;
Display := Name_Find; 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; Dir := Name_Find;
end; end;
end if; end if;
...@@ -3637,7 +3667,8 @@ package body Prj.Nmsc is ...@@ -3637,7 +3667,8 @@ package body Prj.Nmsc is
Data : in out Project_Data; Data : in out Project_Data;
Location : Source_Ptr; Location : Source_Ptr;
Current_Source : in out String_List_Id; Current_Source : in out String_List_Id;
Source_Recorded : in out Boolean) Source_Recorded : in out Boolean;
Trusted_Mode : Boolean)
is is
Canonical_File_Name : Name_Id; Canonical_File_Name : Name_Id;
Canonical_Path_Name : Name_Id; Canonical_Path_Name : Name_Id;
...@@ -3655,9 +3686,18 @@ package body Prj.Nmsc is ...@@ -3655,9 +3686,18 @@ package body Prj.Nmsc is
Get_Name_String (File_Name); Get_Name_String (File_Name);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Canonical_File_Name := Name_Find; Canonical_File_Name := Name_Find;
Get_Name_String (Path_Name);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); declare
Canonical_Path_Name := Name_Find; 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 -- Find out the unit name, the unit kind and if it needs
-- a specific SFN pragma. -- a specific SFN pragma.
......
gcc/ada/prj-part.adb
...@@ -863,14 +863,17 @@ package body Prj.Part is ...@@ -863,14 +863,17 @@ package body Prj.Part is
Extends_All := False; Extends_All := False;
declare 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 begin
Name_Len := Normed'Length; Name_Len := Normed_Path'Length;
Name_Buffer (1 .. Name_Len) := Normed; Name_Buffer (1 .. Name_Len) := Normed_Path;
Normed_Path_Name := Name_Find; Normed_Path_Name := Name_Find;
Canonical_Case_File_Name (Normed); Name_Len := Canonical_Path'Length;
Name_Len := Normed'Length; Name_Buffer (1 .. Name_Len) := Canonical_Path;
Name_Buffer (1 .. Name_Len) := Normed;
Canonical_Path_Name := Name_Find; Canonical_Path_Name := Name_Find;
end; end;
...@@ -1670,7 +1673,10 @@ package body Prj.Part is ...@@ -1670,7 +1673,10 @@ package body Prj.Part is
else else
declare declare
Final_Result : constant String := 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 begin
Free (Result); Free (Result);
return Final_Result; return Final_Result;
......
gcc/ada/s-tpobop.adb
...@@ -119,6 +119,15 @@ package body System.Tasking.Protected_Objects.Operations is ...@@ -119,6 +119,15 @@ package body System.Tasking.Protected_Objects.Operations is
-- Call this only while holding the PO's lock. -- Call this only while holding the PO's lock.
-- It returns with the PO's lock still held. -- 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 -- -- Cancel_Protected_Entry_Call --
--------------------------------- ---------------------------------
...@@ -288,11 +297,9 @@ package body System.Tasking.Protected_Objects.Operations is ...@@ -288,11 +297,9 @@ package body System.Tasking.Protected_Objects.Operations is
Entry_Call : Entry_Call_Link; Entry_Call : Entry_Call_Link;
With_Abort : Boolean) With_Abort : Boolean)
is is
E : Protected_Entry_Index := Protected_Entry_Index (Entry_Call.E); E : constant Protected_Entry_Index :=
New_Object : Protection_Entries_Access; Protected_Entry_Index (Entry_Call.E);
Ceiling_Violation : Boolean; Barrier_Value : Boolean;
Barrier_Value : Boolean;
Result : Boolean;
begin begin
-- When the Action procedure for an entry body returns, it is either -- When the Action procedure for an entry body returns, it is either
...@@ -339,75 +346,7 @@ package body System.Tasking.Protected_Objects.Operations is ...@@ -339,75 +346,7 @@ package body System.Tasking.Protected_Objects.Operations is
end if; end if;
else else
-- Body of current entry requeued the call Requeue_Call (Self_ID, Object, Entry_Call, With_Abort);
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;
end if; end if;
elsif Entry_Call.Mode /= Conditional_Call elsif Entry_Call.Mode /= Conditional_Call
...@@ -447,105 +386,9 @@ package body System.Tasking.Protected_Objects.Operations is ...@@ -447,105 +386,9 @@ package body System.Tasking.Protected_Objects.Operations is
Object : Entries.Protection_Entries_Access; Object : Entries.Protection_Entries_Access;
Unlock_Object : Boolean := True) Unlock_Object : Boolean := True)
is 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; E : Protected_Entry_Index;
Caller : Task_ID; Caller : Task_ID;
Entry_Call : Entry_Call_Link; Entry_Call : Entry_Call_Link;
Cancelled : Boolean;
begin begin
loop loop
...@@ -581,8 +424,9 @@ package body System.Tasking.Protected_Objects.Operations is ...@@ -581,8 +424,9 @@ package body System.Tasking.Protected_Objects.Operations is
end; end;
if Object.Call_In_Progress = null then if Object.Call_In_Progress = null then
Requeue_Call (Entry_Call, Cancelled); Requeue_Call
exit when Cancelled; (Self_ID, Object, Entry_Call, Entry_Call.Requeue_With_Abort);
exit when Entry_Call.State = Cancelled;
else else
Object.Call_In_Progress := null; Object.Call_In_Progress := null;
...@@ -804,6 +648,92 @@ package body System.Tasking.Protected_Objects.Operations is ...@@ -804,6 +648,92 @@ package body System.Tasking.Protected_Objects.Operations is
Entry_Calls.Check_Exception (Self_ID, Entry_Call); Entry_Calls.Check_Exception (Self_ID, Entry_Call);
end Protected_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 -- -- Protected_Entry_Caller --
---------------------------- ----------------------------
......
gcc/ada/sem_attr.adb
...@@ -861,9 +861,19 @@ package body Sem_Attr is ...@@ -861,9 +861,19 @@ package body Sem_Attr is
procedure Check_Dereference is procedure Check_Dereference is
begin 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 then
return;
end if;
-- Case of an expression
Resolve (P);
if Is_Access_Type (P_Type) then
Rewrite (P, Rewrite (P,
Make_Explicit_Dereference (Sloc (P), Make_Explicit_Dereference (Sloc (P),
Prefix => Relocate_Node (P))); Prefix => Relocate_Node (P)));
......
gcc/ada/sem_ch12.adb
...@@ -6672,6 +6672,10 @@ package body Sem_Ch12 is ...@@ -6672,6 +6672,10 @@ package body Sem_Ch12 is
Specification => New_Spec, Specification => New_Spec,
Name => Nam); 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 -- Gather possible interpretations for the actual before analyzing the
-- instance. If overloaded, it will be resolved when analyzing the -- instance. If overloaded, it will be resolved when analyzing the
-- renaming declaration. -- renaming declaration.
......
gcc/ada/sem_ch8.adb
...@@ -1356,7 +1356,7 @@ package body Sem_Ch8 is ...@@ -1356,7 +1356,7 @@ package body Sem_Ch8 is
if Old_S /= Any_Id then if Old_S /= Any_Id then
if Is_Actual if Is_Actual
and then Box_Present (Inst_Node) and then From_Default (N)
then then
-- This is an implicit reference to the default actual -- This is an implicit reference to the default actual
......
gcc/ada/sem_elab.adb
...@@ -963,7 +963,10 @@ package body Sem_Elab is ...@@ -963,7 +963,10 @@ package body Sem_Elab is
-- will be doing the actual call later, not now, and it -- will be doing the actual call later, not now, and it
-- is at the time of the actual call (statically speaking) -- is at the time of the actual call (statically speaking)
-- that we must do our static check, not at the time of -- 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); P := Parent (N);
while Present (P) loop while Present (P) loop
...@@ -972,6 +975,13 @@ package body Sem_Elab is ...@@ -972,6 +975,13 @@ package body Sem_Elab is
Nkind (P) = N_Component_Declaration Nkind (P) = N_Component_Declaration
then then
return; return;
-- The call occurs within the constraint of a component,
-- so it must be checked.
elsif Nkind (P) = N_Component_Definition then
exit;
else else
P := Parent (P); P := Parent (P);
end if; end if;
......
gcc/ada/sem_util.adb
...@@ -3330,6 +3330,13 @@ package body Sem_Util is ...@@ -3330,6 +3330,13 @@ package body Sem_Util is
or else Nkind (Object) = N_Slice or else Nkind (Object) = N_Slice
then then
return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 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;
end if; end if;
......
gcc/ada/sinfo.adb
...@@ -1193,6 +1193,14 @@ package body Sinfo is ...@@ -1193,6 +1193,14 @@ package body Sinfo is
return Flag4 (N); return Flag4 (N);
end From_At_Mod; 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 function Generic_Associations
(N : Node_Id) return List_Id is (N : Node_Id) return List_Id is
begin begin
...@@ -3641,6 +3649,14 @@ package body Sinfo is ...@@ -3641,6 +3649,14 @@ package body Sinfo is
Set_Flag4 (N, Val); Set_Flag4 (N, Val);
end Set_From_At_Mod; 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 procedure Set_Generic_Associations
(N : Node_Id; Val : List_Id) is (N : Node_Id; Val : List_Id) is
begin begin
......
gcc/ada/sinfo.ads
...@@ -968,6 +968,13 @@ package Sinfo is ...@@ -968,6 +968,13 @@ package Sinfo is
-- and the representation clause is considered to be type specific -- and the representation clause is considered to be type specific
-- instead of subtype 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 (Node5-Sem)
-- Generic_parent is defined on declaration nodes that are instances. -- Generic_parent is defined on declaration nodes that are instances.
-- The value of Generic_Parent is the generic entity from which the -- The value of Generic_Parent is the generic entity from which the
...@@ -4341,6 +4348,7 @@ package Sinfo is ...@@ -4341,6 +4348,7 @@ package Sinfo is
-- Name (Node2) -- Name (Node2)
-- Parent_Spec (Node4-Sem) -- Parent_Spec (Node4-Sem)
-- Corresponding_Spec (Node5-Sem) -- Corresponding_Spec (Node5-Sem)
-- From_Default (Flag6-Sem)
----------------------------------------- -----------------------------------------
-- 8.5.5 Generic Renaming Declaration -- -- 8.5.5 Generic Renaming Declaration --
...@@ -6356,20 +6364,19 @@ package Sinfo is ...@@ -6356,20 +6364,19 @@ package Sinfo is
-- The front end also deals with specific cases that are not allowed -- The front end also deals with specific cases that are not allowed
-- e.g. involving unconstrained array types. -- e.g. involving unconstrained array types.
-- However, some checks, e.g. the check for suspicious aliasing -- For the case of the standard gigi backend, this means that all
-- when converting to a pointer type, can more conveniently be -- checks are done in the front-end.
-- performed in the back end where alias sets are known.
-- In addition, for specialized back ends, notably the JVM-based -- However, in the case of specialized back-ends, notably the JVM
-- back end for JGNAT, additional requirements and restrictions apply -- backend for JGNAT, additional requirements and restrictions apply
-- to unchecked conversion, and these are most conveniently performed -- to unchecked conversion, and these are most conveniently performed
-- in the specialized back-end. -- in the specialized back-end.
-- To accommodate this requirement, the following special node is -- To accommodate this requirement, for such back ends, the following
-- generated recording an unchecked conversion that needs to be -- special node is generated recording an unchecked conversion that
-- validated. The back end should post an appropriate error message -- needs to be validated. The back end should post an appropriate
-- error message if the unchecked conversion is invalid or a warning -- error message if the unchecked conversion is invalid or warrants
-- message if a special warning is warranted. -- a special warning message.
-- Source_Type and Target_Type point to the entities for the two -- Source_Type and Target_Type point to the entities for the two
-- types involved in the unchecked conversion instantiation that -- types involved in the unchecked conversion instantiation that
...@@ -7230,6 +7237,9 @@ package Sinfo is ...@@ -7230,6 +7237,9 @@ package Sinfo is
function From_At_Mod function From_At_Mod
(N : Node_Id) return Boolean; -- Flag4 (N : Node_Id) return Boolean; -- Flag4
function From_Default
(N : Node_Id) return Boolean; -- Flag6
function Generic_Associations function Generic_Associations
(N : Node_Id) return List_Id; -- List3 (N : Node_Id) return List_Id; -- List3
...@@ -8013,6 +8023,9 @@ package Sinfo is ...@@ -8013,6 +8023,9 @@ package Sinfo is
procedure Set_From_At_Mod procedure Set_From_At_Mod
(N : Node_Id; Val : Boolean := True); -- Flag4 (N : Node_Id; Val : Boolean := True); -- Flag4
procedure Set_From_Default
(N : Node_Id; Val : Boolean := True); -- Flag6
procedure Set_Generic_Associations procedure Set_Generic_Associations
(N : Node_Id; Val : List_Id); -- List3 (N : Node_Id; Val : List_Id); -- List3
...@@ -8579,6 +8592,7 @@ package Sinfo is ...@@ -8579,6 +8592,7 @@ package Sinfo is
pragma Inline (Formal_Type_Definition); pragma Inline (Formal_Type_Definition);
pragma Inline (Forwards_OK); pragma Inline (Forwards_OK);
pragma Inline (From_At_Mod); pragma Inline (From_At_Mod);
pragma Inline (From_Default);
pragma Inline (Generic_Associations); pragma Inline (Generic_Associations);
pragma Inline (Generic_Formal_Declarations); pragma Inline (Generic_Formal_Declarations);
pragma Inline (Generic_Parent); pragma Inline (Generic_Parent);
...@@ -8837,6 +8851,7 @@ package Sinfo is ...@@ -8837,6 +8851,7 @@ package Sinfo is
pragma Inline (Set_Formal_Type_Definition); pragma Inline (Set_Formal_Type_Definition);
pragma Inline (Set_Forwards_OK); pragma Inline (Set_Forwards_OK);
pragma Inline (Set_From_At_Mod); pragma Inline (Set_From_At_Mod);
pragma Inline (Set_From_Default);
pragma Inline (Set_Generic_Associations); pragma Inline (Set_Generic_Associations);
pragma Inline (Set_Generic_Formal_Declarations); pragma Inline (Set_Generic_Formal_Declarations);
pragma Inline (Set_Generic_Parent); pragma Inline (Set_Generic_Parent);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment