[multiple changes]
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. From-SVN: r216377
This commit is contained in:
Arnaud Charlet
parent
c3ed5e9eaf
commit
dc06dd8366
6 changed files with 155 additions and 52 deletions
|
|
@ -1,3 +1,34 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -203,6 +203,12 @@ package body Ada.Strings.Search is
|
|||
Last : out Natural)
|
||||
is
|
||||
begin
|
||||
-- AI05-031: Raise Index error if Source non-empty and From not in range
|
||||
|
||||
if Source'Length /= 0 and then From not in Source'Range then
|
||||
raise Index_Error;
|
||||
end if;
|
||||
|
||||
for J in From .. Source'Last loop
|
||||
if Belongs (Source (J), Set, Test) then
|
||||
First := J;
|
||||
|
|
|
|||
|
|
@ -5958,12 +5958,52 @@ package body Freeze is
|
|||
-- 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 --
|
||||
-----------------
|
||||
|
|
@ -6104,7 +6144,10 @@ package body Freeze is
|
|||
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 |
|
||||
|
|
|
|||
|
|
@ -7829,6 +7829,9 @@ pragma Warnings (static_string_EXPRESSION [,REASON]);
|
|||
pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]);
|
||||
|
||||
REASON ::= Reason => STRING_LITERAL @{& STRING_LITERAL@}
|
||||
|
||||
Note: in Ada 83 mode, a string literal may be used in place of
|
||||
a static string expression (which does not exist in Ada 83).
|
||||
@end smallexample
|
||||
|
||||
@noindent
|
||||
|
|
|
|||
|
|
@ -2947,8 +2947,7 @@ package body Sem_Ch13 is
|
|||
-- 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;
|
||||
|
|
@ -3621,10 +3620,10 @@ package body Sem_Ch13 is
|
|||
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;
|
||||
|
|
@ -4269,11 +4268,7 @@ package body Sem_Ch13 is
|
|||
|
||||
-- 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;
|
||||
|
|
@ -4295,7 +4290,7 @@ package body Sem_Ch13 is
|
|||
|
||||
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);
|
||||
|
|
@ -4826,13 +4821,10 @@ package body Sem_Ch13 is
|
|||
-- 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;
|
||||
|
|
@ -4985,14 +4977,12 @@ package body Sem_Ch13 is
|
|||
-- 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;
|
||||
|
|
@ -5828,6 +5818,7 @@ package body Sem_Ch13 is
|
|||
|
||||
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;
|
||||
|
|
@ -7625,6 +7616,29 @@ package body Sem_Ch13 is
|
|||
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.
|
||||
|
|
@ -8501,9 +8515,9 @@ package body Sem_Ch13 is
|
|||
-- 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;
|
||||
|
|
@ -8862,8 +8876,8 @@ package body Sem_Ch13 is
|
|||
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 &!",
|
||||
|
|
@ -8954,11 +8968,8 @@ package body Sem_Ch13 is
|
|||
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
|
||||
|
|
@ -11132,9 +11143,7 @@ package body Sem_Ch13 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)
|
||||
|
|
@ -11849,8 +11858,7 @@ package body Sem_Ch13 is
|
|||
(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;
|
||||
|
|
@ -12739,9 +12747,7 @@ package body Sem_Ch13 is
|
|||
|
||||
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
|
||||
|
|
@ -12858,24 +12864,22 @@ package body Sem_Ch13 is
|
|||
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;
|
||||
|
|
|
|||
|
|
@ -3201,6 +3201,8 @@ package body Sem_Prag is
|
|||
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);
|
||||
|
|
@ -6220,11 +6222,25 @@ package body Sem_Prag is
|
|||
|
||||
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;
|
||||
|
||||
----------------------
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue