+2010-10-19 Tristan Gingold <gingold@adacore.com>
+
+ * init.c: On Alpha/VMS, only adjust PC for HPARITH.
+
+2010-10-19 Tristan Gingold <gingold@adacore.com>
+
+ * sem_attr.adb (Eval_Attribute): Handle Attribute_Ref, which can be
+ evaluated on VMS.
+
+2010-10-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Check_Generic_Child_Unit): Handle properly the case of
+ an instantiation of a renaming of the implicit generic child that
+ appears within an instance of its parent.
+
+2010-10-19 Thomas Quinot <quinot@adacore.com>
+
+ * exp_ch9.adb: Minor reformatting.
+ * einfo.adb, einfo.ads, atree.adb, atree.ads, exp_dist.adb, atree.h:
+ (Referenced_Object): Remove unused entity attribute.
+ (Direct_Primitive_Operations): Move to Elist10, this is set for all
+ tagged types, including synchronous ones, so can't use field15 which is
+ used as Storage_Size_Variable for task types and Entry_Bodies_Array for
+ protected types.
+ (Add_RACW_Primitive_Declarations_And_Bodies): Remove bogus guard
+ against Concurrent_Types (we must handle the case of a RACW designating
+ a class-wide private synchronous type).
+ Use Direct_Primitive_Operations, not Primitive_Operations, since we
+ really want the former.
+
+2010-10-19 Bob Duff <duff@adacore.com>
+
+ * sem_ch8.adb (Pop_Scope): Change "return;" to "raise Program_Error;".
+
+2010-10-19 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch4.adb (Expand_Set_Membership.Make_Cond): Add missing support
+ for N_Range nodes.
+
2010-10-19 Thomas Quinot <quinot@adacore.com>
* einfo.ads, atree.ads: Minor comment fixes.
end if;
end Elist8;
+ function Elist10 (N : Node_Id) return Elist_Id is
+ pragma Assert (Nkind (N) in N_Entity);
+ Value : constant Union_Id := Nodes.Table (N + 1).Field10;
+ begin
+ if Value = 0 then
+ return No_Elist;
+ else
+ return Elist_Id (Value);
+ end if;
+ end Elist10;
+
function Elist13 (N : Node_Id) return Elist_Id is
pragma Assert (Nkind (N) in N_Entity);
Value : constant Union_Id := Nodes.Table (N + 2).Field6;
Nodes.Table (N + 1).Field8 := Union_Id (Val);
end Set_Elist8;
+ procedure Set_Elist10 (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field10 := Union_Id (Val);
+ end Set_Elist10;
+
procedure Set_Elist13 (N : Node_Id; Val : Elist_Id) is
begin
pragma Assert (Nkind (N) in N_Entity);
-- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0)
-- Similar definitions for Field7 to Field28 (and Node7-Node28,
- -- Elist7-Elist28, Uint7-Uint28, Ureal7-Ureal28). Note that not all
- -- these functions are defined, only the ones that are actually used.
+ -- Elist7-Elist28, Uint7-Uint28, Ureal7-Ureal28). Note that not all these
+ -- functions are defined, only the ones that are actually used.
function Last_Node_Id return Node_Id;
pragma Inline (Last_Node_Id);
function Elist8 (N : Node_Id) return Elist_Id;
pragma Inline (Elist8);
+ function Elist10 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist10);
+
function Elist13 (N : Node_Id) return Elist_Id;
pragma Inline (Elist13);
procedure Set_Elist8 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist8);
+ procedure Set_Elist10 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist10);
+
procedure Set_Elist13 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist13);
#define Elist3(N) Field3 (N)
#define Elist4(N) Field4 (N)
#define Elist8(N) Field8 (N)
+#define Elist10(N) Field10 (N)
#define Elist13(N) Field13 (N)
#define Elist15(N) Field15 (N)
#define Elist16(N) Field16 (N)
-- Current_Value Node9
-- Renaming_Map Uint9
+ -- Direct_Primitive_Operations Elist10
-- Discriminal_Link Node10
-- Handler_Records List10
-- Normalized_Position_Max Uint10
- -- Referenced_Object Node10
-- Component_Bit_Offset Uint11
-- Full_View Node11
-- Entry_Parameters_Type Node15
-- Extra_Formal Node15
-- Lit_Indexes Node15
- -- Direct_Primitive_Operations Elist15
-- Related_Instance Node15
-- Scale_Value Uint15
-- Storage_Size_Variable Node15
function Direct_Primitive_Operations (Id : E) return L is
begin
- pragma Assert (Is_Tagged_Type (Id)
- and then not Is_Concurrent_Type (Id));
- return Elist15 (Id);
+ pragma Assert (Is_Tagged_Type (Id));
+ return Elist10 (Id);
end Direct_Primitive_Operations;
function Directly_Designated_Type (Id : E) return E is
return Flag227 (Id);
end Referenced_As_Out_Parameter;
- function Referenced_Object (Id : E) return N is
- begin
- pragma Assert (Is_Type (Id));
- return Node10 (Id);
- end Referenced_Object;
-
function Register_Exception_Call (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Exception);
procedure Set_Direct_Primitive_Operations (Id : E; V : L) is
begin
- pragma Assert
- (Is_Tagged_Type (Id)
- and then
- (Is_Record_Type (Id)
- or else
- Is_Incomplete_Type (Id)
- or else
- Ekind_In (Id, E_Private_Type, E_Private_Subtype)));
- Set_Elist15 (Id, V);
+ pragma Assert (Is_Tagged_Type (Id));
+ Set_Elist10 (Id, V);
end Set_Direct_Primitive_Operations;
procedure Set_Prival (Id : E; V : E) is
Set_Flag227 (Id, V);
end Set_Referenced_As_Out_Parameter;
- procedure Set_Referenced_Object (Id : E; V : N) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Node10 (Id, V);
- end Set_Referenced_Object;
-
procedure Set_Register_Exception_Call (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_Exception);
procedure Write_Field10_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Type_Kind =>
- Write_Str ("Referenced_Object");
+ when Class_Wide_Kind |
+ Incomplete_Kind |
+ E_Record_Type |
+ E_Record_Subtype |
+ Private_Kind |
+ Concurrent_Kind =>
+ Write_Str ("Direct_Primitive_Operations");
when E_In_Parameter |
E_Constant =>
Task_Kind =>
Write_Str ("Storage_Size_Variable");
- when Class_Wide_Kind |
- Incomplete_Kind |
- E_Record_Type |
- E_Record_Subtype |
- Private_Kind =>
- Write_Str ("Direct_Primitive_Operations");
-
when E_Component =>
Write_Str ("DT_Entry_Count");
-- Present in floating point types and subtypes and decimal types and
-- subtypes. Contains the Digits value specified in the declaration.
--- Direct_Primitive_Operations (Elist15)
+-- Direct_Primitive_Operations (Elist10)
-- Present in tagged types and subtypes (including synchronized types),
-- in tagged private types and in tagged incomplete types. Element list
-- of entities for primitive operations of the tagged type. Not present
-- we have a separate warning for variables that are only assigned and
-- never read, and out parameters are a special case.
--- Referenced_Object (Node10)
--- Present in all type entities. Set non-Empty only for type entities
--- constructed for unconstrained objects, or objects that depend on
--- discriminants. Points to the expression from which the actual
--- subtype of the object can be evaluated.
-
-- Register_Exception_Call (Node20)
-- Present in exception entities. When an exception is declared,
-- a call is expanded to Register_Exception. This field points to
-- Associated_Node_For_Itype (Node8)
-- Class_Wide_Type (Node9)
- -- Referenced_Object (Node10)
-- Full_View (Node11)
-- Esize (Uint12)
-- RM_Size (Uint13)
-- E_Class_Wide_Type
-- E_Class_Wide_Subtype
+ -- Direct_Primitive_Operations (Elist10)
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Equivalent_Type (Node18) (always Empty for type)
-- E_Incomplete_Type
-- E_Incomplete_Subtype
+ -- Direct_Primitive_Operations (Elist10)
-- Non_Limited_View (Node17)
-- Private_Dependents (Elist18)
-- Discriminant_Constraint (Elist21)
-- E_Private_Type
-- E_Private_Subtype
- -- Direct_Primitive_Operations (Elist15)
+ -- Direct_Primitive_Operations (Elist10)
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
-- E_Protected_Type
-- E_Protected_Subtype
+ -- Direct_Primitive_Operations (Elist10)
-- Entry_Bodies_Array (Node15)
-- First_Private_Entity (Node16)
-- First_Entity (Node17)
-- E_Record_Type
-- E_Record_Subtype
- -- Direct_Primitive_Operations (Elist15)
+ -- Direct_Primitive_Operations (Elist10)
-- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrappers (Elist26) (base type only)
-- Cloned_Subtype (Node16) (subtype case only)
-- E_Record_Type_With_Private
-- E_Record_Subtype_With_Private
- -- Direct_Primitive_Operations (Elist15)
+ -- Direct_Primitive_Operations (Elist10)
-- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrappers (Elist26) (base type only)
-- First_Entity (Node17)
-- E_Task_Type
-- E_Task_Subtype
+ -- Direct_Primitive_Operations (Elist10)
-- Storage_Size_Variable (Node15) (base type only)
-- First_Private_Entity (Node16)
-- First_Entity (Node17)
function Referenced (Id : E) return B;
function Referenced_As_LHS (Id : E) return B;
function Referenced_As_Out_Parameter (Id : E) return B;
- function Referenced_Object (Id : E) return N;
function Register_Exception_Call (Id : E) return N;
function Related_Array_Object (Id : E) return E;
function Related_Expression (Id : E) return N;
-- predicate is true only if the value is set (Known) and is set to a
-- compile time known value. Note that in the case of Alignment and
-- Normalized_First_Bit, dynamic values are not possible, so we do not
- -- need a separate Known_Static calls in these cases. The not set (unknown
+ -- need a separate Known_Static calls in these cases. The not set (unknown)
-- values are as follows:
-- Alignment Uint_0 or No_Uint
procedure Set_Referenced (Id : E; V : B := True);
procedure Set_Referenced_As_LHS (Id : E; V : B := True);
procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True);
- procedure Set_Referenced_Object (Id : E; V : N);
procedure Set_Register_Exception_Call (Id : E; V : N);
procedure Set_Related_Array_Object (Id : E; V : E);
procedure Set_Related_Expression (Id : E; V : N);
pragma Inline (Referenced);
pragma Inline (Referenced_As_LHS);
pragma Inline (Referenced_As_Out_Parameter);
- pragma Inline (Referenced_Object);
pragma Inline (Register_Exception_Call);
pragma Inline (Related_Array_Object);
pragma Inline (Related_Expression);
pragma Inline (Set_Referenced);
pragma Inline (Set_Referenced_As_LHS);
pragma Inline (Set_Referenced_As_Out_Parameter);
- pragma Inline (Set_Referenced_Object);
pragma Inline (Set_Register_Exception_Call);
pragma Inline (Set_Related_Array_Object);
pragma Inline (Set_Related_Expression);
-- number-of-elements * component_type'Max_Size_In_Storage_Elements
- -- which avoids this problem. All this is a big bogus, but it does
+ -- which avoids this problem. All this is a bit bogus, but it does
-- mean we catch common cases of trying to allocate arrays that
-- are too large, and which in the absence of a check results in
-- undetected chaos ???
R : constant Node_Id := Relocate_Node (Alt);
begin
- if Is_Entity_Name (Alt)
- and then Is_Type (Entity (Alt))
+ if (Is_Entity_Name (Alt)
+ and then Is_Type (Entity (Alt)))
+ or else Nkind (Alt) = N_Range
then
Cond :=
Make_In (Sloc (Alt),
-- Generate a specification without a letter suffix in order to
-- override an interface function or procedure.
- Spec :=
- Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
+ Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
- -- The formal parameters become the actuals of the protected
- -- function or procedure call.
+ -- The formal parameters become the actuals of the protected function
+ -- or procedure call.
Actuals := New_List;
Formal := First (Parameter_Specifications (Spec));
return
Make_Subprogram_Body (Loc,
- Declarations => Empty_List,
- Specification => Spec,
+ Declarations => Empty_List,
+ Specification => Spec,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Build_Dispatching_Subprogram_Body;
end if;
-- Build callers, receivers for every primitive operations and a RPC
- -- receiver for this type.
+ -- receiver for this type. Note that we use Direct_Primitive_Operations,
+ -- not Primitive_Operations, because we really want just the primitives
+ -- of the tagged type itself, and in the case of a tagged synchronized
+ -- type we do not want to get the primitives of the corresponding
+ -- record type).
- if not Is_Concurrent_Type (Designated_Type)
- and then Present (Primitive_Operations (Designated_Type))
- then
+ if Present (Direct_Primitive_Operations (Designated_Type)) then
Overload_Counter_Table.Reset;
Current_Primitive_Elmt :=
- First_Elmt (Primitive_Operations (Designated_Type));
+ First_Elmt (Direct_Primitive_Operations (Designated_Type));
while Current_Primitive_Elmt /= No_Elmt loop
Current_Primitive := Node (Current_Primitive_Elmt);
exception = &storage_error;
msg = "stack overflow (or erroneous memory access)";
}
- __gnat_adjust_context_for_raise (0, (void *)mechargs);
+ __gnat_adjust_context_for_raise (SS$_ACCVIO, (void *)mechargs);
break;
case SS$_STKOVF:
exception = &storage_error;
msg = "stack overflow";
- __gnat_adjust_context_for_raise (0, (void *)mechargs);
+ __gnat_adjust_context_for_raise (SS$_STKOVF, (void *)mechargs);
break;
case SS$_HPARITH:
#else
exception = &constraint_error;
msg = "arithmetic error";
-#ifndef __alpha__
- /* No need to adjust pc on Alpha: the pc is already on the instruction
- after the trapping one. */
- __gnat_adjust_context_for_raise (0, (void *)mechargs);
-#endif
+ __gnat_adjust_context_for_raise (SS$_HPARITH, (void *)mechargs);
#endif
break;
void
__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
{
- /* Add one to the address of the instruction signaling the condition,
- located in the sigargs array. */
+ if (signo == SS$_HPARITH)
+ {
+ /* Sub one to the address of the instruction signaling the condition,
+ located in the sigargs array. */
- CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext;
- CHF$SIGNAL_ARRAY * sigargs
- = (CHF$SIGNAL_ARRAY *) mechargs->chf$q_mch_sig_addr;
+ CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext;
+ CHF$SIGNAL_ARRAY * sigargs
+ = (CHF$SIGNAL_ARRAY *) mechargs->chf$q_mch_sig_addr;
- int vcount = sigargs->chf$is_sig_args;
- int * pc_slot = & (&sigargs->chf$l_sig_name)[vcount-2];
+ int vcount = sigargs->chf$is_sig_args;
+ int * pc_slot = & (&sigargs->chf$l_sig_name)[vcount-2];
- (*pc_slot) ++;
+ (*pc_slot)--;
+ }
}
#endif
end case;
end;
+ ---------
+ -- Ref --
+ ---------
+
+ when Attribute_Ref =>
+ Fold_Uint (N, Expr_Value (E1), True);
+
---------------
-- Remainder --
---------------
Attribute_Position |
Attribute_Priority |
Attribute_Read |
- Attribute_Ref |
Attribute_Result |
Attribute_Storage_Pool |
Attribute_Storage_Size |
then
Install_Parent (Inst_Par);
Parent_Installed := True;
+
+ -- The generic unit may be the renaming of the implicit child
+ -- present in an instance. In that case the parent instance is
+ -- obtained from the name of the renamed entity.
+
+ elsif Ekind (Entity (Gen_Id)) = E_Generic_Package
+ and then Present (Renamed_Entity (Entity (Gen_Id)))
+ and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id)))
+ then
+ declare
+ Renamed_Package : constant Node_Id :=
+ Name (Parent (Entity (Gen_Id)));
+ begin
+ if Nkind (Renamed_Package) = N_Expanded_Name then
+ Inst_Par := Entity (Prefix (Renamed_Package));
+ Install_Parent (Inst_Par);
+ Parent_Installed := True;
+ end if;
+ end;
end if;
end if;
or else
SST.Actions_To_Be_Wrapped_After /= No_List
then
- return;
+ raise Program_Error;
end if;
-- Free last subprogram name if allocated, and pop scope
projects / platform / upstream / gcc.git / commitdiff