-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Set_Etype (Nam, T);
end if;
+ -- Complete analysis of the subtype mark in any case, for ASIS use.
+
+ if Present (Subtype_Mark (N)) then
+ Find_Type (Subtype_Mark (N));
+ end if;
+
elsif Present (Subtype_Mark (N)) then
Find_Type (Subtype_Mark (N));
T := Entity (Subtype_Mark (N));
- Analyze_And_Resolve (Nam, T);
+ Analyze (Nam);
+
+ if Nkind (Nam) = N_Type_Conversion
+ and then not Is_Tagged_Type (T)
+ then
+ Error_Msg_N
+ ("renaming of conversion only allowed for tagged types", Nam);
+ end if;
+
+ Resolve (Nam, T);
-- Ada 2005 (AI-230/AI-254): Access renaming
end if;
end if;
+ -- Special processing for renaming function return object
+
+ if Nkind (Nam) = N_Function_Call
+ and then Comes_From_Source (Nam)
+ then
+ case Ada_Version is
+
+ -- Usage is illegal in Ada 83
+
+ when Ada_83 =>
+ Error_Msg_N
+ ("(Ada 83) cannot rename function return object", Nam);
+
+ -- In Ada 95, warn for odd case of renaming parameterless function
+ -- call if this is not a limited type (where this is useful)
+
+ when others =>
+ if Warn_On_Object_Renames_Function
+ and then No (Parameter_Associations (Nam))
+ and then not Is_Limited_Type (Etype (Nam))
+ then
+ Error_Msg_N
+ ("?renaming function result object is suspicious",
+ Nam);
+ Error_Msg_NE
+ ("\?function & will be called only once",
+ Nam, Entity (Name (Nam)));
+ Error_Msg_N
+ ("\?suggest using an initialized constant object instead",
+ Nam);
+ end if;
+ end case;
+ end if;
+
-- An object renaming requires an exact match of the type. Class-wide
-- matching is not allowed.
-- formal object of a generic unit G, and the object renaming
-- declaration occurs within the body of G or within the body
-- of a generic unit declared within the declarative region
- -- of G, then the declaration of the formal object of G shall
+ -- of G, then the declaration of the formal object of G must
-- have a null exclusion.
if Is_Formal_Object (Nam_Ent)
Error_Node := Access_Definition (Nam_Decl);
end if;
- Error_Msg_N ("null-exclusion required in formal " &
- "object declaration", Error_Node);
+ Error_Msg_N
+ ("`NOT NULL` required in formal object declaration",
+ Error_Node);
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_N
+ ("\because of renaming at# ('R'M 8.5.4(4))", Error_Node);
-- Ada 2005 (AI-423): Otherwise, the subtype of the object name
-- shall exclude null.
elsif Nkind (Subtyp_Decl) = N_Subtype_Declaration
and then not Has_Null_Exclusion (Subtyp_Decl)
then
- Error_Msg_N ("subtype must have null-exclusion",
- Subtyp_Decl);
+ Error_Msg_N
+ ("`NOT NULL` required for subtype & ('R'M 8.5.1(4.6/2))",
+ Defining_Identifier (Subtyp_Decl));
end if;
end if;
end;
not (Has_Null_Exclusion (Parent (Sub_Formal))
or else Can_Never_Be_Null (Etype (Sub_Formal)))
then
- Error_Msg_N ("null-exclusion required in parameter profile",
- Parent (Sub_Formal));
+ Error_Msg_NE
+ ("`NOT NULL` required for parameter &",
+ Parent (Sub_Formal), Sub_Formal);
end if;
Next_Formal (Ren_Formal);
not (Has_Null_Exclusion (Parent (Sub))
or else Can_Never_Be_Null (Etype (Sub)))
then
- Error_Msg_N ("null-exclusion required in return profile",
- Result_Definition (Parent (Sub)));
+ Error_Msg_N
+ ("return must specify `NOT NULL`",
+ Result_Definition (Parent (Sub)));
end if;
end Check_Null_Exclusion;
-- for it at the freezing point.
Set_Corresponding_Spec (N, Rename_Spec);
+
if Nkind (Unit_Declaration_Node (Rename_Spec)) =
N_Abstract_Subprogram_Declaration
then
and then not Can_Never_Be_Null (Old_F)
then
Error_Msg_N ("access parameter is controlling,", New_F);
- Error_Msg_NE ("\corresponding parameter of& " &
- " must be explicitly null excluding", New_F, Old_S);
+ Error_Msg_NE
+ ("\corresponding parameter of& "
+ & "must be explicitly null excluding", New_F, Old_S);
end if;
Next_Formal (Old_F);
Statements => New_List (Attr_Node)));
end if;
- Rewrite (N, Body_Node);
- Analyze (N);
+ -- In case of tagged types we add the body of the generated function to
+ -- the freezing actions of the type (because in the general case such
+ -- type is still not frozen). We exclude from this processing generic
+ -- formal subprograms found in instantiations and AST_Entry renamings.
+
+ if not Present (Corresponding_Formal_Spec (N))
+ and then Etype (Nam) /= RTE (RE_AST_Handler)
+ then
+ declare
+ P : constant Entity_Id := Prefix (Nam);
+
+ begin
+ Find_Type (P);
+
+ if Is_Tagged_Type (Etype (P)) then
+ Ensure_Freeze_Node (Etype (P));
+ Append_Freeze_Action (Etype (P), Body_Node);
+ else
+ Rewrite (N, Body_Node);
+ Analyze (N);
+ Set_Etype (New_S, Base_Type (Etype (New_S)));
+ end if;
+ end;
+
+ -- Generic formal subprograms or AST_Handler renaming
+
+ else
+ Rewrite (N, Body_Node);
+ Analyze (N);
+ Set_Etype (New_S, Base_Type (Etype (New_S)));
+ end if;
if Is_Compilation_Unit (New_S) then
Error_Msg_N
("a library unit can only rename another library unit", N);
end if;
- Set_Etype (New_S, Base_Type (Etype (New_S)));
-
-- We suppress elaboration warnings for the resulting entity, since
-- clearly they are not needed, and more particularly, in the case
-- of a generic formal subprogram, the resulting entity can appear
if Nkind (Parent (N)) /= N_Compilation_Unit then
return;
- elsif Scope (Old_E) /= Standard_Standard
+ -- Check for library unit. Note that we used to check for the scope
+ -- being Standard here, but that was wrong for Standard itself.
+
+ elsif not Is_Compilation_Unit (Old_E)
and then not Is_Child_Unit (Old_E)
then
Error_Msg_N ("renamed unit must be a library unit", Name (N));
-- Another special check if N is the prefix of a selected
-- component which is a known unit, add message complaining
- -- about missingw with for this unit.
+ -- about missing with for this unit.
elsif Nkind (Parent (N)) = N_Selected_Component
and then N = Prefix (Parent (N))
else
Generate_Reference (E, N);
+ Check_Nested_Access (E);
end if;
-- Set Entity, with style check if need be. For a discriminant
-- we assume a missing with for the corresponding package.
if Is_Known_Unit (N) then
- Error_Msg_Node_2 := Selector;
- Error_Msg_N ("missing `WITH &.&;`", Prefix (N));
+ if not Error_Posted (N) then
+ Error_Msg_Node_2 := Selector;
+ Error_Msg_N ("missing `WITH &.&;`", Prefix (N));
+ end if;
-- If this is a selection from a dummy package, then suppress
-- the error message, of course the entity is missing if the
else
Error_Msg_N
("task type cannot be used as type mark " &
- "within its own body", N);
+ "within its own spec or body", N);
end if;
+
+ elsif Ekind (Base_Type (T_Name)) = E_Protected_Type then
+
+ -- In Ada 2005, a protected name can be used in an access
+ -- definition within its own body.
+
+ if Ada_Version >= Ada_05
+ and then Nkind (Parent (N)) = N_Access_Definition
+ then
+ Set_Entity (N, T_Name);
+ Set_Etype (N, T_Name);
+ return;
+
+ else
+ Error_Msg_N
+ ("protected type cannot be used as type mark " &
+ "within its own spec or body", N);
+ end if;
+
else
Error_Msg_N ("type declaration cannot refer to itself", N);
end if;
procedure Add_Implicit_Operator
(T : Entity_Id;
Op_Type : Entity_Id := Empty);
- -- Add implicit interpretation to node N, using the type for which
- -- a predefined operator exists. If the operator yields a boolean
- -- type, the Operand_Type is implicitly referenced by the operator,
- -- and a reference to it must be generated.
+ -- Add implicit interpretation to node N, using the type for which a
+ -- predefined operator exists. If the operator yields a boolean type,
+ -- the Operand_Type is implicitly referenced by the operator, and a
+ -- reference to it must be generated.
---------------------------
-- Add_Implicit_Operator --
and then Has_Components (Designated_Type (T))));
end Is_Appropriate_For_Record;
- ---------------
- -- New_Scope --
- ---------------
-
- procedure New_Scope (S : Entity_Id) is
- E : Entity_Id;
-
- begin
- if Ekind (S) = E_Void then
- null;
-
- -- Set scope depth if not a non-concurrent type, and we have not
- -- yet set the scope depth. This means that we have the first
- -- occurrence of the scope, and this is where the depth is set.
-
- elsif (not Is_Type (S) or else Is_Concurrent_Type (S))
- and then not Scope_Depth_Set (S)
- then
- if S = Standard_Standard then
- Set_Scope_Depth_Value (S, Uint_0);
-
- elsif Is_Child_Unit (S) then
- Set_Scope_Depth_Value (S, Uint_1);
-
- elsif not Is_Record_Type (Current_Scope) then
- if Ekind (S) = E_Loop then
- Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope));
- else
- Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1);
- end if;
- end if;
- end if;
-
- Scope_Stack.Increment_Last;
-
- declare
- SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
-
- begin
- SST.Entity := S;
- SST.Save_Scope_Suppress := Scope_Suppress;
- SST.Save_Local_Entity_Suppress := Local_Entity_Suppress.Last;
-
- if Scope_Stack.Last > Scope_Stack.First then
- SST.Component_Alignment_Default := Scope_Stack.Table
- (Scope_Stack.Last - 1).
- Component_Alignment_Default;
- end if;
-
- SST.Last_Subprogram_Name := null;
- SST.Is_Transient := False;
- SST.Node_To_Be_Wrapped := Empty;
- SST.Pending_Freeze_Actions := No_List;
- SST.Actions_To_Be_Wrapped_Before := No_List;
- SST.Actions_To_Be_Wrapped_After := No_List;
- SST.First_Use_Clause := Empty;
- SST.Is_Active_Stack_Base := False;
- SST.Previous_Visibility := False;
- end;
-
- if Debug_Flag_W then
- Write_Str ("--> new scope: ");
- Write_Name (Chars (Current_Scope));
- Write_Str (", Id=");
- Write_Int (Int (Current_Scope));
- Write_Str (", Depth=");
- Write_Int (Int (Scope_Stack.Last));
- Write_Eol;
- end if;
-
- -- Copy from Scope (S) the categorization flags to S, this is not
- -- done in case Scope (S) is Standard_Standard since propagation
- -- is from library unit entity inwards.
-
- if S /= Standard_Standard
- and then Scope (S) /= Standard_Standard
- and then not Is_Child_Unit (S)
- then
- E := Scope (S);
-
- if Nkind (E) not in N_Entity then
- return;
- end if;
-
- -- We only propagate inwards for library level entities,
- -- inner level subprograms do not inherit the categorization.
-
- if Is_Library_Level_Entity (S) then
- Set_Is_Preelaborated (S, Is_Preelaborated (E));
- Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
- Set_Categorization_From_Scope (E => S, Scop => E);
- end if;
- end if;
- end New_Scope;
-
------------------------
-- Note_Redundant_Use --
------------------------
Scope_Stack.Decrement_Last;
end Pop_Scope;
+ ---------------
+ -- Push_Scope --
+ ---------------
+
+ procedure Push_Scope (S : Entity_Id) is
+ E : Entity_Id;
+
+ begin
+ if Ekind (S) = E_Void then
+ null;
+
+ -- Set scope depth if not a non-concurrent type, and we have not
+ -- yet set the scope depth. This means that we have the first
+ -- occurrence of the scope, and this is where the depth is set.
+
+ elsif (not Is_Type (S) or else Is_Concurrent_Type (S))
+ and then not Scope_Depth_Set (S)
+ then
+ if S = Standard_Standard then
+ Set_Scope_Depth_Value (S, Uint_0);
+
+ elsif Is_Child_Unit (S) then
+ Set_Scope_Depth_Value (S, Uint_1);
+
+ elsif not Is_Record_Type (Current_Scope) then
+ if Ekind (S) = E_Loop then
+ Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope));
+ else
+ Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1);
+ end if;
+ end if;
+ end if;
+
+ Scope_Stack.Increment_Last;
+
+ declare
+ SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+
+ begin
+ SST.Entity := S;
+ SST.Save_Scope_Suppress := Scope_Suppress;
+ SST.Save_Local_Entity_Suppress := Local_Entity_Suppress.Last;
+
+ if Scope_Stack.Last > Scope_Stack.First then
+ SST.Component_Alignment_Default := Scope_Stack.Table
+ (Scope_Stack.Last - 1).
+ Component_Alignment_Default;
+ end if;
+
+ SST.Last_Subprogram_Name := null;
+ SST.Is_Transient := False;
+ SST.Node_To_Be_Wrapped := Empty;
+ SST.Pending_Freeze_Actions := No_List;
+ SST.Actions_To_Be_Wrapped_Before := No_List;
+ SST.Actions_To_Be_Wrapped_After := No_List;
+ SST.First_Use_Clause := Empty;
+ SST.Is_Active_Stack_Base := False;
+ SST.Previous_Visibility := False;
+ end;
+
+ if Debug_Flag_W then
+ Write_Str ("--> new scope: ");
+ Write_Name (Chars (Current_Scope));
+ Write_Str (", Id=");
+ Write_Int (Int (Current_Scope));
+ Write_Str (", Depth=");
+ Write_Int (Int (Scope_Stack.Last));
+ Write_Eol;
+ end if;
+
+ -- Deal with copying flags from the previous scope to this one. This
+ -- is not necessary if either scope is standard, or if the new scope
+ -- is a child unit.
+
+ if S /= Standard_Standard
+ and then Scope (S) /= Standard_Standard
+ and then not Is_Child_Unit (S)
+ then
+ E := Scope (S);
+
+ if Nkind (E) not in N_Entity then
+ return;
+ end if;
+
+ -- Copy categorization flags from Scope (S) to S, this is not done
+ -- when Scope (S) is Standard_Standard since propagation is from
+ -- library unit entity inwards. Copy other relevant attributes as
+ -- well (Discard_Names in particular).
+
+ -- We only propagate inwards for library level entities,
+ -- inner level subprograms do not inherit the categorization.
+
+ if Is_Library_Level_Entity (S) then
+ Set_Is_Preelaborated (S, Is_Preelaborated (E));
+ Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
+ Set_Discard_Names (S, Discard_Names (E));
+ Set_Suppress_Value_Tracking_On_Call
+ (S, Suppress_Value_Tracking_On_Call (E));
+ Set_Categorization_From_Scope (E => S, Scop => E);
+ end if;
+ end if;
+ end Push_Scope;
+
---------------------
-- Premature_Usage --
---------------------
function Present_System_Aux (N : Node_Id := Empty) return Boolean is
Loc : Source_Ptr;
- Aux_Name : Name_Id;
+ Aux_Name : Unit_Name_Type;
Unum : Unit_Number_Type;
Withn : Node_Id;
With_Sys : Node_Id;
end if;
if Is_Child_Unit (S)
- and not In_Child -- check only for current unit.
+ and not In_Child -- check only for current unit
then
In_Child := True;
- -- restore visibility of parents according to whether the child
+ -- Restore visibility of parents according to whether the child
-- is private and whether we are in its visible part.
Comp_Unit := Parent (Unit_Declaration_Node (S));
OSDN Git Service
