-- Full_View (Node11)
-- Defined in all type and subtype entities and in deferred constants.
--- References the entity for the corresponding full type declaration.
--- For all types other than private and incomplete types, this field
--- always contains Empty. If an incomplete type E1 is completed by a
--- private type E2 whose full type declaration entity is E3 then the
--- full view of E1 is E2, and the full view of E2 is E3. See also
--- Underlying_Type.
+-- References the entity for the corresponding full type or constant
+-- declaration. For all types other than private and incomplete types,
+-- this field always contains Empty. If an incomplete type E1 is
+-- completed by a private type E2 whose full type declaration entity is
+-- E3 then the full view of E1 is E2, and the full view of E2 is E3. See
+-- also Underlying_Type.
-- Generic_Homonym (Node11)
-- Defined in generic packages. The generic homonym is the entity of
-- Implicit_Dereference. Set also on the discriminant named in the aspect
-- clause, to simplify type resolution.
--- Has_Independent_Components (Flag34)
--- Defined in objects and types. Set if the aspect Independent_Components
--- applies (as set by coresponding pragma or aspect specification).
+-- Has_Independent_Components (Flag34) [base type only]
+-- Defined in types. Set if the aspect Independent_Components applies
+-- (in the base type only), if corresponding pragma or aspect applies.
+-- In the case of an object of anonymous array type, the flag is set on
+-- the created array type.
-- Has_Inheritable_Invariants (Flag248)
-- Defined in all type entities. Set in private types from which one
-- Is_Incomplete_Type (synthesized)
-- Applies to all entities, true for incomplete types and subtypes
+-- Is_Independent (Flag268)
+-- Defined in record components. Set if a valid pragma or aspect
+-- Independent applies to the component, or if a valid pragma or aspect
+-- Independent_Components applies to the enclosing record type.
+
-- Is_Inlined (Flag11)
-- Defined in all entities. Set for functions and procedures which are
-- to be inlined. For subprograms created during expansion, this flag
-- In addition, we define the kind E_Allocator_Type to label allocators.
-- This is because special resolution rules apply to this construct.
-- Eventually the constructs are labeled with the access type imposed by
--- the context. Gigi should never see the type E_Allocator.
+-- the context. Gigi should never see types with this Ekind.
-- Similarly, the type E_Access_Attribute_Type is used as the initial kind
-- associated with an access attribute. After resolution a specific access
-- 'Unrestricted_Access and Unchecked_Access)
E_Allocator_Type,
- -- A special internal type used to label allocators and attribute
- -- references using 'Access. This is needed because special resolution
+ -- A special internal type used to label allocators and references to
+ -- objects using 'Reference. This is needed because special resolution
-- rules apply to these constructs. On the resolution pass, this type
-- is always replaced by the actual access type, so Gigi should never
-- see types with this Ekind.
-- Has_Biased_Representation (Flag139)
-- Has_Per_Object_Constraint (Flag154)
-- Is_Atomic (Flag85)
+ -- Is_Independent (Flag268)
-- Is_Tag (Flag78)
-- Is_Volatile (Flag16)
-- Treat_As_Volatile (Flag41)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
-- Has_Completion (Flag26) (constants only)
- -- Has_Independent_Components (Flag34) (base type only)
-- Has_Thunks (Flag228) (constants only)
-- Has_Size_Clause (Flag29)
-- Has_Up_Level_Access (Flag215)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
- -- Has_Independent_Components (Flag34) (base type only)
-- Has_Initial_Value (Flag219)
-- Has_Size_Clause (Flag29)
-- Has_Up_Level_Access (Flag215)
function Is_Immediately_Visible (Id : E) return B;
function Is_Implementation_Defined (Id : E) return B;
function Is_Imported (Id : E) return B;
+ function Is_Independent (Id : E) return B;
function Is_Inlined (Id : E) return B;
function Is_Instantiated (Id : E) return B;
function Is_Interface (Id : E) return B;
procedure Set_Is_Immediately_Visible (Id : E; V : B := True);
procedure Set_Is_Implementation_Defined (Id : E; V : B := True);
procedure Set_Is_Imported (Id : E; V : B := True);
+ procedure Set_Is_Independent (Id : E; V : B := True);
procedure Set_Is_Inlined (Id : E; V : B := True);
procedure Set_Is_Instantiated (Id : E; V : B := True);
procedure Set_Is_Interface (Id : E; V : B := True);
pragma Inline (Is_Imported);
pragma Inline (Is_Incomplete_Or_Private_Type);
pragma Inline (Is_Incomplete_Type);
+ pragma Inline (Is_Independent);
pragma Inline (Is_Inlined);
pragma Inline (Is_Instantiated);
pragma Inline (Is_Integer_Type);
pragma Inline (Set_Is_Immediately_Visible);
pragma Inline (Set_Is_Implementation_Defined);
pragma Inline (Set_Is_Imported);
+ pragma Inline (Set_Is_Independent);
pragma Inline (Set_Is_Inlined);
pragma Inline (Set_Is_Instantiated);
pragma Inline (Set_Is_Interface);
if Is_Entity_Name (Input) then
Input_Id := Entity_Of (Input);
- if Ekind_In (Input_Id, E_Abstract_State, E_Variable) then
-
+ if Ekind_In (Input_Id, E_Abstract_State,
+ E_In_Parameter,
+ E_In_Out_Parameter,
+ E_Out_Parameter,
+ E_Variable)
+ then
-- The input cannot denote states or variables declared
-- within the related package.
Add_Item (Input_Id, States_Seen);
end if;
- if Present (Encapsulating_State (Input_Id)) then
+ if Ekind_In (Input_Id, E_Abstract_State, E_Variable)
+ and then Present (Encapsulating_State (Input_Id))
+ then
Add_Item (Input_Id, Constits_Seen);
end if;
end if;
-- The input references something that is not a state or a
- -- variable.
+ -- variable (SPARK RM 7.1.5(3)).
else
Error_Msg_N
end if;
-- Some form of illegal construct masquerading as a name
+ -- (SPARK RM 7.1.5(3)).
else
Error_Msg_N
-- procedure identified by Name, returns it if it exists, otherwise
-- errors out and uses Arg as the pragma argument for the message.
- procedure Fix_Error (Msg : in out String);
- -- This is called prior to issuing an error message. Msg is a string
- -- that typically contains the substring "pragma". If the pragma comes
- -- from an aspect, each such "pragma" substring is replaced with the
- -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
- -- aspect (which may be different from the pragma name). If the current
- -- pragma results from rewriting another pragma, then Error_Msg_Name_1
- -- is set to the original pragma name.
+ function Fix_Error (Msg : String) return String;
+ -- This is called prior to issuing an error message. Msg is the normal
+ -- error message issued in the pragma case. This routine checks for the
+ -- case of a pragma coming from an aspect in the source, and returns a
+ -- message suitable for the aspect case as follows:
+ --
+ -- Each substring "pragma" is replaced by "aspect"
+ --
+ -- If "argument of" is at the start of the error message text, it is
+ -- replaced by "entity for".
+ --
+ -- If "argument" is at the start of the error message text, it is
+ -- replaced by "entity".
+ --
+ -- So for example, "argument of pragma X must be discrete type"
+ -- returns "entity for aspect X must be a discrete type".
+
+ -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
+ -- be different from the pragma name). If the current pragma results
+ -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
+ -- original pragma name.
procedure Gather_Associations
(Names : Name_List;
Error_Msg_Name_1 := Pname;
declare
- Msg : String :=
+ Msg : constant String :=
"argument for pragma% must be a identifier or "
& "static string expression!";
begin
- Fix_Error (Msg);
- Flag_Non_Static_Expr (Msg, Argx);
+ Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
raise Pragma_Exit;
end;
end if;
else
Error_Msg_Name_1 := Pname;
-
- declare
- Msg : String :=
- "argument for pragma% must be a static expression!";
- begin
- Fix_Error (Msg);
- Flag_Non_Static_Expr (Msg, Expr);
- end;
-
+ Flag_Non_Static_Expr
+ (Fix_Error ("argument for pragma% must be a static expression!"),
+ Expr);
raise Pragma_Exit;
end if;
end Check_Expr_Is_Static_Expression;
------------------
procedure Error_Pragma (Msg : String) is
- MsgF : String := Msg;
begin
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, N);
+ Error_Msg_N (Fix_Error (Msg), N);
raise Pragma_Exit;
end Error_Pragma;
----------------------
procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
- MsgF : String := Msg;
begin
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
+ Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
raise Pragma_Exit;
end Error_Pragma_Arg;
procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
- MsgF : String := Msg1;
begin
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
+ Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
Error_Pragma_Arg (Msg2, Arg);
end Error_Pragma_Arg;
----------------------------
procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
- MsgF : String := Msg;
begin
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, Arg);
+ Error_Msg_N (Fix_Error (Msg), Arg);
raise Pragma_Exit;
end Error_Pragma_Arg_Ident;
----------------------
procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
- MsgF : String := Msg;
begin
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_Sloc := Sloc (Ref);
- Error_Msg_NE (MsgF, N, Ref);
+ Error_Msg_Sloc := Sloc (Ref);
+ Error_Msg_NE (Fix_Error (Msg), N, Ref);
raise Pragma_Exit;
end Error_Pragma_Ref;
-- Fix_Error --
---------------
- procedure Fix_Error (Msg : in out String) is
+ function Fix_Error (Msg : String) return String is
+ Res : String (Msg'Range) := Msg;
+ Res_Last : Natural := Msg'Last;
+ J : Natural;
+
begin
-- If we have a rewriting of another pragma, go to that pragma
-- Change appearence of "pragma" in message to "aspect"
- for J in Msg'First .. Msg'Last - 5 loop
- if Msg (J .. J + 5) = "pragma" then
- Msg (J .. J + 5) := "aspect";
+ J := Res'First;
+ while J <= Res_Last - 5 loop
+ if Res (J .. J + 5) = "pragma" then
+ Res (J .. J + 5) := "aspect";
+ J := J + 6;
+
+ else
+ J := J + 1;
end if;
end loop;
+ -- Change "argument of" at start of message to "entity for"
+
+ if Res'Length > 11
+ and then Res (Res'First .. Res'First + 10) = "argument of"
+ then
+ Res (Res'First .. Res'First + 9) := "entity for";
+ Res (Res'First + 10 .. Res_Last - 1) :=
+ Res (Res'First + 11 .. Res_Last);
+ Res_Last := Res_Last - 1;
+ end if;
+
+ -- Change "argument" at start of message to "entity"
+
+ if Res'Length > 8
+ and then Res (Res'First .. Res'First + 7) = "argument"
+ then
+ Res (Res'First .. Res'First + 5) := "entity";
+ Res (Res'First + 6 .. Res_Last - 2) :=
+ Res (Res'First + 8 .. Res_Last);
+ Res_Last := Res_Last - 2;
+ end if;
+
-- Get name from corresponding aspect
Error_Msg_Name_1 := Original_Aspect_Name (N);
end if;
+
+ -- Return possibly modified message
+
+ return Res (Res'First .. Res_Last);
end Fix_Error;
-------------------------
elsif Import_Interface_Present (N) then
goto OK;
+ -- OK if the pragma was expanded by the compiler. Can occur when
+ -- using pragma Provide_Shift_Operators on multiple types.
+
+ elsif not Comes_From_Source (N) then
+ goto OK;
+
-- Error if being set Imported twice
else
-- Independent --
-----------------
- -- pragma Independent (LOCAL_NAME);
+ -- pragma Independent (record_component_LOCAL_NAME);
when Pragma_Independent => Independent : declare
E_Id : Node_Id;
E : Entity_Id;
- D : Node_Id;
- K : Node_Kind;
begin
Check_Ada_83_Warning;
end if;
E := Entity (E_Id);
- D := Declaration_Node (E);
- K := Nkind (D);
+
+ -- Check we have a record component. We have not yet setup
+ -- components fully, so identify by syntactic structure.
+
+ if Nkind (Declaration_Node (E)) /= N_Component_Declaration then
+ Error_Pragma_Arg
+ ("argument for pragma% must be record component", Arg1);
+ end if;
-- Check duplicate before we chain ourselves
Check_Duplicate_Pragma (E);
- -- Check appropriate entity
+ -- Chain pragma
- if Is_Type (E) then
- if Rep_Item_Too_Early (E, N)
- or else
- Rep_Item_Too_Late (E, N)
- then
- return;
- else
- Check_First_Subtype (Arg1);
- end if;
-
- elsif K = N_Object_Declaration
- or else (K = N_Component_Declaration
- and then Original_Record_Component (E) = E)
+ if Rep_Item_Too_Early (E, N)
+ or else
+ Rep_Item_Too_Late (E, N)
then
- if Rep_Item_Too_Late (E, N) then
- return;
- end if;
-
- else
- Error_Pragma_Arg
- ("inappropriate entity for pragma%", Arg1);
+ return;
end if;
+ -- Set flag in component
+
+ Set_Is_Independent (E);
+
Independence_Checks.Append ((N, E));
end Independent;
E : Entity_Id;
D : Node_Id;
K : Node_Kind;
+ C : Node_Id;
begin
Check_Ada_83_Warning;
if K = N_Full_Type_Declaration
and then (Is_Array_Type (E) or else Is_Record_Type (E))
then
- Independence_Checks.Append ((N, E));
+ Independence_Checks.Append ((N, Base_Type (E)));
Set_Has_Independent_Components (Base_Type (E));
+ -- For record type, set all components independent
+
+ if Is_Record_Type (E) then
+ C := First_Component (E);
+ while Present (C) loop
+ Set_Is_Independent (C);
+ Next_Component (C);
+ end loop;
+ end if;
+
elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
and then Nkind (D) = N_Object_Declaration
and then Nkind (Object_Definition (D)) =
N_Constrained_Array_Definition
then
- Independence_Checks.Append ((N, E));
- Set_Has_Independent_Components (E);
+ Independence_Checks.Append ((N, Base_Type (Etype (E))));
+ Set_Has_Independent_Components (Base_Type (Etype (E)));
else
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
-
Type_Id := Get_Pragma_Arg (Assoc);
+
+ if not Is_Entity_Name (Type_Id)
+ or else not Is_Type (Entity (Type_Id))
+ then
+ Error_Pragma_Arg
+ ("argument for pragma% must be type or subtype", Arg1);
+ end if;
+
Find_Type (Type_Id);
Typ := Entity (Type_Id);
--------------------------------
procedure Check_Library_Level_Entity (E : Entity_Id) is
- MsgF : String := "incorrect placement of pragma%";
+ MsgF : constant String := "incorrect placement of pragma%";
begin
if not Is_Library_Level_Entity (E) then
Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, N);
+ Error_Msg_N (Fix_Error (MsgF), N);
if Ekind_In (E, E_Generic_Package,
E_Package,
projects / gcc.git / commitdiff