+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>
* decl.c (gnat_to_gnu_entity, case E_Access_Type): Pass value
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 \
-- 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;
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
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;
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
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;
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;
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
-- 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;
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
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);
Spawn (Gcc_Path.all, Args, Success);
-- Restore the standard output and error
+
Dup2 (Saved_Output, Standout);
Dup2 (Saved_Error, Standerr);
-- 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;
("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))
end if;
end if;
end if;
- end loop;
+ end loop File_Loop;
Close (Dir);
end if;
declare
Discard : Boolean;
-
begin
Delete_File
(Source_List_Path (1 .. Source_List_Last),
begin
Excluded_Expressions (Index) :=
Compile (Pattern => Excluded_Patterns (Index).all, Glob => True);
-
exception
when Error_In_Regexp =>
Prj.Com.Fail
begin
Foreign_Expressions (Index) :=
Compile (Pattern => Foreign_Patterns (Index).all, Glob => True);
-
exception
when Error_In_Regexp =>
Prj.Com.Fail
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
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
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;
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;
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.
(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
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;
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;
The_Path : constant String :=
Normalize_Pathname (Get_Name_String (Path)) &
- Directory_Separator;
+ Directory_Separator;
The_Path_Last : constant Natural :=
Compute_Directory_Last (The_Path);
(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
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
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;
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;
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;
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.
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;
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;
-- 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 --
---------------------------------
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
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
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
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;
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 --
----------------------------
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)));
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.
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
-- 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
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;
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;
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
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
-- 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
-- Name (Node2)
-- Parent_Spec (Node4-Sem)
-- Corresponding_Spec (Node5-Sem)
+ -- From_Default (Flag6-Sem)
-----------------------------------------
-- 8.5.5 Generic Renaming Declaration --
-- 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
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
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
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);
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);
OSDN Git Service
