-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- Dispatches to specific expansion procedures.
procedure Expand_Entry_Index_Parameter (N : Node_Id);
- -- A reference to the identifier in the entry index specification of
- -- protected entry body is modified to a reference to a constant definition
- -- equal to the index of the entry family member being called. This
- -- constant is calculated as part of the elaboration of the expanded code
- -- for the body, and is calculated from the object-wide entry index
- -- returned by Next_Entry_Call.
+ -- A reference to the identifier in the entry index specification of an
+ -- entry body is modified to a reference to a constant definition equal to
+ -- the index of the entry family member being called. This constant is
+ -- calculated as part of the elaboration of the expanded code for the body,
+ -- and is calculated from the object-wide entry index returned by Next_
+ -- Entry_Call.
procedure Expand_Entry_Parameter (N : Node_Id);
-- A reference to an entry parameter is modified to be a reference to the
-- represent the operation within the protected object. In other cases
-- Expand_Formal is a no-op.
- procedure Expand_Protected_Private (N : Node_Id);
- -- A reference to a private component of a protected type is expanded to a
- -- component selected from the record used to implement the protected
- -- object. Such a record is passed to all operations on a protected object
- -- in a parameter named _object. This object is a constant in the body of a
- -- function, and a variable within a procedure or entry body.
+ procedure Expand_Protected_Component (N : Node_Id);
+ -- A reference to a private component of a protected type is expanded into
+ -- a reference to the corresponding prival in the current protected entry
+ -- or subprogram.
procedure Expand_Renaming (N : Node_Id);
-- For renamings, just replace the identifier by the corresponding
elsif Is_Entry_Formal (E) then
Expand_Entry_Parameter (N);
- elsif Ekind (E) = E_Component
- and then Is_Protected_Private (E)
- then
- -- Protect against junk use of tasking in no run time mode
-
+ elsif Is_Protected_Component (E) then
if No_Run_Time_Mode then
return;
end if;
- Expand_Protected_Private (N);
+ Expand_Protected_Component (N);
elsif Ekind (E) = E_Entry_Index_Parameter then
Expand_Entry_Index_Parameter (N);
-- Interpret possible Current_Value for constant case
- elsif (Ekind (E) = E_Constant
- or else
- Ekind (E) = E_In_Parameter
- or else
- Ekind (E) = E_Loop_Parameter)
+ elsif Is_Constant_Object (E)
and then Present (Current_Value (E))
then
Expand_Current_Value (N);
----------------------------------
procedure Expand_Entry_Index_Parameter (N : Node_Id) is
+ Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N));
begin
- Set_Entity (N, Entry_Index_Constant (Entity (N)));
+ Set_Entity (N, Index_Con);
+ Set_Etype (N, Etype (Index_Con));
end Expand_Entry_Index_Parameter;
----------------------------
-- we also generate an extra parameter to hold the Constrained
-- attribute of the actual. No renaming is generated for this flag.
+ -- Calling Node_Posssible_Modifications in the expander is dubious,
+ -- because this generates a cross-reference entry, and should be
+ -- done during semantic processing so it is called in -gnatc mode???
+
if Ekind (Entity (N)) /= E_In_Parameter
and then In_Assignment_Context (N)
then
- Note_Possible_Modification (N);
+ Note_Possible_Modification (N, Sure => True);
end if;
Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc));
end if;
end Expand_N_Real_Literal;
- ------------------------------
- -- Expand_Protected_Private --
- ------------------------------
+ --------------------------------
+ -- Expand_Protected_Component --
+ --------------------------------
- procedure Expand_Protected_Private (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- E : constant Entity_Id := Entity (N);
- Op : constant Node_Id := Protected_Operation (E);
- Scop : Entity_Id;
- Lo : Node_Id;
- Hi : Node_Id;
- D_Range : Node_Id;
-
- begin
- if Nkind (Op) /= N_Subprogram_Body
- or else Nkind (Specification (Op)) /= N_Function_Specification
- then
- Set_Ekind (Prival (E), E_Variable);
- else
- Set_Ekind (Prival (E), E_Constant);
- end if;
+ procedure Expand_Protected_Component (N : Node_Id) is
- -- If the private component appears in an assignment (either lhs or
- -- rhs) and is a one-dimensional array constrained by a discriminant,
- -- rewrite as P (Lo .. Hi) with an explicit range, so that discriminal
- -- is directly visible. This solves delicate visibility problems.
+ function Inside_Eliminated_Body return Boolean;
+ -- Determine whether the current entity is inside a subprogram or an
+ -- entry which has been marked as eliminated.
- if Comes_From_Source (N)
- and then Is_Array_Type (Etype (E))
- and then Number_Dimensions (Etype (E)) = 1
- and then not Within_Init_Proc
- then
- Lo := Type_Low_Bound (Etype (First_Index (Etype (E))));
- Hi := Type_High_Bound (Etype (First_Index (Etype (E))));
-
- if Nkind (Parent (N)) = N_Assignment_Statement
- and then ((Is_Entity_Name (Lo)
- and then Ekind (Entity (Lo)) = E_In_Parameter)
- or else (Is_Entity_Name (Hi)
- and then
- Ekind (Entity (Hi)) = E_In_Parameter))
- then
- D_Range := New_Node (N_Range, Loc);
+ ----------------------------
+ -- Inside_Eliminated_Body --
+ ----------------------------
- if Is_Entity_Name (Lo)
- and then Ekind (Entity (Lo)) = E_In_Parameter
- then
- Set_Low_Bound (D_Range,
- Make_Identifier (Loc, Chars (Entity (Lo))));
- else
- Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo));
- end if;
+ function Inside_Eliminated_Body return Boolean is
+ S : Entity_Id := Current_Scope;
- if Is_Entity_Name (Hi)
- and then Ekind (Entity (Hi)) = E_In_Parameter
+ begin
+ while Present (S) loop
+ if (Ekind (S) = E_Entry
+ or else Ekind (S) = E_Entry_Family
+ or else Ekind (S) = E_Function
+ or else Ekind (S) = E_Procedure)
+ and then Is_Eliminated (S)
then
- Set_High_Bound (D_Range,
- Make_Identifier (Loc, Chars (Entity (Hi))));
- else
- Set_High_Bound (D_Range, Duplicate_Subexpr (Hi));
+ return True;
end if;
- Rewrite (N,
- Make_Slice (Loc,
- Prefix => New_Occurrence_Of (E, Loc),
- Discrete_Range => D_Range));
-
- Analyze_And_Resolve (N, Etype (E));
- return;
- end if;
- end if;
-
- -- The type of the reference is the type of the prival, which may differ
- -- from that of the original component if it is an itype.
-
- Set_Entity (N, Prival (E));
- Set_Etype (N, Etype (Prival (E)));
- Scop := Current_Scope;
+ S := Scope (S);
+ end loop;
- -- Find entity for protected operation, which must be on scope stack
+ return False;
+ end Inside_Eliminated_Body;
- while not Is_Protected_Type (Scope (Scop)) loop
- Scop := Scope (Scop);
- end loop;
+ -- Start of processing for Expand_Protected_Component
- Append_Elmt (N, Privals_Chain (Scop));
- end Expand_Protected_Private;
+ begin
+ -- Eliminated bodies are not expanded and thus do not need privals
+
+ if not Inside_Eliminated_Body then
+ declare
+ Priv : constant Entity_Id := Prival (Entity (N));
+ begin
+ Set_Entity (N, Priv);
+ Set_Etype (N, Etype (Priv));
+ end;
+ end if;
+ end Expand_Protected_Component;
---------------------
-- Expand_Renaming --
-- and has already been flipped during this phase of instantiation.
procedure Hide_Current_Scope;
- -- When compiling a generic child unit, the parent context must be
+ -- When instantiating a generic child unit, the parent context must be
-- present, but the instance and all entities that may be generated
-- must be inserted in the current scope. We leave the current scope
-- on the stack, but make its entities invisible to avoid visibility
- -- problems. This is reversed at the end of instantiations. This is
+ -- problems. This is reversed at the end of the instantiation. This is
-- not done for the instantiation of the bodies, which only require the
-- instances of the generic parents to be in scope.
-- at the end of the enclosing generic package, which is semantically
-- neutral.
- procedure Pre_Analyze_Actuals (N : Node_Id);
+ procedure Preanalyze_Actuals (N : Node_Id);
-- Analyze actuals to perform name resolution. Full resolution is done
-- later, when the expected types are known, but names have to be captured
-- before installing parents of generics, that are not visible for the
procedure Process_Default (F : Entity_Id) is
Loc : constant Source_Ptr := Sloc (I_Node);
+ F_Id : constant Entity_Id := Defining_Entity (F);
+
Decl : Node_Id;
Default : Node_Id;
Id : Entity_Id;
-- new defining identifier for it.
Decl := New_Copy_Tree (F);
+ Id := Make_Defining_Identifier (Sloc (F_Id), Chars => Chars (F_Id));
- if Nkind (F) = N_Formal_Concrete_Subprogram_Declaration then
- Id :=
- Make_Defining_Identifier (Sloc (Defining_Entity (F)),
- Chars => Chars (Defining_Entity (F)));
+ if Nkind (F) in N_Formal_Subprogram_Declaration then
Set_Defining_Unit_Name (Specification (Decl), Id);
else
- Id :=
- Make_Defining_Identifier (Sloc (Defining_Entity (F)),
- Chars => Chars (Defining_Identifier (F)));
Set_Defining_Identifier (Decl, Id);
end if;
Set_Size_Known_At_Compile_Time
(T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def))));
-
end Analyze_Formal_Derived_Type;
----------------------------------
end if;
if Present (E) then
- Analyze_Per_Use_Expression (E, T);
+ Preanalyze_Spec_Expression (E, T);
if Is_Limited_Type (T) and then not OK_For_Limited_Init (E) then
Error_Msg_N
end if;
Generate_Definition (Act_Decl_Id);
- Pre_Analyze_Actuals (N);
+ Preanalyze_Actuals (N);
Init_Env;
Env_Installed := True;
-- subprogram will be frozen at the point the wrapper package is
-- frozen, so it does not need its own freeze node. In fact, if one
-- is created, it might conflict with the freezing actions from the
- -- wrapper package (see 7206-013).
-
- -- Should not really reference non-public TN's in comments ???
+ -- wrapper package.
Set_Has_Delayed_Freeze (Anon_Id, False);
-- Make node global for error reporting
Instantiation_Node := N;
- Pre_Analyze_Actuals (N);
+ Preanalyze_Actuals (N);
Init_Env;
Env_Installed := True;
Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation
+ -- Inherit overriding indicator from instance node.
Act_Tree :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty, Instantiating => True);
Act_Spec := Specification (Act_Tree);
+ Set_Must_Override (Act_Spec, Must_Override (N));
+ Set_Must_Not_Override (Act_Spec, Must_Not_Override (N));
+
Renaming_List :=
Analyze_Associations
(N,
elsif Is_Overloadable (E1) then
- -- Verify that the names of the entities match. Note that actuals
- -- that are attributes are rewritten as subprograms.
+ -- Verify that the actual subprograms match. Note that actuals
+ -- that are attributes are rewritten as subprograms. If the
+ -- subprogram in the formal package is defaulted, no check is
+ -- needed. Note that this can only happen in Ada2005 when the
+ -- formal package can be partially parametrized.
- Check_Mismatch
- (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
+ if Nkind (Unit_Declaration_Node (E1)) =
+ N_Subprogram_Renaming_Declaration
+ and then From_Default (Unit_Declaration_Node (E1))
+ then
+ null;
+
+ else
+ Check_Mismatch
+ (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
+ end if;
else
raise Program_Error;
end if;
end if;
- Note_Possible_Modification (Actual);
+ Note_Possible_Modification (Actual, Sure => True);
-- Check for instantiation of atomic/volatile actual for
-- non-atomic/volatile formal (RM C.6 (12)).
Append (Decl_Node, List);
-- No need to repeat (pre-)analysis of some expression nodes
- -- already handled in Pre_Analyze_Actuals.
+ -- already handled in Preanalyze_Actuals.
if Nkind (Actual) /= N_Allocator then
Analyze (Actual);
-- a child unit.
if Nkind (Actual) = N_Aggregate then
- Pre_Analyze_And_Resolve (Actual, Typ);
+ Preanalyze_And_Resolve (Actual, Typ);
end if;
if Is_Limited_Type (Typ)
Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
N_Object_Declaration)
and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
- and then Has_Null_Exclusion (Actual_Decl)
- and then not Has_Null_Exclusion (Analyzed_Formal)
+ and then not Has_Null_Exclusion (Actual_Decl)
+ and then Has_Null_Exclusion (Analyzed_Formal)
then
- Error_Msg_Sloc := Sloc (Actual_Decl);
+ Error_Msg_Sloc := Sloc (Analyzed_Formal);
Error_Msg_N
- ("`NOT NULL` required in formal, to match actual #",
- Analyzed_Formal);
+ ("actual must exclude null to match generic formal#", Actual);
end if;
return List;
---------------------------------
procedure Instantiate_Subprogram_Body
- (Body_Info : Pending_Body_Info)
+ (Body_Info : Pending_Body_Info;
+ Body_Optional : Boolean := False)
is
Act_Decl : constant Node_Id := Body_Info.Act_Decl;
Inst_Node : constant Node_Id := Body_Info.Inst_Node;
-- For other cases, commpile the body
else
- Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl));
+ Load_Parent_Of_Generic
+ (Inst_Node, Specification (Gen_Decl), Body_Optional);
Gen_Body_Id := Corresponding_Body (Gen_Decl);
end if;
end if;
elsif Serious_Errors_Detected = 0
and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
then
- if Ekind (Anon_Id) = E_Procedure then
+ if Body_Optional then
+ return;
+
+ elsif Ekind (Anon_Id) = E_Procedure then
Act_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Desig_Act := Designated_Type (Base_Type (Act_T));
-- The designated type may have been introduced through a limited_
- -- with clause, in which case retrieve the non-limited view.
+ -- with clause, in which case retrieve the non-limited view. This
+ -- applies to incomplete types as well as to class-wide types.
- if Ekind (Desig_Act) = E_Incomplete_Type
- and then From_With_Type (Desig_Act)
- then
+ if From_With_Type (Desig_Act) then
Desig_Act := Available_View (Desig_Act);
end if;
end loop;
end Check_Abstract_Primitives;
end if;
+
+ -- Verify that limitedness matches. If parent is a limited
+ -- interface then the generic formal is not unless declared
+ -- explicitly so. If not declared limited, the actual cannot be
+ -- limited (see AI05-0087).
+
+ if Is_Limited_Type (Act_T)
+ and then not Is_Limited_Type (A_Gen_T)
+ and then False
+ then
+ Error_Msg_NE
+ ("actual for non-limited & cannot be a limited type", Actual,
+ Gen_T);
+ Explain_Limited_Type (Act_T, Actual);
+ Abandon_Instantiation (Actual);
+ end if;
end Validate_Derived_Type_Instance;
--------------------------------------
-- instantiations are available, we must analyze them, to ensure that
-- the public symbols generated are the same when the unit is compiled
-- to generate code, and when it is compiled in the context of a unit
- -- that needs a particular nested instance.
+ -- that needs a particular nested instance. This process is applied
+ -- to both package and subprogram instances.
--------------------------------
-- Collect_Previous_Instances --
then
Append_Elmt (Decl, Previous_Instances);
+ -- For a subprogram instantiation, omit instantiations of
+ -- intrinsic operations (Unchecked_Conversions, etc.) that
+ -- have no bodies.
+
+ elsif Nkind_In (Decl, N_Function_Instantiation,
+ N_Procedure_Instantiation)
+ and then not Is_Intrinsic_Subprogram (Entity (Name (Decl)))
+ then
+ Append_Elmt (Decl, Previous_Instances);
+
elsif Nkind (Decl) = N_Package_Declaration then
Collect_Previous_Instances
(Visible_Declarations (Specification (Decl)));
then
declare
Decl : Elmt_Id;
+ Info : Pending_Body_Info;
Par : Node_Id;
begin
Decl := First_Elmt (Previous_Instances);
while Present (Decl) loop
- Instantiate_Package_Body
- (Body_Info =>
- ((Inst_Node => Node (Decl),
- Act_Decl =>
- Instance_Spec (Node (Decl)),
- Expander_Status => Exp_Status,
- Current_Sem_Unit =>
- Get_Code_Unit (Sloc (Node (Decl))),
- Scope_Suppress => Scope_Suppress,
- Local_Suppress_Stack_Top =>
- Local_Suppress_Stack_Top)),
- Body_Optional => True);
+ Info :=
+ (Inst_Node => Node (Decl),
+ Act_Decl =>
+ Instance_Spec (Node (Decl)),
+ Expander_Status => Exp_Status,
+ Current_Sem_Unit =>
+ Get_Code_Unit (Sloc (Node (Decl))),
+ Scope_Suppress => Scope_Suppress,
+ Local_Suppress_Stack_Top =>
+ Local_Suppress_Stack_Top);
+
+ -- Package instance
+
+ if
+ Nkind (Node (Decl)) = N_Package_Instantiation
+ then
+ Instantiate_Package_Body
+ (Info, Body_Optional => True);
+
+ -- Subprogram instance
+
+ else
+ -- The instance_spec is the wrapper package,
+ -- and the subprogram declaration is the last
+ -- declaration in the wrapper.
+
+ Info.Act_Decl :=
+ Last
+ (Visible_Declarations
+ (Specification (Info.Act_Decl)));
+
+ Instantiate_Subprogram_Body
+ (Info, Body_Optional => True);
+ end if;
Next_Elmt (Decl);
end loop;
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top =>
Local_Suppress_Stack_Top)),
- Body_Optional => Body_Optional);
+ Body_Optional => Body_Optional);
end;
end if;
-- Preanalyze_Actuals --
------------------------
- procedure Pre_Analyze_Actuals (N : Node_Id) is
+ procedure Preanalyze_Actuals (N : Node_Id) is
Assoc : Node_Id;
Act : Node_Id;
Errs : constant Int := Serious_Errors_Detected;
Next (Assoc);
end loop;
- end Pre_Analyze_Actuals;
+ end Preanalyze_Actuals;
-------------------
-- Remove_Parent --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- between the current procedure and Load_Parent_Of_Generic.
procedure Instantiate_Subprogram_Body
- (Body_Info : Pending_Body_Info);
+ (Body_Info : Pending_Body_Info;
+ Body_Optional : Boolean := False);
-- Called after semantic analysis, to complete the instantiation of
- -- function and procedure instances.
+ -- function and procedure instances. The flag Body_Optional has the
+ -- same purpose as described for Instantiate_Package_Body.
procedure Save_Global_References (N : Node_Id);
-- Traverse the original generic unit, and capture all references to
with Errout; use Errout;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
-with Layout; use Layout;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
-- definition clause that is the preferred approach in Ada 95.
procedure Analyze_At_Clause (N : Node_Id) is
+ CS : constant Boolean := Comes_From_Source (N);
+
begin
+ -- This is an obsolescent feature
+
Check_Restriction (No_Obsolescent_Features, N);
if Warn_On_Obsolescent_Feature then
("\use address attribute definition clause instead?", N);
end if;
+ -- Rewrite as address clause
+
Rewrite (N,
Make_Attribute_Definition_Clause (Sloc (N),
Name => Identifier (N),
Chars => Name_Address,
Expression => Expression (N)));
+
+ -- We preserve Comes_From_Source, since logically the clause still
+ -- comes from the source program even though it is changed in form.
+
+ Set_Comes_From_Source (N, CS);
+
+ -- Analyze rewritten clause
+
Analyze_Attribute_Definition_Clause (N);
end Analyze_At_Clause;
-- Common processing for 'Read, 'Write, 'Input and 'Output attribute
-- definition clauses.
+ -----------------------------------
+ -- Analyze_Stream_TSS_Definition --
+ -----------------------------------
+
procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is
Subp : Entity_Id := Empty;
I : Interp_Index;
return Base_Type (Typ) = Base_Type (Ent)
and then No (Next_Formal (F));
-
end Has_Good_Profile;
-- Start of processing for Analyze_Stream_TSS_Definition
-- Address attribute definition clause
when Attribute_Address => Address : begin
+
+ -- A little error check, catch for X'Address use X'Address;
+
+ if Nkind (Nam) = N_Identifier
+ and then Nkind (Expr) = N_Attribute_Reference
+ and then Attribute_Name (Expr) = Name_Address
+ and then Nkind (Prefix (Expr)) = N_Identifier
+ and then Chars (Nam) = Chars (Prefix (Expr))
+ then
+ Error_Msg_NE
+ ("address for & is self-referencing", Prefix (Expr), Ent);
+ return;
+ end if;
+
+ -- Not that special case, carry on with analysis of expression
+
Analyze_And_Resolve (Expr, RTE (RE_Address));
if Present (Address_Clause (U_Ent)) then
-- We mark a possible modification of a variable with an
-- address clause, since it is likely aliasing is occurring.
- Note_Possible_Modification (Nam);
+ Note_Possible_Modification (Nam, Sure => False);
-- Here we are checking for explicit overlap of one variable
-- by another, and if we find this then mark the overlapped
-- If the address clause is of the form:
- -- for X'Address use Y'Address
+ -- for Y'Address use X'Address
-- or
- -- Const : constant Address := Y'Address;
+ -- Const : constant Address := X'Address;
-- ...
- -- for X'Address use Const;
+ -- for Y'Address use Const;
-- then we make an entry in the table for checking the size and
-- alignment of the overlaying variable. We defer this check
-- till after code generation to take full advantage of the
-- annotation done by the back end. This entry is only made if
-- we have not already posted a warning about size/alignment
- -- (some warnings of this type are posted in Checks).
+ -- (some warnings of this type are posted in Checks), and if
+ -- the address clause comes from source.
- if Address_Clause_Overlay_Warnings then
+ if Address_Clause_Overlay_Warnings
+ and then Comes_From_Source (N)
+ then
declare
Ent_X : Entity_Id := Empty;
Ent_Y : Entity_Id := Empty;
if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then
Ent_X := Entity (Name (N));
- Address_Clause_Checks.Append ((N, Ent_X, Ent_Y));
+ Address_Clause_Checks.Append ((N, Ent_X, Ent_Y));
+
+ -- If variable overlays a constant view, and we are
+ -- warning on overlays, then mark the variable as
+ -- overlaying a constant (we will give warnings later
+ -- if this variable is assigned).
+
+ if Is_Constant_Object (Ent_Y)
+ and then Ekind (Ent_X) = E_Variable
+ then
+ Set_Overlays_Constant (Ent_X);
+ end if;
end if;
end;
end if;
Set_Has_Small_Clause (U_Ent);
Set_Has_Small_Clause (Implicit_Base);
Set_Has_Non_Standard_Rep (Implicit_Base);
-
- -- Recompute RM_Size, but shouldn't this be done in Freeze???
-
- Set_Discrete_RM_Size (U_Ent);
end if;
end Small;
-- Don't allow rep clause for standard [wide_[wide_]]character
- elsif Root_Type (Enumtype) = Standard_Character
- or else Root_Type (Enumtype) = Standard_Wide_Character
- or else Root_Type (Enumtype) = Standard_Wide_Wide_Character
- then
+ elsif Is_Standard_Character_Type (Enumtype) then
Error_Msg_N ("enumeration rep clause not allowed for this type", N);
return;
Error_Msg_N
("first bit cannot be negative", First_Bit (CC));
+ -- The Last_Bit specified in a component clause must not be
+ -- less than the First_Bit minus one (RM-13.5.1(10)).
+
+ elsif Lbit < Fbit - 1 then
+ Error_Msg_N
+ ("last bit cannot be less than first bit minus one",
+ Last_Bit (CC));
+
-- Values look OK, so find the corresponding record component
-- Even though the syntax allows an attribute reference for
-- implementation-defined components, GNAT does not allow the
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- Some special bad cases of entity names
elsif Is_Entity_Name (N) then
- if Ekind (Entity (N)) = E_In_Parameter then
- Error_Msg_N
- ("assignment to IN mode parameter not allowed", N);
-
- -- Private declarations in a protected object are turned into
- -- constants when compiling a protected function.
+ declare
+ Ent : constant Entity_Id := Entity (N);
- elsif Present (Scope (Entity (N)))
- and then Is_Protected_Type (Scope (Entity (N)))
- and then
- (Ekind (Current_Scope) = E_Function
- or else
- Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function)
- then
- Error_Msg_N
- ("protected function cannot modify protected object", N);
+ begin
+ if Ekind (Ent) = E_In_Parameter then
+ Error_Msg_N
+ ("assignment to IN mode parameter not allowed", N);
+
+ -- Renamings of protected private components are turned into
+ -- constants when compiling a protected function. In the case
+ -- of single protected types, the private component appears
+ -- directly.
+
+ elsif (Is_Prival (Ent)
+ and then
+ (Ekind (Current_Scope) = E_Function
+ or else Ekind (Enclosing_Dynamic_Scope (
+ Current_Scope)) = E_Function))
+ or else
+ (Ekind (Ent) = E_Component
+ and then Is_Protected_Type (Scope (Ent)))
+ then
+ Error_Msg_N
+ ("protected function cannot modify protected object", N);
- elsif Ekind (Entity (N)) = E_Loop_Parameter then
- Error_Msg_N
- ("assignment to loop parameter not allowed", N);
+ elsif Ekind (Ent) = E_Loop_Parameter then
+ Error_Msg_N
+ ("assignment to loop parameter not allowed", N);
- else
- Error_Msg_N
- ("left hand side of assignment must be a variable", N);
- end if;
+ else
+ Error_Msg_N
+ ("left hand side of assignment must be a variable", N);
+ end if;
+ end;
-- For indexed components or selected components, test prefix
("left hand of assignment must not be limited type", Lhs);
Explain_Limited_Type (T1, Lhs);
return;
+
+ -- Enforce RM 3.9.3 (8): left-hand side cannot be abstract
+
+ elsif Is_Interface (T1)
+ and then not Is_Class_Wide_Type (T1)
+ then
+ Error_Msg_N
+ ("target of assignment operation may not be abstract", Lhs);
+ return;
end if;
-- Resolution may have updated the subtype, in case the left-hand
-- This is the point at which we check for an unset reference
Check_Unset_Reference (Rhs);
+ Check_Unprotected_Access (Lhs, Rhs);
-- Remaining steps are skipped if Rhs was syntactically in error
-- We still mark this as a possible modification, that's necessary
-- to reset Is_True_Constant, and desirable for xref purposes.
- Note_Possible_Modification (Lhs);
+ Note_Possible_Modification (Lhs, Sure => True);
return;
-- If we know the right hand side is non-null, then we convert to the
-- Note: modifications of the Lhs may only be recorded after
-- checks have been applied.
- Note_Possible_Modification (Lhs);
+ Note_Possible_Modification (Lhs, Sure => True);
-- ??? a real accessibility check is needed when ???
Analyze (Id);
Ent := Entity (Id);
- Generate_Reference (Ent, Loop_Statement, ' ');
- Generate_Definition (Ent);
- -- If we found a label, mark its type. If not, ignore it, since it
- -- means we have a conflicting declaration, which would already have
- -- been diagnosed at declaration time. Set Label_Construct of the
- -- implicit label declaration, which is not created by the parser
- -- for generic units.
+ -- Guard against serious error (typically, a scope mismatch when
+ -- semantic analysis is requested) by creating loop entity to
+ -- continue analysis.
- if Ekind (Ent) = E_Label then
- Set_Ekind (Ent, E_Loop);
+ if No (Ent) then
+ if Total_Errors_Detected /= 0 then
+ Ent :=
+ New_Internal_Entity
+ (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L');
+ else
+ raise Program_Error;
+ end if;
+
+ else
+ Generate_Reference (Ent, Loop_Statement, ' ');
+ Generate_Definition (Ent);
- if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
- Set_Label_Construct (Parent (Ent), Loop_Statement);
+ -- If we found a label, mark its type. If not, ignore it, since it
+ -- means we have a conflicting declaration, which would already
+ -- have been diagnosed at declaration time. Set Label_Construct
+ -- of the implicit label declaration, which is not created by the
+ -- parser for generic units.
+
+ if Ekind (Ent) = E_Label then
+ Set_Ekind (Ent, E_Loop);
+
+ if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
+ Set_Label_Construct (Parent (Ent), Loop_Statement);
+ end if;
end if;
end if;
Set_Parent (Ent, Loop_Statement);
end if;
- -- Kill current values on entry to loop, since statements in body
- -- of loop may have been executed before the loop is entered.
- -- Similarly we kill values after the loop, since we do not know
- -- that the body of the loop was executed.
+ -- Kill current values on entry to loop, since statements in body of
+ -- loop may have been executed before the loop is entered. Similarly we
+ -- kill values after the loop, since we do not know that the body of the
+ -- loop was executed.
Kill_Current_Values;
Push_Scope (Ent);
End_Scope;
Kill_Current_Values;
Check_Infinite_Loop_Warning (N);
+
+ -- Code after loop is unreachable if the loop has no WHILE or FOR
+ -- and contains no EXIT statements within the body of the loop.
+
+ if No (Iter) and then not Has_Exit (Ent) then
+ Check_Unreachable_Code (N);
+ end if;
end Analyze_Loop_Statement;
----------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- be assumed to be reachable.
procedure Check_Unreachable_Code (N : Node_Id);
- -- This procedure is called with N being the node for a statement that
- -- is an unconditional transfer of control. It checks to see if the
- -- statement is followed by some other statement, and if so generates
- -- an appropriate warning for unreachable code.
+ -- This procedure is called with N being the node for a statement that is
+ -- an unconditional transfer of control or an apparent infinite loop. It
+ -- checks to see if the statement is followed by some other statement, and
+ -- if so generates an appropriate warning for unreachable code.
end Sem_Ch5;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier
and then Entity (Lf) = Entity (Rf)
and then not Is_Floating_Point_Type (Etype (L))
- and then (Ekind (Entity (Lf)) = E_Constant or else
- Ekind (Entity (Lf)) = E_In_Parameter or else
- Ekind (Entity (Lf)) = E_Loop_Parameter)
+ and then Is_Constant_Object (Entity (Lf))
then
return True;
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
- if (C_Typ = Standard_Character
- or else C_Typ = Standard_Wide_Character
- or else C_Typ = Standard_Wide_Wide_Character)
+ if Is_Standard_Character_Type (C_Typ)
and then Fold
then
null;
Fold : Boolean;
begin
- -- One special case to deal with first. If we can tell that
- -- the result will be false because the lengths of one or
- -- more index subtypes are compile time known and different,
- -- then we can replace the entire result by False. We only
- -- do this for one dimensional arrays, because the case of
- -- multi-dimensional arrays is rare and too much trouble!
- -- If one of the operands is an illegal aggregate, its type
- -- might still be an arbitrary composite type, so nothing to do.
+ -- One special case to deal with first. If we can tell that the result
+ -- will be false because the lengths of one or more index subtypes are
+ -- compile time known and different, then we can replace the entire
+ -- result by False. We only do this for one dimensional arrays, because
+ -- the case of multi-dimensional arrays is rare and too much trouble! If
+ -- one of the operands is an illegal aggregate, its type might still be
+ -- an arbitrary composite type, so nothing to do.
if Is_Array_Type (Typ)
and then Typ /= Any_Composite
return;
end if;
- declare
+ -- OK, we have the case where we may be able to do this fold
+
+ Length_Mismatch : declare
procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
-- If Op is an expression for a constrained array with a known
-- at compile time length, then Len is set to this (non-negative
T : Entity_Id;
begin
+ -- First easy case string literal
+
if Nkind (Op) = N_String_Literal then
Len := UI_From_Int (String_Length (Strval (Op)));
+ return;
+ end if;
+
+ -- Second easy case, not constrained subtype, so no length
- elsif not Is_Constrained (Etype (Op)) then
+ if not Is_Constrained (Etype (Op)) then
Len := Uint_Minus_1;
+ return;
+ end if;
- else
- T := Etype (First_Index (Etype (Op)));
+ -- General case
- if Is_Discrete_Type (T)
- and then
- Compile_Time_Known_Value (Type_Low_Bound (T))
- and then
- Compile_Time_Known_Value (Type_High_Bound (T))
+ T := Etype (First_Index (Etype (Op)));
+
+ -- The simple case, both bounds are known at compile time
+
+ if Is_Discrete_Type (T)
+ and then
+ Compile_Time_Known_Value (Type_Low_Bound (T))
+ and then
+ Compile_Time_Known_Value (Type_High_Bound (T))
+ then
+ Len := UI_Max (Uint_0,
+ Expr_Value (Type_High_Bound (T)) -
+ Expr_Value (Type_Low_Bound (T)) + 1);
+ return;
+ end if;
+
+ -- A more complex case, where the bounds are of the form
+ -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
+ -- either A'First or A'Last (with A an entity name), or X is an
+ -- entity name, and the two X's are the same and K1 and K2 are
+ -- known at compile time, in this case, the length can also be
+ -- computed at compile time, even though the bounds are not
+ -- known. A common case of this is e.g. (X'First..X'First+5).
+
+ Extract_Length : declare
+ procedure Decompose_Expr
+ (Expr : Node_Id;
+ Ent : out Entity_Id;
+ Kind : out Character;
+ Cons : out Uint);
+ -- Given an expression, see if is of the form above,
+ -- X [+/- K]. If so Ent is set to the entity in X,
+ -- Kind is 'F','L','E' for 'First/'Last/simple entity,
+ -- and Cons is the value of K. If the expression is
+ -- not of the required form, Ent is set to Empty.
+
+ --------------------
+ -- Decompose_Expr --
+ --------------------
+
+ procedure Decompose_Expr
+ (Expr : Node_Id;
+ Ent : out Entity_Id;
+ Kind : out Character;
+ Cons : out Uint)
+ is
+ Exp : Node_Id;
+
+ begin
+ if Nkind (Expr) = N_Op_Add
+ and then Compile_Time_Known_Value (Right_Opnd (Expr))
+ then
+ Exp := Left_Opnd (Expr);
+ Cons := Expr_Value (Right_Opnd (Expr));
+
+ elsif Nkind (Expr) = N_Op_Subtract
+ and then Compile_Time_Known_Value (Right_Opnd (Expr))
+ then
+ Exp := Left_Opnd (Expr);
+ Cons := -Expr_Value (Right_Opnd (Expr));
+
+ else
+ Exp := Expr;
+ Cons := Uint_0;
+ end if;
+
+ -- At this stage Exp is set to the potential X
+
+ if Nkind (Exp) = N_Attribute_Reference then
+ if Attribute_Name (Exp) = Name_First then
+ Kind := 'F';
+ elsif Attribute_Name (Exp) = Name_Last then
+ Kind := 'L';
+ else
+ Ent := Empty;
+ return;
+ end if;
+
+ Exp := Prefix (Exp);
+
+ else
+ Kind := 'E';
+ end if;
+
+ if Is_Entity_Name (Exp)
+ and then Present (Entity (Exp))
+ then
+ Ent := Entity (Exp);
+ else
+ Ent := Empty;
+ end if;
+ end Decompose_Expr;
+
+ -- Local Variables
+
+ Ent1, Ent2 : Entity_Id;
+ Kind1, Kind2 : Character;
+ Cons1, Cons2 : Uint;
+
+ -- Start of processing for Extract_Length
+
+ begin
+ Decompose_Expr (Type_Low_Bound (T), Ent1, Kind1, Cons1);
+ Decompose_Expr (Type_High_Bound (T), Ent2, Kind2, Cons2);
+
+ if Present (Ent1)
+ and then Kind1 = Kind2
+ and then Ent1 = Ent2
then
- Len := UI_Max (Uint_0,
- Expr_Value (Type_High_Bound (T)) -
- Expr_Value (Type_Low_Bound (T)) + 1);
+ Len := Cons2 - Cons1 + 1;
else
Len := Uint_Minus_1;
end if;
- end if;
+ end Extract_Length;
end Get_Static_Length;
+ -- Local Variables
+
Len_L : Uint;
Len_R : Uint;
+ -- Start of processing for Length_Mismatch
+
begin
Get_Static_Length (Left, Len_L);
Get_Static_Length (Right, Len_R);
Warn_On_Known_Condition (N);
return;
end if;
- end;
+ end Length_Mismatch;
+ end if;
-- Another special case: comparisons of access types, where one or both
-- operands are known to be null, so the result can be determined.
- elsif Is_Access_Type (Typ) then
+ if Is_Access_Type (Typ) then
if Known_Null (Left) then
if Known_Null (Right) then
Fold_Uint (N, Test (Nkind (N) = N_Op_Eq), False);
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Style; use Style;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
D : Node_Id;
begin
- -- Any use in a default expression is legal
+ -- Any use in a a spec-expression is legal
- if In_Default_Expression then
+ if In_Spec_Expression then
null;
elsif Nkind (PN) = N_Range then
and then Scope (Disc) = Current_Scope
and then not
(Nkind (Parent (P)) = N_Subtype_Indication
- and then
- (Nkind (Parent (Parent (P))) = N_Component_Definition
- or else
- Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
+ and then
+ Nkind_In (Parent (Parent (P)), N_Component_Definition,
+ N_Subtype_Declaration)
and then Paren_Count (N) = 0)
then
Error_Msg_N
-- Legal case is in index or discriminant constraint
- elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint
- or else Nkind (PN) = N_Discriminant_Association
+ elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint,
+ N_Discriminant_Association)
then
if Paren_Count (N) > 0 then
Error_Msg_N
else
D := PN;
P := Parent (PN);
- while Nkind (P) /= N_Component_Declaration
- and then Nkind (P) /= N_Subtype_Indication
- and then Nkind (P) /= N_Entry_Declaration
+ while not Nkind_In (P, N_Component_Declaration,
+ N_Subtype_Indication,
+ N_Entry_Declaration)
loop
D := P;
P := Parent (P);
-- is of course a double fault.
if (Nkind (P) = N_Subtype_Indication
- and then
- (Nkind (Parent (P)) = N_Component_Definition
- or else
- Nkind (Parent (P)) = N_Derived_Type_Definition)
+ and then Nkind_In (Parent (P), N_Component_Definition,
+ N_Derived_Type_Definition)
and then D = Constraint (P))
-- The constraint itself may be given by a subtype indication,
loop
P := Parent (C);
exit when Nkind (P) = N_Subprogram_Body;
-
- if Nkind (P) = N_Or_Else or else
- Nkind (P) = N_And_Then or else
- Nkind (P) = N_If_Statement or else
- Nkind (P) = N_Case_Statement
+ if Nkind_In (P, N_Or_Else,
+ N_And_Then,
+ N_If_Statement,
+ N_Case_Statement)
then
return False;
Require_Entity (N);
end if;
- -- If the context expects a value, and the name is a procedure,
- -- this is most likely a missing 'Access. Do not try to resolve
- -- the parameterless call, error will be caught when the outer
- -- call is analyzed.
+ -- If the context expects a value, and the name is a procedure, this is
+ -- most likely a missing 'Access. Don't try to resolve the parameterless
+ -- call, error will be caught when the outer call is analyzed.
if Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Procedure
and then not Is_Overloaded (N)
and then
- (Nkind (Parent (N)) = N_Parameter_Association
- or else Nkind (Parent (N)) = N_Function_Call
- or else Nkind (Parent (N)) = N_Procedure_Call_Statement)
+ Nkind_In (Parent (N), N_Parameter_Association,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
then
return;
end if;
- -- Rewrite as call if overloadable entity that is (or could be, in
- -- the overloaded case) a function call. If we know for sure that
- -- the entity is an enumeration literal, we do not rewrite it.
+ -- Rewrite as call if overloadable entity that is (or could be, in the
+ -- overloaded case) a function call. If we know for sure that the entity
+ -- is an enumeration literal, we do not rewrite it.
if (Is_Entity_Name (N)
and then Is_Overloadable (Entity (N))
Set_Entity (Op_Node, Op_Id);
Generate_Reference (Op_Id, N, ' ');
- Rewrite (N, Op_Node);
+
+ -- Do rewrite setting Comes_From_Source on the result if the original
+ -- call came from source. Although it is not strictly the case that the
+ -- operator as such comes from the source, logically it corresponds
+ -- exactly to the function call in the source, so it should be marked
+ -- this way (e.g. to make sure that validity checks work fine).
+
+ declare
+ CS : constant Boolean := Comes_From_Source (N);
+ begin
+ Rewrite (N, Op_Node);
+ Set_Comes_From_Source (N, CS);
+ end;
-- If this is an arithmetic operator and the result type is private,
-- the operands and the result must be wrapped in conversion to
return Kind;
end Operator_Kind;
- -----------------------------
- -- Pre_Analyze_And_Resolve --
- -----------------------------
+ ----------------------------
+ -- Preanalyze_And_Resolve --
+ ----------------------------
- procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is
+ procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
begin
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
- end Pre_Analyze_And_Resolve;
+ end Preanalyze_And_Resolve;
-- Version without context type
- procedure Pre_Analyze_And_Resolve (N : Node_Id) is
+ procedure Preanalyze_And_Resolve (N : Node_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
begin
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
- end Pre_Analyze_And_Resolve;
+ end Preanalyze_And_Resolve;
----------------------------------
-- Replace_Actual_Discriminants --
Intval => UR_To_Uint (Realval (N))));
Set_Etype (N, Universal_Integer);
Set_Is_Static_Expression (N);
+
elsif Nkind (N) = N_String_Literal
and then Is_Character_Type (Typ)
then
-- of the arguments is Any_Type, and if so, suppress
-- the message, since it is a cascaded error.
- if Nkind (N) = N_Function_Call
- or else Nkind (N) = N_Procedure_Call_Statement
+ if Nkind_In (N, N_Function_Call,
+ N_Procedure_Call_Statement)
then
declare
A : Node_Id;
-- with a name that is an explicit dereference, there is
-- nothing to be done at this point.
- elsif Nkind (N) = N_Explicit_Dereference
- or else Nkind (N) = N_Attribute_Reference
- or else Nkind (N) = N_And_Then
- or else Nkind (N) = N_Indexed_Component
- or else Nkind (N) = N_Or_Else
- or else Nkind (N) = N_Range
- or else Nkind (N) = N_Selected_Component
- or else Nkind (N) = N_Slice
+ elsif Nkind_In (N, N_Explicit_Dereference,
+ N_Attribute_Reference,
+ N_And_Then,
+ N_Indexed_Component,
+ N_Or_Else,
+ N_Range,
+ N_Selected_Component,
+ N_Slice)
or else Nkind (Name (N)) = N_Explicit_Dereference
then
null;
-- For procedure or function calls, set the type of the name,
-- and also the entity pointer for the prefix
- elsif (Nkind (N) = N_Procedure_Call_Statement
- or else Nkind (N) = N_Function_Call)
+ elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call)
and then (Is_Entity_Name (Name (N))
or else Nkind (Name (N)) = N_Operator_Symbol)
then
elsif Present (Alias (Entity (N)))
and then
- Nkind (Parent (Parent (Entity (N))))
- = N_Subprogram_Renaming_Declaration
+ Nkind (Parent (Parent (Entity (N)))) =
+ N_Subprogram_Renaming_Declaration
then
Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ);
Prev : Node_Id := Empty;
Orig_A : Node_Id;
+ procedure Check_Argument_Order;
+ -- Performs a check for the case where the actuals are all simple
+ -- identifiers that correspond to the formal names, but in the wrong
+ -- order, which is considered suspicious and cause for a warning.
+
procedure Check_Prefixed_Call;
-- If the original node is an overloaded call in prefix notation,
-- insert an 'Access or a dereference as needed over the first actual.
-- common type. Used to enforce the restrictions on array conversions
-- of AI95-00246.
+ --------------------------
+ -- Check_Argument_Order --
+ --------------------------
+
+ procedure Check_Argument_Order is
+ begin
+ -- Nothing to do if no parameters, or original node is neither a
+ -- function call nor a procedure call statement (happens in the
+ -- operator-transformed-to-function call case), or the call does
+ -- not come from source, or this warning is off.
+
+ if not Warn_On_Parameter_Order
+ or else
+ No (Parameter_Associations (N))
+ or else
+ not Nkind_In (Original_Node (N), N_Procedure_Call_Statement,
+ N_Function_Call)
+ or else
+ not Comes_From_Source (N)
+ then
+ return;
+ end if;
+
+ declare
+ Nargs : constant Nat := List_Length (Parameter_Associations (N));
+
+ begin
+ -- Nothing to do if only one parameter
+
+ if Nargs < 2 then
+ return;
+ end if;
+
+ -- Here if at least two arguments
+
+ declare
+ Actuals : array (1 .. Nargs) of Node_Id;
+ Actual : Node_Id;
+ Formal : Node_Id;
+
+ Wrong_Order : Boolean := False;
+ -- Set True if an out of order case is found
+
+ begin
+ -- Collect identifier names of actuals, fail if any actual is
+ -- not a simple identifier, and record max length of name.
+
+ Actual := First (Parameter_Associations (N));
+ for J in Actuals'Range loop
+ if Nkind (Actual) /= N_Identifier then
+ return;
+ else
+ Actuals (J) := Actual;
+ Next (Actual);
+ end if;
+ end loop;
+
+ -- If we got this far, all actuals are identifiers and the list
+ -- of their names is stored in the Actuals array.
+
+ Formal := First_Formal (Nam);
+ for J in Actuals'Range loop
+
+ -- If we ran out of formals, that's odd, probably an error
+ -- which will be detected elsewhere, but abandon the search.
+
+ if No (Formal) then
+ return;
+ end if;
+
+ -- If name matches and is in order OK
+
+ if Chars (Formal) = Chars (Actuals (J)) then
+ null;
+
+ else
+ -- If no match, see if it is elsewhere in list and if so
+ -- flag potential wrong order if type is compatible.
+
+ for K in Actuals'Range loop
+ if Chars (Formal) = Chars (Actuals (K))
+ and then
+ Has_Compatible_Type (Actuals (K), Etype (Formal))
+ then
+ Wrong_Order := True;
+ goto Continue;
+ end if;
+ end loop;
+
+ -- No match
+
+ return;
+ end if;
+
+ <<Continue>> Next_Formal (Formal);
+ end loop;
+
+ -- If Formals left over, also probably an error, skip warning
+
+ if Present (Formal) then
+ return;
+ end if;
+
+ -- Here we give the warning if something was out of order
+
+ if Wrong_Order then
+ Error_Msg_N
+ ("actuals for this call may be in wrong order?", N);
+ end if;
+ end;
+ end;
+ end Check_Argument_Order;
+
-------------------------
-- Check_Prefixed_Call --
-------------------------
-- Start of processing for Resolve_Actuals
begin
+ Check_Argument_Order;
+
if Present (First_Actual (N)) then
Check_Prefixed_Call;
end if;
-- Case where actual is present
- -- If the actual is an entity, generate a reference to it now. We
+ -- If the actual is an entity, generate a reference to it now. We
-- do this before the actual is resolved, because a formal of some
-- protected subprogram, or a task discriminant, will be rewritten
-- during expansion, and the reference to the source entity may
and then Ekind (F) /= E_In_Parameter
then
Generate_Reference (Orig_A, A, 'm');
-
elsif not Is_Overloaded (A) then
Generate_Reference (Orig_A, A);
end if;
or else
Chars (Selector_Name (Parent (A))) = Chars (F))
then
+ -- If style checking mode on, check match of formal name
+
+ if Style_Check then
+ if Nkind (Parent (A)) = N_Parameter_Association then
+ Check_Identifier (Selector_Name (Parent (A)), F);
+ end if;
+ end if;
+
-- If the formal is Out or In_Out, do not resolve and expand the
-- conversion, because it is subsequently expanded into explicit
-- temporaries and assignments. However, the object of the
if Has_Aliased_Components (Etype (Expression (A)))
/= Has_Aliased_Components (Etype (F))
then
- if Ada_Version < Ada_05 then
- Error_Msg_N
- ("both component types in a view conversion must be"
- & " aliased, or neither", A);
- -- Ada 2005: rule is relaxed (see AI-363)
+ -- In a view conversion, the conversion must be legal in
+ -- both directions, and thus both component types must be
+ -- aliased, or neither (4.6 (8)).
- elsif Has_Aliased_Components (Etype (F))
- and then
- not Has_Aliased_Components (Etype (Expression (A)))
+ -- The additional rule 4.6 (24.9.2) seems unduly
+ -- restrictive: the privacy requirement should not
+ -- apply to generic types, and should be checked in
+ -- an instance. ARG query is in order.
+
+ Error_Msg_N
+ ("both component types in a view conversion must be"
+ & " aliased, or neither", A);
+
+ elsif
+ not Same_Ancestor (Etype (F), Etype (Expression (A)))
+ then
+ if Is_By_Reference_Type (Etype (F))
+ or else Is_By_Reference_Type (Etype (Expression (A)))
then
Error_Msg_N
- ("view conversion operand must have aliased " &
- "components", N);
- Error_Msg_N
- ("\since target type has aliased components", N);
+ ("view conversion between unrelated by reference " &
+ "array types not allowed (\'A'I-00246)", A);
+ else
+ declare
+ Comp_Type : constant Entity_Id :=
+ Component_Type
+ (Etype (Expression (A)));
+ begin
+ if Comes_From_Source (A)
+ and then Ada_Version >= Ada_05
+ and then
+ ((Is_Private_Type (Comp_Type)
+ and then not Is_Generic_Type (Comp_Type))
+ or else Is_Tagged_Type (Comp_Type)
+ or else Is_Volatile (Comp_Type))
+ then
+ Error_Msg_N
+ ("component type of a view conversion cannot"
+ & " be private, tagged, or volatile"
+ & " (RM 4.6 (24))",
+ Expression (A));
+ end if;
+ end;
end if;
-
- elsif not Same_Ancestor (Etype (F), Etype (Expression (A)))
- and then
- (Is_By_Reference_Type (Etype (F))
- or else Is_By_Reference_Type (Etype (Expression (A))))
- then
- Error_Msg_N
- ("view conversion between unrelated by reference " &
- "array types not allowed (\'A'I-00246)", A);
end if;
end if;
declare
DDT : constant Entity_Id :=
Directly_Designated_Type (Base_Type (Etype (F)));
+
New_Itype : Entity_Id;
+
begin
if Is_Class_Wide_Type (DDT)
and then Is_Interface (DDT)
then
New_Itype := Create_Itype (E_Anonymous_Access_Type, A);
- Set_Etype (New_Itype, Etype (A));
- Init_Size_Align (New_Itype);
+ Set_Etype (New_Itype, Etype (A));
Set_Directly_Designated_Type (New_Itype,
Directly_Designated_Type (Etype (A)));
Set_Etype (A, New_Itype);
-- enabled only, otherwise the transient scope will not
-- be removed in the expansion of the wrapped construct.
- if (Is_Controlled (DDT)
- or else Has_Task (DDT))
+ if (Is_Controlled (DDT) or else Has_Task (DDT))
and then Expander_Active
then
Establish_Transient_Scope (A, False);
-- a tagged synchronized type, declared outside of the type.
-- In this case the controlling actual must be converted to
-- its corresponding record type, which is the formal type.
+ -- The actual may be a subtype, either because of a constraint
+ -- or because it is a generic actual, so use base type to
+ -- locate concurrent type.
if Is_Concurrent_Type (Etype (A))
- and then Etype (F) = Corresponding_Record_Type (Etype (A))
+ and then Etype (F) =
+ Corresponding_Record_Type (Base_Type (Etype (A)))
then
Rewrite (A,
Unchecked_Convert_To
if Ekind (F) /= E_In_Parameter then
-- For an Out parameter, check for useless assignment. Note
- -- that we can't set Last_Assignment this early, because we
- -- may kill current values in Resolve_Call, and that call
- -- would clobber the Last_Assignment field.
+ -- that we can't set Last_Assignment this early, because we may
+ -- kill current values in Resolve_Call, and that call would
+ -- clobber the Last_Assignment field.
- -- Note: call Warn_On_Useless_Assignment before doing the
- -- check below for Is_OK_Variable_For_Out_Formal so that the
- -- setting of Referenced_As_LHS/Referenced_As_Out_Formal
- -- properly reflects the last assignment, not this one!
+ -- Note: call Warn_On_Useless_Assignment before doing the check
+ -- below for Is_OK_Variable_For_Out_Formal so that the setting
+ -- of Referenced_As_LHS/Referenced_As_Out_Formal properly
+ -- reflects the last assignment, not this one!
if Ekind (F) = E_Out_Parameter then
if Warn_On_Modified_As_Out_Parameter (F)
end if;
-- An actual associated with an access parameter is implicitly
- -- converted to the anonymous access type of the formal and
- -- must satisfy the legality checks for access conversions.
+ -- converted to the anonymous access type of the formal and must
+ -- satisfy the legality checks for access conversions.
if Ekind (F_Typ) = E_Anonymous_Access_Type then
if not Valid_Conversion (A, F_Typ, A) then
function In_Dispatching_Context return Boolean is
Par : constant Node_Id := Parent (N);
begin
- return (Nkind (Par) = N_Function_Call
- or else Nkind (Par) = N_Procedure_Call_Statement)
+ return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement)
and then Is_Entity_Name (Name (Par))
and then Is_Dispatching_Operation (Entity (Name (Par)));
end In_Dispatching_Context;
Aggr := Original_Node (Expression (E));
if Has_Discriminants (Subtyp)
- and then
- (Nkind (Aggr) = N_Aggregate
- or else
- Nkind (Aggr) = N_Extension_Aggregate)
+ and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate)
then
Discrim := First_Discriminant (Base_Type (Subtyp));
-- N is the expression after "delta" in a fixed_point_definition;
-- see RM-3.5.9(6):
- return Nkind (Parent (N)) = N_Ordinary_Fixed_Point_Definition
- or else Nkind (Parent (N)) = N_Decimal_Fixed_Point_Definition
+ return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition,
+ N_Decimal_Fixed_Point_Definition,
-- N is one of the bounds in a real_range_specification;
-- see RM-3.5.7(5):
- or else Nkind (Parent (N)) = N_Real_Range_Specification
+ N_Real_Range_Specification,
-- N is the expression of a delta_constraint;
-- see RM-J.3(3):
- or else Nkind (Parent (N)) = N_Delta_Constraint;
+ N_Delta_Constraint);
end Expected_Type_Is_Any_Real;
-----------------------------
-- conversion to a specific fixed-point type (instead the expander
-- takes care of the case).
- elsif (B_Typ = Universal_Integer
- or else B_Typ = Universal_Real)
+ elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real)
and then Present (Universal_Interpretation (L))
and then Present (Universal_Interpretation (R))
then
Set_Etype (N, B_Typ);
elsif (B_Typ = Universal_Real
- or else Etype (N) = Universal_Fixed
- or else (Etype (N) = Any_Fixed
- and then Is_Fixed_Point_Type (B_Typ))
- or else (Is_Fixed_Point_Type (B_Typ)
- and then (Is_Integer_Or_Universal (L)
- or else
- Is_Integer_Or_Universal (R))))
- and then (Nkind (N) = N_Op_Multiply or else
- Nkind (N) = N_Op_Divide)
+ or else Etype (N) = Universal_Fixed
+ or else (Etype (N) = Any_Fixed
+ and then Is_Fixed_Point_Type (B_Typ))
+ or else (Is_Fixed_Point_Type (B_Typ)
+ and then (Is_Integer_Or_Universal (L)
+ or else
+ Is_Integer_Or_Universal (R))))
+ and then Nkind_In (N, N_Op_Multiply, N_Op_Divide)
then
if TL = Universal_Integer or else TR = Universal_Integer then
Check_For_Visible_Operator (N, B_Typ);
Set_Mixed_Mode_Operand (R, TL);
end if;
- -- Check the rule in RM05-4.5.5(19.1/2) disallowing the
- -- universal_fixed multiplying operators from being used when the
- -- expected type is also universal_fixed. Note that B_Typ will be
- -- Universal_Fixed in some cases where the expected type is actually
- -- Any_Real; Expected_Type_Is_Any_Real takes care of that case.
+ -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed
+ -- multiplying operators from being used when the expected type is
+ -- also universal_fixed. Note that B_Typ will be Universal_Fixed in
+ -- some cases where the expected type is actually Any_Real;
+ -- Expected_Type_Is_Any_Real takes care of that case.
if Etype (N) = Universal_Fixed
or else Etype (N) = Any_Fixed
then
if B_Typ = Universal_Fixed
and then not Expected_Type_Is_Any_Real (N)
- and then Nkind (Parent (N)) /= N_Type_Conversion
- and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
+ and then not Nkind_In (Parent (N), N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
then
- Error_Msg_N
- ("type cannot be determined from context!", N);
- Error_Msg_N
- ("\explicit conversion to result type required", N);
+ Error_Msg_N ("type cannot be determined from context!", N);
+ Error_Msg_N ("\explicit conversion to result type required", N);
Set_Etype (L, Any_Type);
Set_Etype (R, Any_Type);
else
if Ada_Version = Ada_83
- and then Etype (N) = Universal_Fixed
- and then Nkind (Parent (N)) /= N_Type_Conversion
- and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
+ and then Etype (N) = Universal_Fixed
+ and then not
+ Nkind_In (Parent (N), N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
then
Error_Msg_N
- ("(Ada 83) fixed-point operation " &
- "needs explicit conversion",
- N);
+ ("(Ada 83) fixed-point operation "
+ & "needs explicit conversion", N);
end if;
-- The expected type is "any real type" in contexts like
and then (Is_Integer_Or_Universal (L)
or else Nkind (L) = N_Real_Literal
or else Nkind (R) = N_Real_Literal
- or else
- Is_Integer_Or_Universal (R))
+ or else Is_Integer_Or_Universal (R))
then
Set_Etype (N, B_Typ);
else
if (TL = Universal_Integer or else TL = Universal_Real)
- and then (TR = Universal_Integer or else TR = Universal_Real)
+ and then
+ (TR = Universal_Integer or else TR = Universal_Real)
then
Check_For_Visible_Operator (N, B_Typ);
end if;
-- universal fixed, this is an error, unless there is only one
-- applicable fixed_point type (usually duration).
- if B_Typ = Universal_Fixed
- and then Etype (L) = Universal_Fixed
- then
+ if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then
T := Unique_Fixed_Point_Type (N);
if T = Any_Type then
-- Give warning if explicit division by zero
- if (Nkind (N) = N_Op_Divide
- or else Nkind (N) = N_Op_Rem
- or else Nkind (N) = N_Op_Mod)
+ if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod)
and then not Division_Checks_Suppressed (Etype (N))
then
Rop := Right_Opnd (N);
if Compile_Time_Known_Value (Rop)
and then ((Is_Integer_Type (Etype (Rop))
- and then Expr_Value (Rop) = Uint_0)
+ and then Expr_Value (Rop) = Uint_0)
or else
(Is_Real_Type (Etype (Rop))
- and then Expr_Value_R (Rop) = Ureal_0))
+ and then Expr_Value_R (Rop) = Ureal_0))
then
-- Specialize the warning message according to the operation
Activate_Division_Check (N);
end if;
end if;
+
+ -- If Restriction No_Implicit_Conditionals is active, then it is
+ -- violated if either operand can be negative for mod, or for rem
+ -- if both operands can be negative.
+
+ if Restrictions.Set (No_Implicit_Conditionals)
+ and then Nkind_In (N, N_Op_Rem, N_Op_Mod)
+ then
+ declare
+ Lo : Uint;
+ Hi : Uint;
+ OK : Boolean;
+
+ LNeg : Boolean;
+ RNeg : Boolean;
+ -- Set if corresponding operand might be negative
+
+ begin
+ Determine_Range (Left_Opnd (N), OK, Lo, Hi);
+ LNeg := (not OK) or else Lo < 0;
+
+ Determine_Range (Right_Opnd (N), OK, Lo, Hi);
+ RNeg := (not OK) or else Lo < 0;
+
+ if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg))
+ or else
+ (Nkind (N) = N_Op_Mod and then (LNeg or RNeg))
+ then
+ Check_Restriction (No_Implicit_Conditionals, N);
+ end if;
+ end;
+ end if;
end if;
Check_Unset_Reference (L);
-- operations use the same circuitry because the name in the call
-- can be an arbitrary expression with special resolution rules.
- elsif Nkind (Subp) = N_Selected_Component
- or else Nkind (Subp) = N_Indexed_Component
+ elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component)
or else (Is_Entity_Name (Subp)
and then Ekind (Entity (Subp)) = E_Entry)
then
P := N;
loop
P := Parent (P);
- exit when No (P);
+
+ -- Exclude calls that occur within the default of a formal
+ -- parameter of the entry, since those are evaluated outside
+ -- of the body.
+
+ exit when No (P) or else Nkind (P) = N_Parameter_Specification;
if Nkind (P) = N_Entry_Body
or else (Nkind (P) = N_Subprogram_Body
- and then Is_Entry_Barrier_Function (P))
+ and then Is_Entry_Barrier_Function (P))
then
Rtype := Etype (N);
Error_Msg_NE
Error_Msg_N ("\cannot call operation that may modify it", N);
end if;
- -- Freeze the subprogram name if not in default expression. Note that we
+ -- Freeze the subprogram name if not in a spec-expression. Note that we
-- freeze procedure calls as well as function calls. Procedure calls are
-- not frozen according to the rules (RM 13.14(14)) because it is
-- impossible to have a procedure call to a non-frozen procedure in pure
-- needs extending because we can generate procedure calls that need
-- freezing.
- if Is_Entity_Name (Subp) and then not In_Default_Expression then
+ if Is_Entity_Name (Subp) and then not In_Spec_Expression then
Freeze_Expression (Subp);
end if;
-- If the subprogram is marked Inline_Always, then even if it returns
-- an unconstrained type the call does not require use of the secondary
- -- stack.
+ -- stack. However, inlining will only take place if the body to inline
+ -- is already present. It may not be available if e.g. the subprogram is
+ -- declared in a child instance.
if Is_Inlined (Nam)
- and then Present (First_Rep_Item (Nam))
- and then Nkind (First_Rep_Item (Nam)) = N_Pragma
- and then Pragma_Name (First_Rep_Item (Nam)) = Name_Inline_Always
+ and then Has_Pragma_Inline_Always (Nam)
+ and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
+ and then Present (Body_To_Inline (Unit_Declaration_Node (Nam)))
then
null;
-- way we still take advantage of the current value information while
-- scanning the actuals.
- if (not Is_Library_Level_Entity (Nam)
- or else Suppress_Value_Tracking_On_Call (Current_Scope))
+ -- We suppress killing values if we are processing the nodes associated
+ -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged
+ -- type kills all the values as part of analyzing the code that
+ -- initializes the dispatch tables.
+
+ if Inside_Freezing_Actions = 0
+ and then (not Is_Library_Level_Entity (Nam)
+ or else Suppress_Value_Tracking_On_Call (Current_Scope))
and then (Comes_From_Source (Nam)
or else (Present (Alias (Nam))
and then Comes_From_Source (Alias (Nam))))
and then Comes_From_Source (E)
and then No (Constant_Value (E))
and then Is_Frozen (Etype (E))
- and then not In_Default_Expression
+ and then not In_Spec_Expression
and then not Is_Imported (E)
then
(Corresponding_Equality (Entity (N)))
then
Eval_Relational_Op (N);
+
elsif Nkind (N) = N_Op_Ne
and then Is_Abstract_Subprogram (Entity (N))
then
-- In the common case of a call which uses an explicitly null
-- value for an access parameter, give specialized error msg
- if Nkind (Parent (N)) = N_Procedure_Call_Statement
- or else
- Nkind (Parent (N)) = N_Function_Call
+ if Nkind_In (Parent (N), N_Procedure_Call_Statement,
+ N_Function_Call)
then
Error_Msg_N
("null is not allowed as argument for an access parameter", N);
-- sequences that otherwise fail to notice the modification.
if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
- Note_Possible_Modification (P);
+ Note_Possible_Modification (P, Sure => False);
end if;
end Resolve_Reference;
Resolve (L, B_Typ);
Resolve (R, B_Typ);
- -- Check for issuing warning for always False assert, this happens
- -- when assertions are turned off, in which case the pragma Assert
+ -- Check for issuing warning for always False assert/check, this happens
+ -- when assertions are turned off, in which case the pragma Assert/Check
-- was transformed into:
-- if False and then <condition> then ...
then
declare
Orig : constant Node_Id := Original_Node (Parent (N));
+
begin
if Nkind (Orig) = N_Pragma
and then Pragma_Name (Orig) = Name_Assert
Error_Msg_N ("?assertion would fail at run-time", Orig);
end if;
end;
+
+ -- Similar processing for Check pragma
+
+ elsif Nkind (Orig) = N_Pragma
+ and then Pragma_Name (Orig) = Name_Check
+ then
+ -- Don't want to warn if original condition is explicit False
+
+ declare
+ Expr : constant Node_Id :=
+ Original_Node
+ (Expression
+ (Next (First
+ (Pragma_Argument_Associations (Orig)))));
+ begin
+ if Is_Entity_Name (Expr)
+ and then Entity (Expr) = Standard_False
+ then
+ null;
+ else
+ Error_Msg_N ("?check would fail at run-time", Orig);
+ end if;
+ end;
end if;
end;
end if;
elsif Nkind (Parent (N)) = N_Op_Concat
and then not Need_Check
- and then Nkind (Original_Node (N)) /= N_Character_Literal
- and then Nkind (Original_Node (N)) /= N_Attribute_Reference
- and then Nkind (Original_Node (N)) /= N_Qualified_Expression
- and then Nkind (Original_Node (N)) /= N_Type_Conversion
+ and then not Nkind_In (Original_Node (N), N_Character_Literal,
+ N_Attribute_Reference,
+ N_Qualified_Expression,
+ N_Type_Conversion)
then
Subtype_Id := Typ;
-- Otherwise we must create a string literal subtype. Note that the
-- whole idea of string literal subtypes is simply to avoid the need
-- for building a full fledged array subtype for each literal.
+
else
Set_String_Literal_Subtype (N, Typ);
Subtype_Id := Etype (N);
-- corresponding character aggregate and let the aggregate
-- code do the checking.
- if R_Typ = Standard_Character
- or else R_Typ = Standard_Wide_Character
- or else R_Typ = Standard_Wide_Wide_Character
- then
+ if Is_Standard_Character_Type (R_Typ) then
+
-- Check for the case of full range, where we are definitely OK
if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
Set_Etype (Operand, Universal_Real);
elsif Is_Numeric_Type (Typ)
- and then (Nkind (Operand) = N_Op_Multiply
- or else Nkind (Operand) = N_Op_Divide)
+ and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide)
and then (Etype (Right_Opnd (Operand)) = Universal_Real
- or else Etype (Left_Opnd (Operand)) = Universal_Real)
+ or else
+ Etype (Left_Opnd (Operand)) = Universal_Real)
then
-- Return if expression is ambiguous
-- mod. These are the cases where the grouping can affect results.
if Paren_Count (Rorig) = 0
- and then (Nkind (Rorig) = N_Op_Mod
- or else
- Nkind (Rorig) = N_Op_Multiply
- or else
- Nkind (Rorig) = N_Op_Divide)
+ and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide)
then
-- For mod, we always give the warning, since the value is
-- affected by the parenthesization (e.g. (-5) mod 315 /=
-- overflow is impossible (divisor > 1) or we have a case of
-- division by zero in any case.
- if (Nkind (Rorig) = N_Op_Divide
- or else
- Nkind (Rorig) = N_Op_Rem)
+ if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem)
and then Compile_Time_Known_Value (Right_Opnd (Rorig))
and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1
then
Set_First_Index (Slice_Subtype, Index);
Set_Etype (Slice_Subtype, Base_Type (Etype (N)));
Set_Is_Constrained (Slice_Subtype, True);
- Init_Size_Align (Slice_Subtype);
Check_Compile_Time_Size (Slice_Subtype);
-- call to Check_Compile_Time_Size could be eliminated, which would
-- be nice, because then that routine could be made private to Freeze.
- if Is_Packed (Slice_Subtype) and not In_Default_Expression then
+ -- Why the test for In_Spec_Expression here ???
+
+ if Is_Packed (Slice_Subtype) and not In_Spec_Expression then
Freeze_Itype (Slice_Subtype, N);
end if;
Set_First_Index (Array_Subtype, Index);
Set_Etype (Array_Subtype, Base_Type (Typ));
Set_Is_Constrained (Array_Subtype, True);
- Init_Size_Align (Array_Subtype);
Rewrite (N,
Make_Unchecked_Type_Conversion (Loc,
if Nkind (N) = N_Real_Literal then
Error_Msg_NE ("?real literal interpreted as }!", N, T1);
-
else
Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1);
end if;
return False;
end if;
- -- Check that component subtypes statically match
+ -- Check that component subtypes statically match. For numeric
+ -- types this means that both must be either constrained or
+ -- unconstrained. For enumeration types the bounds must match.
+ -- All of this is checked in Subtypes_Statically_Match.
- if Is_Constrained (Target_Comp_Type) /=
- Is_Constrained (Opnd_Comp_Type)
- or else not Subtypes_Statically_Match
+ if not Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type)
then
Error_Msg_N
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) >
- Type_Access_Level (Target_Type)
+ Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we
-- know will fail, so generate an appropriate warning.
-- handles checking the prefix of the operand for this case.)
if Nkind (Operand) = N_Selected_Component
- and then Object_Access_Level (Operand)
- > Type_Access_Level (Target_Type)
+ and then Object_Access_Level (Operand) >
+ Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we
-- know will fail, so generate an appropriate warning.
OSDN Git Service
