+2014-10-17 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Add_Invariants): For a class-wide type invariant,
+ preserve semantic information on the invariant expression
+ (typically a function call) because it may be inherited by a
+ type extension in a different unit, and it cannot be resolved
+ by visibility elsewhere because it may refer to local entities.
+
+2014-10-17 Robert Dewar <dewar@adacore.com>
+
+ * gnat_rm.texi: Document that string literal can be used for
+ pragma Warnings when operating in Ada 83 mode.
+
+2014-10-17 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Find_Aggregate_Component_Desig_Type): New
+ subsidiary function to Freeze_ Expression, used to determine
+ whether an aggregate for an array of access types also freezes the
+ designated type, when some aggregate components are allocators.
+
+2014-10-17 Ed Schonberg <schonberg@adacore.com>
+
+ * a-strsea.adb (Find_Token): AI05-031 indicates that the
+ procedure must raise Index_Error when Source is not empty and
+ the From parameter is not within the range of the Source string.
+
+2014-10-17 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb (Is_Static_String_Expression): Allow string
+ literal in Ada 83 mode.
+
2014-10-17 Vincent Celier <celier@adacore.com>
* prj-conf.adb (Get_Config_Switches): In CodePeer mode, do
-- may reference entities that have to be frozen before the body and
-- obviously cannot be frozen inside the body.
+ function Find_Aggregate_Component_Desig_Type return Entity_Id;
+ -- If the expression is an array aggregate, the type of the component
+ -- expressions is also frozen. If the component type is an access type
+ -- and the expressions include allocators, the designed type is frozen
+ -- as well.
+
function In_Exp_Body (N : Node_Id) return Boolean;
-- Given an N_Handled_Sequence_Of_Statements node N, determines whether
-- it is the handled statement sequence of an expander-generated
-- subprogram (init proc, stream subprogram, or renaming as body).
-- If so, this is not a freezing context.
+ -----------------------------------------
+ -- Find_Aggregate_Component_Desig_Type --
+ -----------------------------------------
+
+ function Find_Aggregate_Component_Desig_Type return Entity_Id is
+ Assoc : Node_Id;
+ Exp : Node_Id;
+
+ begin
+ if Present (Expressions (N)) then
+ Exp := First (Expressions (N));
+ while Present (Exp) loop
+ if Nkind (Exp) = N_Allocator then
+ return Designated_Type (Component_Type (Etype (N)));
+ end if;
+
+ Next (Exp);
+ end loop;
+ end if;
+
+ if Present (Component_Associations (N)) then
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ if Nkind (Expression (Assoc)) = N_Allocator then
+ return Designated_Type (Component_Type (Etype (N)));
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end if;
+
+ return Empty;
+ end Find_Aggregate_Component_Desig_Type;
+
-----------------
-- In_Exp_Body --
-----------------
if Is_Array_Type (Etype (N))
and then Is_Access_Type (Component_Type (Etype (N)))
then
- Desig_Typ := Designated_Type (Component_Type (Etype (N)));
+
+ -- Check whether aggregate includes allocators.
+
+ Desig_Typ := Find_Aggregate_Component_Desig_Type;
end if;
when N_Selected_Component |
-- evaluation of this aspect should be delayed to the
-- freeze point (why???)
- if No (Expr)
- or else Is_True (Static_Boolean (Expr))
+ if No (Expr) or else Is_True (Static_Boolean (Expr))
then
Set_Uses_Lock_Free (E);
end if;
if (Attr = Name_Constant_Indexing
and then Present
(Find_Aspect (Etype (Ent), Aspect_Constant_Indexing)))
-
- or else (Attr = Name_Variable_Indexing
- and then Present
- (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing)))
+ or else
+ (Attr = Name_Variable_Indexing
+ and then Present
+ (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing)))
then
if Debug_Flag_Dot_XX then
null;
-- Case of address clause for a (non-controlled) object
- elsif
- Ekind (U_Ent) = E_Variable
- or else
- Ekind (U_Ent) = E_Constant
- then
+ elsif Ekind_In (U_Ent, E_Variable, E_Constant) then
declare
Expr : constant Node_Id := Expression (N);
O_Ent : Entity_Id;
if Present (O_Ent)
and then (Has_Controlled_Component (Etype (O_Ent))
- or else Is_Controlled (Etype (O_Ent)))
+ or else Is_Controlled (Etype (O_Ent)))
then
Error_Msg_N
("??cannot overlay with controlled object", Expr);
-- except from aspect specification.
if From_Aspect_Specification (N) then
- if not (Is_Protected_Type (U_Ent)
- or else Is_Task_Type (U_Ent))
- then
+ if not Is_Concurrent_Type (U_Ent) then
Error_Msg_N
- ("Interrupt_Priority can only be defined for task" &
- "and protected object",
- Nam);
+ ("Interrupt_Priority can only be defined for task "
+ & "and protected object", Nam);
elsif Duplicate_Clause then
null;
-- aspect specification.
if From_Aspect_Specification (N) then
- if not (Is_Protected_Type (U_Ent)
- or else Is_Task_Type (U_Ent)
+ if not (Is_Concurrent_Type (U_Ent)
or else Ekind (U_Ent) = E_Procedure)
then
Error_Msg_N
- ("Priority can only be defined for task and protected " &
- "object",
- Nam);
+ ("Priority can only be defined for task and protected "
+ & "object", Nam);
elsif Duplicate_Clause then
null;
if Val = No_Uint then
Err := True;
+
elsif Val < Lo or else Hi < Val then
Error_Msg_N ("value outside permitted range", Expr);
Err := True;
Set_Parent (Exp, N);
Preanalyze_Assert_Expression (Exp, Standard_Boolean);
+ -- A class-wide invariant may be inherited in a separate unit,
+ -- where the corresponding expression cannot be resolved by
+ -- visibility, because it refers to a local function. Propagate
+ -- semantic information to the original representation item, to
+ -- be used when an invariant procedure for a derived type is
+ -- constructed.
+
+ -- Unclear how to handle class-wide invariants that are not
+ -- function calls ???
+
+ if not Inherit
+ and then Class_Present (Ritem)
+ and then Nkind (Exp) = N_Function_Call
+ and then Nkind (Arg2) = N_Indexed_Component
+ then
+ Rewrite (Arg2,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Entity (Name (Exp)), Loc),
+ Parameter_Associations =>
+ New_Copy_List (Expressions (Arg2))));
+ end if;
+
-- In ASIS mode, even if assertions are not enabled, we must
-- analyze the original expression in the aspect specification
-- because it is part of the original tree.
-- at the freeze point.
elsif A_Id = Aspect_Input or else
- A_Id = Aspect_Output or else
- A_Id = Aspect_Read or else
- A_Id = Aspect_Write
+ A_Id = Aspect_Output or else
+ A_Id = Aspect_Read or else
+ A_Id = Aspect_Write
then
Analyze (End_Decl_Expr);
Check_Overloaded_Name;
and then Has_Discriminants (T))
or else
(Is_Access_Type (T)
- and then Is_Record_Type (Designated_Type (T))
- and then Has_Discriminants (Designated_Type (T)))
+ and then Is_Record_Type (Designated_Type (T))
+ and then Has_Discriminants (Designated_Type (T)))
then
Error_Msg_NE
("invalid address clause for initialized object &!",
then
return;
- elsif
- Ekind (Ent) = E_Constant
- or else
- Ekind (Ent) = E_In_Parameter
- then
+ elsif Ekind_In (Ent, E_Constant, E_In_Parameter) then
+
-- This is the case where we must have Ent defined before
-- U_Ent. Clearly if they are in different units this
-- requirement is met since the unit containing Ent is
-- need to know such a size, but this routine may be called with a
-- generic type as part of normal processing.
- elsif Is_Generic_Type (R_Typ)
- or else R_Typ = Any_Type
- then
+ elsif Is_Generic_Type (R_Typ) or else R_Typ = Any_Type then
return 0;
-- Access types (cannot have size smaller than System.Address)
(Is_Record_Type (T2) or else Is_Array_Type (T2))
and then
(Component_Alignment (T1) /= Component_Alignment (T2)
- or else
- Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
+ or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
then
return False;
end if;
Prim := First (Choices (Assoc));
- if Nkind (Prim) /= N_Identifier
- or else Present (Next (Prim))
- then
+ if Nkind (Prim) /= N_Identifier or else Present (Next (Prim)) then
Error_Msg_N ("illegal name in association", Prim);
elsif Chars (Prim) = Name_First then
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)
+ 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));
+ 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
- ("?z?representation of 'Time values may change between " &
- "'G'N'A'T versions", N);
+ ("?z?representation of 'Time values may change between "
+ & "'G'N'A'T versions", N);
end if;
end;
end if;
function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
-- Analyzes the argument, and determines if it is a static string
-- expression, returns True if so, False if non-static or not String.
+ -- A special case is that a string literal returns True in Ada 83 mode
+ -- (which has no such thing as static string expressions).
procedure Pragma_Misplaced;
pragma No_Return (Pragma_Misplaced);
function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
begin
Analyze_And_Resolve (Argx);
- return Is_OK_Static_Expression (Argx)
- and then Nkind (Argx) = N_String_Literal;
+
+ -- Special case Ada 83, where the expression will never be static,
+ -- but we will return true if we had a string literal to start with.
+
+ if Ada_Version = Ada_83 then
+ return Lit;
+
+ -- Normal case, true only if we end up with a string literal that
+ -- is marked as being the result of evaluating a static expression.
+
+ else
+ return Is_OK_Static_Expression (Argx)
+ and then Nkind (Argx) = N_String_Literal;
+ end if;
+
end Is_Static_String_Expression;
----------------------
projects / gcc.git / commitdiff