if Has_Component_Size_Clause (Btype) then
Error_Msg_N
- ("component size clase for& previously given", Nam);
+ ("component size clause for& previously given", Nam);
elsif Csize /= No_Uint then
Check_Size (Expr, Component_Type (Btype), Csize, Biased);
-- that will be used to represent the biased subtype that
-- reflects the biased representation of components. We need
-- this subtype to get proper conversions on referencing
- -- elements of the array.
-
- if Biased then
- New_Ctyp :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
-
- Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => New_Ctyp,
- Subtype_Indication =>
- New_Occurrence_Of (Component_Type (Btype), Loc));
-
- Set_Parent (Decl, N);
- Analyze (Decl, Suppress => All_Checks);
-
- Set_Has_Delayed_Freeze (New_Ctyp, False);
- Set_Esize (New_Ctyp, Csize);
- Set_RM_Size (New_Ctyp, Csize);
- Init_Alignment (New_Ctyp);
- Set_Has_Biased_Representation (New_Ctyp, True);
- Set_Is_Itype (New_Ctyp, True);
- Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
-
- Set_Component_Type (Btype, New_Ctyp);
+ -- elements of the array. Note that component size clauses
+ -- are ignored in VM mode.
+
+ if VM_Target = No_VM then
+ if Biased then
+ New_Ctyp :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
+
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => New_Ctyp,
+ Subtype_Indication =>
+ New_Occurrence_Of (Component_Type (Btype), Loc));
+
+ Set_Parent (Decl, N);
+ Analyze (Decl, Suppress => All_Checks);
+
+ Set_Has_Delayed_Freeze (New_Ctyp, False);
+ Set_Esize (New_Ctyp, Csize);
+ Set_RM_Size (New_Ctyp, Csize);
+ Init_Alignment (New_Ctyp);
+ Set_Has_Biased_Representation (New_Ctyp, True);
+ Set_Is_Itype (New_Ctyp, True);
+ Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
+
+ Set_Component_Type (Btype, New_Ctyp);
+ end if;
+
+ Set_Component_Size (Btype, Csize);
+
+ -- For VM case, we ignore component size clauses
+
+ else
+ -- Give a warning unless we are in GNAT mode, in which case
+ -- the warning is suppressed since it is not useful.
+
+ if not GNAT_Mode then
+ Error_Msg_N
+ ("?component size ignored in this configuration", N);
+ end if;
end if;
- Set_Component_Size (Btype, Csize);
Set_Has_Component_Size_Clause (Btype, True);
Set_Has_Non_Standard_Rep (Btype, True);
end if;
end;
end if;
- -- Clear any existing component clauses for the type (this happens with
- -- derived types, where we are now overriding the original).
+ -- For untagged types, clear any existing component clauses for the
+ -- type. If the type is derived, this is what allows us to override
+ -- a rep clause for the parent. For type extensions, the representation
+ -- of the inherited components is inherited, so we want to keep previous
+ -- component clauses for completeness.
- Comp := First_Component_Or_Discriminant (Rectype);
- while Present (Comp) loop
- Set_Component_Clause (Comp, Empty);
- Next_Component_Or_Discriminant (Comp);
- end loop;
+ if not Is_Tagged_Type (Rectype) then
+ Comp := First_Component_Or_Discriminant (Rectype);
+ while Present (Comp) loop
+ Set_Component_Clause (Comp, Empty);
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end if;
-- All done if no component clauses
("component clause is for non-existent field", CC);
elsif Present (Component_Clause (Comp)) then
- Error_Msg_Sloc := Sloc (Component_Clause (Comp));
- Error_Msg_N
- ("component clause previously given#", CC);
+
+ -- Diagose duplicate rep clause, or check consistency
+ -- if this is inherited component. In a double fault,
+ -- there may be a duplicate inconsistent clause for an
+ -- inherited component.
+
+ if
+ Scope (Original_Record_Component (Comp)) = Rectype
+ or else Parent (Component_Clause (Comp)) = N
+ then
+ Error_Msg_Sloc := Sloc (Component_Clause (Comp));
+ Error_Msg_N ("component clause previously given#", CC);
+
+ else
+ declare
+ Rep1 : constant Node_Id := Component_Clause (Comp);
+
+ begin
+ if Intval (Position (Rep1)) /=
+ Intval (Position (CC))
+ or else Intval (First_Bit (Rep1)) /=
+ Intval (First_Bit (CC))
+ or else Intval (Last_Bit (Rep1)) /=
+ Intval (Last_Bit (CC))
+ then
+ Error_Msg_N ("component clause inconsistent "
+ & "with representation of ancestor", CC);
+
+ elsif Warn_On_Redundant_Constructs then
+ Error_Msg_N ("?redundant component clause "
+ & "for inherited component!", CC);
+ end if;
+ end;
+ end if;
else
-- Make reference for field in record rep clause and set
while Present (Comp) loop
if Present (Component_Clause (Comp)) then
Num_Repped_Components := Num_Repped_Components + 1;
+
else
Num_Unrepped_Components := Num_Unrepped_Components + 1;
end if;
Comp := First_Component_Or_Discriminant (Rectype);
while Present (Comp) loop
if No (Component_Clause (Comp))
+ and then Comes_From_Source (Comp)
and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
or else Size_Known_At_Compile_Time
(Underlying_Type (Etype (Comp))))
return 0;
end if;
+ -- Note: In the following two tests for LoSet and HiSet, it may
+ -- seem redundant to test for N_Real_Literal here since normally
+ -- one would assume that the test for the value being known at
+ -- compile time includes this case. However, there is a glitch.
+ -- If the real literal comes from folding a non-static expression,
+ -- then we don't consider any non- static expression to be known
+ -- at compile time if we are in configurable run time mode (needed
+ -- in some cases to give a clearer definition of what is and what
+ -- is not accepted). So the test is indeed needed. Without it, we
+ -- would set neither Lo_Set nor Hi_Set and get an infinite loop.
+
if not LoSet then
if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal
or else Compile_Time_Known_Value (Type_Low_Bound (Ancest))
end if;
end if;
- -- No error, link item into head of chain of rep items for the entity
+ -- No error, link item into head of chain of rep items for the entity,
+ -- but avoid chaining if we have an overloadable entity, and the pragma
+ -- is one that can apply to multiple overloaded entities.
+
+ if Is_Overloadable (T)
+ and then Nkind (N) = N_Pragma
+ and then (Chars (N) = Name_Convention
+ or else
+ Chars (N) = Name_Import
+ or else
+ Chars (N) = Name_Export
+ or else
+ Chars (N) = Name_External
+ or else
+ Chars (N) = Name_Interface)
+ then
+ null;
+ else
+ Record_Rep_Item (T, N);
+ end if;
+
+ -- Rep item was OK, not too late
- Record_Rep_Item (T, N);
return False;
end Rep_Item_Too_Late;
("?conversion between pointers with different conventions!", N);
end if;
+ -- Warn if one of the operands is Ada.Calendar.Time. Do not emit a
+ -- warning when compiling GNAT-related sources.
+
+ if Warn_On_Unchecked_Conversion
+ and then not In_Predefined_Unit (N)
+ and then RTU_Loaded (Ada_Calendar)
+ and then
+ (Chars (Source) = Name_Time
+ or else
+ Chars (Target) = Name_Time)
+ then
+ -- If Ada.Calendar is loaded and the name of one of the operands is
+ -- Time, there is a good chance that this is Ada.Calendar.Time.
+
+ declare
+ Calendar_Time : constant Entity_Id :=
+ Full_View (RTE (RO_CA_Time));
+ begin
+ pragma Assert (Present (Calendar_Time));
+
+ if Source = Calendar_Time
+ or else Target = Calendar_Time
+ then
+ Error_Msg_N
+ ("?representation of 'Time values may change between " &
+ "'G'N'A'T versions", N);
+ end if;
+ end;
+ end if;
+
-- Make entry in unchecked conversion table for later processing
-- by Validate_Unchecked_Conversions, which will check sizes and
-- alignments (using values set by the back-end where possible).
-- Flag functions that can be called without parameters, i.e. those that
-- have no parameters, or those for which defaults exist for all parameters
- procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id);
- -- If there is a separate spec for a subprogram or generic subprogram, the
- -- formals of the body are treated as references to the corresponding
- -- formals of the spec. This reference does not count as an actual use of
- -- the formal, in order to diagnose formals that are unused in the body.
-
procedure Set_Formal_Validity (Formal_Id : Entity_Id);
-- Formal_Id is an formal parameter entity. This procedure deals with
-- setting the proper validity status for this entity, which depends
procedure Analyze_Return_Statement (N : Node_Id) is
- pragma Assert (Nkind (N) = N_Simple_Return_Statement
- or else
- Nkind (N) = N_Extended_Return_Statement);
+ pragma Assert (Nkind_In (N, N_Simple_Return_Statement,
+ N_Extended_Return_Statement));
Returns_Object : constant Boolean :=
Nkind (N) = N_Extended_Return_Statement
Par : constant Node_Id := Parent (N);
begin
- if (Nkind (Par) = N_Function_Call and then N = Name (Par))
+ if (Nkind (Par) = N_Function_Call
+ and then N = Name (Par))
or else Nkind (Par) = N_Function_Instantiation
- or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
+ or else (Nkind (Par) = N_Indexed_Component
+ and then N = Prefix (Par))
or else (Nkind (Par) = N_Pragma_Argument_Association
and then not Is_Pragma_String_Literal (Par))
or else Nkind (Par) = N_Subprogram_Renaming_Declaration
- or else (Nkind (Par) = N_Attribute_Reference
- and then Attribute_Name (Par) /= Name_Value)
+ or else (Nkind (Par) = N_Attribute_Reference
+ and then Attribute_Name (Par) /= Name_Value)
then
Find_Direct_Name (N);
Write_Eol;
end if;
- Trace_Scope (N, Body_Id, " Analyze subprogram");
+ Trace_Scope (N, Body_Id, " Analyze subprogram: ");
-- Generic subprograms are handled separately. They always have a
-- generic specification. Determine whether current scope has a
elsif Present (Spec_Id)
and then Expander_Active
and then
- (Is_Always_Inlined (Spec_Id)
+ (Has_Pragma_Inline_Always (Spec_Id)
or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
then
Build_Body_To_Inline (N, Spec_Id);
-- initialized!
declare
- Stm : Node_Id := First (Statements (HSS));
+ Stm : Node_Id;
begin
-- Skip initial labels (for one thing this occurs when we are in
-- front end ZCX mode, but in any case it is irrelevant), and also
-- initial Push_xxx_Error_Label nodes, which are also irrelevant.
+ Stm := First (Statements (HSS));
while Nkind (Stm) = N_Label
or else Nkind (Stm) in N_Push_xxx_Label
loop
Trace_Scope
(N,
Defining_Entity (N),
- " Analyze subprogram spec. ");
+ " Analyze subprogram spec: ");
if Debug_Flag_C then
Write_Str ("==== Compiling subprogram spec ");
Set_Etype (Designator, Standard_Void_Type);
end if;
- -- Introduce new scope for analysis of the formals and of the
- -- return type.
+ -- Introduce new scope for analysis of the formals and the return type
Set_Scope (Designator, Current_Scope);
then
Conv := Current_Entity (Id);
- elsif (Nkind (Id) = N_Selected_Component
- or else Nkind (Id) = N_Expanded_Name)
+ elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
then
Conv := Current_Entity (Selector_Name (Id));
-
else
return False;
end if;
begin
D := First (Decls);
-
while Present (D) loop
- if (Nkind (D) = N_Function_Instantiation
- and then not Is_Unchecked_Conversion (D))
- or else Nkind (D) = N_Protected_Type_Declaration
- or else Nkind (D) = N_Package_Declaration
- or else Nkind (D) = N_Package_Instantiation
- or else Nkind (D) = N_Subprogram_Body
- or else Nkind (D) = N_Procedure_Instantiation
- or else Nkind (D) = N_Task_Type_Declaration
+ if (Nkind (D) = N_Function_Instantiation
+ and then not Is_Unchecked_Conversion (D))
+ or else Nkind_In (D, N_Protected_Type_Declaration,
+ N_Package_Declaration,
+ N_Package_Instantiation,
+ N_Subprogram_Body,
+ N_Procedure_Instantiation,
+ N_Task_Type_Declaration)
then
Cannot_Inline
("cannot inline & (non-allowed declaration)?", D, Subp);
while Present (S) loop
Stat_Count := Stat_Count + 1;
- if Nkind (S) = N_Abort_Statement
- or else Nkind (S) = N_Asynchronous_Select
- or else Nkind (S) = N_Conditional_Entry_Call
- or else Nkind (S) = N_Delay_Relative_Statement
- or else Nkind (S) = N_Delay_Until_Statement
- or else Nkind (S) = N_Selective_Accept
- or else Nkind (S) = N_Timed_Entry_Call
+ if Nkind_In (S, N_Abort_Statement,
+ N_Asynchronous_Select,
+ N_Conditional_Entry_Call,
+ N_Delay_Relative_Statement,
+ N_Delay_Until_Statement,
+ N_Selective_Accept,
+ N_Timed_Entry_Call)
then
Cannot_Inline
("cannot inline & (non-allowed statement)?", S, Subp);
-- checks on inlining (forbidden declarations, handlers, etc).
if Stat_Count > Max_Size
- and then not Is_Always_Inlined (Subp)
+ and then not Has_Pragma_Inline_Always (Subp)
then
Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
return;
then
null;
- elsif Is_Always_Inlined (Subp) then
+ elsif Has_Pragma_Inline_Always (Subp) then
-- Remove last character (question mark) to make this into an error,
-- because the Inline_Always pragma cannot be obeyed.
Decl := Unit_Declaration_Node (Subp);
end if;
- if Nkind (Decl) = N_Subprogram_Body
- or else Nkind (Decl) = N_Subprogram_Body_Stub
- or else Nkind (Decl) = N_Subprogram_Declaration
- or else Nkind (Decl) = N_Abstract_Subprogram_Declaration
- or else Nkind (Decl) = N_Subprogram_Renaming_Declaration
+ if Nkind_In (Decl, N_Subprogram_Body,
+ N_Subprogram_Body_Stub,
+ N_Subprogram_Declaration,
+ N_Abstract_Subprogram_Declaration,
+ N_Subprogram_Renaming_Declaration)
then
Spec := Specification (Decl);
-- argument the signature that may match that of a standard operation.
elsif Nkind (Subp) = N_Defining_Operator_Symbol
- and then Must_Not_Override (Spec)
+ and then Must_Not_Override (Spec)
then
if Operator_Matches_Spec (Subp, Subp) then
Error_Msg_NE
-- Don't count exception junk
or else
- ((Nkind (Last_Stm) = N_Goto_Statement
- or else Nkind (Last_Stm) = N_Label
- or else Nkind (Last_Stm) = N_Object_Declaration)
+ (Nkind_In (Last_Stm, N_Goto_Statement,
+ N_Label,
+ N_Object_Declaration)
and then Exception_Junk (Last_Stm))
or else Nkind (Last_Stm) in N_Push_xxx_Label
or else Nkind (Last_Stm) in N_Pop_xxx_Label
elsif Kind = N_Case_Statement then
declare
Case_Alt : Node_Id;
-
begin
Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
while Present (Case_Alt) loop
-- Otherwise we have the case of a procedure marked No_Return
else
- Error_Msg_N
- ("?implied return after this statement will raise Program_Error",
- Last_Stm);
- Error_Msg_NE
- ("?procedure & is marked as No_Return",
- Last_Stm, Proc);
+ if not Raise_Exception_Call then
+ Error_Msg_N
+ ("?implied return after this statement " &
+ "will raise Program_Error",
+ Last_Stm);
+ Error_Msg_NE
+ ("\?procedure & is marked as No_Return!",
+ Last_Stm, Proc);
+ end if;
declare
RE : constant Node_Id :=
Are_Anonymous_Access_To_Subprogram_Types :=
Ekind (Type_1) = Ekind (Type_2)
and then
- (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
+ (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
or else
Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
then
return True;
- elsif (Nkind (N) = N_Private_Type_Declaration
- or else
- Nkind (N) = N_Private_Extension_Declaration)
+ elsif Nkind_In (N, N_Private_Type_Declaration,
+ N_Private_Extension_Declaration)
and then Present (Defining_Identifier (N))
and then T = Full_View (Defining_Identifier (N))
then
-- operation in a type derivation on for a generic actual.
if Nkind (Parent (Typ)) /= N_Full_Type_Declaration
- and then Nkind (Parent (Def_Id)) /= N_Subtype_Declaration
- and then Nkind (Parent (Def_Id)) /= N_Task_Type_Declaration
- and then Nkind (Parent (Def_Id)) /= N_Protected_Type_Declaration
+ and then
+ not Nkind_In (Parent (Def_Id), N_Subtype_Declaration,
+ N_Task_Type_Declaration,
+ N_Protected_Type_Declaration)
then
Collect_Abstract_Interfaces (Typ, Ifaces_List);
Default : Node_Id;
Ptype : Entity_Id;
+ -- The following are used for setting Is_Only_Out_
+ Num_Out_Params : Nat := 0;
+ First_Out_Param : Entity_Id := Empty;
+
function Is_Class_Wide_Default (D : Node_Id) return Boolean;
-- Check whether the default has a class-wide type. After analysis the
-- default has the type of the formal, so we must also check explicitly
elsif Is_Value_Type (Formal_Type) then
null;
- elsif Nkind (Parent (T)) /= N_Access_Function_Definition
- and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
+ elsif not Nkind_In (Parent (T), N_Access_Function_Definition,
+ N_Access_Procedure_Definition)
then
Error_Msg_N ("invalid use of incomplete type", Param_Spec);
Apply_Scalar_Range_Check (Default, Formal_Type);
end if;
end if;
+
+ elsif Ekind (Formal) = E_Out_Parameter then
+ Num_Out_Params := Num_Out_Params + 1;
+
+ if Num_Out_Params = 1 then
+ First_Out_Param := Formal;
+ end if;
+
+ elsif Ekind (Formal) = E_In_Out_Parameter then
+ Num_Out_Params := Num_Out_Params + 1;
end if;
Next (Param_Spec);
end loop;
+
+ if Present (First_Out_Param) and then Num_Out_Params = 1 then
+ Set_Is_Only_Out_Parameter (First_Out_Param);
+ end if;
end Process_Formals;
----------------------------
projects / thirdparty / gcc.git / commitdiff
