+2015-03-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Ensure_Aggregate_Form):
+ Ensure that the name denoted by the Chars of a pragma argument
+ association has the proper Sloc when converted into an aggregate.
+
+2015-03-02 Bob Duff <duff@adacore.com>
+
+ * sem_ch6.adb (Check_Private_Overriding): Capture
+ Incomplete_Or_Partial_View in a constant. This is cleaner and
+ more efficient.
+
+2015-03-02 Gary Dismukes <dismukes@adacore.com>
+
+ * einfo.ads, exp_unst.ads: Minor reformatting.
+
+2015-03-02 Ed Schonberg <schonberg@adacore.com>
+
+ * a-strsea.adb (Find_Token): Ensure that the range of iteration
+ does not perform any improper character access. This prevents
+ erroneous access in the unusual case of an empty string target
+ and a From parameter less than Source'First.
+
+2015-03-02 Robert Dewar <dewar@adacore.com>
+
+ * elists.adb (List_Length): Fix incorrect result.
+
2015-03-02 Bob Duff <duff@adacore.com>
* sem_ch6.adb (Check_Private_Overriding): Refine the legality
raise Index_Error;
end if;
- for J in From .. Source'Last loop
+ -- If Source is the empty string, From may still be out of its
+ -- range. The following ensures that in all cases there is no
+ -- possible erroneous access to a non-existing character.
+
+ for J in Integer'Max (From, Source'First) .. Source'Last loop
if Belongs (Source (J), Set, Test) then
First := J;
-- the case where we are unnesting nested subprograms (in which case it
-- is also set for types and subtypes which are not static types, and
-- that are referenced uplevel, as well as for subprograms that contain
--- uplevel references or call other subprogram, see Exp_unst for details.
+-- uplevel references or call other subprograms (Exp_Unst has details).
-- Has_Visible_Refinement (Flag263)
-- Defined in E_Abstract_State entities. Set when a state has at least
-- type is known to be a static type (defined as a discrete type with
-- static bounds, a record all of whose component types are static types,
-- or an array, all of whose bounds are of a static type, and also have
--- a component type that is a static type. See Set_Uplevel_Type for more
+-- a component type that is a static type). See Set_Uplevel_Type for more
-- information on how this flag is used. Note that if Is_Static_Type is
-- True, then it is never the case that the Has_Uplevel_Reference flag is
-- set for the same type.
if No (Elmt) then
return N;
else
+ N := N + 1;
Next_Elmt (Elmt);
end if;
end loop;
-- xxx is replaced by Tnn!(AREC1.xxx).all (where ! represents a call
-- to unchecked conversion to convert the address to the access type
-- and Tnn is a locally declared type that is "access all t", where t
- -- is the type of the reference.
+ -- is the type of the reference).
-- Note: the reason that we use Address as the component type in the
-- declaration of AREC1T is that we may create this type before we see
procedure Check_Private_Overriding (T : Entity_Id) is
- function Overrides_Visible_Function return Boolean;
+ function Overrides_Visible_Function
+ (Partial_View : Entity_Id) return Boolean;
-- True if S overrides a function in the visible part. The
-- overridden function could be explicitly or implicitly declared.
- function Overrides_Visible_Function return Boolean is
+ function Overrides_Visible_Function
+ (Partial_View : Entity_Id) return Boolean
+ is
begin
if not Is_Overriding or else not Has_Homonym (S) then
return False;
end if;
- if not Present (Incomplete_Or_Partial_View (T)) then
+ if not Present (Partial_View) then
return True;
end if;
-- Search through all the homonyms H of S in the current
-- package spec, and return True if we find one that matches.
-- Note that Parent (H) will be the declaration of the
- -- Incomplete_Or_Partial_View of T for a match.
+ -- partial view of T for a match.
declare
H : Entity_Id := S;
(Parent (H),
N_Private_Extension_Declaration,
N_Private_Type_Declaration)
- and then Defining_Identifier (Parent (H)) =
- Incomplete_Or_Partial_View (T)
+ and then Defining_Identifier (Parent (H)) = Partial_View
then
return True;
end if;
Error_Msg_N ("abstract subprograms must be visible "
& "(RM 3.9.3(10))!", S);
- elsif Ekind (S) = E_Function
- and then not Overrides_Visible_Function
- then
- -- Here, S is "function ... return T;" declared in the
- -- private part, not overriding some visible operation.
- -- That's illegal in the tagged case (but not if the
- -- private type is untagged).
-
- if ((Present (Incomplete_Or_Partial_View (T))
- and then Is_Tagged_Type (Incomplete_Or_Partial_View (T)))
- or else (not Present (Incomplete_Or_Partial_View (T))
- and then Is_Tagged_Type (T)))
- and then T = Base_Type (Etype (S))
- then
- Error_Msg_N ("private function with tagged result must"
- & " override visible-part function", S);
- Error_Msg_N ("\move subprogram to the visible part"
- & " (RM 3.9.3(10))", S);
+ elsif Ekind (S) = E_Function then
+ declare
+ Partial_View : constant Entity_Id :=
+ Incomplete_Or_Partial_View (T);
- -- AI05-0073: extend this test to the case of a function
- -- with a controlling access result.
+ begin
+ if not Overrides_Visible_Function (Partial_View) then
+
+ -- Here, S is "function ... return T;" declared in
+ -- the private part, not overriding some visible
+ -- operation. That's illegal in the tagged case
+ -- (but not if the private type is untagged).
+
+ if ((Present (Partial_View)
+ and then Is_Tagged_Type (Partial_View))
+ or else (not Present (Partial_View)
+ and then Is_Tagged_Type (T)))
+ and then T = Base_Type (Etype (S))
+ then
+ Error_Msg_N
+ ("private function with tagged result must"
+ & " override visible-part function", S);
+ Error_Msg_N
+ ("\move subprogram to the visible part"
+ & " (RM 3.9.3(10))", S);
- elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
- and then Is_Tagged_Type (Designated_Type (Etype (S)))
- and then
- not Is_Class_Wide_Type (Designated_Type (Etype (S)))
- and then Ada_Version >= Ada_2012
- then
- Error_Msg_N
- ("private function with controlling access result "
- & "must override visible-part function", S);
- Error_Msg_N
- ("\move subprogram to the visible part"
- & " (RM 3.9.3(10))", S);
- end if;
+ -- AI05-0073: extend this test to the case of a
+ -- function with a controlling access result.
+
+ elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
+ and then Is_Tagged_Type (Designated_Type (Etype (S)))
+ and then
+ not Is_Class_Wide_Type
+ (Designated_Type (Etype (S)))
+ and then Ada_Version >= Ada_2012
+ then
+ Error_Msg_N
+ ("private function with controlling access "
+ & "result must override visible-part function",
+ S);
+ Error_Msg_N
+ ("\move subprogram to the visible part"
+ & " (RM 3.9.3(10))", S);
+ end if;
+ end if;
+ end;
end if;
end if;
end Check_Private_Overriding;
---------------------------
procedure Ensure_Aggregate_Form (Arg : Node_Id) is
- Expr : constant Node_Id := Expression (Arg);
- Loc : constant Source_Ptr := Sloc (Expr);
- Comps : List_Id := No_List;
- Exprs : List_Id := No_List;
- Nam : Name_Id;
-
- CFSD : constant Boolean := Get_Comes_From_Source_Default;
- -- Used to restore Comes_From_Source_Default
+ CFSD : constant Boolean := Get_Comes_From_Source_Default;
+ Expr : constant Node_Id := Expression (Arg);
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Comps : List_Id := No_List;
+ Exprs : List_Id := No_List;
+ Nam : Name_Id := No_Name;
+ Nam_Loc : Source_Ptr;
begin
- if Nkind (Arg) = N_Aspect_Specification then
- Nam := No_Name;
- else
- pragma Assert (Nkind (Arg) = N_Pragma_Argument_Association);
- Nam := Chars (Arg);
+ -- The pragma argument is in positional form:
+
+ -- pragma Depends (Nam => ...)
+ -- ^
+ -- Chars field
+
+ -- Note that the Sloc of the Chars field is the Sloc of the pragma
+ -- argument association.
+
+ if Nkind (Arg) = N_Pragma_Argument_Association then
+ Nam := Chars (Arg);
+ Nam_Loc := Sloc (Arg);
+
+ -- Remove the pragma argument name as this will be captured in the
+ -- aggregate.
+
+ Set_Chars (Arg, No_Name);
end if;
-- The argument is already in aggregate form, but the presence of a
else
Comps := New_List (
Make_Component_Association (Loc,
- Choices => New_List (Make_Identifier (Loc, Chars (Arg))),
+ Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
Expression => Relocate_Node (Expr)));
end if;
- -- Remove the pragma argument name as this information has been
- -- captured in the aggregate.
-
- if Nkind (Arg) = N_Pragma_Argument_Association then
- Set_Chars (Arg, No_Name);
- end if;
-
Set_Expression (Arg,
Make_Aggregate (Loc,
Component_Associations => Comps,
projects / gcc.git / commitdiff