+2017-10-09 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch3.adb: Rename Uses_Unseen_Priv into
+ Contains_Lib_Incomplete_Type.
+
+2017-10-09 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_aggr.adb, sem_spark.adb, adabkend.adb, exp_ch5.adb, frontend.adb,
+ sem_ch12.adb, fmap.adb, exp_ch6.adb, exp_spark.adb, lib-load.adb,
+ exp_ch9.adb, osint.adb, exp_disp.adb, sem_ch8.adb, sem_ch8.ads,
+ prepcomp.adb, gnat1drv.adb, atree.adb, sinput-l.adb, targparm.adb,
+ sem_ch10.adb, par-ch8.adb: Minor reformatting.
+
2017-10-09 Hristian Kirtchev <kirtchev@adacore.com>
* sem_elab.adb (Is_Suitable_Access): This scenario is now only relevant
-- The front end leaves the Current_Error_Node at a location that is
-- meaningless and confusing when emitting bug boxes from the back end.
- -- By resetting it here we default to "No source file position
- -- information available" message on back end crashes.
+ -- Reset the global variable in order to emit "No source file position
+ -- information available" messages on back end crashes.
Current_Error_Node := Empty;
begin
pragma Debug (New_Node_Debugging_Output (Source));
pragma Debug (New_Node_Debugging_Output (Destination));
+
Nodes.Table (Destination) := Nodes.Table (Source);
Nodes.Table (Destination).In_List := Save_In_List;
Nodes.Table (Destination).Link := Save_Link;
begin
pragma Debug (New_Node_Debugging_Output (E1));
pragma Debug (New_Node_Debugging_Output (E2));
+
pragma Assert (True
and then Has_Extension (E1)
and then Has_Extension (E2)
begin
pragma Assert (not (Has_Extension (Node)));
+
Result := Allocate_Initialize_Node (Node, With_Extension => True);
pragma Debug (Debug_Extend_Node);
+
return Result;
end Extend_Node;
Current_Error_Node := Ent;
end if;
- Nodes.Table (Ent).Nkind := New_Node_Kind;
- Nodes.Table (Ent).Sloc := New_Sloc;
+ Nodes.Table (Ent).Nkind := New_Node_Kind;
+ Nodes.Table (Ent).Sloc := New_Sloc;
pragma Debug (New_Node_Debugging_Output (Ent));
-- Mark the new entity as Ghost depending on the current Ghost region
begin
pragma Assert (New_Node_Kind not in N_Entity);
+
Nod := Allocate_Initialize_Node (Empty, With_Extension => False);
Nodes.Table (Nod).Nkind := New_Node_Kind;
Nodes.Table (Nod).Sloc := New_Sloc;
(not Has_Extension (Old_Node)
and not Has_Extension (New_Node)
and not Nodes.Table (New_Node).In_List);
+
pragma Debug (New_Node_Debugging_Output (Old_Node));
pragma Debug (New_Node_Debugging_Output (New_Node));
(not Has_Extension (Old_Node)
and not Has_Extension (New_Node)
and not Nodes.Table (New_Node).In_List);
+
pragma Debug (New_Node_Debugging_Output (Old_Node));
pragma Debug (New_Node_Debugging_Output (New_Node));
-- suppressed in this case). It is unnecessary but harmless in
-- other cases.
- -- Special case: no copy if the target has no discriminants.
+ -- Special case: no copy if the target has no discriminants
if Has_Discriminants (L_Typ)
and then Is_Unchecked_Union (Base_Type (L_Typ))
if Prev_Orig /= Prev
and then Nkind (Prev) = N_Attribute_Reference
- and then
- Get_Attribute_Id (Attribute_Name (Prev)) = Attribute_Access
+ and then Get_Attribute_Id (Attribute_Name (Prev)) =
+ Attribute_Access
and then Is_Aliased_View (Prev_Orig)
then
Prev_Orig := Prev;
-- reference will have been rewritten.
if Expander_Active then
+
-- The expanded name may have been constant folded in which case
-- the original node is not necessarily an entity name (e.g. an
-- indexed component).
and then not Is_Interface (Full_Typ)
and then Has_Interfaces (Full_Typ)
and then (Full_Typ = Root_Typ
- or else not Is_Variable_Size_Record (Etype (Full_Typ)));
+ or else not Is_Variable_Size_Record (Etype (Full_Typ)));
end Building_Static_Secondary_DT;
----------------------------------
if Is_Discrete_Type (Etype (Discrim)) then
Append_To (Constr_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Etype (Discrim), Loc),
+ Prefix =>
+ New_Occurrence_Of (Etype (Discrim), Loc),
Attribute_Name => Name_First));
else
Make_Secondary_DT
(Typ => Typ,
- Iface => Base_Type
- (Related_Type (Node (AI_Tag_Comp))),
+ Iface =>
+ Base_Type (Related_Type (Node (AI_Tag_Comp))),
Iface_Comp => Node (AI_Tag_Comp),
Suffix_Index => Suffix_Index,
- Num_Iface_Prims => UI_To_Int
- (DT_Entry_Count (Node (AI_Tag_Comp))),
+ Num_Iface_Prims =>
+ UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))),
Iface_DT_Ptr => Node (AI_Tag_Elmt),
Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
Build_Thunks => True,
-- Replace occurrences of System'To_Address by calls to
-- System.Storage_Elements.To_Address
- procedure Expand_SPARK_Freeze_Type (E : Entity_Id);
+ procedure Expand_SPARK_N_Freeze_Type (E : Entity_Id);
-- Build the DIC procedure of a type when needed, if not already done
- procedure Expand_SPARK_Indexed_Component (N : Node_Id);
+ procedure Expand_SPARK_N_Indexed_Component (N : Node_Id);
-- Insert explicit dereference if required
procedure Expand_SPARK_N_Loop_Statement (N : Node_Id);
procedure Expand_SPARK_N_Op_Ne (N : Node_Id);
-- Rewrite operator /= based on operator = when defined explicitly
- procedure Expand_SPARK_Selected_Component (N : Node_Id);
+ procedure Expand_SPARK_N_Selected_Component (N : Node_Id);
-- Insert explicit dereference if required
------------------
when N_Freeze_Entity =>
if Is_Type (Entity (N)) then
- Expand_SPARK_Freeze_Type (Entity (N));
+ Expand_SPARK_N_Freeze_Type (Entity (N));
end if;
when N_Indexed_Component =>
- Expand_SPARK_Indexed_Component (N);
+ Expand_SPARK_N_Indexed_Component (N);
when N_Selected_Component =>
- Expand_SPARK_Selected_Component (N);
+ Expand_SPARK_N_Selected_Component (N);
-- In SPARK mode, no other constructs require expansion
end case;
end Expand_SPARK;
- ------------------------------
- -- Expand_SPARK_Freeze_Type --
- ------------------------------
+ --------------------------------
+ -- Expand_SPARK_N_Freeze_Type --
+ --------------------------------
- procedure Expand_SPARK_Freeze_Type (E : Entity_Id) is
+ procedure Expand_SPARK_N_Freeze_Type (E : Entity_Id) is
begin
-- When a DIC is inherited by a tagged type, it may need to be
-- specialized to the descendant type, hence build a separate DIC
if Has_DIC (E) and then Is_Tagged_Type (E) then
Build_DIC_Procedure_Body (E, For_Freeze => True);
end if;
- end Expand_SPARK_Freeze_Type;
+ end Expand_SPARK_N_Freeze_Type;
----------------------------------------
-- Expand_SPARK_N_Attribute_Reference --
end if;
end Expand_SPARK_N_Loop_Statement;
- ------------------------------------
- -- Expand_SPARK_Indexed_Component --
- ------------------------------------
+ --------------------------------------
+ -- Expand_SPARK_N_Indexed_Component --
+ --------------------------------------
+
+ procedure Expand_SPARK_N_Indexed_Component (N : Node_Id) is
+ Pref : constant Node_Id := Prefix (N);
+ Typ : constant Entity_Id := Etype (Pref);
- procedure Expand_SPARK_Indexed_Component (N : Node_Id) is
- P : constant Node_Id := Prefix (N);
- T : constant Entity_Id := Etype (P);
begin
- if Is_Access_Type (T) then
- Insert_Explicit_Dereference (P);
- Analyze_And_Resolve (P, Designated_Type (T));
+ if Is_Access_Type (Typ) then
+ Insert_Explicit_Dereference (Pref);
+ Analyze_And_Resolve (Pref, Designated_Type (Typ));
end if;
- end Expand_SPARK_Indexed_Component;
+ end Expand_SPARK_N_Indexed_Component;
---------------------------------------
-- Expand_SPARK_N_Object_Declaration --
end if;
end Expand_SPARK_Potential_Renaming;
- -------------------------------------
- -- Expand_SPARK_Selected_Component --
- -------------------------------------
+ ---------------------------------------
+ -- Expand_SPARK_N_Selected_Component --
+ ---------------------------------------
+
+ procedure Expand_SPARK_N_Selected_Component (N : Node_Id) is
+ Pref : constant Node_Id := Prefix (N);
+ Typ : constant Entity_Id := Underlying_Type (Etype (Pref));
- procedure Expand_SPARK_Selected_Component (N : Node_Id) is
- P : constant Node_Id := Prefix (N);
- Ptyp : constant Entity_Id := Underlying_Type (Etype (P));
begin
- if Present (Ptyp)
- and then Is_Access_Type (Ptyp)
- then
+ if Present (Typ) and then Is_Access_Type (Typ) then
+
-- First set prefix type to proper access type, in case it currently
-- has a private (non-access) view of this type.
- Set_Etype (P, Ptyp);
+ Set_Etype (Pref, Typ);
- Insert_Explicit_Dereference (P);
- Analyze_And_Resolve (P, Designated_Type (Ptyp));
+ Insert_Explicit_Dereference (Pref);
+ Analyze_And_Resolve (Pref, Designated_Type (Typ));
- if Ekind (Etype (P)) = E_Private_Subtype
- and then Is_For_Access_Subtype (Etype (P))
+ if Ekind (Etype (Pref)) = E_Private_Subtype
+ and then Is_For_Access_Subtype (Etype (Pref))
then
- Set_Etype (P, Base_Type (Etype (P)));
+ Set_Etype (Pref, Base_Type (Etype (Pref)));
end if;
end if;
- end Expand_SPARK_Selected_Component;
+ end Expand_SPARK_N_Selected_Component;
end Exp_SPARK;
else
Write_Str ("warning: no read access for mapping file """);
end if;
+
Write_Str (File_Name);
Write_Line ("""");
No_Mapping_File := True;
-- Case of gnat.adc file present
if Source_gnat_adc > No_Source_File then
+
-- Parse the gnat.adc file for configuration pragmas
Initialize_Scanner (No_Unit, Source_gnat_adc);
("fatal error, run-time library not installed correctly");
Write_Line ("cannot locate file system.ads");
raise Unrecoverable_Error;
+
elsif S = No_Access_To_Source_File then
Write_Line
("fatal error, run-time library not installed correctly");
if Main_Source_File > No_Source_File then
Version := Source_Checksum (Main_Source_File);
+
else
-- To avoid emitting a source location (since there is no file),
-- we write a custom error message instead of using the machinery
-- in errout.adb.
Set_Standard_Error;
+
if Main_Source_File = No_Access_To_Source_File then
- Write_Str ("no read access for file """
- & Get_Name_String (Fname) & """");
+ Write_Str
+ ("no read access for file """ & Get_Name_String (Fname)
+ & """");
else
- Write_Str ("file """
- & Get_Name_String (Fname) & """ not found");
+ Write_Str
+ ("file """ & Get_Name_String (Fname) & """ not found");
end if;
+
Write_Eol;
Set_Standard_Output;
end if;
else
Write_Str (" file was not found, load failed");
end if;
+
Write_Eol;
end if;
else
Error_Msg_File_1 := Fname;
+
if Src_Ind = No_Access_To_Source_File then
Error_Msg ("no read access to file{", Load_Msg_Sloc);
else
FD : out File_Descriptor;
T : File_Type := Source)
is
- -- Source_File_FD : File_Descriptor;
- -- The file descriptor for the current source file. A negative value
- -- indicates failure to open the specified source file.
-
Len : Integer;
-- Length of file, assume no more than 2 gigabytes of source
Append (Use_Node, Item_List);
Is_Last := True;
+
else
Set_More_Ids (Use_Node);
-- Error recovery: cannot raise Error_Resync
procedure P_Use_Type_Clause (Item_List : List_Id) is
+ Use_Sloc : constant Source_Ptr := Prev_Token_Ptr;
+
All_Present : Boolean;
Is_First : Boolean := True;
Is_Last : Boolean := False;
Use_Node : Node_Id;
- Use_Sloc : constant Source_Ptr := Prev_Token_Ptr;
begin
if Token = Tok_All then
String_To_Name_Buffer (Current_Data.Deffile);
declare
- N : constant File_Name_Type := Name_Find;
- Deffile : constant Source_File_Index :=
- Load_Definition_File (N);
- Add_Deffile : Boolean := True;
- T : constant Nat := Total_Errors_Detected;
+ N : constant File_Name_Type := Name_Find;
+ Deffile : constant Source_File_Index := Load_Definition_File (N);
+ T : constant Nat := Total_Errors_Detected;
+
+ Add_Deffile : Boolean := True;
begin
if Deffile <= No_Source_File then
- Fail ("definition file """
- & Get_Name_String (N)
- & """ not found");
+ Fail
+ ("definition file """ & Get_Name_String (N) & """ not found");
end if;
-- Initialize the preprocessor and set the characteristics of the
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
if Nkind (Assoc) = N_Iterated_Component_Association then
- Error_Msg_N ("iterated component association can only "
- & "appear in an array aggregate", N);
+ Error_Msg_N
+ ("iterated component association can only appear in an "
+ & "array aggregate", N);
raise Unrecoverable_Error;
else
-- the private declarations of a parent unit.
procedure Install_Parents
- (Lib_Unit : Node_Id; Is_Private : Boolean; Chain : Boolean := True);
+ (Lib_Unit : Node_Id;
+ Is_Private : Boolean;
+ Chain : Boolean := True);
-- This procedure establishes the context for the compilation of a child
-- unit. If Lib_Unit is a child library spec then the context of the parent
-- is installed, and the parent itself made immediately visible, so that
if Is_Child_Spec (Lib_Unit) then
Install_Parents
- (Lib_Unit, Private_Present (Parent (Lib_Unit)), Chain);
+ (Lib_Unit => Lib_Unit,
+ Is_Private => Private_Present (Parent (Lib_Unit)),
+ Chain => Chain);
end if;
Install_Limited_Context_Clauses (N);
---------------------
procedure Install_Parents
- (Lib_Unit : Node_Id; Is_Private : Boolean; Chain : Boolean := True) is
+ (Lib_Unit : Node_Id;
+ Is_Private : Boolean;
+ Chain : Boolean := True)
+ is
P : Node_Id;
E_Name : Entity_Id;
P_Name : Entity_Id;
-- This is the recursive call that ensures all parents are loaded
if Is_Child_Spec (P) then
- Install_Parents (P,
- Is_Private or else Private_Present (Parent (Lib_Unit)), Chain);
+ Install_Parents
+ (Lib_Unit => P,
+ Is_Private =>
+ Is_Private or else Private_Present (Parent (Lib_Unit)),
+ Chain => Chain);
end if;
-- Now we can install the context for this parent
procedure Check_Generic_Parent is
Inst : constant Node_Id :=
- Next (Unit_Declaration_Node (Actual));
+ Next (Unit_Declaration_Node (Actual));
Par : Entity_Id;
begin
if Nkind (Parent (Actual)) = N_Package_Specification
then
Par := Scope (Generic_Parent (Parent (Actual)));
+
if Is_Generic_Instance (Par) then
null;
-- If the actual is a child generic unit, check
-- whether the instantiation of the parent is
- -- also local and must also be frozen now.
- -- We must retrieve the instance node to locate
- -- the parent instance if any.
+ -- also local and must also be frozen now. We
+ -- must retrieve the instance node to locate the
+ -- parent instance if any.
elsif Ekind (Par) = E_Generic_Package
- and then Is_Child_Unit (Gen_Par)
- and then Ekind (Scope (Gen_Par))
- = E_Generic_Package
+ and then Is_Child_Unit (Gen_Par)
+ and then Ekind (Scope (Gen_Par)) =
+ E_Generic_Package
then
if Nkind (Inst) = N_Package_Instantiation
- and then
- Nkind (Name (Inst)) = N_Expanded_Name
+ and then Nkind (Name (Inst)) =
+ N_Expanded_Name
then
-
- -- Retrieve entity of psarent instance.
+ -- Retrieve entity of parent instance
Par := Entity (Prefix (Name (Inst)));
end if;
begin
if Present (Renamed_Entity (Actual)) then
Gen_Par :=
- Generic_Parent (Specification (
- Unit_Declaration_Node (
- Renamed_Entity (Actual))));
+ Generic_Parent (Specification
+ (Unit_Declaration_Node
+ (Renamed_Entity (Actual))));
else
- Gen_Par := Generic_Parent
- (Specification (Unit_Declaration_Node (Actual)));
+ Gen_Par :=
+ Generic_Parent (Specification
+ (Unit_Declaration_Node (Actual)));
end if;
if not Expander_Active
-- that it is the instance that must be frozen.
if Nkind (Parent (Actual)) =
- N_Package_Renaming_Declaration
+ N_Package_Renaming_Declaration
then
Set_Has_Delayed_Freeze
(Renamed_Entity (Actual));
Append_Elmt
- (Renamed_Entity (Actual), Actuals_To_Freeze);
+ (Renamed_Entity (Actual),
+ Actuals_To_Freeze);
else
Set_Has_Delayed_Freeze (Actual);
Append_Elmt (Actual, Actuals_To_Freeze);
-- contract expression. Full analysis of the expression is done when
-- the contract is processed.
+ function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean;
+ -- Check if a nested package has entities within it that rely on library
+ -- level private types where the full view has not been completed for
+ -- the purposes of checking if it is acceptable to freeze an expression
+ -- function at the point of declaration.
+
procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id);
-- Determine whether Body_Decl denotes the body of a late controlled
-- primitive (either Initialize, Adjust or Finalize). If this is the
-- declarations, or before a declaration that freezes previous entities,
-- such as in a subprogram body.
- function Uses_Unseen_Priv (Pkg : Entity_Id) return Boolean;
- -- Check if a nested package has entities within it that rely on library
- -- level private types where the full view has not been seen for the
- -- purposes of checking if it is acceptable to freeze an expression
- -- function at the point of declaration.
-
-----------------
-- Adjust_Decl --
-----------------
end loop;
end Check_Entry_Contracts;
+ ----------------------------------
+ -- Contains_Lib_Incomplete_Type --
+ ----------------------------------
+
+ function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean is
+ Curr : Entity_Id;
+
+ begin
+ -- Avoid looking through scopes that do not meet the precondition of
+ -- Pkg not being within a library unit spec.
+
+ if not Is_Compilation_Unit (Pkg)
+ and then not Is_Generic_Instance (Pkg)
+ and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg))
+ then
+ -- Loop through all entities in the current scope to identify
+ -- an entity that depends on a private type.
+
+ Curr := First_Entity (Pkg);
+ loop
+ if Nkind (Curr) in N_Entity
+ and then Depends_On_Private (Curr)
+ then
+ return True;
+ end if;
+
+ exit when Last_Entity (Current_Scope) = Curr;
+ Curr := Next_Entity (Curr);
+ end loop;
+ end if;
+
+ return False;
+ end Contains_Lib_Incomplete_Type;
+
--------------------------------------
-- Handle_Late_Controlled_Primitive --
--------------------------------------
end loop;
end Resolve_Aspects;
- ----------------------
- -- Uses_Unseen_Priv --
- ----------------------
-
- function Uses_Unseen_Priv (Pkg : Entity_Id) return Boolean is
- Curr : Entity_Id;
-
- begin
- -- Avoid looking through scopes that do not meet the precondition of
- -- Pkg not being within a library unit spec.
-
- if not Is_Compilation_Unit (Pkg)
- and then not Is_Generic_Instance (Pkg)
- and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg))
- then
- -- Loop through all entities in the current scope to identify
- -- an entity that depends on a private type.
-
- Curr := First_Entity (Pkg);
- loop
- if Nkind (Curr) in N_Entity
- and then Depends_On_Private (Curr)
- then
- return True;
- end if;
-
- exit when Last_Entity (Current_Scope) = Curr;
- Curr := Next_Entity (Curr);
- end loop;
- end if;
-
- return False;
- end Uses_Unseen_Priv;
-
-- Local variables
Context : Node_Id := Empty;
-- not cause unwanted freezing at that point.
-- It is also necessary to check for a case where both an expression
- -- function is used and the current scope depends on an unseen
+ -- function is used and the current scope depends on an incomplete
-- private type from a library unit, otherwise premature freezing of
-- the private type will occur.
and then ((Nkind (Next_Decl) /= N_Subprogram_Body
or else not Was_Expression_Function (Next_Decl))
or else (not Is_Ignored_Ghost_Entity (Current_Scope)
- and then not Uses_Unseen_Priv (Current_Scope)))
+ and then not Contains_Lib_Incomplete_Type
+ (Current_Scope)))
then
-- When a controlled type is frozen, the expander generates stream
-- and controlled-type support routines. If the freeze is caused
-- Find the most previous use clause (that is, the first one to appear in
-- the source) by traversing the previous clause chain that exists in both
-- N_Use_Package_Clause nodes and N_Use_Type_Clause nodes.
+ -- ??? a better subprogram name is in order
function Find_Renamed_Entity
(N : Node_Id;
Clause2 : Entity_Id) return Entity_Id;
-- Determine which use clause parameter is the most descendant in terms of
-- scope.
+ -- ??? a better subprogram name is in order
procedure Premature_Usage (N : Node_Id);
-- Diagnose usage of an entity before it is visible
procedure Use_One_Package
- (N : Node_Id; Pack_Name : Entity_Id := Empty; Force : Boolean := False);
+ (N : Node_Id;
+ Pack_Name : Entity_Id := Empty;
+ Force : Boolean := False);
-- Make visible entities declared in package P potentially use-visible
-- in the current context. Also used in the analysis of subunits, when
-- re-installing use clauses of parent units. N is the use_clause that
-- names P (and possibly other packages).
procedure Use_One_Type
- (Id : Node_Id; Installed : Boolean := False; Force : Boolean := False);
+ (Id : Node_Id;
+ Installed : Boolean := False;
+ Force : Boolean := False);
-- Id is the subtype mark from a use_type_clause. This procedure makes
-- the primitive operators of the type potentially use-visible. The
-- boolean flag Installed indicates that the clause is being reinstalled
-- implicit generic actual.
if From_Default (N)
- and then Is_Generic_Actual_Subprogram (New_S)
- and then Present (Alias (New_S))
+ and then Is_Generic_Actual_Subprogram (New_S)
+ and then Present (Alias (New_S))
then
Mark_Use_Clauses (Alias (New_S));
-- within the package itself, ignore it.
procedure Analyze_Use_Package (N : Node_Id; Chain : Boolean := True) is
-
procedure Analyze_Package_Name (Clause : Node_Id);
-- Perform analysis on a package name from a use_package_clause
if Entity (Pref) = Standard_Standard then
Error_Msg_N
- ("predefined package Standard cannot appear in a "
- & "context clause", Pref);
+ ("predefined package Standard cannot appear in a context "
+ & "clause", Pref);
end if;
end if;
end Analyze_Package_Name;
if not More_Ids (N) and then not Prev_Ids (N) then
Analyze_Package_Name (N);
+
elsif More_Ids (N) and then not Prev_Ids (N) then
Analyze_Package_Name_List (N);
end if;
return;
end if;
- Pack := Entity (Name (N));
if Chain then
Chain_Use_Clause (N);
end if;
+ Pack := Entity (Name (N));
+
-- There are many cases where scopes are manipulated during analysis, so
-- check that Pack's current use clause has not already been chained
-- before setting its previous use clause.
if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then
if Ekind (Pack) = E_Generic_Package then
Error_Msg_N -- CODEFIX
- ("a generic package is not allowed in a use clause",
- Name (N));
+ ("a generic package is not allowed in a use clause", Name (N));
elsif Ekind_In (Pack, E_Generic_Function, E_Generic_Package)
then
elsif Ekind_In (Pack, E_Function, E_Procedure, E_Operator) then
Error_Msg_N -- CODEFIX
- ("a subprogram is not allowed in a use clause",
- Name (N));
+ ("a subprogram is not allowed in a use clause", Name (N));
else
Error_Msg_N ("& is not allowed in a use clause", Name (N));
----------------------
procedure Chain_Use_Clause (N : Node_Id) is
- Pack : Entity_Id;
Level : Int := Scope_Stack.Last;
+ Pack : Entity_Id;
begin
-- Common case
-- parent unit when compiling a child.
Pack := Defining_Entity (Parent (N), Empty_On_Errors => True);
+
if not In_Open_Scopes (Pack) then
null;
function Entity_Of_Unit (U : Node_Id) return Entity_Id is
begin
- if Nkind (U) = N_Package_Instantiation
- and then Analyzed (U)
- then
+ if Nkind (U) = N_Package_Instantiation and then Analyzed (U) then
return Defining_Entity (Instance_Spec (U));
else
return Defining_Entity (U);
-- path, so ignore the fact that they are overloaded and mark them
-- anyway.
- if Nkind (N) not in N_Subexpr
- or else not Is_Overloaded (N)
- then
+ if Nkind (N) not in N_Subexpr or else not Is_Overloaded (N) then
Mark_Use_Clauses (N);
end if;
function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id is
Curr : Node_Id;
+
begin
-- Loop through the Prev_Use_Clause chain
----------------------
procedure Mark_Use_Clauses (Id : Node_Or_Entity_Id) is
-
procedure Mark_Parameters (Call : Entity_Id);
-- Perform use_type_clause marking for all parameters in a subprogram
-- or operator call.
Curr : Node_Id;
begin
- -- Ignore cases where the scope of the type is not a package
- -- (e.g. Standard_Standard).
+ -- Ignore cases where the scope of the type is not a package (e.g.
+ -- Standard_Standard).
if Ekind (Pak) /= E_Package then
return;
Curr := Current_Use_Clause (Pak);
while Present (Curr)
- and then not Is_Effective_Use_Clause (Curr)
+ and then not Is_Effective_Use_Clause (Curr)
loop
- -- We need to mark the previous use clauses as effective, but each
- -- use clause may in turn render other use_package_clauses
+ -- We need to mark the previous use clauses as effective, but
+ -- each use clause may in turn render other use_package_clauses
-- effective. Additionally, it is possible to have a parent
-- package renamed as a child of itself so we must check the
-- prefix entity is not the same as the package we are marking.
-- for ignoring previous errors.
Mark_Use_Package (Scope (Base_Type (Etype (E))));
+
if Nkind (E) in N_Op
and then Present (Entity (E))
and then Present (Scope (Entity (E)))
-- Use clauses in and of themselves do not count as a "use" of a
-- package.
- if Nkind_In (Parent (Id), N_Use_Type_Clause, N_Use_Package_Clause) then
+ if Nkind_In (Parent (Id), N_Use_Package_Clause, N_Use_Type_Clause) then
return;
end if;
-- Mark primitives
elsif (Ekind (Id) in Overloadable_Kind
- or else Ekind_In
- (Ekind (Id), E_Generic_Function, E_Generic_Procedure))
+ or else Ekind_In (Id, E_Generic_Function,
+ E_Generic_Procedure))
and then (Is_Potentially_Use_Visible (Id)
or else Is_Intrinsic_Subprogram (Id))
then
-- expression.
if Nkind (Id) in N_Binary_Op
- and then not (Nkind (Left_Opnd (Id)) in N_Op)
+ and then not (Nkind (Left_Opnd (Id)) in N_Op)
then
Mark_Use_Type (Left_Opnd (Id));
end if;
and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
and then Handle_Use
then
- Install_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause,
- Force_Installation => True);
+ Install_Use_Clauses
+ (Scope_Stack.Table (SS_Last).First_Use_Clause,
+ Force_Installation => True);
end if;
end Restore_Scope_Stack;
-----------------------------
procedure Update_Use_Clause_Chain is
-
procedure Update_Chain_In_Scope (Level : Int);
-- Iterate through one level in the scope stack verifying each use-type
-- clause within said level is used then reset the Current_Use_Clause
and then not Is_Effective_Use_Clause (Curr)
and then not In_Instance
then
-
-- We are dealing with a potentially unused use_package_clause
if Nkind (Curr) = N_Use_Package_Clause then
if not (Present (Associated_Node (N))
and then Present
- (Current_Use_Clause (Associated_Node (N)))
+ (Current_Use_Clause
+ (Associated_Node (N)))
and then Is_Effective_Use_Clause
- (Current_Use_Clause (Associated_Node (N))))
+ (Current_Use_Clause
+ (Associated_Node (N))))
then
Error_Msg_Node_1 := Entity (N);
- Error_Msg_NE ("use clause for package &? has no effect",
- Curr, Entity (N));
+ Error_Msg_NE
+ ("use clause for package &? has no effect",
+ Curr, Entity (N));
end if;
-- We are dealing with an unused use_type_clause
else
Error_Msg_Node_1 := Etype (N);
- Error_Msg_NE ("use clause for }? has no effect",
- Curr, Etype (N));
+ Error_Msg_NE
+ ("use clause for }? has no effect", Curr, Etype (N));
end if;
end if;
Pack_Name : Entity_Id := Empty;
Force : Boolean := False)
is
-
procedure Note_Redundant_Use (Clause : Node_Id);
-- Mark the name in a use clause as redundant if the corresponding
-- entity is already use-visible. Emit a warning if the use clause comes
------------------------
procedure Note_Redundant_Use (Clause : Node_Id) is
- Pack_Name : constant Entity_Id := Entity (Clause);
Decl : constant Node_Id := Parent (Clause);
+ Pack_Name : constant Entity_Id := Entity (Clause);
Cur_Use : Node_Id := Current_Use_Clause (Pack_Name);
Prev_Use : Node_Id := Empty;
elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
declare
Cur_Unit : constant Unit_Number_Type :=
- Get_Source_Unit (Cur_Use);
+ Get_Source_Unit (Cur_Use);
New_Unit : constant Unit_Number_Type :=
- Get_Source_Unit (Clause);
- Scop : Entity_Id;
+ Get_Source_Unit (Clause);
+
+ Scop : Entity_Id;
begin
if Cur_Unit = New_Unit then
Redundant := Clause;
Prev_Use := Cur_Use;
- -- Most common case: redundant clause in body,
- -- original clause in spec. Current scope is spec entity.
+ -- Most common case: redundant clause in body, original
+ -- clause in spec. Current scope is spec entity.
elsif Current_Scope = Cunit_Entity (Current_Sem_Unit) then
Redundant := Cur_Use;
-- visible part of the child, and no warning should be emitted.
if Nkind (Parent (Decl)) = N_Package_Specification
- and then
- List_Containing (Decl) = Private_Declarations (Parent (Decl))
+ and then List_Containing (Decl) =
+ Private_Declarations (Parent (Decl))
then
declare
Par : constant Entity_Id := Defining_Entity (Parent (Decl));
if Is_Compilation_Unit (Par)
and then Par /= Cunit_Entity (Current_Sem_Unit)
and then Parent (Cur_Use) = Spec
- and then
- List_Containing (Cur_Use) = Visible_Declarations (Spec)
+ and then List_Containing (Cur_Use) =
+ Visible_Declarations (Spec)
then
return;
end if;
end;
end if;
- -- Finally, if the current use clause is in the context then
- -- the clause is redundant when it is nested within the unit.
+ -- Finally, if the current use clause is in the context then the
+ -- clause is redundant when it is nested within the unit.
elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit
and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit
end if;
if Present (Redundant) and then Parent (Redundant) /= Prev_Use then
+
-- Make sure we are looking at most-descendant use_package_clause
-- by traversing the chain with Find_Most_Prev and then verifying
-- there is no scope manipulation via Most_Descendant_Use_Clause.
and then
(Nkind (Parent (Prev_Use)) /= N_Compilation_Unit
or else Most_Descendant_Use_Clause
- (Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use)
+ (Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use)
then
Prev_Use := Find_Most_Prev (Prev_Use);
end if;
-- Local variables
+ Current_Instance : Entity_Id := Empty;
Id : Entity_Id;
+ P : Entity_Id;
Prev : Entity_Id;
- Current_Instance : Entity_Id := Empty;
- Real_P : Entity_Id;
Private_With_OK : Boolean := False;
- P : Entity_Id;
+ Real_P : Entity_Id;
-- Start of processing for Use_One_Package
if In_Use (P) then
Note_Redundant_Use (Pack_Name);
+
if not Force then
Set_Current_Use_Clause (P, N);
end if;
+
return;
-- Warn about detected redundant clauses
("& is already use-visible within itself?r?",
Pack_Name, P);
end if;
+
return;
end if;
end if;
end if;
- -- If unit is a package renaming, indicate that the renamed
- -- package is also in use (the flags on both entities must
- -- remain consistent, and a subsequent use of either of them
- -- should be recognized as redundant).
+ -- If unit is a package renaming, indicate that the renamed package is
+ -- also in use (the flags on both entities must remain consistent, and a
+ -- subsequent use of either of them should be recognized as redundant).
if Present (Renamed_Object (P)) then
Set_In_Use (Renamed_Object (P));
------------------
procedure Use_One_Type
- (Id : Node_Id; Installed : Boolean := False; Force : Boolean := False)
+ (Id : Node_Id;
+ Installed : Boolean := False;
+ Force : Boolean := False)
is
- Elmt : Elmt_Id;
- Is_Known_Used : Boolean;
- Op_List : Elist_Id;
- T : Entity_Id;
-
function Spec_Reloaded_For_Body return Boolean;
-- Determine whether the compilation unit is a package body and the use
-- type clause is in the spec of the same package. Even though the spec
return
Nkind (Spec) = N_Package_Specification
- and then
- In_Same_Source_Unit (Corresponding_Body (Parent (Spec)),
- Cunit_Entity (Current_Sem_Unit));
+ and then In_Same_Source_Unit
+ (Corresponding_Body (Parent (Spec)),
+ Cunit_Entity (Current_Sem_Unit));
end;
end if;
-------------------------------
procedure Use_Class_Wide_Operations (Typ : Entity_Id) is
- Scop : Entity_Id;
- Ent : Entity_Id;
-
function Is_Class_Wide_Operation_Of
(Op : Entity_Id;
T : Entity_Id) return Boolean;
---------------------------------
function Is_Class_Wide_Operation_Of
- (Op : Entity_Id;
- T : Entity_Id) return Boolean
+ (Op : Entity_Id;
+ T : Entity_Id) return Boolean
is
Formal : Entity_Id;
if Etype (Formal) = Class_Wide_Type (T) then
return True;
end if;
+
Next_Formal (Formal);
end loop;
return False;
end Is_Class_Wide_Operation_Of;
+ -- Local variables
+
+ Ent : Entity_Id;
+ Scop : Entity_Id;
+
-- Start of processing for Use_Class_Wide_Operations
begin
end if;
end Use_Class_Wide_Operations;
+ -- Local variables
+
+ Elmt : Elmt_Id;
+ Is_Known_Used : Boolean;
+ Op_List : Elist_Id;
+ T : Entity_Id;
+
-- Start of processing for Use_One_Type
begin
-- in use or the entity is declared in the current package, thus
-- use-visible.
- Is_Known_Used := (In_Use (T)
- and then ((Present (Current_Use_Clause (T))
- and then All_Present
- (Current_Use_Clause (T)))
- or else not All_Present (Parent (Id))))
- or else In_Use (Scope (T))
- or else Scope (T) = Current_Scope;
+ Is_Known_Used :=
+ (In_Use (T)
+ and then ((Present (Current_Use_Clause (T))
+ and then All_Present (Current_Use_Clause (T)))
+ or else not All_Present (Parent (Id))))
+ or else In_Use (Scope (T))
+ or else Scope (T) = Current_Scope;
Set_Redundant_Use (Id,
Is_Known_Used or else Is_Potentially_Use_Visible (T));
Set_Current_Use_Clause (T, Parent (Id));
Set_In_Use (T);
- -- If T is tagged, primitive operators on class-wide operands
- -- are also available.
+ -- If T is tagged, primitive operators on class-wide operands are
+ -- also available.
if Is_Tagged_Type (T) then
Set_In_Use (Class_Wide_Type (T));
if Present (Current_Use_Clause (T)) then
Use_Clause_Known : declare
- Clause1 : constant Node_Id := Find_Most_Prev
- (Current_Use_Clause (T));
+ Clause1 : constant Node_Id :=
+ Find_Most_Prev (Current_Use_Clause (T));
Clause2 : constant Node_Id := Parent (Id);
Ent1 : Entity_Id;
Ent2 : Entity_Id;
else
declare
- S1, S2 : Entity_Id;
+ S1 : Entity_Id;
+ S2 : Entity_Id;
begin
S1 := Scope (Ent1);
end if;
end Use_Clause_Known;
- -- Here if Current_Use_Clause is not set for T, another case
- -- where we do not have the location information available.
+ -- Here if Current_Use_Clause is not set for T, another case where
+ -- we do not have the location information available.
else
Error_Msg_NE -- CODEFIX
-- The package where T is declared is already used
elsif In_Use (Scope (T)) then
- Error_Msg_Sloc := Sloc (Find_Most_Prev
- (Current_Use_Clause (Scope (T))));
+ Error_Msg_Sloc :=
+ Sloc (Find_Most_Prev (Current_Use_Clause (Scope (T))));
Error_Msg_NE -- CODEFIX
("& is already use-visible through package use clause #??",
Id, T);
procedure Analyze_Package_Renaming (N : Node_Id);
procedure Analyze_Subprogram_Renaming (N : Node_Id);
- procedure Analyze_Use_Package (N : Node_Id;
- Chain : Boolean := True);
- -- Analyze a use package clause and control (through the Chain
- -- parameter) whether to add N to the use clause chain for the name
- -- denoted within use clause N in case we are reanalyzing a use clause
- -- because of stack manipulation.
-
- procedure Analyze_Use_Type (N : Node_Id;
- Chain : Boolean := True);
- -- Similar to Analyze_Use_Package except the Chain parameter applies
- -- to the type within N's subtype mark Current_Use_Clause.
+ procedure Analyze_Use_Package (N : Node_Id; Chain : Boolean := True);
+ -- Analyze a use package clause and control (through the Chain parameter)
+ -- whether to add N to the use clause chain for the name denoted within
+ -- use clause N in case we are reanalyzing a use clause because of stack
+ -- manipulation.
+
+ procedure Analyze_Use_Type (N : Node_Id; Chain : Boolean := True);
+ -- Similar to Analyze_Use_Package except the Chain parameter applies to the
+ -- type within N's subtype mark Current_Use_Clause.
procedure End_Scope;
-- Called at end of scope. On exit from blocks and bodies (subprogram,
is
begin
case Nkind (N) is
+
-- Base identifier. Set permission to W or No depending on Mode.
when N_Identifier
=>
declare
P : constant Node_Id := Entity (N);
-
C : constant Perm_Tree_Access :=
- Get (Current_Perm_Env, Unique_Entity (P));
+ Get (Current_Perm_Env, Unique_Entity (P));
begin
-- The base tree can be RW (first move from this base path) or
T : Osint.File_Type) return Source_File_Index
is
FD : File_Descriptor;
+ Hi : Source_Ptr;
+ Lo : Source_Ptr;
Src : Source_Buffer_Ptr;
X : Source_File_Index;
- Lo : Source_Ptr;
- Hi : Source_Ptr;
Preprocessing_Needed : Boolean := False;
Set_NUP : Set_NUP_Type := null)
is
FD : File_Descriptor;
- Text : Source_Buffer_Ptr;
Hi : Source_Ptr;
+ Text : Source_Buffer_Ptr;
begin
if Parameters_Obtained then
if Null_Source_Buffer_Ptr (Text) then
Write_Line ("fatal error, run-time library not installed correctly");
+
if FD = Null_FD then
Write_Line ("cannot locate file system.ads");
else
Write_Line ("no read access for file system.ads");
end if;
+
raise Unrecoverable_Error;
end if;
projects / gcc.git / commitdiff