2014-05-21 Robert Dewar <dewar@adacore.com>
+ * sem_elab.adb: Minor reformatting.
+ * s-taprop.ads: Minor comment fix.
+ * sem_ch8.adb (Analyze_Subprogram_Renaming): Remove call to
+ Kill_Elaboration_Checks.
+ * errout.adb, erroutc.adb: Minor reformatting.
+
+2014-05-21 Thomas Quinot <quinot@adacore.com>
+
+ * exp_pakd.adb (Byte_Swap): Handle the case of a sub-byte
+ component. No byte swapping occurs, but this procedure also takes
+ care of appropriately justifying the argument.
+
+2014-05-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch6.adb: sem_ch6.adb (Analyze_Aspects_On_Body_Or_Stub):
+ New routine.
+ (Analyze_Subprogram_Body_Helper): Move the
+ analysis of aspect specifications and the processing of the
+ subprogram body contract after inlining has taken place.
+ (Diagnose_Misplaced_Aspect_Specifications): Removed.
+
+2014-05-21 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Build_Derived_Record_Type): Revert previous change.
+
+2014-05-21 Robert Dewar <dewar@adacore.com>
+
+ * sem_eval.ads, sem_eval.adb (Why_Not_Static): Messages are not
+ continuations any more.
+
+2014-05-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sinfo.ads, sinfo.adb: New flag Needs_Initialized_Actual,
+ present in formal_Private_Definitions and on private extension
+ declarations of a formal derived type. Set when the use of the
+ formal type in a generic suggests that the actual should be a
+ fully initialized type.
+ * sem_warn.adb (May_Need_Initialized_Actual): new subprogram
+ to indicate that an entity of a generic type has default
+ initialization, and that the corresponing actual type in any
+ subsequent instantiation should be fully initialized.
+ * sem_ch12.adb (Check_Initialized_Type): new subprogram,
+ to emit a warning if the actual for a generic type on which
+ Needs_Initialized_Actual is set is not a fully initialized type.
+
+2014-05-21 Robert Dewar <dewar@adacore.com>
+
* sem_elab.adb, prj-dect.adb: Minor reformatting.
2014-05-21 Robert Dewar <dewar@adacore.com>
exit when
Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
- if Errors.Table (Cur_Msg).Sfile =
- Errors.Table (Next_Msg).Sfile
+ if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile
then
exit when Sptr < Errors.Table (Next_Msg).Sptr
- or else
- (Sptr = Errors.Table (Next_Msg).Sptr
- and then
- Optr < Errors.Table (Next_Msg).Optr);
+ or else (Sptr = Errors.Table (Next_Msg).Sptr
+ and then Optr < Errors.Table (Next_Msg).Optr);
end if;
Prev_Msg := Next_Msg;
N1, N2 : Error_Msg_Id;
procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
- -- Called to delete message Delete, keeping message Keep. Marks all
- -- messages of Delete with deleted flag set to True, and also makes sure
- -- that for the error messages that are retained the preferred message
- -- is the one retained (we prefer the shorter one in the case where one
- -- has an Instance tag). Note that we always know that Keep has at least
- -- as many continuations as Delete (since we always delete the shorter
- -- sequence).
+ -- Called to delete message Delete, keeping message Keep. Marks msg
+ -- Delete and all its continuations with deleted flag set to True.
+ -- Also makes sure that for the error messages that are retained the
+ -- preferred message is the one retained (we prefer the shorter one in
+ -- the case where one has an Instance tag). Note that we always know
+ -- that Keep has at least as many continuations as Delete (since we
+ -- always delete the shorter sequence).
----------------
-- Delete_Msg --
Shift : Uint;
begin
- pragma Assert (T_Size > 8);
+ if T_Size <= 8 then
+ Swap_F := Empty;
+ Swap_T := RTE (RE_Unsigned_8);
- if T_Size <= 16 then
- Swap_RE := RE_Bswap_16;
+ else
+ if T_Size <= 16 then
+ Swap_RE := RE_Bswap_16;
+
+ elsif T_Size <= 32 then
+ Swap_RE := RE_Bswap_32;
+
+ else pragma Assert (T_Size <= 64);
+ Swap_RE := RE_Bswap_64;
+ end if;
- elsif T_Size <= 32 then
- Swap_RE := RE_Bswap_32;
+ Swap_F := RTE (Swap_RE);
+ Swap_T := Etype (Swap_F);
- else pragma Assert (T_Size <= 64);
- Swap_RE := RE_Bswap_64;
end if;
- Swap_F := RTE (Swap_RE);
- Swap_T := Etype (Swap_F);
Shift := Esize (Swap_T) - T_Size;
Arg := RJ_Unchecked_Convert_To (Swap_T, N);
Right_Opnd => Make_Integer_Literal (Loc, Shift));
end if;
- Swapped :=
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Swap_F, Loc),
- Parameter_Associations => New_List (Arg));
+ if Present (Swap_F) then
+ Swapped :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Swap_F, Loc),
+ Parameter_Associations => New_List (Arg));
+ else
+ Swapped := Arg;
+ end if;
if Right_Justify and then Shift > Uint_0 then
Swapped :=
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False);
pragma Inline (Set_Priority);
- -- Set the priority of the task specified by T to T.Current_Priority. The
- -- priority set is what would correspond to the Ada concept of "base
- -- priority" in the terms of the lower layer system, but the operation may
- -- be used by the upper layer to implement changes in "active priority"
- -- that are not due to lock effects. The effect should be consistent with
- -- the Ada Reference Manual. In particular, when a task lowers its
- -- priority due to the loss of inherited priority, it goes at the head of
- -- the queue for its new priority (RM D.2.2 par 9). Loss_Of_Inheritance
- -- helps the underlying implementation to do it right when the OS doesn't.
+ -- Set the priority of the task specified by T to Prio. The priority set
+ -- is what would correspond to the Ada concept of "base priority" in the
+ -- terms of the lower layer system, but the operation may be used by the
+ -- upper layer to implement changes in "active priority" that are not due
+ -- to lock effects. The effect should be consistent with the Ada Reference
+ -- Manual. In particular, when a task lowers its priority due to the loss
+ -- of inherited priority, it goes at the head of the queue for its new
+ -- priority (RM D.2.2 par 9). Loss_Of_Inheritance helps the underlying
+ -- implementation to do it right when the OS doesn't.
function Get_Priority (T : ST.Task_Id) return System.Any_Priority;
pragma Inline (Get_Priority);
-- List of primitives made temporarily visible in the instantiation
-- to match the visibility of the formal type
+ procedure Check_Initialized_Types;
+ -- In a generic package body, an entity of a generic private type may
+ -- appear uninitialized. This is suspicious, unless the actual is a
+ -- fully initialized type.
+
+ procedure Check_Initialized_Types is
+ Decl : Node_Id;
+ Formal : Entity_Id;
+ Actual : Entity_Id;
+
+ begin
+ Decl := First (Generic_Formal_Declarations (Gen_Decl));
+ while Present (Decl) loop
+ if (Nkind (Decl) = N_Private_Extension_Declaration
+ and then Needs_Initialized_Actual (Decl))
+
+ or else (Nkind (Decl) = N_Formal_Type_Declaration
+ and then
+ Nkind (Formal_Type_Definition (Decl)) =
+ N_Formal_Private_Type_Definition
+ and then Needs_Initialized_Actual
+ (Formal_Type_Definition (Decl)))
+ then
+ Formal := Defining_Identifier (Decl);
+ Actual := First_Entity (Act_Decl_Id);
+
+ -- For each formal there is a subtype declaration that renames
+ -- the actual and has the same name as the formal.
+
+ while Present (Actual) loop
+ exit when Ekind (Actual) = E_Package
+ and then Present (Renamed_Object (Actual));
+
+ if Chars (Actual) = Chars (Formal)
+ and then not Is_Scalar_Type (Actual)
+ and then not Is_Fully_Initialized_Type (Actual)
+ and then Warn_On_No_Value_Assigned
+ then
+ Error_Msg_NE
+ ("from its use in generic unit, actual for&"
+ & " should be fully initialized type?",
+ Actual, Formal);
+ exit;
+ end if;
+
+ Next_Entity (Actual);
+ end loop;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Check_Initialized_Types;
begin
Gen_Body_Id := Corresponding_Body (Gen_Decl);
Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
Check_Generic_Actuals (Act_Decl_Id, False);
+ Check_Initialized_Types;
-- Install primitives hidden at the point of the instantiation but
-- visible when processing the generic formals
-- include an expression that is an allocator, whose expansion needs the
-- proper Master for the created tasks.
- if Nkind (Related_Nod) = N_Object_Declaration
- and then Expander_Active
+ if Nkind (Related_Nod) = N_Object_Declaration and then Expander_Active
then
- if Is_Interface (Desig_Type)
- and then Is_Limited_Record (Desig_Type)
+ if Is_Interface (Desig_Type) and then Is_Limited_Record (Desig_Type)
then
Build_Class_Wide_Master (Anon_Type);
-- Similarly, if the type is an anonymous access that designates
-- tasks, create a master entity for it in the current context.
- elsif Has_Task (Desig_Type)
- and then Comes_From_Source (Related_Nod)
+ elsif Has_Task (Desig_Type) and then Comes_From_Source (Related_Nod)
then
Build_Master_Entity (Defining_Identifier (Related_Nod));
Build_Master_Renaming (Anon_Type);
-- use previous subprogram type as the designated type, and then
-- remove scope added above.
- if ASIS_Mode
- and then Present (Scope (Defining_Identifier (F)))
+ if ASIS_Mode and then Present (Scope (Defining_Identifier (F)))
then
Set_Etype (T_Name, T_Name);
Init_Size_Align (T_Name);
-- its own context, allowing the following circularity that cannot be
-- detected earlier
- elsif Is_Class_Wide_Type (Full_Desig)
- and then Etype (Full_Desig) = T
+ elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T
then
Error_Msg_N
("access type cannot designate its own classwide type", S);
case Nkind (Constr) is
when N_Attribute_Reference =>
- return
- Attribute_Name (Constr) = Name_Access
- and then Prefix (Constr) = Scope (Entity (Prefix (Constr)));
+ return Attribute_Name (Constr) = Name_Access
+ and then Prefix (Constr) = Scope (Entity (Prefix (Constr)));
when N_Discriminant_Association =>
return Denotes_Discriminant (Expression (Constr));
-- ??? a cleaner approach may be possible and/or this solution
-- could be extended to general-purpose late primitives, TBD.
- if not ASIS_Mode
- and then not Body_Seen
- and then not Is_Body (Decl)
+ if not ASIS_Mode and then not Body_Seen and then not Is_Body (Decl)
then
Body_Seen := True;
-- imported through a LIMITED WITH clause, it appears as incomplete
-- but has no full view.
- if Ekind (Prev) = E_Incomplete_Type
- and then Present (Full_View (Prev))
+ if Ekind (Prev) = E_Incomplete_Type and then Present (Full_View (Prev))
then
T := Full_View (Prev);
else
if Present (Prev_Entity)
and then
-
-- If the homograph is an implicit subprogram, it is overridden
-- by the current declaration.
-- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
-- out some static checks
- if Ada_Version >= Ada_2005
- and then Can_Never_Be_Null (T)
- then
+ if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then
+
-- In case of aggregates we must also take care of the correct
-- initialization of nested aggregates bug this is done at the
- -- point of the analysis of the aggregate (see sem_aggr.adb)
+ -- point of the analysis of the aggregate (see sem_aggr.adb).
if Present (Expression (N))
and then Nkind (Expression (N)) = N_Aggregate
Set_Current_Value (Id, E);
end if;
- elsif Is_Scalar_Type (T)
- and then Is_OK_Static_Expression (E)
- then
+ elsif Is_Scalar_Type (T) and then Is_OK_Static_Expression (E) then
Set_Is_Known_Valid (Id);
end if;
if Is_Access_Type (T) then
if Known_Non_Null (E) then
Set_Is_Known_Non_Null (Id, True);
- elsif Known_Null (E)
- and then not Can_Never_Be_Null (Id)
- then
+ elsif Known_Null (E) and then not Can_Never_Be_Null (Id) then
Set_Is_Known_Null (Id, True);
end if;
end if;
declare
Val : constant Node_Id := Constant_Value (Entity (E));
begin
- if Present (Val)
- and then Nkind (Val) = N_String_Literal
- then
+ if Present (Val) and then Nkind (Val) = N_String_Literal then
Rewrite (E, New_Copy (Val));
end if;
end;
-- Deal with setting In_Private_Part flag if in private part
- if Ekind (Scope (Id)) = E_Package
- and then In_Private_Part (Scope (Id))
+ if Ekind (Scope (Id)) = E_Package and then In_Private_Part (Scope (Id))
then
Set_In_Private_Part (Id);
end if;
pragma Assert (Prev = T
or else (Ekind (Prev) = E_Incomplete_Type
- and then Present (Full_View (Prev))
- and then Full_View (Prev) = T));
+ and then Present (Full_View (Prev))
+ and then Full_View (Prev) = T));
end;
end if;
-- Ada 2005 (AI-443): Synchronized private extension or a rewritten
-- synchronized formal derived type.
- if Ada_Version >= Ada_2005
- and then Synchronized_Present (N)
- then
+ if Ada_Version >= Ada_2005 and then Synchronized_Present (N) then
Set_Is_Limited_Record (T);
-- Formal derived type case
-- interface.
if (not Is_Tagged_Type (Parent_Type)
- or else not Is_Limited_Type (Parent_Type))
+ or else not Is_Limited_Type (Parent_Type))
and then
- (not Is_Interface (Parent_Type)
+ (not Is_Interface (Parent_Type)
or else not Is_Synchronized_Interface (Parent_Type))
then
Error_Msg_NE ("parent type of & must be tagged limited " &
else
if not Is_Interface (Parent_Type)
or else (not Is_Limited_Interface (Parent_Type)
- and then
- not Is_Synchronized_Interface (Parent_Type))
+ and then not Is_Synchronized_Interface (Parent_Type))
then
Error_Msg_NE
("parent type of & must be limited interface", N, T);
-- Subtype of unconstrained array without constraint is not allowed
-- in SPARK.
- if Is_Array_Type (T)
- and then not Is_Constrained (T)
- then
+ if Is_Array_Type (T) and then not Is_Constrained (T) then
Check_SPARK_Restriction
("subtype of unconstrained array must have constraint", N);
end if;
if Present (Generic_Parent_Type (N))
and then
- (Nkind
- (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
+ (Nkind (Parent (Generic_Parent_Type (N))) /=
+ N_Formal_Type_Declaration
or else Nkind
- (Formal_Type_Definition (Parent (Generic_Parent_Type (N))))
- /= N_Formal_Private_Type_Definition)
+ (Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) /=
+ N_Formal_Private_Type_Definition)
then
if Is_Tagged_Type (Id) then
end if;
end if;
- if Is_Private_Type (T)
- and then Present (Full_View (T))
- then
+ if Is_Private_Type (T) and then Present (Full_View (T)) then
Conditional_Delay (Id, Full_View (T));
-- The subtypes of components or subcomponents of protected types
-- In the array case, check compatibility for each index
- elsif Is_Array_Type (Etype (Id))
- and then Present (First_Index (Id))
+ elsif Is_Array_Type (Etype (Id)) and then Present (First_Index (Id))
then
-- This really should be a subprogram that finds the indications
-- to check???
begin
while Present (Subt_Index) loop
if ((Nkind (Subt_Index) = N_Identifier
- and then Ekind (Entity (Subt_Index)) in Scalar_Kind)
+ and then Ekind (Entity (Subt_Index)) in Scalar_Kind)
or else Nkind (Subt_Index) = N_Subtype_Indication)
and then
Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range
-- Ada 2005 (AI-231): Propagate the null-excluding attribute to the
-- array type to ensure that objects of this type are initialized.
- if Ada_Version >= Ada_2005
- and then Can_Never_Be_Null (Element_Type)
- then
+ if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (Element_Type) then
Set_Can_Never_Be_Null (T);
if Null_Exclusion_Present (Component_Definition (Def))
-- types created for packed entities do not need such, they are
-- compatible with the user-defined type.
- if Number_Dimensions (T) = 1
- and then not Is_Packed_Array_Type (T)
- then
+ if Number_Dimensions (T) = 1 and then not Is_Packed_Array_Type (T) then
New_Concatenation_Op (T);
end if;
if Null_Exclusion_Present (Type_Definition (N)) then
Set_Can_Never_Be_Null (Derived_Type);
+ -- What is with the "AND THEN FALSE" here ???
+
if Can_Never_Be_Null (Parent_Type)
and then False
then
and then Has_Discriminants (Parent_Type)
then
Parent_Base := Base_Type (Full_View (Parent_Type));
-
- -- Handle a derived type which is the full view of a private type not
- -- defined in a generic unit which is derived from a private type with
- -- discriminants whose full view is a non-tagged record type.
-
- elsif not Inside_A_Generic
- and then Ekind (Parent_Type) = E_Private_Type
- and then Has_Discriminants (Parent_Type)
- and then Present (Full_View (Parent_Type))
- and then Is_Record_Type (Full_View (Parent_Type))
- and then not Is_Tagged_Type (Full_View (Parent_Type))
- and then Has_Private_Declaration (Derived_Type)
- then
- Parent_Base := Base_Type (Full_View (Parent_Type));
else
Parent_Base := Base_Type (Parent_Type);
end if;
-- chained beyond that point. It is initialized to Empty to deal with
-- the case where there is no separate spec.
+ procedure Analyze_Aspects_On_Body_Or_Stub;
+ -- Analyze the aspect specifications of a subprogram body [stub]. It is
+ -- assumed that N has aspects.
+
procedure Check_Anonymous_Return;
-- Ada 2005: if a function returns an access type that denotes a task,
-- or a type that contains tasks, we must create a master entity for
-- verify that a function ends with a RETURN and that a procedure does
-- not contain any RETURN.
- procedure Diagnose_Misplaced_Aspect_Specifications;
- -- It is known that subprogram body N has aspects, but they are not
- -- properly placed. Provide specific error messages depending on the
- -- aspects involved.
-
function Disambiguate_Spec return Entity_Id;
-- When a primitive is declared between the private view and the full
-- view of a concurrent type which implements an interface, a special
-- indicator, check that it is consistent with the known status of the
-- entity.
+ -------------------------------------
+ -- Analyze_Aspects_On_Body_Or_Stub --
+ -------------------------------------
+
+ procedure Analyze_Aspects_On_Body_Or_Stub is
+ procedure Diagnose_Misplaced_Aspects;
+ -- Subprogram body [stub] N has aspects, but they are not properly
+ -- placed. Provide precise diagnostics depending on the aspects
+ -- involved.
+
+ --------------------------------
+ -- Diagnose_Misplaced_Aspects --
+ --------------------------------
+
+ procedure Diagnose_Misplaced_Aspects is
+ Asp : Node_Id;
+ Asp_Nam : Name_Id;
+ Asp_Id : Aspect_Id;
+ -- The current aspect along with its name and id
+
+ procedure SPARK_Aspect_Error (Ref_Nam : Name_Id);
+ -- Emit an error message concerning SPARK aspect Asp. Ref_Nam is
+ -- the name of the refined version of the aspect.
+
+ ------------------------
+ -- SPARK_Aspect_Error --
+ ------------------------
+
+ procedure SPARK_Aspect_Error (Ref_Nam : Name_Id) is
+ begin
+ -- The corresponding spec already contains the aspect in
+ -- question and the one appearing on the body must be the
+ -- refined form:
+
+ -- procedure P with Global ...;
+ -- procedure P with Global ... is ... end P;
+ -- ^
+ -- Refined_Global
+
+ if Has_Aspect (Spec_Id, Asp_Id) then
+ Error_Msg_Name_1 := Asp_Nam;
+
+ -- Subunits cannot carry aspects that apply to a subprogram
+ -- declaration.
+
+ if Nkind (Parent (N)) = N_Subunit then
+ Error_Msg_N ("aspect % cannot apply to a subunit", Asp);
+
+ else
+ Error_Msg_Name_2 := Ref_Nam;
+ Error_Msg_N ("aspect % should be %", Asp);
+ end if;
+
+ -- Otherwise the aspect must appear in the spec, not in the
+ -- body:
+
+ -- procedure P;
+ -- procedure P with Global ... is ... end P;
+
+ else
+ Error_Msg_N
+ ("aspect specification must appear in subprogram "
+ & "declaration", Asp);
+ end if;
+ end SPARK_Aspect_Error;
+
+ -- Start of processing for Diagnose_Misplaced_Aspects
+
+ begin
+ -- Iterate over the aspect specifications and emit specific errors
+ -- where applicable.
+
+ Asp := First (Aspect_Specifications (N));
+ while Present (Asp) loop
+ Asp_Nam := Chars (Identifier (Asp));
+ Asp_Id := Get_Aspect_Id (Asp_Nam);
+
+ -- Do not emit errors on aspects that can appear on a
+ -- subprogram body. This scenario occurs when the aspect
+ -- specification list contains both misplaced and properly
+ -- placed aspects.
+
+ if Aspect_On_Body_Or_Stub_OK (Asp_Id) then
+ null;
+
+ -- Special diagnostics for SPARK aspects
+
+ elsif Asp_Nam = Name_Depends then
+ SPARK_Aspect_Error (Name_Refined_Depends);
+
+ elsif Asp_Nam = Name_Global then
+ SPARK_Aspect_Error (Name_Refined_Global);
+
+ elsif Asp_Nam = Name_Post then
+ SPARK_Aspect_Error (Name_Refined_Post);
+
+ else
+ Error_Msg_N
+ ("aspect specification must appear in subprogram "
+ & "declaration", Asp);
+ end if;
+
+ Next (Asp);
+ end loop;
+ end Diagnose_Misplaced_Aspects;
+
+ -- Start of processing for Analyze_Aspects_On_Body_Or_Stub
+
+ begin
+ -- Language-defined aspects cannot be associated with a subprogram
+ -- body [stub] if the subprogram has a spec. Certain implementation
+ -- defined aspects are allowed to break this rule (for list, see
+ -- table Aspect_On_Body_Or_Stub_OK).
+
+ if Present (Spec_Id) and then not Aspects_On_Body_Or_Stub_OK (N) then
+ Diagnose_Misplaced_Aspects;
+ else
+ Analyze_Aspect_Specifications (N, Body_Id);
+ end if;
+ end Analyze_Aspects_On_Body_Or_Stub;
+
----------------------------
-- Check_Anonymous_Return --
----------------------------
end if;
end Check_Missing_Return;
- ----------------------------------------------
- -- Diagnose_Misplaced_Aspect_Specifications --
- ----------------------------------------------
-
- procedure Diagnose_Misplaced_Aspect_Specifications is
- Asp : Node_Id;
- Asp_Nam : Name_Id;
- Asp_Id : Aspect_Id;
- -- The current aspect along with its name and id
-
- procedure SPARK_Aspect_Error (Ref_Nam : Name_Id);
- -- Emit an error message concerning SPARK aspect Asp. Ref_Nam is the
- -- name of the refined version of the aspect.
-
- ------------------------
- -- SPARK_Aspect_Error --
- ------------------------
-
- procedure SPARK_Aspect_Error (Ref_Nam : Name_Id) is
- begin
- -- The corresponding spec already contains the aspect in question
- -- and the one appearing on the body must be the refined form:
-
- -- procedure P with Global ...;
- -- procedure P with Global ... is ... end P;
- -- ^
- -- Refined_Global
-
- if Has_Aspect (Spec_Id, Asp_Id) then
- Error_Msg_Name_1 := Asp_Nam;
-
- -- Subunits cannot carry aspects that apply to a subprogram
- -- declaration.
-
- if Nkind (Parent (N)) = N_Subunit then
- Error_Msg_N ("aspect % cannot apply to a subunit", Asp);
-
- else
- Error_Msg_Name_2 := Ref_Nam;
- Error_Msg_N ("aspect % should be %", Asp);
- end if;
-
- -- Otherwise the aspect must appear in the spec, not in the body:
-
- -- procedure P;
- -- procedure P with Global ... is ... end P;
-
- else
- Error_Msg_N
- ("aspect specification must appear in subprogram declaration",
- Asp);
- end if;
- end SPARK_Aspect_Error;
-
- -- Start of processing for Diagnose_Misplaced_Aspect_Specifications
-
- begin
- -- Iterate over the aspect specifications and emit specific errors
- -- where applicable.
-
- Asp := First (Aspect_Specifications (N));
- while Present (Asp) loop
- Asp_Nam := Chars (Identifier (Asp));
- Asp_Id := Get_Aspect_Id (Asp_Nam);
-
- -- Do not emit errors on aspects that can appear on a subprogram
- -- body. This scenario occurs when the aspect specification list
- -- contains both misplaced and properly placed aspects.
-
- if Aspect_On_Body_Or_Stub_OK (Asp_Id) then
- null;
-
- -- Special diagnostics for SPARK aspects
-
- elsif Asp_Nam = Name_Depends then
- SPARK_Aspect_Error (Name_Refined_Depends);
-
- elsif Asp_Nam = Name_Global then
- SPARK_Aspect_Error (Name_Refined_Global);
-
- elsif Asp_Nam = Name_Post then
- SPARK_Aspect_Error (Name_Refined_Post);
-
- else
- Error_Msg_N
- ("aspect specification must appear in subprogram declaration",
- Asp);
- end if;
-
- Next (Asp);
- end loop;
- end Diagnose_Misplaced_Aspect_Specifications;
-
-----------------------
-- Disambiguate_Spec --
-----------------------
end if;
end if;
- -- Language-defined aspects cannot appear on a subprogram body [stub] if
- -- the subprogram has a spec. Certain implementation-defined aspects are
- -- allowed to break this rule (see table Aspect_On_Body_Or_Stub_OK).
-
- if Has_Aspects (N) then
- if Present (Spec_Id)
- and then not Aspects_On_Body_Or_Stub_OK (N)
- then
- Diagnose_Misplaced_Aspect_Specifications;
-
- else
- Analyze_Aspect_Specifications (N, Body_Id);
- end if;
- end if;
-
-- Previously we scanned the body to look for nested subprograms, and
-- rejected an inline directive if nested subprograms were present,
-- because the back-end would generate conflicting symbols for the
Check_Eliminated (Body_Id);
if Nkind (N) = N_Subprogram_Body_Stub then
+
+ -- Analyze any aspect specifications that appear on the subprogram
+ -- body stub.
+
+ if Has_Aspects (N) then
+ Analyze_Aspects_On_Body_Or_Stub;
+ end if;
+
+ -- Stop the analysis now as the stub cannot be inlined, plus it does
+ -- not have declarative or statement lists.
+
return;
end if;
HSS := Handled_Statement_Sequence (N);
Set_Actual_Subtypes (N, Current_Scope);
- -- Deal with [refined] preconditions, postconditions, Contract_Cases,
- -- invariants and predicates associated with the body and its spec.
- -- Note that this is not pure expansion as Expand_Subprogram_Contract
- -- prepares the contract assertions for generic subprograms or for ASIS.
- -- Do not generate contract checks in SPARK mode.
-
- if not GNATprove_Mode then
- Expand_Subprogram_Contract (N, Spec_Id, Body_Id);
- end if;
-
-- Add a declaration for the Protection object, renaming declarations
-- for discriminals and privals and finally a declaration for the entry
-- family index (if applicable). This form of early expansion is done
Exchange_Limited_Views (Spec_Id);
end if;
+ -- Analyze any aspect specifications that appear on the subprogram body
+
+ if Has_Aspects (N) then
+ Analyze_Aspects_On_Body_Or_Stub;
+ end if;
+
+ -- Deal with [refined] preconditions, postconditions, Contract_Cases,
+ -- invariants and predicates associated with the body and its spec.
+ -- Note that this is not pure expansion as Expand_Subprogram_Contract
+ -- prepares the contract assertions for generic subprograms or for ASIS.
+ -- Do not generate contract checks in SPARK mode.
+
+ if not GNATprove_Mode then
+ Expand_Subprogram_Contract (N, Spec_Id, Body_Id);
+ end if;
+
-- Analyze the declarations (this call will analyze the precondition
-- Check pragmas we prepended to the list, as well as the declaration
-- of the _Postconditions procedure).
end if;
end if;
+ -- At this point, we used to have the following, but we removed it
+ -- because it was certainly wrong for generic formal parameters in
+ -- at least some cases, causing elaboration checks to be skipped.
+ -- Possibly it is helpful in some other cases, but it caused no
+ -- regressions to remove it completely.
+
-- There is no need for elaboration checks on the new entity, which may
-- be called before the next freezing point where the body will appear.
-- Elaboration checks refer to the real entity, not the one created by
-- the renaming declaration.
- Set_Kill_Elaboration_Checks (New_S, True);
+ -- Set_Kill_Elaboration_Checks (New_S, True);
if Etype (Nam) = Any_Type then
Set_Has_Completion (New_S);
if Nkind (Decl) = N_Subprogram_Body then
Body_Acts_As_Spec := True;
- elsif Nkind (Decl) = N_Subprogram_Declaration
- or else Nkind (Decl) = N_Subprogram_Body_Stub
+ elsif Nkind_In (Decl, N_Subprogram_Declaration, N_Subprogram_Body_Stub)
or else Inst_Case
then
Body_Acts_As_Spec := False;
- -- If we have none of an instantiation, subprogram body or
- -- subprogram declaration, then it is not a case that we want
- -- to check. (One case is a call to a generic formal subprogram,
- -- where we do not want the check in the template).
+ -- If we have none of an instantiation, subprogram body or subprogram
+ -- declaration, then it is not a case that we want to check. (One case
+ -- is a call to a generic formal subprogram, where we do not want the
+ -- check in the template).
else
return;
exit when Is_Compilation_Unit (E_Scope)
and then (Is_Child_Unit (E_Scope)
- or else Scope (E_Scope) = Standard_Standard);
+ or else Scope (E_Scope) = Standard_Standard);
-- If we did not find a compilation unit, other than standard,
-- then nothing to check (happens in some instantiation cases)
-- However, this assumption is only valid if we are in static mode.
if not Dynamic_Elaboration_Checks
- and then Instantiation_Depth (Sloc (Ent)) >
- Instantiation_Depth (Sloc (N))
+ and then
+ Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N))
then
return;
end if;
-- Do not give a warning for a package with no body
- if Ekind (Ent) = E_Generic_Package
- and then not Has_Generic_Body (N)
- then
+ if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then
return;
end if;
-- the sgi build and storage errors. To be resolved later ???
if (Callee_Unit_Internal and Caller_Unit_Internal)
- and then not Debug_Flag_EE
+ and then not Debug_Flag_EE
then
return;
end if;
if Unit_Caller /= No_Unit
and then Unit_Callee /= Unit_Caller
and then not Dynamic_Elaboration_Checks
+
+ -- This is an attempt to solve the problem of mishandling of
+ -- generic formal parameters, but it does not work right yet ???
+
+ -- and then not Used_As_Generic_Actual (Ent)
then
+ -- It is here that things go wrong for calling a generic formal???
+
E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller));
-- If we don't get a spec entity, just ignore call. Not quite
-- Loop to carefully follow renamings and derivations one step
-- outside the current unit, but not further.
- if not Inst_Case
- and then Present (Alias (Ent))
- then
+ if not Inst_Case and then Present (Alias (Ent)) then
E_Scope := Alias (Ent);
else
E_Scope := Ent;
-- For an entry call, check relevant restriction
if Nkind (N) = N_Entry_Call_Statement
- and then not In_Subprogram_Or_Concurrent_Unit
+ and then not In_Subprogram_Or_Concurrent_Unit
then
Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N);
-- Filter out case of default expressions, where we do not
-- do the check at this stage.
- if Nkind (P) = N_Parameter_Specification
- or else
- Nkind (P) = N_Component_Declaration
+ if Nkind_In (P, N_Parameter_Specification,
+ N_Component_Declaration)
then
return;
end if;
if Nkind (P) = N_Protected_Body then
return;
- elsif Nkind (P) = N_Subprogram_Body
- or else
- Nkind (P) = N_Task_Body
- or else
- Nkind (P) = N_Block_Statement
- or else
- Nkind (P) = N_Entry_Body
+ elsif Nkind_In (P, N_Subprogram_Body,
+ N_Task_Body,
+ N_Block_Statement,
+ N_Entry_Body)
then
if L = Declarations (P) then
exit;
-- treat the current node as a call to each of these functions, to check
-- their elaboration impact.
- if Is_Init_Proc (Ent)
- and then From_Elab_Code
- then
+ if Is_Init_Proc (Ent) and then From_Elab_Code then
Process_Init_Proc : declare
Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
begin
if Nkind (Decl) = N_Object_Declaration
and then (Present (Expression (Decl))
- or else No_Initialization (Decl))
+ or else No_Initialization (Decl))
then
return;
end if;
C_Scope := Current_Scope;
- if Present (Outer_Scope)
- and then Within (Scope (Ent), Outer_Scope)
- then
+ if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then
Set_C_Scope;
Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
-- code, do not trace past an accept statement, because the rendez-
-- vous will happen after elaboration.
- if (Nkind (Original_Node (N)) = N_Accept_Statement
- or else Nkind (Original_Node (N)) = N_Selective_Accept)
+ if Nkind_In (Original_Node (N), N_Accept_Statement,
+ N_Selective_Accept)
and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
then
return Abandon;
return OK;
- -- If we have an access attribute for a subprogram, check
- -- it. Suppress this behavior under debug flag.
+ -- If we have an access attribute for a subprogram, check it.
+ -- Suppress this behavior under debug flag.
elsif not Debug_Flag_Dot_UU
and then Nkind (N) = N_Attribute_Reference
Sbody := Unit_Declaration_Node (E);
- if Nkind (Sbody) /= N_Subprogram_Body
- and then
- Nkind (Sbody) /= N_Package_Body
- then
+ if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then
Ebody := Corresponding_Body (Sbody);
if No (Ebody) then
if No (Corresponding_Body (Unit_Declaration_Node (Proc)))
and then
(not Is_Generic_Instance (Scope (Proc))
- or else
- Scope (Proc) = Scope (Defining_Identifier (Decl)))
+ or else Scope (Proc) = Scope (Defining_Identifier (Decl)))
then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_N
-- that is, on which we need to place to elaboration flag. This happens
-- with init proc calls.
- if Is_Init_Proc (Subp)
- or else Init_Call
- then
+ if Is_Init_Proc (Subp) or else Init_Call then
+
-- The initialization call is on an object whose type is not declared
-- in the same scope as the subprogram. The type of the object must
-- be a subtype of the type of operation. This object is the first
begin
-- Check whether Id is a procedure with at least one parameter
- if Ekind (Id) = E_Procedure
- and then Present (First_Formal (Id))
- then
+ if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then
declare
Typ : constant Entity_Id := Etype (First_Formal (Id));
Deep_Fin : Entity_Id := Empty;
Fin := Find_Prim_Op (Typ, Name_Finalize);
end if;
- return
- (Present (Deep_Fin) and then Id = Deep_Fin)
- or else
- (Present (Fin) and then Id = Fin);
+ return (Present (Deep_Fin) and then Id = Deep_Fin)
+ or else (Present (Fin) and then Id = Fin);
end;
end if;
S1 := Scop1;
while S1 /= Standard_Standard
and then not Is_Compilation_Unit (S1)
- and then (Ekind (S1) = E_Package
- or else
- Ekind (S1) = E_Protected_Type
- or else
- Ekind (S1) = E_Block)
+ and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block)
loop
S1 := Scope (S1);
end loop;
S2 := Scop2;
while S2 /= Standard_Standard
and then not Is_Compilation_Unit (S2)
- and then (Ekind (S2) = E_Package
- or else
- Ekind (S2) = E_Protected_Type
- or else
- Ekind (S2) = E_Block)
+ and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block)
loop
S2 := Scope (S2);
end loop;
if Nkind (N) = N_Subprogram_Declaration then
declare
Ent : constant Entity_Id := Defining_Unit_Name (Specification (N));
- begin
+ begin
-- Internal subprograms will already have a generated body, so
-- there is no need to provide a stub for them.
if Raises_Constraint_Error (Expr) then
Error_Msg_N
- ("\expression raises exception, cannot be static " &
+ ("!expression raises exception, cannot be static " &
"(RM 4.9(34))", N);
return;
end if;
and then not Is_RTE (Typ, RE_Bignum)
then
Error_Msg_N
- ("\static expression must have scalar or string type " &
+ ("!static expression must have scalar or string type " &
"(RM 4.9(2))", N);
return;
end if;
or else
Is_Aggregate (Right_Opnd (CO))))
then
- Error_Msg_N ("\aggregate (#) is never static", N);
+ Error_Msg_N ("!aggregate (#) is never static", N);
elsif No (CV) or else not Is_Static_Expression (CV) then
Error_Msg_NE
- ("\& is not a static constant (RM 4.9(5))", N, E);
+ ("!& is not a static constant (RM 4.9(5))", N, E);
end if;
end Entity_Case;
else
Error_Msg_NE
- ("\& is not static constant or named number "
+ ("!& is not static constant or named number "
& "(RM 4.9(5))", N, E);
end if;
when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
if Nkind (N) in N_Op_Shift then
Error_Msg_N
- ("\shift functions are never static (RM 4.9(6,18))", N);
+ ("!shift functions are never static (RM 4.9(6,18))", N);
else
Why_Not_Static (Left_Opnd (N));
if Attribute_Name (N) = Name_Size then
Error_Msg_N
- ("\size attribute is only static for static scalar type "
+ ("!size attribute is only static for static scalar type "
& "(RM 4.9(7,8))", N);
-- Flag array cases
Attribute_Name (N) /= Name_Length
then
Error_Msg_N
- ("\static array attribute must be Length, First, or Last "
+ ("!static array attribute must be Length, First, or Last "
& "(RM 4.9(8))", N);
-- Since we know the expression is not-static (we already
else
Error_Msg_N
- ("\prefix is non-static array (RM 4.9(8))", Prefix (N));
+ ("!prefix is non-static array (RM 4.9(8))", Prefix (N));
end if;
return;
Is_Generic_Type (E)
then
Error_Msg_N
- ("\attribute of generic type is never static "
+ ("!attribute of generic type is never static "
& "(RM 4.9(7,8))", N);
elsif Is_Static_Subtype (E) then
elsif Is_Scalar_Type (E) then
Error_Msg_N
- ("\prefix type for attribute is not static scalar subtype "
+ ("!prefix type for attribute is not static scalar subtype "
& "(RM 4.9(7))", N);
else
Error_Msg_N
- ("\static attribute must apply to array/scalar type "
+ ("!static attribute must apply to array/scalar type "
& "(RM 4.9(7,8))", N);
end if;
when N_String_Literal =>
Error_Msg_N
- ("\subtype of string literal is non-static (RM 4.9(4))", N);
+ ("!subtype of string literal is non-static (RM 4.9(4))", N);
-- Explicit dereference
when N_Explicit_Dereference =>
Error_Msg_N
- ("\explicit dereference is never static (RM 4.9)", N);
+ ("!explicit dereference is never static (RM 4.9)", N);
-- Function call
-- scalar arithmetic operation.
if not Is_RTE (Typ, RE_Bignum) then
- Error_Msg_N ("\non-static function call (RM 4.9(6,18))", N);
+ Error_Msg_N ("!non-static function call (RM 4.9(6,18))", N);
end if;
-- Parameter assocation (test actual parameter)
-- Indexed component
when N_Indexed_Component =>
- Error_Msg_N ("\indexed component is never static (RM 4.9)", N);
+ Error_Msg_N ("!indexed component is never static (RM 4.9)", N);
-- Procedure call
when N_Procedure_Call_Statement =>
- Error_Msg_N ("\procedure call is never static (RM 4.9)", N);
+ Error_Msg_N ("!procedure call is never static (RM 4.9)", N);
-- Qualified expression (test expression)
-- Aggregate
when N_Aggregate | N_Extension_Aggregate =>
- Error_Msg_N ("\an aggregate is never static (RM 4.9)", N);
+ Error_Msg_N ("!an aggregate is never static (RM 4.9)", N);
-- Range
-- Selected component
when N_Selected_Component =>
- Error_Msg_N ("\selected component is never static (RM 4.9)", N);
+ Error_Msg_N ("!selected component is never static (RM 4.9)", N);
-- Slice
when N_Slice =>
- Error_Msg_N ("\slice is never static (RM 4.9)", N);
+ Error_Msg_N ("!slice is never static (RM 4.9)", N);
when N_Type_Conversion =>
Why_Not_Static (Expression (N));
or else not Is_Static_Subtype (Entity (Subtype_Mark (N)))
then
Error_Msg_N
- ("\static conversion requires static scalar subtype result "
+ ("!static conversion requires static scalar subtype result "
& "(RM 4.9(9))", N);
end if;
when N_Unchecked_Type_Conversion =>
Error_Msg_N
- ("\unchecked type conversion is never static (RM 4.9)", N);
+ ("!unchecked type conversion is never static (RM 4.9)", N);
-- All other cases, no reason to give
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
procedure Why_Not_Static (Expr : Node_Id);
-- This procedure may be called after generating an error message that
- -- complains that something is non-static. If it finds good reasons,
- -- it generates one or more continuation error messages pointing the
- -- appropriate offending component of the expression. If no good reasons
- -- can be figured out, then no messages are generated. The expectation here
- -- is that the caller has already issued a message complaining that the
- -- expression is non-static. Note that this message should be placed using
- -- Error_Msg_F or Error_Msg_FE, so that it will sort before any messages
- -- placed by this call. Note that it is fine to call Why_Not_Static with
- -- something that is not an expression, and usually this has no effect, but
- -- in some cases (N_Parameter_Association or N_Range), it makes sense for
- -- the internal recursive calls.
+ -- complains that something is non-static. If it finds good reasons, it
+ -- generates one or more error messages pointing the appropriate offending
+ -- component of the expression. If no good reasons can be figured out, then
+ -- no messages are generated. The expectation here is that the caller has
+ -- already issued a message complaining that the expression is non-static.
+ -- Note that this message should be placed using Error_Msg_F or
+ -- Error_Msg_FE, so that it will sort before any messages placed by this
+ -- call. Note that it is fine to call Why_Not_Static with something that
+ -- is not an expression, and usually this has no effect, but in some cases
+ -- (N_Parameter_Association or N_Range), it makes sense for the internal
+ -- recursive calls.
+ --
+ -- Note that these messages are not continuation messages, instead they are
+ -- separate unconditional messages, marked with '!'. The reason for this is
+ -- that they can be posted at a different location from the maim message as
+ -- documented above ("appropriate offending component"), and continuation
+ -- messages must always point to the same location as the parent message.
procedure Initialize;
-- Initializes the internal data structures. Must be called before each
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2014, 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- --
-- For an entry formal entity from an entry declaration, find the
-- corresponding body formal from the given accept statement.
+ function May_Need_Initialized_Actual (Ent : Entity_Id) return Boolean;
+ -- If an entity of a generic type has default initialization, then the
+ -- corresponding actual type should be fully initialized, or else there
+ -- will be uninitialized components in the instantiation, that might go
+ -- unreported. This predicate allows the compiler to emit an appropriate
+ -- warning in the generic itself. In a sense, the use of a type that
+ -- requires full initialization is a weak part of the generic contract.
+
function Missing_Subunits return Boolean;
-- We suppress warnings when there are missing subunits, because this
-- may generate too many false positives: entities in a parent may only
raise Program_Error;
end Body_Formal;
+ -----------------------------------
+ -- May_Need_Initialized_Actual --
+ -----------------------------------
+
+ function May_Need_Initialized_Actual (Ent : Entity_Id) return Boolean is
+ T : constant Entity_Id := Etype (Ent);
+ Par : constant Node_Id := Parent (T);
+ Res : Boolean;
+
+ begin
+ if not Is_Generic_Type (T) then
+ Res := False;
+
+ elsif (Nkind (Par)) = N_Private_Extension_Declaration then
+ Set_Needs_Initialized_Actual (Par);
+ Res := True;
+
+ elsif (Nkind (Par)) = N_Formal_Type_Declaration
+ and then Nkind (Formal_Type_Definition (Par))
+ = N_Formal_Private_Type_Definition
+ then
+ Set_Needs_Initialized_Actual (Formal_Type_Definition (Par));
+ Res := True;
+
+ else
+ Res := False;
+ end if;
+
+ if Res then
+ Error_Msg_N ("?!variable& of a generic type is "
+ & "potentially uninitialized", Ent);
+ Error_Msg_NE ("\?instantiations must provide fully initialized "
+ & "type for&", Ent, T);
+ end if;
+
+ return Res;
+ end May_Need_Initialized_Actual;
+
----------------------
-- Missing_Subunits --
----------------------
if not Has_Unmodified (E1)
and then not Warnings_Off_E1
and then not Is_Junk_Name (Chars (E1))
+ and then not May_Need_Initialized_Actual (E1)
then
Output_Reference_Error
("?v?variable& is read but never assigned!");
elsif not Has_Unreferenced (E1)
and then not Warnings_Off_E1
and then not Is_Junk_Name (Chars (E1))
+ and then not May_Need_Initialized_Actual (E1)
then
Output_Reference_Error -- CODEFIX
("?v?variable& is never read and never assigned!");
end if;
goto Continue;
+
end if;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
return List2 (N);
end Names;
+ function Needs_Initialized_Actual
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Private_Type_Definition
+ or else NT (N).Nkind = N_Private_Extension_Declaration);
+ return Flag18 (N);
+ end Needs_Initialized_Actual;
+
function Next_Entity
(N : Node_Id) return Node_Id is
begin
Set_List2_With_Parent (N, Val);
end Set_Names;
+ procedure Set_Needs_Initialized_Actual
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Private_Type_Definition
+ or else NT (N).Nkind = N_Private_Extension_Declaration);
+ Set_Flag18 (N, Val);
+ end Set_Needs_Initialized_Actual;
+
procedure Set_Next_Entity
(N : Node_Id; Val : Node_Id) is
begin
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
-- present in an N_Subtype_Indication node, since we also use these in
-- calls to Freeze_Expression.
+ -- Needs_Initialized_Actual (Flag18-Sem)
+ -- Present in formal_private_type_definitions and on private extension
+ -- declarations. Set when the use of a formal type in a generic suggests
+ -- that the actual should be a fully initialized type, to avoid potential
+ -- use of uninitialized values.
+
-- Next_Entity (Node2-Sem)
-- Present in defining identifiers, defining character literals and
-- defining operator symbols (i.e. in all entities). The entities of a
-- Synchronized_Present (Flag7)
-- Subtype_Indication (Node5)
-- Interface_List (List2) (set to No_List if none)
+ -- Needs_Initialized_Actual (Flag18-Sem)
---------------------
-- 8.4 Use Clause --
-- Abstract_Present (Flag4)
-- Tagged_Present (Flag15)
-- Limited_Present (Flag17)
+ -- Needs_Initialized_Actual (Flag18-Sem)
--------------------------------------------
-- 12.5.1 Formal Derived Type Definition --
function Generalized_Indexing
(N : Node_Id) return Node_Id; -- Node4
-
function Generic_Associations
(N : Node_Id) return List_Id; -- List3
function Names
(N : Node_Id) return List_Id; -- List2
+ function Needs_Initialized_Actual
+ (N : Node_Id) return Boolean; -- Flag18
+
function Next_Entity
(N : Node_Id) return Node_Id; -- Node2
procedure Set_Names
(N : Node_Id; Val : List_Id); -- List2
+ procedure Set_Needs_Initialized_Actual
+ (N : Node_Id; Val : Boolean := True); -- Flag18
+
procedure Set_Next_Entity
(N : Node_Id; Val : Node_Id); -- Node2
(1 => True, -- Expressions (List1)
2 => False, -- unused
3 => True, -- Prefix (Node3)
- 4 => False, -- Generalized_Indexing (Node4-Sem)
+ 4 => False, -- Generalized_Indexing (Node4-Sem)
5 => False), -- Etype (Node5-Sem)
N_Slice =>
pragma Inline (Must_Override);
pragma Inline (Name);
pragma Inline (Names);
+ pragma Inline (Needs_Initialized_Actual);
pragma Inline (Next_Entity);
pragma Inline (Next_Exit_Statement);
pragma Inline (Next_Implicit_With);
pragma Inline (Set_Must_Override);
pragma Inline (Set_Name);
pragma Inline (Set_Names);
+ pragma Inline (Set_Needs_Initialized_Actual);
pragma Inline (Set_Next_Entity);
pragma Inline (Set_Next_Exit_Statement);
pragma Inline (Set_Next_Implicit_With);
projects / platform / upstream / linaro-gcc.git / commitdiff