+2011-08-03 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_aggr.adb (Analyze_Array_Aggregate): When checking the discrete
+ choices of a named array aggregate, bail out when any choices are
+ marked as Errors_Posted.
+
+2011-08-03 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch13.adb (Expand_N_Freeze_Entity): cleanup determination of scope
+ in which entity is frozen, to handle properly loop variables in
+ iterators.
+
+2011-08-03 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Set_String_Literal_Subtype): if the lower bound of the
+ subtype is not static, compute the upper bound using attributes, to
+ handle properly index types that are not integer types.
+
+2011-08-03 Bob Duff <duff@adacore.com>
+
+ * gnat_rm.texi, gnat_ugn.texi: Fix some dangling URLs.
+ Update copyright notice.
+
+2011-08-03 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Build_Discriminant_Constraints): Only use
+ Original_Discriminant if within an instance.
+ * sem_ch4.adb (Analyze_Selected_Component): Ditto.
+
+2011-08-03 Thomas Quinot <quinot@adacore.com>
+
+ * einfo.ads: Minor reformatting.
+
+2011-08-03 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_disp.adb (Check_Premature_Freezing): diagnose the presence of a
+ composite type with an unfrozen subcomponent, in the profile of a
+ primitive operation.
+
2011-08-03 Robert Dewar <dewar@adacore.com>
* sem_util.ads, exp_aggr.adb, exp_ch3.adb: Minor reformatting.
-- Thus this flag has no meaning to the back end.
-- Is_Limited_Composite (Flag106)
--- Present in all entities. Set for composite types that have a
--- limited component. Used to enforce the rule that operations on
--- the composite type that depend on the full view of the component
--- do not become visible until the immediate scope of the composite
--- type itself (RM 7.3.1 (5)).
+-- Present in all entities. Set for composite types that have a limited
+-- component. Used to enforce the rule that operations on the composite
+-- type that depend on the full view of the component do not become
+-- visible until the immediate scope of the composite type itself
+-- (RM 7.3.1 (5)).
-- Is_Limited_Interface (Flag197)
-- Present in record types and subtypes. True for interface types, if
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
-with Stand; use Stand;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Validsw; use Validsw;
procedure Expand_N_Freeze_Entity (N : Node_Id) is
E : constant Entity_Id := Entity (N);
E_Scope : Entity_Id;
- S : Entity_Id;
In_Other_Scope : Boolean;
In_Outer_Scope : Boolean;
Decl : Node_Id;
E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
end if;
- S := Current_Scope;
- while S /= Standard_Standard and then S /= E_Scope loop
- S := Scope (S);
- end loop;
+ -- If the scope of the entity is in open scopes, it is the current one
+ -- or an enclosing one, including a loop, a block, or a subprogram.
- In_Other_Scope := not (S = E_Scope);
- In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope);
+ if In_Open_Scopes (E_Scope) then
+ In_Other_Scope := False;
+ In_Outer_Scope := E_Scope /= Current_Scope;
+
+ -- Otherwise it is a local package or a different compilation unit.
+ else
+ In_Other_Scope := True;
+ In_Outer_Scope := False;
+ end if;
-- If the entity being frozen is defined in a scope that is not
-- currently on the scope stack, we must establish the proper
DT_Aggr : constant Elist_Id := New_Elmt_List;
-- Entities marked with attribute Is_Dispatch_Table_Entity
- procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id);
+ procedure Check_Premature_Freezing
+ (Subp : Entity_Id;
+ Tagged_Type : Entity_Id;
+ Typ : Entity_Id);
-- Verify that all non-tagged types in the profile of a subprogram
-- are frozen at the point the subprogram is frozen. This enforces
-- the rule on RM 13.14 (14) as modified by AI05-019. At the point a
-- Typical violation of the rule involves an object declaration that
-- freezes a tagged type, when one of its primitive operations has a
-- type in its profile whose full view has not been analyzed yet.
+ -- More complex cases involve composite types that have one private
+ -- unfrozen subcomponent.
procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
-- Export the dispatch table DT of tagged type Typ. Required to generate
-- Check_Premature_Freezing --
------------------------------
- procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is
+ procedure Check_Premature_Freezing
+ (Subp : Entity_Id;
+ Tagged_Type : Entity_Id;
+ Typ : Entity_Id)
+ is
+ Comp : Entity_Id;
begin
if Present (N)
- and then Is_Private_Type (Typ)
+ and then Is_Private_Type (Typ)
and then No (Full_View (Typ))
and then not Is_Generic_Type (Typ)
and then not Is_Tagged_Type (Typ)
("declaration must appear after completion of type &", N, Typ);
Error_Msg_NE
("\which is an untagged type in the profile of"
- & " primitive operation & declared#",
- N, Subp);
+ & " primitive operation & declared#", N, Subp);
+
+ else
+ Comp := Private_Component (Typ);
+
+ if not Is_Tagged_Type (Typ)
+ and then Present (Comp)
+ and then not Is_Frozen (Comp)
+ then
+ Error_Msg_Sloc := Sloc (Subp);
+ Error_Msg_Node_2 := Subp;
+ Error_Msg_Name_1 := Chars (Tagged_Type);
+ Error_Msg_NE
+ ("declaration must appear after completion of type &",
+ N, Comp);
+ Error_Msg_NE
+ ("\which is a component of untagged type& in the profile of"
+ & " primitive & of type % that is frozen by the declaration ",
+ N, Typ);
+ end if;
end if;
end Check_Premature_Freezing;
begin
F := First_Formal (Prim);
while Present (F) loop
- Check_Premature_Freezing (Prim, Etype (F));
+ Check_Premature_Freezing (Prim, Typ, Etype (F));
Next_Formal (F);
end loop;
- Check_Premature_Freezing (Prim, Etype (Prim));
+ Check_Premature_Freezing (Prim, Typ, Etype (Prim));
end;
if Present (Frnodes) then
the next revision of the standard. The formal definition given by
the Ada Rapporteur Group (ARG) can be found in two Ada Issues (AI-249 and
AI-305) available at
-@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00249.TXT} and
-@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00305.TXT}
-respectively.
+@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/ais/ai-00249.txt} and
+@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/ais/ai-00305.txt}.
The above set is a superset of the restrictions provided by pragma
@code{Profile (Restricted)}, it includes six additional restrictions
@c o
@c G N A T _ U G N o
@c o
-@c Copyright (C) 1992-2010, AdaCore o
+@c Copyright (C) 1992-2011, AdaCore o
@c o
@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
-- Used to keep track of the number of discrete choices in the
-- current association.
+ Errors_Posted_On_Choices : Boolean := False;
+ -- Keeps track of whether any choices have semantic errors
+
begin
-- STEP 2 (A): Check discrete choices validity
Check_Unset_Reference (Choice);
Check_Non_Static_Context (Choice);
+ -- If semantic errors were posted on the choice, then
+ -- record that for possible early return from later
+ -- processing (see handling of enumeration choices).
+
+ if Error_Posted (Choice) then
+ Errors_Posted_On_Choices := True;
+ end if;
+
-- Do not range check a choice. This check is redundant
-- since this test is already done when we check that the
-- bounds of the array aggregate are within range.
and then Compile_Time_Known_Value (Choices_Low)
and then Compile_Time_Known_Value (Choices_High)
then
- -- If the bounds have semantic errors, do not attempt
- -- further resolution to prevent cascaded errors.
+ -- If any of the expressions or range bounds in choices
+ -- have semantic errors, then do not attempt further
+ -- resolution, to prevent cascaded errors.
- if Error_Posted (Choices_Low)
- or else Error_Posted (Choices_High)
- then
- return False;
+ if Errors_Posted_On_Choices then
+ return Failure;
end if;
declare
-- the point of instantiation, we want to find the discriminant
-- that corresponds to D in Rec, i.e. X.
- if Present (Original_Discriminant (Id)) then
+ if Present (Original_Discriminant (Id))
+ and then In_Instance
+ then
Discr := Find_Corresponding_Discriminant (Id, T);
Found := True;
-- be done transitively, so note the new original discriminant.
if Nkind (Sel) = N_Identifier
+ and then In_Instance
and then Present (Original_Discriminant (Sel))
then
Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type);
Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound);
else
- Set_String_Literal_Low_Bound
- (Subtype_Id, Make_Integer_Literal (Loc, 1));
- Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive);
-
- -- Build bona fide subtype for the string, and wrap it in an
- -- unchecked conversion, because the backend expects the
- -- String_Literal_Subtype to have a static lower bound.
+ -- If the lower bound is not static we create a range for the string
+ -- literal, using the index type and the known length of the literal.
+ -- The index type is not necessarily Positive, so the upper bound is
+ -- computed as T'Val (T'Pos (Low_Bound) + L - 1)
declare
Index_List : constant List_Id := New_List;
Index_Type : constant Entity_Id := Etype (First_Index (Typ));
High_Bound : constant Node_Id :=
- Make_Op_Add (Loc,
- Left_Opnd => New_Copy_Tree (Low_Bound),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- String_Length (Strval (N)) - 1));
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Val,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Expressions =>
+ New_List (
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Pos,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Expressions => New_List (New_Copy_Tree (Low_Bound))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ String_Length (Strval (N)) - 1))));
+
Array_Subtype : Entity_Id;
Index_Subtype : Entity_Id;
Drange : Node_Id;
Index : Node_Id;
begin
+ Set_String_Literal_Low_Bound
+ (Subtype_Id,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix =>
+ New_Occurrence_Of (Base_Type (Index_Type), Loc)));
+ Set_Etype (String_Literal_Low_Bound (Subtype_Id), Index_Type);
+ Analyze_And_Resolve (String_Literal_Low_Bound (Subtype_Id));
+
+ -- Build bona fide subtype for the string, and wrap it in an
+ -- unchecked conversion, because the backend expects the
+ -- String_Literal_Subtype to have a static lower bound.
+
Index_Subtype :=
Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound);
projects / gcc.git / commitdiff