diff options
Diffstat (limited to 'gcc/ada/exp_attr.adb')
| -rw-r--r-- | gcc/ada/exp_attr.adb | 534 |
1 files changed, 335 insertions, 199 deletions
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index a0a550d..578e441 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -82,63 +82,30 @@ package body Exp_Attr is package Cached_Attribute_Ops is - Map_Size : constant := 63; - subtype Header_Num is Integer range 0 .. Map_Size - 1; - - function Attribute_Op_Hash (Id : Entity_Id) return Header_Num is - (Header_Num (Id mod Map_Size)); - - -- Caches used to avoid building duplicate subprograms for a single - -- type/attribute pair (where the attribute is either Put_Image or - -- one of the four streaming attributes). The type used as a key in - -- in accessing these maps should not be the entity of a subtype. - - package Read_Map is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Key => Entity_Id, - Element => Entity_Id, - No_Element => Empty, - Hash => Attribute_Op_Hash, - Equal => "="); - - package Write_Map is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Key => Entity_Id, - Element => Entity_Id, - No_Element => Empty, - Hash => Attribute_Op_Hash, - Equal => "="); - - package Input_Map is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Key => Entity_Id, - Element => Entity_Id, - No_Element => Empty, - Hash => Attribute_Op_Hash, - Equal => "="); - - package Output_Map is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Key => Entity_Id, - Element => Entity_Id, - No_Element => Empty, - Hash => Attribute_Op_Hash, - Equal => "="); - - package Put_Image_Map is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Key => Entity_Id, - Element => Entity_Id, - No_Element => Empty, - Hash => Attribute_Op_Hash, - Equal => "="); - - procedure Validate_Cached_Candidate - (Subp : in out Entity_Id; - Attr_Ref : Node_Id); - -- If Subp is non-empty but it is not callable from the point of - -- Attr_Ref (perhaps because it is not visible from that point), - -- then Subp is set to Empty. Otherwise, do nothing. + procedure Add_To_Read_Map + (Key_Typ : Entity_Id; Element_Subp : Entity_Id); + function Get_From_Read_Map + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id; + + procedure Add_To_Write_Map + (Key_Typ : Entity_Id; Element_Subp : Entity_Id); + function Get_From_Write_Map + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id; + + procedure Add_To_Input_Map + (Key_Typ : Entity_Id; Element_Subp : Entity_Id); + function Get_From_Input_Map + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id; + + procedure Add_To_Output_Map + (Key_Typ : Entity_Id; Element_Subp : Entity_Id); + function Get_From_Output_Map + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id; + + procedure Add_To_Put_Image_Map + (Key_Typ : Entity_Id; Element_Subp : Entity_Id); + function Get_From_Put_Image_Map + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id; end Cached_Attribute_Ops; @@ -290,45 +257,208 @@ package body Exp_Attr is package body Cached_Attribute_Ops is - ------------------------------- - -- Validate_Cached_Candidate -- - ------------------------------- + -- Caches are used to avoid building duplicate subprograms for a single + -- type/attribute pair (where the attribute is either Put_Image or + -- one of the four streaming attributes). The type used as a key in + -- in accessing these maps should not be the entity of a subtype. - procedure Validate_Cached_Candidate - (Subp : in out Entity_Id; - Attr_Ref : Node_Id) is - begin - if No (Subp) then - return; - end if; + Map_Size : constant := 63; + subtype Header_Num is Integer range 0 .. Map_Size - 1; - declare - Subp_Comp_Unit : constant Node_Id := - Enclosing_Comp_Unit_Node (Subp); - Attr_Ref_Comp_Unit : constant Node_Id := - Enclosing_Comp_Unit_Node (Attr_Ref); - - -- The preceding Enclosing_Comp_Unit_Node calls are needed - -- (as opposed to changing Interunit_Ref_OK so that it could - -- be passed Subp and Attr_Ref) because the games we play - -- with source position info for these conjured-up routines can - -- confuse In_Same_Extended_Unit (which is called from in - -- Interunit_Ref_OK) in the case where one of these - -- conjured-up routines contains an attribute reference - -- denoting another such routine (e.g., if the Put_Image routine - -- for a composite type contains a Some_Component_Type'Put_Image - -- attribute reference). Calling Enclosing_Comp_Unit_Node first - -- avoids the case where In_Same_Extended_Unit gets confused. + function Attribute_Op_Hash (Id : Entity_Id) return Header_Num is + (Header_Num (Id mod Map_Size)); + + function Cached_Candidate_Is_OK + (Subp : Entity_Id; Attr_Ref : Node_Id) return Boolean; + -- Return True if Subp is callable from the point of Attr_Ref + -- (so it is ok to rewrite Attr_Ref as a call to Subp). + generic + package Existing_Subps_Map is + procedure Add_Subp + (Key_Typ : Entity_Id; Element_Subp : Entity_Id); + -- Having created a subp to implement a particular attribute of + -- Key_Typ, make it available for possible reuse by remembering it. + + function Get_Subp + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id; + -- If one of the recorded candidates for Key_Typ is suitable, + -- (see Cached_Candidate_Is_OK for meaning of "suitable") + -- then return it. If not, then return Empty. + end Existing_Subps_Map; + + package body Existing_Subps_Map is + package Subp_List_Table is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Key => Entity_Id, + Element => Elist_Id, + No_Element => No_Elist, + Hash => Attribute_Op_Hash, + Equal => "="); + + function Normalize_Map_Key (Typ : Entity_Id) return Entity_Id; + -- We need a single Entity_Id to represent all views and + -- all subtypes of a given type, just for use as a key value + -- for map lookups. It doesn't much matter which Entity_Id we + -- choose as long as we are consistent. + + ----------------------- + -- Normalize_Map_Key -- + ----------------------- + + function Normalize_Map_Key (Typ : Entity_Id) return Entity_Id is + First_Sub : constant Entity_Id := First_Subtype (Typ); + I_Or_P : constant Entity_Id + := Incomplete_Or_Partial_View (First_Sub); begin - if Interunit_Ref_OK (Subp_Comp_Unit, Attr_Ref_Comp_Unit) - and then (Is_Library_Level_Entity (Subp) - or else Enclosing_Dynamic_Scope (Subp) = - Enclosing_Lib_Unit_Entity (Subp)) - then - return; + if Present (I_Or_P) then + return I_Or_P; + else + return First_Sub; end if; - end; + end Normalize_Map_Key; + + -------------- + -- Add_Subp -- + -------------- + + procedure Add_Subp + (Key_Typ : Entity_Id; Element_Subp : Entity_Id) + is + Normalized : constant Entity_Id := Normalize_Map_Key (Key_Typ); + Current : constant Elist_Id := Subp_List_Table.Get (Normalized); + begin + if Present (Current) then + declare + Elmt : Elmt_Id := First_Elmt (Current); + Comp_Unit_Of_Subp : constant Node_Id := + Enclosing_Comp_Unit_Node (Element_Subp); + begin + while Present (Elmt) loop + pragma Assert (Comp_Unit_Of_Subp /= + Enclosing_Comp_Unit_Node (Node (Elmt))); + Next_Elmt (Elmt); + end loop; + end; + + Append_Elmt (Element_Subp, Current); + else + Subp_List_Table.Set (Normalized, New_Elmt_List (Element_Subp)); + end if; + end Add_Subp; + + -------------- + -- Get_Subp -- + -------------- + + function Get_Subp + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id + is + Normalized : constant Entity_Id := Normalize_Map_Key (Key_Typ); + List : constant Elist_Id := + Subp_List_Table.Get (Normalized); + Result : Entity_Id := Empty; + Elmt : Elmt_Id; + begin + if Present (List) then + Elmt := First_Elmt (List); + + while Present (Elmt) loop + Result := Node (Elmt); + + if Cached_Candidate_Is_OK + (Subp => Result, Attr_Ref => Attr_Ref) + then + return Result; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + return Empty; + end Get_Subp; + + end Existing_Subps_Map; + + -- Declare an instance for each of the 5 attributes and complete each + -- attribute's Add and Get subprograms by renaming. + + package Read_Map is new Existing_Subps_Map; + procedure Add_To_Read_Map + (Key_Typ : Entity_Id; Element_Subp : Entity_Id) + renames Read_Map.Add_Subp; + function Get_From_Read_Map + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id + renames Read_Map.Get_Subp; + + package Write_Map is new Existing_Subps_Map; + procedure Add_To_Write_Map + (Key_Typ : Entity_Id; Element_Subp : Entity_Id) + renames Write_Map.Add_Subp; + function Get_From_Write_Map + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id + renames Write_Map.Get_Subp; + + package Input_Map is new Existing_Subps_Map; + procedure Add_To_Input_Map + (Key_Typ : Entity_Id; Element_Subp : Entity_Id) + renames Input_Map.Add_Subp; + function Get_From_Input_Map + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id + renames Input_Map.Get_Subp; + + package Output_Map is new Existing_Subps_Map; + procedure Add_To_Output_Map + (Key_Typ : Entity_Id; Element_Subp : Entity_Id) + renames Output_Map.Add_Subp; + function Get_From_Output_Map + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id + renames Output_Map.Get_Subp; + + package Put_Image_Map is new Existing_Subps_Map; + procedure Add_To_Put_Image_Map + (Key_Typ : Entity_Id; Element_Subp : Entity_Id) + renames Put_Image_Map.Add_Subp; + function Get_From_Put_Image_Map + (Key_Typ : Entity_Id; Attr_Ref : Node_Id) return Entity_Id + renames Put_Image_Map.Get_Subp; + + ---------------------------- + -- Cached_Candidate_Is_OK -- + ---------------------------- + + function Cached_Candidate_Is_OK + (Subp : Entity_Id; Attr_Ref : Node_Id) return Boolean + is + Subp_Comp_Unit : constant Node_Id := + Enclosing_Comp_Unit_Node (Subp); + Attr_Ref_Comp_Unit : constant Node_Id := + Enclosing_Comp_Unit_Node (Attr_Ref); + + -- The preceding Enclosing_Comp_Unit_Node calls are needed + -- (as opposed to changing Interunit_Ref_OK so that it could + -- be passed Subp and Attr_Ref) because the games we play + -- with source position info for these conjured-up routines can + -- confuse In_Same_Extended_Unit (which is called from in + -- Interunit_Ref_OK) in the case where one of these + -- conjured-up routines contains an attribute reference + -- denoting another such routine (e.g., if the Put_Image routine + -- for a composite type contains a Some_Component_Type'Put_Image + -- attribute reference). Calling Enclosing_Comp_Unit_Node first + -- avoids the case where In_Same_Extended_Unit gets confused. + + begin + if Subp_Comp_Unit = Attr_Ref_Comp_Unit then + return True; + + elsif Interunit_Ref_OK (Subp_Comp_Unit, Attr_Ref_Comp_Unit) + and then (Is_Library_Level_Entity (Subp) + or else Enclosing_Dynamic_Scope (Subp) = + Enclosing_Lib_Unit_Entity (Subp)) + then + return True; + end if; -- We have previously tried being more ambitious here in hopes of -- referencing subprograms declared in other units (as opposed @@ -340,8 +470,8 @@ package body Exp_Attr is -- "_305PI"). So, after a fair amount of unsuccessful debugging, -- it was decided to abandon the effort. - Subp := Empty; - end Validate_Cached_Candidate; + return False; + end Cached_Candidate_Is_OK; end Cached_Attribute_Ops; ------------------------- @@ -1906,6 +2036,9 @@ package body Exp_Attr is function Get_Integer_Type (Typ : Entity_Id) return Entity_Id; -- Return a small integer type appropriate for the enumeration type + function Get_Array_Stream_Item_Type (Typ : Entity_Id) return Entity_Id; + -- For non-scalar types return the first subtype of Typ. + procedure Rewrite_Attribute_Proc_Call (Pname : Entity_Id); -- Rewrites an attribute for Read, Write, Output, or Put_Image with a -- call to the appropriate TSS procedure. Pname is the entity for the @@ -1943,7 +2076,8 @@ package body Exp_Attr is Insertion_Scope : Entity_Id := Empty; Insertion_Point : Node_Id := Empty; Insert_Before : Boolean := False; - Typ_Comp_Unit : Node_Id := Enclosing_Comp_Unit_Node (Typ); + First_Typ : constant Entity_Id := First_Subtype (Typ); + Typ_Comp_Unit : Node_Id := Enclosing_Comp_Unit_Node (First_Typ); begin -- handle no-enclosing-comp-unit cases if No (Typ_Comp_Unit) then @@ -1961,16 +2095,16 @@ package body Exp_Attr is -- See comment accompanying earlier call to Interunit_Ref_OK -- for discussion of these Enclosing_Comp_Unit_Node calls. then - -- Typ is declared in the current unit, so - -- we want to hoist to the same scope as Typ. + -- First_Typ is declared in the current unit, so + -- we want to hoist to the same scope as First_Typ. - Insertion_Scope := Scope (Typ); - Insertion_Point := Freeze_Node (Typ); + Insertion_Scope := Scope (First_Typ); + Insertion_Point := Freeze_Node (First_Typ); else -- Typ is declared in a different unit, so -- hoist to library level. - pragma Assert (Is_Library_Level_Entity (Typ)); + pragma Assert (Is_Library_Level_Entity (First_Typ)); while Present (Ancestor) loop if Is_List_Member (Ancestor) then @@ -2052,6 +2186,16 @@ package body Exp_Attr is end if; end Build_And_Insert_Type_Attr_Subp; + -- Two instances, used for doing what the instance names suggest. + + procedure Build_And_Insert_Record_Or_Elementary_Input_Func is + new Build_And_Insert_Type_Attr_Subp + (Build_Record_Or_Elementary_Input_Function); + + procedure Build_And_Insert_Record_Or_Elementary_Output_Proc is + new Build_And_Insert_Type_Attr_Subp + (Build_Record_Or_Elementary_Output_Procedure); + ---------------------- -- Get_Integer_Type -- ---------------------- @@ -2066,6 +2210,19 @@ package body Exp_Attr is return Small_Integer_Type_For (Siz, Uns => Is_Unsigned_Type (Typ)); end Get_Integer_Type; + -------------------------------- + -- Get_Array_Stream_Item_Type -- + -------------------------------- + + function Get_Array_Stream_Item_Type (Typ : Entity_Id) return Entity_Id is + First_Sub_Typ : constant Entity_Id := First_Subtype (Typ); + begin + if Is_Private_Type (First_Sub_Typ) then + return Typ; + end if; + return First_Sub_Typ; + end Get_Array_Stream_Item_Type; + --------------------------------- -- Rewrite_Attribute_Proc_Call -- --------------------------------- @@ -2494,6 +2651,7 @@ package body Exp_Attr is Rewrite (Prefix (N), Convert_To (Btyp_DDT, New_Copy_Tree (Prefix (N)))); + Flag_Interface_Pointer_Displacement (Prefix (N)); Analyze_And_Resolve (Prefix (N), Btyp_DDT); end if; @@ -2518,6 +2676,8 @@ package body Exp_Attr is Rewrite (N, Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)))); + Flag_Interface_Pointer_Displacement (N); + Analyze_And_Resolve (N, Typ); end if; end; @@ -2970,6 +3130,7 @@ package body Exp_Attr is Designated_Type (Etype (Parent (N))); begin Rewrite (Pref, Convert_To (Iface_Typ, Relocate_Node (Pref))); + Flag_Interface_Pointer_Displacement (Pref); Analyze_And_Resolve (Pref, Iface_Typ); return; end; @@ -4482,6 +4643,7 @@ package body Exp_Attr is P_Type : constant Entity_Id := Entity (Pref); B_Type : constant Entity_Id := Base_Type (P_Type); U_Type : constant Entity_Id := Underlying_Type (P_Type); + I_Type : Entity_Id := P_Type; Strm : constant Node_Id := First (Exprs); Fname : Entity_Id; Decl : Node_Id; @@ -4613,9 +4775,11 @@ package body Exp_Attr is -- since in this case we are required to call this routine. if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Read)) then - Build_Record_Or_Elementary_Input_Function - (P_Type, Decl, Fname); - Insert_Action (N, Decl); + Build_And_Insert_Record_Or_Elementary_Input_Func + (Typ => Base_Type (U_Type), + Decl => Decl, + Subp => Fname, + Attr_Ref => N); -- For normal cases, we call the I_xxx routine directly @@ -4633,8 +4797,9 @@ package body Exp_Attr is new Build_And_Insert_Type_Attr_Subp (Build_Array_Input_Function); begin + I_Type := Get_Array_Stream_Item_Type (U_Type); Build_And_Insert_Array_Input_Func - (Typ => Full_Base (U_Type), + (Typ => I_Type, Decl => Decl, Subp => Fname, Attr_Ref => N); @@ -4733,17 +4898,11 @@ package body Exp_Attr is -- first named subtype is unconstrained? Shouldn't we be -- passing in the first named subtype of the type? - declare - procedure Build_And_Insert_Record_Input_Func is - new Build_And_Insert_Type_Attr_Subp - (Build_Record_Or_Elementary_Input_Function); - begin - Build_And_Insert_Record_Input_Func - (Typ => U_Type, - Decl => Decl, - Subp => Fname, - Attr_Ref => N); - end; + Build_And_Insert_Record_Or_Elementary_Input_Func + (Typ => Underlying_Type (First_Subtype (P_Type)), + Decl => Decl, + Subp => Fname, + Attr_Ref => N); if Nkind (Parent (N)) = N_Object_Declaration and then Is_Record_Type (U_Type) @@ -4771,6 +4930,10 @@ package body Exp_Attr is end; end if; end if; + + if not Is_Tagged_Type (U_Type) then + Cached_Attribute_Ops.Add_To_Input_Map (U_Type, Fname); + end if; end if; -- If we fall through, Fname is the function to be called. The result @@ -4784,16 +4947,17 @@ package body Exp_Attr is Relocate_Node (Strm))); Set_Controlling_Argument (Call, Cntrl); - Rewrite (N, Unchecked_Convert_To (P_Type, Call)); - Analyze_And_Resolve (N, P_Type); + if Is_Private_Type (P_Type) or else Is_Class_Wide_Type (P_Type) then + Rewrite (N, Unchecked_Convert_To (P_Type, Call)); + Analyze_And_Resolve (N, P_Type); + else + Rewrite (N, Call); + Analyze_And_Resolve (N, I_Type); + end if; if Nkind (Parent (N)) = N_Object_Declaration then Freeze_Stream_Subprogram (Fname); end if; - - if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Input_Map.Set (U_Type, Fname); - end if; end Input; ------------------- @@ -5142,7 +5306,8 @@ package body Exp_Attr is Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Result_Id, Loc), Selector_Name => Make_Identifier (Loc, - Chars (Constructor_Name (Typ)))); + Direct_Attribute_Definition_Name + (Typ, Name_Constructor))); begin Set_Is_Prefixed_Call (Proc_Name); @@ -5797,9 +5962,11 @@ package body Exp_Attr is -- since in this case we are required to call this routine. if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Write)) then - Build_Record_Or_Elementary_Output_Procedure - (P_Type, Decl, Pname); - Insert_Action (N, Decl); + Build_And_Insert_Record_Or_Elementary_Output_Proc + (Typ => Base_Type (U_Type), + Decl => Decl, + Subp => Pname, + Attr_Ref => N); -- For normal cases, we call the W_xxx routine directly @@ -5818,7 +5985,7 @@ package body Exp_Attr is (Build_Array_Output_Procedure); begin Build_And_Insert_Array_Output_Proc - (Typ => Full_Base (U_Type), + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, Subp => Pname, Attr_Ref => N); @@ -5878,27 +6045,21 @@ package body Exp_Attr is return; end if; - declare - procedure Build_And_Insert_Record_Output_Proc is - new Build_And_Insert_Type_Attr_Subp - (Build_Record_Or_Elementary_Output_Procedure); - begin - Build_And_Insert_Record_Output_Proc - (Typ => Base_Type (U_Type), - Decl => Decl, - Subp => Pname, - Attr_Ref => N); - end; + Build_And_Insert_Record_Or_Elementary_Output_Proc + (Typ => Underlying_Type (First_Subtype (P_Type)), + Decl => Decl, + Subp => Pname, + Attr_Ref => N); + end if; + + if not Is_Tagged_Type (U_Type) then + Cached_Attribute_Ops.Add_To_Output_Map (U_Type, Pname); end if; end if; -- If we fall through, Pname is the name of the procedure to call Rewrite_Attribute_Proc_Call (Pname); - - if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Output_Map.Set (U_Type, Pname); - end if; end Output; --------- @@ -6061,7 +6222,7 @@ package body Exp_Attr is -- For modular types, nothing to do (no overflow, since wraps) - elsif Is_Modular_Integer_Type (Ptyp) then + elsif Has_Modular_Operations (Ptyp) then null; -- For other types, if argument is marked as needing a range check or @@ -6280,13 +6441,12 @@ package body Exp_Attr is /= RTU_Entity (Interfaces_C)) then Rewrite (N, Build_String_Put_Image_Call (N)); - Analyze (N); + Analyze (N, Suppress => All_Checks); return; elsif Is_Array_Type (U_Type) then - Pname := Cached_Attribute_Ops.Put_Image_Map.Get (U_Type); - Cached_Attribute_Ops.Validate_Cached_Candidate - (Pname, Attr_Ref => N); + Pname := Cached_Attribute_Ops.Get_From_Put_Image_Map + (U_Type, Attr_Ref => N); if No (Pname) then declare procedure Build_And_Insert_Array_Put_Image_Proc is @@ -6295,13 +6455,13 @@ package body Exp_Attr is begin Build_And_Insert_Array_Put_Image_Proc - (Typ => U_Type, + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, - Subp => Pname, - Attr_Ref => N); + Subp => Pname, + Attr_Ref => N); end; - Cached_Attribute_Ops.Put_Image_Map.Set (U_Type, Pname); + Cached_Attribute_Ops.Add_To_Put_Image_Map (U_Type, Pname); end if; -- Tagged type case, use the primitive Put_Image function. Note @@ -6338,9 +6498,8 @@ package body Exp_Attr is declare Base_Typ : constant Entity_Id := Full_Base (U_Type); begin - Pname := Cached_Attribute_Ops.Put_Image_Map.Get (Base_Typ); - Cached_Attribute_Ops.Validate_Cached_Candidate - (Pname, Attr_Ref => N); + Pname := Cached_Attribute_Ops.Get_From_Put_Image_Map + (Base_Typ, Attr_Ref => N); if No (Pname) then declare procedure Build_And_Insert_Record_Put_Image_Proc is @@ -6355,7 +6514,8 @@ package body Exp_Attr is Attr_Ref => N); end; - Cached_Attribute_Ops.Put_Image_Map.Set (Base_Typ, Pname); + Cached_Attribute_Ops.Add_To_Put_Image_Map + (Base_Typ, Pname); end if; end; end if; @@ -6434,15 +6594,14 @@ package body Exp_Attr is E2 : constant Node_Id := Next (E1); Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); - Accum_Typ : Entity_Id := Empty; + Accum_Typ : constant Entity_Id := Etype (N); New_Loop : Node_Id; function Build_Stat (Comp : Node_Id) return Node_Id; -- The reducer can be a function, a procedure whose first -- parameter is in-out, or an attribute that is a function, -- which (for now) can only be Min/Max. This subprogram - -- builds the corresponding computation for the generated loop - -- and retrieves the accumulator type as per RM 4.5.10(19/5). + -- builds the corresponding computation for the generated loop. ---------------- -- Build_Stat -- @@ -6453,7 +6612,6 @@ package body Exp_Attr is begin if Nkind (E1) = N_Attribute_Reference then - Accum_Typ := Base_Type (Entity (Prefix (E1))); Stat := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Bnn, Loc), Expression => Make_Attribute_Reference (Loc, @@ -6464,7 +6622,6 @@ package body Exp_Attr is Comp))); elsif Ekind (Entity (E1)) = E_Procedure then - Accum_Typ := Etype (First_Formal (Entity (E1))); Stat := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Entity (E1), Loc), Parameter_Associations => New_List ( @@ -6472,7 +6629,6 @@ package body Exp_Attr is Comp)); else - Accum_Typ := Etype (Entity (E1)); Stat := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Bnn, Loc), Expression => Make_Function_Call (Loc, @@ -6482,28 +6638,6 @@ package body Exp_Attr is Comp))); end if; - -- Try to cope if E1 is wrong because it is an overloaded - -- subprogram that happens to be the first candidate - -- on a homonym chain, but that resolution candidate turns - -- out to be the wrong one. - -- This workaround usually gets the right type, but it can - -- yield the wrong subtype of that type. - - if Base_Type (Accum_Typ) /= Base_Type (Etype (N)) then - Accum_Typ := Etype (N); - end if; - - -- Try to cope with wrong E1 when Etype (N) doesn't help - if Is_Universal_Numeric_Type (Accum_Typ) then - if Is_Array_Type (Etype (Prefix (N))) then - Accum_Typ := Component_Type (Etype (Prefix (N))); - else - -- Further hackery can be added here when there is a - -- demonstrated need. - null; - end if; - end if; - return Stat; end Build_Stat; @@ -6746,7 +6880,7 @@ package body Exp_Attr is (Build_Array_Read_Procedure); begin Build_And_Insert_Array_Read_Proc - (Typ => Full_Base (U_Type), + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, Subp => Pname, Attr_Ref => N); @@ -6817,6 +6951,10 @@ package body Exp_Attr is Attr_Ref => N); end; end if; + + if not Is_Tagged_Type (U_Type) then + Cached_Attribute_Ops.Add_To_Read_Map (U_Type, Pname); + end if; end if; Rewrite_Attribute_Proc_Call (Pname); @@ -6860,10 +6998,6 @@ package body Exp_Attr is Analyze (Assign_Tag); end; end if; - - if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Read_Map.Set (U_Type, Pname); - end if; end Read; --------- @@ -7363,7 +7497,7 @@ package body Exp_Attr is -- For modular types, nothing to do (no overflow, since wraps) - elsif Is_Modular_Integer_Type (Ptyp) then + elsif Has_Modular_Operations (Ptyp) then null; -- For other types, if argument is marked as needing a range check or @@ -8461,7 +8595,7 @@ package body Exp_Attr is (Build_Array_Write_Procedure); begin Build_And_Insert_Array_Write_Proc - (Typ => Full_Base (U_Type), + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, Subp => Pname, Attr_Ref => N); @@ -8542,15 +8676,15 @@ package body Exp_Attr is Attr_Ref => N); end; end if; + + if not Is_Tagged_Type (U_Type) then + Cached_Attribute_Ops.Add_To_Write_Map (U_Type, Pname); + end if; end if; -- If we fall through, Pname is the procedure to be called Rewrite_Attribute_Proc_Call (Pname); - - if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Write_Map.Set (U_Type, Pname); - end if; end Write; -- The following attributes are handled by the back end (except that @@ -8577,6 +8711,7 @@ package body Exp_Attr is | Attribute_Bit_Order | Attribute_Class | Attribute_Compiler_Version + | Attribute_Constructor | Attribute_Default_Bit_Order | Attribute_Default_Scalar_Storage_Order | Attribute_Definite @@ -9159,19 +9294,20 @@ package body Exp_Attr is -- In particular, we do not want the entity for a subtype. begin if Nam = TSS_Stream_Read then - Ent := Cached_Attribute_Ops.Read_Map.Get (U_Base); + Ent := Cached_Attribute_Ops.Get_From_Read_Map + (U_Base, Attr_Ref => Attr_Ref); elsif Nam = TSS_Stream_Write then - Ent := Cached_Attribute_Ops.Write_Map.Get (U_Base); + Ent := Cached_Attribute_Ops.Get_From_Write_Map + (U_Base, Attr_Ref => Attr_Ref); elsif Nam = TSS_Stream_Input then - Ent := Cached_Attribute_Ops.Input_Map.Get (U_Base); + Ent := Cached_Attribute_Ops.Get_From_Input_Map + (U_Base, Attr_Ref => Attr_Ref); elsif Nam = TSS_Stream_Output then - Ent := Cached_Attribute_Ops.Output_Map.Get (U_Base); + Ent := Cached_Attribute_Ops.Get_From_Output_Map + (U_Base, Attr_Ref => Attr_Ref); end if; end; - Cached_Attribute_Ops.Validate_Cached_Candidate - (Subp => Ent, Attr_Ref => Attr_Ref); - if Present (Ent) then return Ent; end if; |