+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb Flag286 is now used as Is_Exception_Handler.
+ (Is_Exception_Handler): New routine.
+ (Set_Is_Exception_Handler): New routine.
+ (Write_Entity_Flags): Output the status of Is_Exception_Handler.
+ * einfo.ads New attribute Is_Exception_Handler along with
+ occurrences in entities.
+ (Is_Exception_Handler): New routine along with pragma Inline.
+ (Set_Is_Exception_Handler): New routine along with pragma Inline.
+ * exp_ch7.adb (Make_Transient_Block): Ignore blocks generated
+ for exception handlers with a choice parameter.
+ * sem_ch11.adb (Analyze_Exception_Handlers): Mark the scope
+ generated for a choice parameter as an exception handler.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Build_Derived_Access_Type): Remove dead code.
+ (Constrain_Discriminated_Type): In an instance, if the type has
+ unknown discriminants, use its full view.
+ (Process_Subtype): Check that the base type is private before
+ adding subtype to Private_Dependents list.
+
+2016-04-20 Bob Duff <duff@adacore.com>
+
+ * sem_ch13.adb: Minor comment fix.
+
2016-04-20 Yannick Moy <moy@adacore.com>
* sem_ch4.adb: Fix typos in comments.
-- Is_Uplevel_Referenced_Entity Flag283
-- Is_Unimplemented Flag284
-- Is_Volatile_Full_Access Flag285
- -- (unused) Flag286
+ -- Is_Exception_Handler Flag286
-- Rewritten_For_C Flag287
-- (unused) Flag288
return Flag146 (Id);
end Is_Abstract_Type;
- function Is_Local_Anonymous_Access (Id : E) return B is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Flag194 (Id);
- end Is_Local_Anonymous_Access;
-
function Is_Access_Constant (Id : E) return B is
begin
pragma Assert (Is_Access_Type (Id));
return Flag52 (Id);
end Is_Entry_Formal;
+ function Is_Exception_Handler (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Block);
+ return Flag286 (Id);
+ end Is_Exception_Handler;
+
function Is_Exported (Id : E) return B is
begin
return Flag99 (Id);
return Flag25 (Id);
end Is_Limited_Record;
+ function Is_Local_Anonymous_Access (Id : E) return B is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ return Flag194 (Id);
+ end Is_Local_Anonymous_Access;
+
function Is_Machine_Code_Subprogram (Id : E) return B is
begin
pragma Assert (Is_Subprogram (Id));
Set_Flag52 (Id, V);
end Set_Is_Entry_Formal;
+ procedure Set_Is_Exception_Handler (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Block);
+ Set_Flag286 (Id, V);
+ end Set_Is_Exception_Handler;
+
procedure Set_Is_Exported (Id : E; V : B := True) is
begin
Set_Flag99 (Id, V);
W ("Is_Dispatching_Operation", Flag6 (Id));
W ("Is_Eliminated", Flag124 (Id));
W ("Is_Entry_Formal", Flag52 (Id));
+ W ("Is_Exception_Handler", Flag286 (Id));
W ("Is_Exported", Flag99 (Id));
W ("Is_First_Subtype", Flag70 (Id));
W ("Is_For_Access_Subtype", Flag118 (Id));
-- Is_Enumeration_Type (synthesized)
-- Defined in all entities, true for enumeration types and subtypes
+-- Is_Exception_Handler (Flag286)
+-- Defined in blocks. Set if the block serves only as a scope of an
+-- exception handler with a choice parameter. Such a block does not
+-- physically appear in the tree.
+
-- Is_Exported (Flag99)
-- Defined in all entities. Set if the entity is exported. For now we
-- only allow the export of constants, exceptions, functions, procedures
-- Discard_Names (Flag88)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
+ -- Is_Exception_Handler (Flag286)
-- Sec_Stack_Needed_For_Return (Flag167)
-- Uses_Sec_Stack (Flag95)
-- Scope_Depth (synth)
function Is_Dispatching_Operation (Id : E) return B;
function Is_Eliminated (Id : E) return B;
function Is_Entry_Formal (Id : E) return B;
+ function Is_Exception_Handler (Id : E) return B;
function Is_Exported (Id : E) return B;
function Is_First_Subtype (Id : E) return B;
function Is_For_Access_Subtype (Id : E) return B;
procedure Set_Is_Dispatching_Operation (Id : E; V : B := True);
procedure Set_Is_Eliminated (Id : E; V : B := True);
procedure Set_Is_Entry_Formal (Id : E; V : B := True);
+ procedure Set_Is_Exception_Handler (Id : E; V : B := True);
procedure Set_Is_Exported (Id : E; V : B := True);
procedure Set_Is_First_Subtype (Id : E; V : B := True);
procedure Set_Is_For_Access_Subtype (Id : E; V : B := True);
pragma Inline (Is_Entry);
pragma Inline (Is_Entry_Formal);
pragma Inline (Is_Enumeration_Type);
+ pragma Inline (Is_Exception_Handler);
pragma Inline (Is_Exported);
pragma Inline (Is_First_Subtype);
pragma Inline (Is_Fixed_Point_Type);
pragma Inline (Set_Is_Dispatching_Operation);
pragma Inline (Set_Is_Eliminated);
pragma Inline (Set_Is_Entry_Formal);
+ pragma Inline (Set_Is_Exception_Handler);
pragma Inline (Set_Is_Exported);
pragma Inline (Set_Is_First_Subtype);
pragma Inline (Set_Is_For_Access_Subtype);
elsif Ekind_In (S, E_Entry, E_Loop) then
exit;
- -- In a procedure or a block, we release on exit of the
- -- procedure or block. ??? memory leak can be created by
- -- recursive calls.
-
- elsif Ekind_In (S, E_Block, E_Procedure) then
+ -- In a procedure or a block, release the sec stack on exit
+ -- from the construct. Note that an exception handler with a
+ -- choice parameter requires a declarative region in the form
+ -- of a block. The block does not physically manifest in the
+ -- tree as it only serves as a scope. Do not consider such a
+ -- block because it will never release the sec stack.
+
+ -- ??? Memory leak can be created by recursive calls
+
+ elsif Ekind (S) = E_Procedure
+ or else (Ekind (S) = E_Block
+ and then not Is_Exception_Handler (S))
+ then
+ Set_Uses_Sec_Stack (Current_Scope, False);
Set_Uses_Sec_Stack (S, True);
Check_Restriction (No_Secondary_Stack, Action);
- Set_Uses_Sec_Stack (Current_Scope, False);
exit;
else
H_Scope :=
New_Internal_Entity
(E_Block, Current_Scope, Sloc (Choice), 'E');
+ Set_Is_Exception_Handler (H_Scope);
end if;
Push_Scope (H_Scope);
N_Formal_Package_Declaration
then
Error_Msg_NE
- ("exception& is declared in " &
- "generic formal package", Id, Ent);
+ ("exception& is declared in generic formal "
+ & "package", Id, Ent);
Error_Msg_N
- ("\and therefore cannot appear in " &
- "handler (RM 11.2(8))", Id);
+ ("\and therefore cannot appear in handler "
+ & "(RM 11.2(8))", Id);
exit;
-- If the exception is declared in an inner
Analyze_Statements (Statements (Handler));
- -- If a choice was present, we created a special scope for it,
- -- so this is where we pop that special scope to get rid of it.
+ -- If a choice was present, we created a special scope for it, so
+ -- this is where we pop that special scope to get rid of it.
if Present (Choice) then
End_Scope;
-- After all forms of overriding have been resolved, a tagged type may
-- be left with a set of implicitly declared and possibly erroneous
-- abstract subprograms, null procedures and subprograms that require
- -- overriding. If this set contains fully conformat homographs, then one
- -- is chosen arbitrarily (already done during resolution), otherwise all
- -- remaining non-fully conformant homographs are hidden from visibility
- -- (Ada RM 8.3 12.3/2).
+ -- overriding. If this set contains fully conformant homographs, then
+ -- one is chosen arbitrarily (already done during resolution), otherwise
+ -- all remaining non-fully conformant homographs are hidden from
+ -- visibility (Ada RM 8.3 12.3/2).
if Is_Tagged_Type (E) then
Hide_Non_Overridden_Subprograms (E);
if Null_Exclusion_Present (Type_Definition (N)) then
Set_Can_Never_Be_Null (Derived_Type);
- -- What is with the "AND THEN FALSE" here ???
-
- if Can_Never_Be_Null (Parent_Type)
- and then False
- then
- Error_Msg_NE
- ("`NOT NULL` not allowed (& already excludes null)",
- N, Parent_Type);
- end if;
-
elsif Can_Never_Be_Null (Parent_Type) then
Set_Can_Never_Be_Null (Derived_Type);
end if;
-- ??? THIS CODE SHOULD NOT BE HERE REALLY.
Desig_Type := Designated_Type (Derived_Type);
+
if Is_Composite_Type (Desig_Type)
and then (not Is_Array_Type (Desig_Type))
and then Has_Discriminants (Desig_Type)
T := Designated_Type (T);
end if;
+ -- In an instance it may be necessary to retrieve the full view of a
+ -- type with unknown discriminants. In other contexts the constraint
+ -- is illegal.
+
+ if In_Instance
+ and then Is_Private_Type (T)
+ and then Has_Unknown_Discriminants (T)
+ and then Present (Full_View (T))
+ then
+ T := Full_View (T);
+ end if;
+
-- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal.
-- Avoid generating an error for access-to-incomplete subtypes.
when Private_Kind =>
Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
- Set_Private_Dependents (Def_Id, New_Elmt_List);
+
+ -- The base type may be private but Def_Id may be a full view
+ -- in an instance.
+
+ if Is_Private_Type (Def_Id) then
+ Set_Private_Dependents (Def_Id, New_Elmt_List);
+ end if;
-- In case of an invalid constraint prevent further processing
-- since the type constructed is missing expected fields.
projects / thirdparty / gcc.git / commitdiff
