with Atree; use Atree;
with Casing; use Casing;
with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Util; use Exp_Util;
with Hostparm; use Hostparm;
with Inline; use Inline;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
with Sem_Ch5; use Sem_Ch5;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Uname; use Uname;
package body Exp_Ch11 is
SD_List : List_Id;
procedure Expand_Exception_Handler_Tables (HSS : Node_Id);
procedure Generate_Subprogram_Descriptor
(N : Node_Id;
Loc : Source_Ptr;
Spec : Entity_Id;
Slist : List_Id);
procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is
Clean : constant Entity_Id := Entity (At_End_Proc (HSS));
Loc : constant Source_Ptr := Sloc (Clean);
Ohandle : Node_Id;
Stmnts : List_Id;
begin
pragma Assert (Present (Clean));
pragma Assert (No (Exception_Handlers (HSS)));
if Exception_Mechanism = Back_End_ZCX_Exceptions then
return;
end if;
if Configurable_Run_Time_Violations > 0 then
return;
end if;
if Restriction_Active (No_Exception_Handlers) then
return;
end if;
if Present (Block) then
New_Scope (Block);
end if;
Ohandle :=
Make_Others_Choice (Loc);
Set_All_Others (Ohandle);
Stmnts := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Clean, Loc)),
Make_Raise_Statement (Loc));
Set_Exception_Handlers (HSS, New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
Statements => Stmnts)));
Analyze_List (Stmnts, Suppress => All_Checks);
Expand_Exception_Handlers (HSS);
if Present (Block) then
Pop_Scope;
end if;
end Expand_At_End_Handler;
procedure Expand_Exception_Handler_Tables (HSS : Node_Id) is
Loc : constant Source_Ptr := Sloc (HSS);
Handlrs : constant List_Id := Exception_Handlers (HSS);
Stms : constant List_Id := Statements (HSS);
Handler : Node_Id;
Hlist : List_Id;
L1 : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('L'));
L2 : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('L'));
Lnn : Entity_Id;
Choice : Node_Id;
E_Id : Node_Id;
HR_Ent : Node_Id;
HL_Ref : Node_Id;
Item : Node_Id;
Subp_Entity : Entity_Id;
procedure Append_To_Stms (N : Node_Id);
function Inside_Selective_Accept return Boolean;
procedure Set_Hlist;
procedure Append_To_Stms (N : Node_Id) is
begin
Insert_After_And_Analyze (Last (Stms), N);
Set_Exception_Junk (N);
end Append_To_Stms;
function Inside_Selective_Accept return Boolean is
Parnt : Node_Id;
Curr : Node_Id := HSS;
begin
Parnt := Parent (HSS);
while Nkind (Parnt) /= N_Compilation_Unit loop
if Nkind (Parnt) = N_Accept_Alternative
and then Curr = Accept_Statement (Parnt)
then
if Present (Accept_Handler_Records (Parnt)) then
Hlist := Accept_Handler_Records (Parnt);
else
Hlist := New_List;
Set_Accept_Handler_Records (Parnt, Hlist);
end if;
return True;
else
Curr := Parnt;
Parnt := Parent (Parnt);
end if;
end loop;
return False;
end Inside_Selective_Accept;
procedure Set_Hlist is
begin
Set_Is_Inlined (Subp_Entity, False);
if Present (Subp_Entity)
and then Present (Handler_Records (Subp_Entity))
then
Hlist := Handler_Records (Subp_Entity);
else
Hlist := New_List;
Set_Handler_Records (Subp_Entity, Hlist);
end if;
end Set_Hlist;
begin
if Zero_Cost_Handling (HSS) then
return;
end if;
Set_Zero_Cost_Handling (HSS);
Subp_Entity := Current_Scope;
Scope_Loop : loop
if Is_Generic_Unit (Subp_Entity) then
return;
elsif Ekind (Subp_Entity) = E_Function
or else Ekind (Subp_Entity) = E_Procedure
then
if Present (Protected_Body_Subprogram (Subp_Entity)) then
Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
end if;
Set_Hlist;
exit Scope_Loop;
elsif Is_Entry (Subp_Entity) then
if Present (Protected_Body_Subprogram (Subp_Entity)) then
Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
Set_Hlist;
exit Scope_Loop;
elsif Inside_Selective_Accept then
exit Scope_Loop;
end if;
elsif Ekind (Subp_Entity) = E_Package
and then Is_Compilation_Unit (Subp_Entity)
then
if Is_Body_Name (Unit_Name (Get_Code_Unit (HSS))) then
Subp_Entity := Body_Entity (Subp_Entity);
end if;
Set_Hlist;
exit Scope_Loop;
elsif Ekind (Subp_Entity) = E_Task_Type then
if Inside_Selective_Accept then
exit Scope_Loop;
elsif Present (Get_Task_Body_Procedure (Subp_Entity)) then
Subp_Entity := Get_Task_Body_Procedure (Subp_Entity);
Set_Hlist;
exit Scope_Loop;
end if;
end if;
Subp_Entity := Scope (Subp_Entity);
end loop Scope_Loop;
pragma Assert (Subp_Entity /= Standard_Standard);
Analyze_Label_Entity (L1);
Analyze_Label_Entity (L2);
Insert_Before_And_Analyze (First (Stms),
Make_Label (Loc,
Identifier => New_Occurrence_Of (L1, Loc)));
Set_Exception_Junk (First (Stms));
Append_To_Stms (
Make_Label (Loc,
Identifier => New_Occurrence_Of (L2, Loc)));
Handler := First_Non_Pragma (Handlrs);
while Present (Handler) loop
Set_Zero_Cost_Handling (Handler);
Lnn :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('L'));
Analyze_Label_Entity (Lnn);
Item :=
Make_Label (Loc,
Identifier => New_Occurrence_Of (Lnn, Loc));
Set_Exception_Junk (Item);
Insert_Before_And_Analyze (First (Statements (Handler)), Item);
Choice := First (Exception_Choices (Handler));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
if All_Others (Choice) then
E_Id := New_Occurrence_Of (RTE (RE_All_Others_Id), Loc);
else
E_Id := New_Occurrence_Of (RTE (RE_Others_Id), Loc);
end if;
elsif Is_VMS_Exception (Entity (Choice)) then
E_Id := New_Occurrence_Of (RTE (RE_Null_Id), Loc);
else
E_Id :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Entity (Choice), Loc),
Attribute_Name => Name_Identity);
end if;
HR_Ent :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('H'));
HL_Ref :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (HR_Ent, Loc),
Attribute_Name => Name_Unrestricted_Access);
declare
New_Scop : constant Entity_Id := Current_Scope;
Ent : Node_Id;
begin
Ent := First (Hlist);
loop
if No (Ent) then
Append_To (Hlist, HL_Ref);
exit;
elsif Scope_Within
(New_Scop, Scope (Entity (Prefix (Ent))))
then
Insert_Before (Ent, HL_Ref);
exit;
else
Next (Ent);
end if;
end loop;
end;
Item :=
Make_Object_Declaration (Loc,
Defining_Identifier => HR_Ent,
Constant_Present => True,
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Handler_Record), Loc),
Expression =>
Make_Aggregate (Loc,
Expressions => New_List (
Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (L1, Loc),
Attribute_Name => Name_Address),
Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (L2, Loc),
Attribute_Name => Name_Address),
E_Id,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Lnn, Loc), Attribute_Name => Name_Address))));
Set_Handler_List_Entry (Item, HL_Ref);
Set_Exception_Junk (Item);
Insert_After_And_Analyze (Last (Statements (Handler)), Item);
Set_Is_Statically_Allocated (HR_Ent);
Analyze_And_Resolve (HL_Ref, RTE (RE_Handler_Record_Ptr));
Next (Choice);
end loop;
Next_Non_Pragma (Handler);
end loop;
end Expand_Exception_Handler_Tables;
procedure Expand_Exception_Handlers (HSS : Node_Id) is
Handlrs : constant List_Id := Exception_Handlers (HSS);
Loc : Source_Ptr;
Handler : Node_Id;
Others_Choice : Boolean;
Obj_Decl : Node_Id;
procedure Prepend_Call_To_Handler
(Proc : RE_Id;
Args : List_Id := No_List);
procedure Prepend_Call_To_Handler
(Proc : RE_Id;
Args : List_Id := No_List)
is
Ent : constant Entity_Id := RTE (Proc);
begin
if Present (Ent) then
declare
Call : constant Node_Id :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (Proc), Loc),
Parameter_Associations => Args);
begin
Prepend_To (Statements (Handler), Call);
Analyze (Call, Suppress => All_Checks);
end;
end if;
end Prepend_Call_To_Handler;
begin
Handler := First_Non_Pragma (Handlrs);
Handler_Loop : while Present (Handler) loop
Loc := Sloc (Handler);
if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
declare
H : constant Node_Id := Handler;
begin
Next_Non_Pragma (Handler);
Remove (H);
goto Continue_Handler_Loop;
end;
end if;
if Present (Choice_Parameter (Handler)) then
declare
Cparm : constant Entity_Id := Choice_Parameter (Handler);
Clc : constant Source_Ptr := Sloc (Cparm);
Save : Node_Id;
begin
Save :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Cparm, Clc),
Make_Explicit_Dereference (Loc,
Make_Function_Call (Loc,
Name => Make_Explicit_Dereference (Loc,
New_Occurrence_Of
(RTE (RE_Get_Current_Excep), Loc))))));
Mark_Rewrite_Insertion (Save);
Prepend (Save, Statements (Handler));
Obj_Decl :=
Make_Object_Declaration (Clc,
Defining_Identifier => Cparm,
Object_Definition =>
New_Occurrence_Of
(RTE (RE_Exception_Occurrence), Clc));
Set_No_Initialization (Obj_Decl, True);
Rewrite (Handler,
Make_Exception_Handler (Loc,
Exception_Choices => Exception_Choices (Handler),
Statements => New_List (
Make_Block_Statement (Loc,
Declarations => New_List (Obj_Decl),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements (Handler))))));
Analyze_List (Statements (Handler), Suppress => All_Checks);
end;
end if;
if Hostparm.Java_VM then
declare
Arg : constant Node_Id :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of
(RTE (RE_Current_Target_Exception), Loc));
begin
Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg));
end;
elsif Abort_Allowed then
Others_Choice :=
Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
if (Others_Choice
or else Entity (First (Exception_Choices (Handler))) /=
Stand.Abort_Signal)
and then not
(Others_Choice
and then All_Others (First (Exception_Choices (Handler))))
and then Abort_Allowed
then
Prepend_Call_To_Handler (RE_Abort_Undefer);
end if;
end if;
Next_Non_Pragma (Handler);
<<Continue_Handler_Loop>>
null;
end loop Handler_Loop;
if Debug_Flag_Dot_X
and then Is_Empty_List (Exception_Handlers (HSS))
then
Set_Exception_Handlers (HSS, No_List);
end if;
if Exception_Mechanism = Front_End_ZCX_Exceptions then
Expand_Exception_Handler_Tables (HSS);
end if;
end Expand_Exception_Handlers;
procedure Expand_N_Exception_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Id : constant Entity_Id := Defining_Identifier (N);
L : List_Id := New_List;
Flag_Id : Entity_Id;
Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
Exname : constant Node_Id :=
Make_Defining_Identifier (Loc, Name_Exname);
begin
if Hostparm.Java_VM then
return;
end if;
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Exname,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id))));
Set_Is_Statically_Allocated (Exname);
Append_To (L, New_Occurrence_Of (Standard_False, Loc));
Append_To (L,
Make_Character_Literal (Loc,
Chars => Name_uA,
Char_Literal_Value => UI_From_Int (Character'Pos ('A'))));
Append_To (L,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Exname, Loc),
Attribute_Name => Name_Length));
Append_To (L, Unchecked_Convert_To (Standard_A_Char,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Exname, Loc),
Attribute_Name => Name_Address)));
Append_To (L, Make_Null (Loc));
Append_To (L, Make_Integer_Literal (Loc, 0));
Append_To (L, Make_Null (Loc));
Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
Analyze_And_Resolve (Expression (N), Etype (Id));
if not Restriction_Active (No_Exception_Handlers)
and then not Restriction_Active (No_Exception_Registration)
then
L := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Id, Loc),
Attribute_Name => Name_Unrestricted_Access)))));
Set_Register_Exception_Call (Id, First (L));
if not Is_Library_Level_Entity (Id) then
Flag_Id := Make_Defining_Identifier (Loc,
New_External_Name (Chars (Id), 'F'));
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Flag_Id,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc),
Expression =>
New_Occurrence_Of (Standard_True, Loc)));
Set_Is_Statically_Allocated (Flag_Id);
Append_To (L,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Flag_Id, Loc),
Expression => New_Occurrence_Of (Standard_False, Loc)));
Insert_After_And_Analyze (N,
Make_Implicit_If_Statement (N,
Condition => New_Occurrence_Of (Flag_Id, Loc),
Then_Statements => L));
else
Insert_List_After_And_Analyze (N, L);
end if;
end if;
end Expand_N_Exception_Declaration;
procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
begin
if Present (Exception_Handlers (N))
and then not Restriction_Active (No_Exception_Handlers)
then
Expand_Exception_Handlers (N);
end if;
if Nkind (Parent (N)) /= N_Package_Body
and then Nkind (Parent (N)) /= N_Accept_Statement
and then not Delay_Cleanups (Current_Scope)
then
Expand_Cleanup_Actions (Parent (N));
else
Set_First_Real_Statement (N, First (Statements (N)));
end if;
end Expand_N_Handled_Sequence_Of_Statements;
procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
begin
Adjust_Condition (Condition (N));
end Expand_N_Raise_Constraint_Error;
procedure Expand_N_Raise_Program_Error (N : Node_Id) is
begin
Adjust_Condition (Condition (N));
end Expand_N_Raise_Program_Error;
procedure Expand_N_Raise_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ehand : Node_Id;
E : Entity_Id;
Str : String_Id;
begin
if Present (Name (N)) and then Hostparm.Java_VM then
return;
end if;
if Configurable_Run_Time_Violations > 0
and then not Comes_From_Source (N)
then
return;
end if;
if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
if Entity (Name (N)) = Standard_Constraint_Error then
Rewrite (N,
Make_Raise_Constraint_Error (Loc,
Reason => CE_Explicit_Raise));
Analyze (N);
return;
elsif Entity (Name (N)) = Standard_Program_Error then
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Explicit_Raise));
Analyze (N);
return;
elsif Entity (Name (N)) = Standard_Storage_Error then
Rewrite (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Explicit_Raise));
Analyze (N);
return;
end if;
end if;
if Present (Name (N)) then
declare
Id : Entity_Id := Entity (Name (N));
begin
Build_Location_String (Loc);
if Present (Renamed_Object (Id)) then
Id := Renamed_Object (Id);
end if;
if Restriction_Active (No_Exception_Handlers) then
if Opt.Exception_Locations_Suppressed then
Name_Len := 1;
else
Name_Len := Name_Len + 1;
end if;
Name_Buffer (Name_Len) := ASCII.NUL;
end if;
if Opt.Exception_Locations_Suppressed then
Name_Len := 0;
end if;
Str := String_From_Name_Buffer;
if Is_VMS_Exception (Id) then
declare
Excep_Image : String_Id;
Cond : Node_Id;
begin
if Present (Interface_Name (Id)) then
Excep_Image := Strval (Interface_Name (Id));
else
Get_Name_String (Chars (Id));
Set_All_Upper_Case;
Excep_Image := String_From_Name_Buffer;
end if;
if Exception_Code (Id) /= No_Uint then
Cond :=
Make_Integer_Literal (Loc, Exception_Code (Id));
else
Cond :=
Unchecked_Convert_To (Standard_Integer,
Make_Function_Call (Loc,
Name => New_Occurrence_Of
(RTE (RE_Import_Value), Loc),
Parameter_Associations => New_List
(Make_String_Literal (Loc,
Strval => Excep_Image))));
end if;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
Parameter_Associations => New_List (Cond)));
Analyze_And_Resolve (Cond, Standard_Integer);
end;
else
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Name (N),
Attribute_Name => Name_Identity),
Make_String_Literal (Loc,
Strval => Str))));
end if;
end;
else
Ehand := Parent (N);
while Nkind (Ehand) /= N_Exception_Handler loop
Ehand := Parent (Ehand);
end loop;
if No (Choice_Parameter (Ehand)) then
E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Set_Choice_Parameter (Ehand, E);
Set_Ekind (E, E_Variable);
Set_Etype (E, RTE (RE_Exception_Occurrence));
Set_Scope (E, Current_Scope);
end if;
declare
Ech : constant Node_Id := First (Exception_Choices (Ehand));
Ent : Entity_Id;
begin
if Nkind (Ech) = N_Others_Choice
and then All_Others (Ech)
then
Ent := RTE (RE_Reraise_Occurrence_No_Defer);
else
Ent := RTE (RE_Reraise_Occurrence_Always);
end if;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Ent, Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
end;
end if;
Analyze (N);
end Expand_N_Raise_Statement;
procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
begin
Adjust_Condition (Condition (N));
end Expand_N_Raise_Storage_Error;
procedure Expand_N_Subprogram_Info (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
begin
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Identifier (N),
Attribute_Name => Name_Code_Address));
Analyze_And_Resolve (N, RTE (RE_Code_Loc));
end Expand_N_Subprogram_Info;
procedure Generate_Subprogram_Descriptor
(N : Node_Id;
Loc : Source_Ptr;
Spec : Entity_Id;
Slist : List_Id)
is
Code : Node_Id;
Ent : Entity_Id;
Decl : Node_Id;
Dtyp : Entity_Id;
Numh : Nat;
Sdes : Node_Id;
Hrc : List_Id;
begin
if Exception_Mechanism /= Front_End_ZCX_Exceptions then
return;
end if;
if Restriction_Active (No_Exception_Handlers) then
return;
end if;
if Operating_Mode /= Generate_Code then
return;
end if;
if Restriction_Active (No_Exceptions)
or Restriction_Active (No_Exception_Handlers)
then
return;
end if;
if not Expander_Active then
return;
end if;
declare
Scop : Entity_Id;
begin
Scop := Spec;
while Scop /= Standard_Standard loop
if Is_Generic_Unit (Scop) or else Is_Eliminated (Scop) then
return;
end if;
Scop := Scope (Scop);
end loop;
end;
if Is_Subprogram (Spec)
and then Present (Protected_Body_Subprogram (Spec))
and then Protected_Body_Subprogram (Spec) /= Spec
then
return;
end if;
if (Nkind (N) = N_Package_Declaration
or else
Nkind (N) = N_Package_Body)
and then No (Handler_Records (Spec))
then
return;
end if;
Get_Name_String (Unit_File_Name (Current_Sem_Unit));
if Name_Buffer (1 .. 12) = "s-except.ads"
or else
Name_Buffer (1 .. 12) = "a-except.ads"
then
return;
end if;
if Name_Buffer (1 .. 11) = "s-stalib.ad" then
return;
end if;
if Name_Buffer (1 .. 11) = "s-stoele.ad" then
return;
end if;
if Name_Buffer (1 .. 11) = "g-htable.ad" then
return;
end if;
if Has_Subprogram_Descriptor (Spec) then
return;
else
Set_Has_Subprogram_Descriptor (Spec);
end if;
if Analyzing_Inlined_Bodies then
return;
end if;
declare
Hnum : Nat := Homonym_Number (Spec);
begin
if Hnum = 1 then
Hnum := 0;
end if;
Ent :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Spec), "SD", Hnum));
end;
if No (Handler_Records (Spec)) then
Hrc := Empty_List;
Numh := 0;
else
Hrc := Handler_Records (Spec);
Numh := List_Length (Hrc);
end if;
New_Scope (Spec);
case Numh is
when 0 =>
Dtyp := RTE (RE_Subprogram_Descriptor_0);
when 1 =>
Dtyp := RTE (RE_Subprogram_Descriptor_1);
when 2 =>
Dtyp := RTE (RE_Subprogram_Descriptor_2);
when 3 =>
Dtyp := RTE (RE_Subprogram_Descriptor_3);
when others =>
Dtyp :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
Set_Is_Statically_Allocated (Dtyp);
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Dtyp,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Subprogram_Descriptor), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc, Numh)))));
Append (Decl, Slist);
if Present (N) then
Analyze (Decl);
end if;
Set_Exception_Junk (Decl);
end case;
if Ekind (Spec) = E_Package then
Code :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Spec, Loc),
Attribute_Name => Name_Elab_Spec);
Set_Etype (Code, Standard_Void_Type);
Set_Analyzed (Code);
elsif Ekind (Spec) = E_Package_Body then
Code :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Spec_Entity (Spec), Loc),
Attribute_Name => Name_Elab_Body);
Set_Etype (Code, Standard_Void_Type);
Set_Analyzed (Code);
else
Code := New_Occurrence_Of (Spec, Loc);
end if;
Code :=
Make_Attribute_Reference (Loc,
Prefix => Code,
Attribute_Name => Name_Code_Address);
Set_Etype (Code, RTE (RE_Address));
Set_Analyzed (Code);
Sdes :=
Make_Object_Declaration (Loc,
Defining_Identifier => Ent,
Constant_Present => True,
Aliased_Present => True,
Object_Definition => New_Occurrence_Of (Dtyp, Loc),
Expression =>
Make_Aggregate (Loc,
Expressions => New_List (
Make_Integer_Literal (Loc, Numh),
Code,
New_Copy_Tree (Code),
Make_Aggregate (Loc, Expressions => Hrc))));
Set_Exception_Junk (Sdes);
Set_Is_Subprogram_Descriptor (Sdes);
Append (Sdes, Slist);
if Present (N) then
Analyze (Sdes);
end if;
Pop_Scope;
Set_Is_Statically_Allocated (Ent);
if In_Extended_Main_Code_Unit (Spec) then
Append_To (SD_List,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ent, Loc),
Attribute_Name => Name_Unrestricted_Access));
Unit_Exception_Table_Present := True;
end if;
end Generate_Subprogram_Descriptor;
procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram
(Spec : Entity_Id;
Slist : List_Id)
is
begin
Generate_Subprogram_Descriptor (Empty, Sloc (Spec), Spec, Slist);
end Generate_Subprogram_Descriptor_For_Imported_Subprogram;
procedure Generate_Subprogram_Descriptor_For_Package
(N : Node_Id;
Spec : Entity_Id)
is
Adecl : Node_Id;
begin
if Total_Errors_Detected /= 0 and then No (N) then
return;
end if;
if Restriction_Active (No_Exception_Handlers) then
return;
end if;
Adecl := Aux_Decls_Node (Parent (N));
if No (Actions (Adecl)) then
Set_Actions (Adecl, New_List);
end if;
Generate_Subprogram_Descriptor (N, Sloc (N), Spec, Actions (Adecl));
end Generate_Subprogram_Descriptor_For_Package;
procedure Generate_Subprogram_Descriptor_For_Subprogram
(N : Node_Id;
Spec : Entity_Id)
is
begin
if Total_Errors_Detected /= 0 and then No (N) then
return;
end if;
if Restriction_Active (No_Exception_Handlers) then
return;
end if;
declare
HSS : constant Node_Id := Handled_Statement_Sequence (N);
begin
if No (Exception_Handlers (HSS)) then
Generate_Subprogram_Descriptor
(N, Sloc (N), Spec, Statements (HSS));
else
Generate_Subprogram_Descriptor
(N, Sloc (N),
Spec, Statements (Last (Exception_Handlers (HSS))));
end if;
end;
end Generate_Subprogram_Descriptor_For_Subprogram;
procedure Generate_Unit_Exception_Table is
Loc : constant Source_Ptr := No_Location;
Num : Nat;
Decl : Node_Id;
Ent : Entity_Id;
Next_Ent : Entity_Id;
Stent : Entity_Id;
begin
if Exception_Mechanism /= Front_End_ZCX_Exceptions then
return;
end if;
if Restriction_Active (No_Exception_Handlers) then
return;
end if;
Ent := First (SD_List);
while Present (Ent) loop
Next_Ent := Next (Ent);
if Is_Eliminated (Scope (Entity (Prefix (Ent)))) then
Remove (Ent); end if;
Ent := Next_Ent;
end loop;
if Is_Empty_List (SD_List) then
Unit_Exception_Table_Present := False;
return;
end if;
if Inside_A_Generic then
return;
end if;
Num := List_Length (SD_List);
Stent :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
Insert_Library_Level_Action (
Make_Subtype_Declaration (Loc,
Defining_Identifier => Stent,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of
(RTE (RE_Subprogram_Descriptors_Record), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc, Num))))));
Set_Is_Statically_Allocated (Stent);
Get_External_Unit_Name_String (Unit_Name (Main_Unit));
Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
Name_Buffer (1 .. 7) := "__gnat_";
Name_Len := Name_Len + 7;
Add_Str_To_Name_Buffer ("__SDP");
Ent :=
Make_Defining_Identifier (Loc,
Chars => Name_Find);
Get_Name_String (Chars (Ent));
Set_Interface_Name (Ent,
Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Ent,
Object_Definition => New_Occurrence_Of (Stent, Loc),
Constant_Present => True,
Aliased_Present => True,
Expression =>
Make_Aggregate (Loc,
New_List (
Make_Integer_Literal (Loc, List_Length (SD_List)),
Make_Aggregate (Loc,
Expressions => SD_List))));
Insert_Library_Level_Action (Decl);
Set_Is_Exported (Ent, True);
Set_Is_Public (Ent, True);
Set_Is_Statically_Allocated (Ent, True);
Get_Name_String (Chars (Ent));
Set_Interface_Name (Ent,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
end Generate_Unit_Exception_Table;
procedure Initialize is
begin
SD_List := Empty_List;
end Initialize;
function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
begin
if not OpenVMS_On_Target then
return False;
end if;
Get_Name_String (Chars (E));
if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
return False;
end if;
return True;
end Is_Non_Ada_Error;
procedure Remove_Handler_Entries (N : Node_Id) is
function Check_Handler_Entry (N : Node_Id) return Traverse_Result;
function Remove_All_Handler_Entries is new
Traverse_Func (Check_Handler_Entry);
Discard : Traverse_Result;
pragma Warnings (Off, Discard);
function Check_Handler_Entry (N : Node_Id) return Traverse_Result is
begin
if Nkind (N) = N_Object_Declaration then
if Present (Handler_List_Entry (N)) then
Remove (Handler_List_Entry (N));
Delete_Tree (Handler_List_Entry (N));
Set_Handler_List_Entry (N, Empty);
elsif Is_Subprogram_Descriptor (N) then
declare
SDN : Node_Id;
begin
SDN := First (SD_List);
while Present (SDN) loop
if Defining_Identifier (N) = Entity (Prefix (SDN)) then
Remove (SDN);
Delete_Tree (SDN);
exit;
end if;
Next (SDN);
end loop;
end;
end if;
end if;
return OK;
end Check_Handler_Entry;
begin
if Exception_Mechanism = Front_End_ZCX_Exceptions then
Discard := Remove_All_Handler_Entries (N);
end if;
end Remove_Handler_Entries;
end Exp_Ch11;