-- assignments, and wrappers may need checks. Other freezing actions
-- should be compiled with all checks off.
- if Present (Actions (N)) then
- Decl := First (Actions (N));
- while Present (Decl) loop
- if Nkind (Decl) = N_Subprogram_Body
- and then (Is_Init_Proc (Defining_Entity (Decl))
- or else
- Chars (Defining_Entity (Decl)) = Name_uAssign
- or else
- (Present (Corresponding_Spec (Decl))
- and then Is_Wrapper
- (Corresponding_Spec (Decl))))
- then
- Analyze (Decl);
+ Decl := First (Actions (N));
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Subprogram_Body
+ and then (Is_Init_Proc (Defining_Entity (Decl))
+ or else
+ Chars (Defining_Entity (Decl)) = Name_uAssign
+ or else
+ (Present (Corresponding_Spec (Decl))
+ and then Is_Wrapper
+ (Corresponding_Spec (Decl))))
+ then
+ Analyze (Decl);
- -- A subprogram body created for a renaming_as_body completes
- -- a previous declaration, which may be in a different scope.
- -- Establish the proper scope before analysis.
+ -- A subprogram body created for a renaming_as_body completes
+ -- a previous declaration, which may be in a different scope.
+ -- Establish the proper scope before analysis.
- elsif Nkind (Decl) = N_Subprogram_Body
- and then Present (Corresponding_Spec (Decl))
- and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
- then
- Push_Scope (Scope (Corresponding_Spec (Decl)));
- Analyze (Decl, Suppress => All_Checks);
- Pop_Scope;
-
- -- We treat generated equality specially, if validity checks are
- -- enabled, in order to detect components default-initialized
- -- with invalid values.
-
- elsif Nkind (Decl) = N_Subprogram_Body
- and then Chars (Defining_Entity (Decl)) = Name_Op_Eq
- and then Validity_Checks_On
- and then Initialize_Scalars
- then
- declare
- Save_Force : constant Boolean := Force_Validity_Checks;
- begin
- Force_Validity_Checks := True;
- Analyze (Decl);
- Force_Validity_Checks := Save_Force;
- end;
+ elsif Nkind (Decl) = N_Subprogram_Body
+ and then Present (Corresponding_Spec (Decl))
+ and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
+ then
+ Push_Scope (Scope (Corresponding_Spec (Decl)));
+ Analyze (Decl, Suppress => All_Checks);
+ Pop_Scope;
+
+ -- We treat generated equality specially, if validity checks are
+ -- enabled, in order to detect components default-initialized with
+ -- invalid values.
+
+ elsif Nkind (Decl) = N_Subprogram_Body
+ and then Chars (Defining_Entity (Decl)) = Name_Op_Eq
+ and then Validity_Checks_On
+ and then Initialize_Scalars
+ then
+ declare
+ Save_Force : constant Boolean := Force_Validity_Checks;
+ begin
+ Force_Validity_Checks := True;
+ Analyze (Decl);
+ Force_Validity_Checks := Save_Force;
+ end;
- -- All other freezing actions
+ -- All other freezing actions
- else
- Analyze (Decl, Suppress => All_Checks);
- end if;
+ else
+ Analyze (Decl, Suppress => All_Checks);
+ end if;
- Next (Decl);
- end loop;
- end if;
+ Next (Decl);
+ end loop;
-- If we are to delete this N_Freeze_Entity, do so by rewriting so that
-- a loop on all nodes being inserted will work propertly.
-- Loop through elsif parts, dealing with constant conditions and
-- possible condition actions that are present.
- if Present (Elsif_Parts (N)) then
- E := First (Elsif_Parts (N));
- while Present (E) loop
+ E := First (Elsif_Parts (N));
+ while Present (E) loop
- -- Do not consider controlled objects found in an if statement
- -- which actually models an if expression because their early
- -- finalization will affect the result of the expression.
+ -- Do not consider controlled objects found in an if statement which
+ -- actually models an if expression because their early finalization
+ -- will affect the result of the expression.
- if not From_Conditional_Expression (N) then
- Process_Statements_For_Controlled_Objects (E);
- end if;
+ if not From_Conditional_Expression (N) then
+ Process_Statements_For_Controlled_Objects (E);
+ end if;
- Adjust_Condition (Condition (E));
+ Adjust_Condition (Condition (E));
- -- If there are condition actions, then rewrite the if statement
- -- as indicated above. We also do the same rewrite for a True or
- -- False condition. The further processing of this constant
- -- condition is then done by the recursive call to expand the
- -- newly created if statement
+ -- If there are condition actions, then rewrite the if statement as
+ -- indicated above. We also do the same rewrite for a True or False
+ -- condition. The further processing of this constant condition is
+ -- then done by the recursive call to expand the newly created if
+ -- statement
- if Present (Condition_Actions (E))
- or else Compile_Time_Known_Value (Condition (E))
- then
- New_If :=
- Make_If_Statement (Sloc (E),
- Condition => Condition (E),
- Then_Statements => Then_Statements (E),
- Elsif_Parts => No_List,
- Else_Statements => Else_Statements (N));
-
- -- Elsif parts for new if come from remaining elsif's of parent
-
- while Present (Next (E)) loop
- if No (Elsif_Parts (New_If)) then
- Set_Elsif_Parts (New_If, New_List);
- end if;
+ if Present (Condition_Actions (E))
+ or else Compile_Time_Known_Value (Condition (E))
+ then
+ New_If :=
+ Make_If_Statement (Sloc (E),
+ Condition => Condition (E),
+ Then_Statements => Then_Statements (E),
+ Elsif_Parts => No_List,
+ Else_Statements => Else_Statements (N));
+
+ -- Elsif parts for new if come from remaining elsif's of parent
+
+ while Present (Next (E)) loop
+ if No (Elsif_Parts (New_If)) then
+ Set_Elsif_Parts (New_If, New_List);
+ end if;
- Append (Remove_Next (E), Elsif_Parts (New_If));
- end loop;
+ Append (Remove_Next (E), Elsif_Parts (New_If));
+ end loop;
- Set_Else_Statements (N, New_List (New_If));
+ Set_Else_Statements (N, New_List (New_If));
- Insert_List_Before (New_If, Condition_Actions (E));
+ Insert_List_Before (New_If, Condition_Actions (E));
- Remove (E);
+ Remove (E);
- if Is_Empty_List (Elsif_Parts (N)) then
- Set_Elsif_Parts (N, No_List);
- end if;
+ if Is_Empty_List (Elsif_Parts (N)) then
+ Set_Elsif_Parts (N, No_List);
+ end if;
- Analyze (New_If);
+ Analyze (New_If);
- -- Note this is not an implicit if statement, since it is part
- -- of an explicit if statement in the source (or of an implicit
- -- if statement that has already been tested). We set the flag
- -- after calling Analyze to avoid generating extra warnings
- -- specific to pure if statements, however (see
- -- Sem_Ch5.Analyze_If_Statement).
+ -- Note this is not an implicit if statement, since it is part of
+ -- an explicit if statement in the source (or of an implicit if
+ -- statement that has already been tested). We set the flag after
+ -- calling Analyze to avoid generating extra warnings specific to
+ -- pure if statements, however (see Sem_Ch5.Analyze_If_Statement).
- Preserve_Comes_From_Source (New_If, N);
- return;
+ Preserve_Comes_From_Source (New_If, N);
+ return;
- -- No special processing for that elsif part, move to next
+ -- No special processing for that elsif part, move to next
- else
- Next (E);
- end if;
- end loop;
- end if;
+ else
+ Next (E);
+ end if;
+ end loop;
-- Some more optimizations applicable if we still have an IF statement
-- Add private field components
- if Present (Private_Declarations (Pdef)) then
- Priv := First (Private_Declarations (Pdef));
- while Present (Priv) loop
- if Nkind (Priv) = N_Component_Declaration then
- if not Static_Component_Size (Defining_Identifier (Priv)) then
-
- -- When compiling for a restricted profile, the private
- -- components must have a static size. If not, this is an
- -- error for a single protected declaration, and rates a
- -- warning on a protected type declaration.
-
- if not Comes_From_Source (Prot_Typ) then
-
- -- It's ok to be checking this restriction at expansion
- -- time, because this is only for the restricted profile,
- -- which is not subject to strict RM conformance, so it
- -- is OK to miss this check in -gnatc mode.
-
- Check_Restriction (No_Implicit_Heap_Allocations, Priv);
- Check_Restriction
- (No_Implicit_Protected_Object_Allocations, Priv);
-
- elsif Restriction_Active (No_Implicit_Heap_Allocations) then
- if not Discriminated_Size (Defining_Identifier (Priv))
- then
- -- Any object of the type will be non-static
+ Priv := First (Private_Declarations (Pdef));
+ while Present (Priv) loop
+ if Nkind (Priv) = N_Component_Declaration then
+ if not Static_Component_Size (Defining_Identifier (Priv)) then
- Error_Msg_N ("component has non-static size??", Priv);
- Error_Msg_NE
- ("\creation of protected object of type& will "
- & "violate restriction "
- & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ);
- else
- -- Object will be non-static if discriminants are
+ -- When compiling for a restricted profile, the private
+ -- components must have a static size. If not, this is an error
+ -- for a single protected declaration, and rates a warning on a
+ -- protected type declaration.
- Error_Msg_NE
- ("creation of protected object of type& with "
- & "non-static discriminants will violate "
- & "restriction No_Implicit_Heap_Allocations??",
- Priv, Prot_Typ);
- end if;
+ if not Comes_From_Source (Prot_Typ) then
+
+ -- It's ok to be checking this restriction at expansion
+ -- time, because this is only for the restricted profile,
+ -- which is not subject to strict RM conformance, so it
+ -- is OK to miss this check in -gnatc mode.
- -- Likewise for No_Implicit_Protected_Object_Allocations
+ Check_Restriction (No_Implicit_Heap_Allocations, Priv);
+ Check_Restriction
+ (No_Implicit_Protected_Object_Allocations, Priv);
- elsif Restriction_Active
- (No_Implicit_Protected_Object_Allocations)
+ elsif Restriction_Active (No_Implicit_Heap_Allocations) then
+ if not Discriminated_Size (Defining_Identifier (Priv))
then
- if not Discriminated_Size (Defining_Identifier (Priv))
- then
- -- Any object of the type will be non-static
-
- Error_Msg_N ("component has non-static size??", Priv);
- Error_Msg_NE
- ("\creation of protected object of type& will "
- & "violate restriction "
- & "No_Implicit_Protected_Object_Allocations??",
- Priv, Prot_Typ);
- else
- -- Object will be non-static if discriminants are
-
- Error_Msg_NE
- ("creation of protected object of type& with "
- & "non-static discriminants will violate "
- & "restriction "
- & "No_Implicit_Protected_Object_Allocations??",
- Priv, Prot_Typ);
- end if;
+ -- Any object of the type will be non-static
+
+ Error_Msg_N ("component has non-static size??", Priv);
+ Error_Msg_NE
+ ("\creation of protected object of type& will "
+ & "violate restriction "
+ & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ);
+ else
+ -- Object will be non-static if discriminants are
+
+ Error_Msg_NE
+ ("creation of protected object of type& with "
+ & "non-static discriminants will violate "
+ & "restriction No_Implicit_Heap_Allocations??",
+ Priv, Prot_Typ);
+ end if;
+
+ -- Likewise for No_Implicit_Protected_Object_Allocations
+
+ elsif Restriction_Active
+ (No_Implicit_Protected_Object_Allocations)
+ then
+ if not Discriminated_Size (Defining_Identifier (Priv)) then
+ -- Any object of the type will be non-static
+
+ Error_Msg_N ("component has non-static size??", Priv);
+ Error_Msg_NE
+ ("\creation of protected object of type& will violate "
+ & "restriction "
+ & "No_Implicit_Protected_Object_Allocations??",
+ Priv, Prot_Typ);
+ else
+ -- Object will be non-static if discriminants are
+
+ Error_Msg_NE
+ ("creation of protected object of type& with "
+ & "non-static discriminants will violate restriction "
+ & "No_Implicit_Protected_Object_Allocations??",
+ Priv, Prot_Typ);
end if;
end if;
+ end if;
- -- The component definition consists of a subtype indication,
- -- or (in Ada 2005) an access definition. Make a copy of the
- -- proper definition.
+ -- The component definition consists of a subtype indication, or
+ -- (in Ada 2005) an access definition. Make a copy of the proper
+ -- definition.
- declare
- Old_Comp : constant Node_Id := Component_Definition (Priv);
- Oent : constant Entity_Id := Defining_Identifier (Priv);
- Nent : constant Entity_Id :=
- Make_Defining_Identifier (Sloc (Oent),
- Chars => Chars (Oent));
- New_Comp : Node_Id;
+ declare
+ Old_Comp : constant Node_Id := Component_Definition (Priv);
+ Oent : constant Entity_Id := Defining_Identifier (Priv);
+ Nent : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (Oent),
+ Chars => Chars (Oent));
+ New_Comp : Node_Id;
- begin
- if Present (Subtype_Indication (Old_Comp)) then
- New_Comp :=
- Make_Component_Definition (Sloc (Oent),
- Aliased_Present => False,
- Subtype_Indication =>
- New_Copy_Tree
- (Subtype_Indication (Old_Comp), Discr_Map));
- else
- New_Comp :=
- Make_Component_Definition (Sloc (Oent),
- Aliased_Present => False,
- Access_Definition =>
- New_Copy_Tree
- (Access_Definition (Old_Comp), Discr_Map));
-
- -- A self-reference in the private part becomes a
- -- self-reference to the corresponding record.
-
- if Entity (Subtype_Mark (Access_Definition (New_Comp)))
- = Prot_Typ
- then
- Replace_Access_Definition (New_Comp);
- end if;
+ begin
+ if Present (Subtype_Indication (Old_Comp)) then
+ New_Comp :=
+ Make_Component_Definition (Sloc (Oent),
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Copy_Tree
+ (Subtype_Indication (Old_Comp), Discr_Map));
+ else
+ New_Comp :=
+ Make_Component_Definition (Sloc (Oent),
+ Aliased_Present => False,
+ Access_Definition =>
+ New_Copy_Tree
+ (Access_Definition (Old_Comp), Discr_Map));
+
+ -- A self-reference in the private part becomes a
+ -- self-reference to the corresponding record.
+
+ if Entity (Subtype_Mark (Access_Definition (New_Comp)))
+ = Prot_Typ
+ then
+ Replace_Access_Definition (New_Comp);
end if;
+ end if;
- New_Priv :=
- Make_Component_Declaration (Loc,
- Defining_Identifier => Nent,
- Component_Definition => New_Comp,
- Expression => Expression (Priv));
+ New_Priv :=
+ Make_Component_Declaration (Loc,
+ Defining_Identifier => Nent,
+ Component_Definition => New_Comp,
+ Expression => Expression (Priv));
- Set_Has_Per_Object_Constraint (Nent,
- Has_Per_Object_Constraint (Oent));
+ Set_Has_Per_Object_Constraint (Nent,
+ Has_Per_Object_Constraint (Oent));
- Append_To (Cdecls, New_Priv);
- end;
+ Append_To (Cdecls, New_Priv);
+ end;
- elsif Nkind (Priv) = N_Subprogram_Declaration then
+ elsif Nkind (Priv) = N_Subprogram_Declaration then
- -- Make the unprotected version of the subprogram available
- -- for expansion of intra object calls. There is need for
- -- a protected version only if the subprogram is an interrupt
- -- handler, otherwise this operation can only be called from
- -- within the body.
+ -- Make the unprotected version of the subprogram available for
+ -- expansion of intra object calls. There is need for a protected
+ -- version only if the subprogram is an interrupt handler,
+ -- otherwise this operation can only be called from within the
+ -- body.
- Sub :=
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Build_Protected_Sub_Specification
- (Priv, Prot_Typ, Unprotected_Mode));
+ Sub :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Build_Protected_Sub_Specification
+ (Priv, Prot_Typ, Unprotected_Mode));
- Insert_After (Current_Node, Sub);
- Analyze (Sub);
+ Insert_After (Current_Node, Sub);
+ Analyze (Sub);
- Set_Protected_Body_Subprogram
- (Defining_Unit_Name (Specification (Priv)),
- Defining_Unit_Name (Specification (Sub)));
- Check_Inlining (Defining_Unit_Name (Specification (Priv)));
- Current_Node := Sub;
+ Set_Protected_Body_Subprogram
+ (Defining_Unit_Name (Specification (Priv)),
+ Defining_Unit_Name (Specification (Sub)));
+ Check_Inlining (Defining_Unit_Name (Specification (Priv)));
+ Current_Node := Sub;
- Sub :=
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Build_Protected_Sub_Specification
- (Priv, Prot_Typ, Protected_Mode));
+ Sub :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Build_Protected_Sub_Specification
+ (Priv, Prot_Typ, Protected_Mode));
- Insert_After (Current_Node, Sub);
- Analyze (Sub);
- Current_Node := Sub;
+ Insert_After (Current_Node, Sub);
+ Analyze (Sub);
+ Current_Node := Sub;
- if Is_Interrupt_Handler
- (Defining_Unit_Name (Specification (Priv)))
- then
- if not Restricted_Profile then
- Register_Handler;
- end if;
+ if Is_Interrupt_Handler
+ (Defining_Unit_Name (Specification (Priv)))
+ then
+ if not Restricted_Profile then
+ Register_Handler;
end if;
end if;
+ end if;
- Next (Priv);
- end loop;
- end if;
+ Next (Priv);
+ end loop;
-- Except for the lock-free implementation, append the _Object field
-- with the right type to the component list. We need to compute the
-- If there are some private entry declarations, expand it as if they
-- were visible entries.
- if Present (Private_Declarations (Pdef)) then
- Comp := First (Private_Declarations (Pdef));
- while Present (Comp) loop
- if Nkind (Comp) = N_Entry_Declaration then
- Expand_Entry_Declaration (Comp);
- end if;
+ Comp := First (Private_Declarations (Pdef));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Entry_Declaration then
+ Expand_Entry_Declaration (Comp);
+ end if;
- Next (Comp);
- end loop;
- end if;
+ Next (Comp);
+ end loop;
-- Create the declaration of an array object which contains the values
-- of aspect/pragma Max_Queue_Length for all entries of the protected
function Make_Field_Attributes (Clist : List_Id) return List_Id is
Item : Node_Id;
- Result : List_Id;
+ Result : constant List_Id := New_List;
begin
- Result := New_List;
-
- if Present (Clist) then
- Item := First (Clist);
-
- -- Loop through components, skipping all internal components,
- -- which are not part of the value (e.g. _Tag), except that we
- -- don't skip the _Parent, since we do want to process that
- -- recursively. If _Parent is an interface type, being abstract
- -- with no components there is no need to handle it.
-
- while Present (Item) loop
- if Nkind (Item) = N_Component_Declaration
- and then
- ((Chars (Defining_Identifier (Item)) = Name_uParent
- and then not Is_Interface
- (Etype (Defining_Identifier (Item))))
- or else
- not Is_Internal_Name (Chars (Defining_Identifier (Item))))
- then
- Append_To
- (Result,
- Make_Field_Attribute (Defining_Identifier (Item)));
- end if;
-
- Next (Item);
- end loop;
- end if;
+ -- Loop through components, skipping all internal components, which
+ -- are not part of the value (e.g. _Tag), except that we don't skip
+ -- the _Parent, since we do want to process that recursively. If
+ -- _Parent is an interface type, being abstract with no components
+ -- there is no need to handle it.
+
+ Item := First (Clist);
+ while Present (Item) loop
+ if Nkind (Item) = N_Component_Declaration
+ and then
+ ((Chars (Defining_Identifier (Item)) = Name_uParent
+ and then not Is_Interface
+ (Etype (Defining_Identifier (Item))))
+ or else
+ not Is_Internal_Name (Chars (Defining_Identifier (Item))))
+ then
+ Append_To
+ (Result,
+ Make_Field_Attribute (Defining_Identifier (Item)));
+ end if;
+
+ Next (Item);
+ end loop;
return Result;
end Make_Field_Attributes;
-- Treat compilation unit pragmas that appear after the library unit
- if Present (Pragmas_After (Aux_Decls_Node (N))) then
- declare
- Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
- begin
- while Present (Prag_Node) loop
- Analyze (Prag_Node);
- Next (Prag_Node);
- end loop;
- end;
- end if;
+ declare
+ Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
+ begin
+ while Present (Prag_Node) loop
+ Analyze (Prag_Node);
+ Next (Prag_Node);
+ end loop;
+ end;
-- Analyze the contract of a [generic] subprogram that acts as a
-- compilation unit after all compilation pragmas have been analyzed.
-- Start of processing for Has_With_Clause
begin
- if Present (Context_Items (C_Unit)) then
- Item := First (Context_Items (C_Unit));
- while Present (Item) loop
- if Nkind (Item) = N_With_Clause
- and then Limited_Present (Item) = Is_Limited
- and then Named_Unit (Item) = Pack
- then
- return True;
- end if;
+ Item := First (Context_Items (C_Unit));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item) = Is_Limited
+ and then Named_Unit (Item) = Pack
+ then
+ return True;
+ end if;
- Next (Item);
- end loop;
- end if;
+ Next (Item);
+ end loop;
return False;
end Has_With_Clause;
Nod1 : Node_Id;
begin
- if Present (Lst) then
- Nod1 := First (Lst);
- while Present (Nod1) loop
- Check_Expr_Constants (Nod1);
- Next (Nod1);
- end loop;
- end if;
+ Nod1 := First (Lst);
+ while Present (Nod1) loop
+ Check_Expr_Constants (Nod1);
+ Next (Nod1);
+ end loop;
end Check_List_Constants;
-- Start of processing for Check_Constant_Address_Clause
-- Now to analyze the elsif parts if any are present
- if Present (Elsif_Parts (N)) then
- E := First (Elsif_Parts (N));
- while Present (E) loop
- Analyze_Cond_Then (E);
- Next (E);
- end loop;
- end if;
+ E := First (Elsif_Parts (N));
+ while Present (E) loop
+ Analyze_Cond_Then (E);
+ Next (E);
+ end loop;
if Present (Else_Statements (N)) then
Analyze_Statements (Else_Statements (N));
if Is_True (Expr_Value (Condition (N))) then
Remove_Warning_Messages (Else_Statements (N));
- if Present (Elsif_Parts (N)) then
- E := First (Elsif_Parts (N));
- while Present (E) loop
- Remove_Warning_Messages (Then_Statements (E));
- Next (E);
- end loop;
- end if;
+ E := First (Elsif_Parts (N));
+ while Present (E) loop
+ Remove_Warning_Messages (Then_Statements (E));
+ Next (E);
+ end loop;
else
Remove_Warning_Messages (Then_Statements (N));
-- Otherwise analyze the parameters
- if Present (Actuals) then
- Actual := First (Actuals);
- while Present (Actual) loop
- Analyze (Actual);
- Check_Parameterless_Call (Actual);
- Next (Actual);
- end loop;
- end if;
+ Actual := First (Actuals);
+ while Present (Actual) loop
+ Analyze (Actual);
+ Check_Parameterless_Call (Actual);
+ Next (Actual);
+ end loop;
Analyze_Call (N);
end Analyze_Function_Call;
-- Otherwise analyze the parameters
- if Present (Actuals) then
- Actual := First (Actuals);
+ Actual := First (Actuals);
- while Present (Actual) loop
- Analyze (Actual);
- Check_Parameterless_Call (Actual);
- Next (Actual);
- end loop;
- end if;
+ while Present (Actual) loop
+ Analyze (Actual);
+ Check_Parameterless_Call (Actual);
+ Next (Actual);
+ end loop;
-- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls
begin
-- Check for aspects that may generate a contract
- if Present (Aspect_Specifications (N)) then
- Item := First (Aspect_Specifications (N));
- while Present (Item) loop
- if Is_Subprogram_Contract_Annotation (Item) then
- return True;
- end if;
+ Item := First (Aspect_Specifications (N));
+ while Present (Item) loop
+ if Is_Subprogram_Contract_Annotation (Item) then
+ return True;
+ end if;
- Next (Item);
- end loop;
- end if;
+ Next (Item);
+ end loop;
-- Check for pragmas that may generate a contract
- if Present (Decls) then
- Item := First (Decls);
- while Present (Item) loop
- if Nkind (Item) = N_Pragma
- and then Is_Subprogram_Contract_Annotation (Item)
- then
- return True;
- end if;
+ Item := First (Decls);
+ while Present (Item) loop
+ if Nkind (Item) = N_Pragma
+ and then Is_Subprogram_Contract_Annotation (Item)
+ then
+ return True;
+ end if;
- Next (Item);
- end loop;
- end if;
+ Next (Item);
+ end loop;
return False;
end Body_Has_Contract;
begin
-- Check for SPARK_Mode aspect
- if Present (Aspect_Specifications (N)) then
- Item := First (Aspect_Specifications (N));
- while Present (Item) loop
- if Get_Aspect_Id (Item) = Aspect_SPARK_Mode then
- return Get_SPARK_Mode_From_Annotation (Item) = On;
- end if;
+ Item := First (Aspect_Specifications (N));
+ while Present (Item) loop
+ if Get_Aspect_Id (Item) = Aspect_SPARK_Mode then
+ return Get_SPARK_Mode_From_Annotation (Item) = On;
+ end if;
- Next (Item);
- end loop;
- end if;
+ Next (Item);
+ end loop;
-- Check for SPARK_Mode pragma
- if Present (Decls) then
- Item := First (Decls);
- while Present (Item) loop
+ Item := First (Decls);
+ while Present (Item) loop
- -- Pragmas that apply to a subprogram body are usually grouped
- -- together. Look for a potential pragma SPARK_Mode among them.
+ -- Pragmas that apply to a subprogram body are usually grouped
+ -- together. Look for a potential pragma SPARK_Mode among them.
- if Nkind (Item) = N_Pragma then
- if Get_Pragma_Id (Item) = Pragma_SPARK_Mode then
- return Get_SPARK_Mode_From_Annotation (Item) = On;
- end if;
+ if Nkind (Item) = N_Pragma then
+ if Get_Pragma_Id (Item) = Pragma_SPARK_Mode then
+ return Get_SPARK_Mode_From_Annotation (Item) = On;
+ end if;
- -- Otherwise the first non-pragma declarative item terminates
- -- the region where pragma SPARK_Mode may appear.
+ -- Otherwise the first non-pragma declarative item terminates the
+ -- region where pragma SPARK_Mode may appear.
- else
- exit;
- end if;
+ else
+ exit;
+ end if;
- Next (Item);
- end loop;
- end if;
+ Next (Item);
+ end loop;
-- Otherwise, the applicable SPARK_Mode is inherited from the
-- enclosing subprogram or package.
Check_Statement_Sequence (Then_Statements (Last_Stm));
Check_Statement_Sequence (Else_Statements (Last_Stm));
- if Present (Elsif_Parts (Last_Stm)) then
- declare
- Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
+ declare
+ Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
- begin
- while Present (Elsif_Part) loop
- Check_Statement_Sequence (Then_Statements (Elsif_Part));
- Next (Elsif_Part);
- end loop;
- end;
- end if;
+ begin
+ while Present (Elsif_Part) loop
+ Check_Statement_Sequence (Then_Statements (Elsif_Part));
+ Next (Elsif_Part);
+ end loop;
+ end;
return;
Decl : Node_Id;
begin
- if Present (L) then
- Decl := First (L);
- while Present (Decl) loop
- if Nkind (Decl) = N_Use_Package_Clause then
- Chain_Use_Clause (Decl);
- Use_One_Package (Decl, Name (Decl));
+ Decl := First (L);
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Use_Package_Clause then
+ Chain_Use_Clause (Decl);
+ Use_One_Package (Decl, Name (Decl));
- elsif Nkind (Decl) = N_Use_Type_Clause then
- Chain_Use_Clause (Decl);
- Use_One_Type (Subtype_Mark (Decl));
+ elsif Nkind (Decl) = N_Use_Type_Clause then
+ Chain_Use_Clause (Decl);
+ Use_One_Type (Subtype_Mark (Decl));
- end if;
+ end if;
- Next (Decl);
- end loop;
- end if;
+ Next (Decl);
+ end loop;
end Set_Use;
-----------------------------
procedure Collect_Tasks (Decls : List_Id) is
begin
- if Present (Decls) then
- Decl := First (Decls);
- while Present (Decl) loop
- if Nkind (Decl) = N_Object_Declaration
- and then Has_Task (Etype (Defining_Identifier (Decl)))
- then
- Add_Task_Proc (Etype (Defining_Identifier (Decl)));
- end if;
+ Decl := First (Decls);
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Object_Declaration
+ and then Has_Task (Etype (Defining_Identifier (Decl)))
+ then
+ Add_Task_Proc (Etype (Defining_Identifier (Decl)));
+ end if;
- Next (Decl);
- end loop;
- end if;
+ Next (Decl);
+ end loop;
end Collect_Tasks;
----------------
return;
end if;
- if Present (Expressions (N)) then
- Exp := First (Expressions (N));
- while Present (Exp) loop
- if Raises_Constraint_Error (Exp) then
- Why_Not_Static (Exp);
- return;
- end if;
+ Exp := First (Expressions (N));
+ while Present (Exp) loop
+ if Raises_Constraint_Error (Exp) then
+ Why_Not_Static (Exp);
+ return;
+ end if;
- Next (Exp);
- end loop;
- end if;
+ Next (Exp);
+ end loop;
-- Special case a subtype name
-- Collect all objects that appear in the visible declarations of the
-- related package.
- if Present (Visible_Declarations (Pack_Spec)) then
- Decl := First (Visible_Declarations (Pack_Spec));
- while Present (Decl) loop
- if Comes_From_Source (Decl)
- and then Nkind (Decl) in N_Object_Declaration
- | N_Object_Renaming_Declaration
- then
- Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
+ Decl := First (Visible_Declarations (Pack_Spec));
+ while Present (Decl) loop
+ if Comes_From_Source (Decl)
+ and then Nkind (Decl) in N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ then
+ Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
- elsif Nkind (Decl) = N_Package_Declaration then
- Collect_States_And_Objects (Decl);
+ elsif Nkind (Decl) = N_Package_Declaration then
+ Collect_States_And_Objects (Decl);
- elsif Is_Single_Concurrent_Type_Declaration (Decl) then
- Append_New_Elmt
- (Anonymous_Object (Defining_Entity (Decl)),
- States_And_Objs);
- end if;
+ elsif Is_Single_Concurrent_Type_Declaration (Decl) then
+ Append_New_Elmt
+ (Anonymous_Object (Defining_Entity (Decl)),
+ States_And_Objs);
+ end if;
- Next (Decl);
- end loop;
- end if;
+ Next (Decl);
+ end loop;
end Collect_States_And_Objects;
-- Local variables
-- Create new entities for the formal parameters
- if Present (Parameter_Specifications (Result)) then
- Formal_Spec := First (Parameter_Specifications (Result));
- while Present (Formal_Spec) loop
- Def_Id := Defining_Identifier (Formal_Spec);
- Set_Defining_Identifier (Formal_Spec,
- Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
-
- Next (Formal_Spec);
- end loop;
- end if;
+ Formal_Spec := First (Parameter_Specifications (Result));
+ while Present (Formal_Spec) loop
+ Def_Id := Defining_Identifier (Formal_Spec);
+ Set_Defining_Identifier (Formal_Spec,
+ Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
+
+ Next (Formal_Spec);
+ end loop;
return Result;
end Copy_Subprogram_Spec;
Nod : Node_Id;
begin
- if Present (List) then
- Nod := First (List);
- while Present (Nod) loop
- Visit (Nod);
- Next (Nod);
- end loop;
- end if;
+ Nod := First (List);
+ while Present (Nod) loop
+ Visit (Nod);
+ Next (Nod);
+ end loop;
end Visit_List;
------------------
projects / thirdparty / gcc.git / commitdiff
