package body Exp_Attr is
- package Cached_Streaming_Ops is
+ package Cached_Attribute_Ops is
Map_Size : constant := 63;
subtype Header_Num is Integer range 0 .. Map_Size - 1;
- function Streaming_Op_Hash (Id : Entity_Id) return Header_Num is
+ function Attribute_Op_Hash (Id : Entity_Id) return Header_Num is
(Header_Num (Id mod Map_Size));
-- Cache used to avoid building duplicate subprograms for a single
Key => Entity_Id,
Element => Entity_Id,
No_Element => Empty,
- Hash => Streaming_Op_Hash,
+ Hash => Attribute_Op_Hash,
Equal => "=");
package Write_Map is new GNAT.HTable.Simple_HTable
Key => Entity_Id,
Element => Entity_Id,
No_Element => Empty,
- Hash => Streaming_Op_Hash,
+ Hash => Attribute_Op_Hash,
Equal => "=");
package Input_Map is new GNAT.HTable.Simple_HTable
Key => Entity_Id,
Element => Entity_Id,
No_Element => Empty,
- Hash => Streaming_Op_Hash,
+ Hash => Attribute_Op_Hash,
Equal => "=");
package Output_Map is new GNAT.HTable.Simple_HTable
Key => Entity_Id,
Element => Entity_Id,
No_Element => Empty,
- Hash => Streaming_Op_Hash,
+ Hash => Attribute_Op_Hash,
Equal => "=");
- end Cached_Streaming_Ops;
+ 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.
+
+ end Cached_Attribute_Ops;
-----------------------
-- Local Subprograms --
--
-- * Rec_Typ - the record type whose internals are to be validated
- procedure Compile_Stream_Body_In_Scope
- (N : Node_Id;
- Decl : Node_Id;
- Arr : Entity_Id);
- -- The body for a stream subprogram may be generated outside of the scope
- -- of the type. If the type is fully private, it may depend on the full
- -- view of other types (e.g. indexes) that are currently private as well.
- -- We install the declarations of the package in which the type is declared
- -- before compiling the body in what is its proper environment. The Check
- -- parameter indicates if checks are to be suppressed for the stream body.
- -- We suppress checks for array/record reads, since the rule is that these
- -- are like assignments, out of range values due to uninitialized storage,
- -- or other invalid values do NOT cause a Constraint_Error to be raised.
- -- If we are within an instance body all visibility has been established
- -- already and there is no need to install the package.
-
- -- This mechanism is now extended to the component types of the array type,
- -- when the component type is not in scope and is private, to handle
- -- properly the case when the full view has defaulted discriminants.
-
- -- This special processing is ultimately caused by the fact that the
- -- compiler lacks a well-defined phase when full views are visible
- -- everywhere. Having such a separate pass would remove much of the
- -- special-case code that shuffles partial and full views in the middle
- -- of semantic analysis and expansion.
-
function Default_Streaming_Unavailable (Typ : Entity_Id) return Boolean;
--
-- In most cases, references to unavailable streaming attributes
-- expansion. Typically used for rounding and truncation attributes that
-- appear directly inside a conversion to integer.
+ function Interunit_Ref_OK
+ (Subp_Unit, Attr_Ref_Unit : Node_Id) return Boolean is
+ (In_Same_Extended_Unit (Subp_Unit, Attr_Ref_Unit)
+ -- If subp declared in unit body, then we don't want to refer
+ -- to it from within unit spec so return False in that case.
+ and then not (Body_Required (Attr_Ref_Unit)
+ and not Body_Required (Subp_Unit)));
+ -- Returns True if it is ok to refer to a cached subprogram declared in
+ -- Subp_Unit from the point of an attribute reference occurring in
+ -- Attr_Ref_Unit. Both arguments are usually N_Compilation_Nodes,
+ -- although there are cases where Subp_Unit might be a type declared in
+ -- package Standard (in which case the In_Same_Extended_Unit call will
+ -- return False).
+
+ package body Cached_Attribute_Ops is
+
+ -------------------------------
+ -- Validate_Cached_Candidate --
+ -------------------------------
+
+ procedure Validate_Cached_Candidate
+ (Subp : in out Entity_Id;
+ Attr_Ref : Node_Id) is
+ begin
+ if No (Subp) then
+ return;
+ end if;
+
+ 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.
+
+ 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;
+ end if;
+ end;
+
+ -- We have previously tried being more ambitious here in hopes of
+ -- referencing subprograms declared in other units (as opposed
+ -- to generating a new copy for the current unit) if they are
+ -- visible from the point of Attr_Ref. Unfortunately,
+ -- we ran into problems with generating inconsistent linknames
+ -- (e.g., a procedure declared with a name ending in "_304PI" being
+ -- unsuccessfully referenced from another unit via a name ending in
+ -- "_305PI"). So, after a fair amount of unsuccessful debugging,
+ -- it was decided to abandon the effort.
+
+ Subp := Empty;
+ end Validate_Cached_Candidate;
+ end Cached_Attribute_Ops;
+
-------------------------
-- Build_Array_VS_Func --
-------------------------
return Func_Id;
end Build_Record_VS_Func;
- ----------------------------------
- -- Compile_Stream_Body_In_Scope --
- ----------------------------------
-
- procedure Compile_Stream_Body_In_Scope
- (N : Node_Id;
- Decl : Node_Id;
- Arr : Entity_Id)
- is
- C_Type : constant Entity_Id := Base_Type (Component_Type (Arr));
- Curr : constant Entity_Id := Current_Scope;
- Install : Boolean := False;
- Scop : Entity_Id := Scope (Arr);
-
- begin
- if Is_Hidden (Arr)
- and then not In_Open_Scopes (Scop)
- and then Ekind (Scop) = E_Package
- then
- Install := True;
-
- else
- -- The component type may be private, in which case we install its
- -- full view to compile the subprogram.
-
- -- The component type may be private, in which case we install its
- -- full view to compile the subprogram. We do not do this if the
- -- type has a Stream_Convert pragma, which indicates that there are
- -- special stream-processing operations for that type (for example
- -- Unbounded_String and its wide varieties).
-
- -- We don't install the package either if array type and element
- -- type come from the same package, and the original array type is
- -- private, because in this case the underlying type Arr is
- -- itself a full view, which carries the full view of the component.
-
- Scop := Scope (C_Type);
-
- if Is_Private_Type (C_Type)
- and then Present (Full_View (C_Type))
- and then not In_Open_Scopes (Scop)
- and then Ekind (Scop) = E_Package
- and then No (Get_Stream_Convert_Pragma (C_Type))
- then
- if Scope (Arr) = Scope (C_Type)
- and then Is_Private_Type (Etype (Prefix (N)))
- and then Full_View (Etype (Prefix (N))) = Arr
- then
- null;
-
- else
- Install := True;
- end if;
- end if;
- end if;
-
- -- If we are within an instance body, then all visibility has been
- -- established already and there is no need to install the package.
-
- if Install and then not In_Instance_Body then
- Push_Scope (Scop);
- Install_Visible_Declarations (Scop);
- Install_Private_Declarations (Scop);
-
- -- The entities in the package are now visible, but the generated
- -- stream entity must appear in the current scope (usually an
- -- enclosing stream function) so that itypes all have their proper
- -- scopes.
-
- Push_Scope (Curr);
- else
- Install := False;
- end if;
-
- Insert_Action (N, Decl);
-
- if Install then
-
- -- Remove extra copy of current scope, and package itself
-
- Pop_Scope;
- End_Package_Scope (Scop);
- end if;
- end Compile_Stream_Body_In_Scope;
-
-----------------------------------
-- Default_Streaming_Unavailable --
-----------------------------------
Pref : constant Node_Id := Prefix (N);
Exprs : constant List_Id := Expressions (N);
+ generic
+ with procedure Build_Type_Attr_Subprogram
+ (Typ : Entity_Id;
+ Decl : out Node_Id;
+ Subp : out Entity_Id);
+ procedure Build_And_Insert_Type_Attr_Subp
+ (Typ : Entity_Id;
+ Decl : out Node_Id;
+ Subp : out Entity_Id;
+ Attr_Ref : Node_Id);
+
+ -- If we have two calls to (for example)
+ -- Some_Untagged_Record_Type'Put_Image, we'd like
+ -- to generate just one procedure and call it twice (as opposed to
+ -- generating two effectively-identical procedures). Hoisting the
+ -- declaration of the procedure ensures that a second such attribute
+ -- reference in the current library unit will not need to generate a
+ -- second procedure.
+
function Get_Integer_Type (Typ : Entity_Id) return Entity_Id;
-- Return a small integer type appropriate for the enumeration type
-- call to the appropriate TSS procedure. Pname is the entity for the
-- procedure to call.
+ -------------------------------------
+ -- Build_And_Insert_Type_Attr_Subp --
+ -------------------------------------
+
+ procedure Build_And_Insert_Type_Attr_Subp
+ (Typ : Entity_Id;
+ Decl : out Node_Id;
+ Subp : out Entity_Id;
+ Attr_Ref : Node_Id)
+ is
+ procedure Build;
+ procedure Build is
+ begin
+ Build_Type_Attr_Subprogram
+ (Typ => Typ,
+ Decl => Decl,
+ Subp => Subp);
+ end Build;
+
+ Ancestor : Node_Id := Attr_Ref;
+ Insertion_Scope : Entity_Id := Empty;
+ Insertion_Point : Node_Id := Empty;
+ Insert_Before : Boolean := False;
+ Typ_Comp_Unit : Node_Id := Enclosing_Comp_Unit_Node (Typ);
+ begin
+ -- handle no-enclosing-comp-unit cases
+ if No (Typ_Comp_Unit) then
+ if Is_Itype (Typ) then
+ Typ_Comp_Unit := Enclosing_Comp_Unit_Node
+ (Associated_Node_For_Itype (Typ));
+ elsif Sloc (Typ) <= Standard_Location then
+ Typ_Comp_Unit := Typ; -- not a comp unit node, but that's ok
+ end if;
+ pragma Assert (Present (Typ_Comp_Unit));
+ end if;
+
+ if Interunit_Ref_OK (Typ_Comp_Unit,
+ Enclosing_Comp_Unit_Node (Attr_Ref))
+ -- 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.
+
+ Insertion_Scope := Scope (Typ);
+ Insertion_Point := Freeze_Node (Typ);
+ else
+ -- Typ is declared in a different unit, so
+ -- hoist to library level.
+
+ pragma Assert (Is_Library_Level_Entity (Typ));
+
+ while Present (Ancestor) loop
+ if Is_List_Member (Ancestor) then
+ Insertion_Point := Ancestor;
+ end if;
+ Ancestor := Parent (Ancestor);
+ end loop;
+
+ if Present (Insertion_Point) then
+ Insert_Before := True;
+ Insertion_Scope :=
+ Find_Enclosing_Scope (Insertion_Point);
+ end if;
+ end if;
+
+ if Present (Insertion_Point)
+ and Present (Insertion_Scope)
+ then
+ Push_Scope (Insertion_Scope);
+ Build;
+ if Insert_Before then
+ Insert_Action
+ (Insertion_Point, Ins_Action => Decl);
+ else
+ Insert_Action_After
+ (Insertion_Point, Ins_Action => Decl);
+ end if;
+ Pop_Scope;
+ else
+ -- Hoisting was unsuccessful, so no need to
+ -- Push/Pop a scope.
+
+ Build;
+ Insert_Action (Attr_Ref, Ins_Action => Decl);
+ end if;
+ end Build_And_Insert_Type_Attr_Subp;
+
----------------------
-- Get_Integer_Type --
----------------------
and then not Is_Class_Wide_Type (Etype (Item))
and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
then
- -- Perform a view conversion when either the argument or the
- -- formal parameter are of a private type.
+ -- Perform an unchecked conversion when either the argument or
+ -- the formal parameter are of a private type.
- if Is_Private_Type (Base_Type (Formal_Typ))
- or else Is_Private_Type (Base_Type (Item_Typ))
+ if (Is_Private_Type (Base_Type (Formal_Typ))
+ or else Is_Private_Type (Base_Type (Item_Typ)))
+ and then (Is_By_Reference_Type (Formal_Typ) or else
+ not Is_Written)
then
Rewrite (Item,
Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
B_Type : constant Entity_Id := Base_Type (P_Type);
U_Type : constant Entity_Id := Underlying_Type (P_Type);
Strm : constant Node_Id := First (Exprs);
- Has_TSS : Boolean := False;
Fname : Entity_Id;
Decl : Node_Id;
Call : Node_Id;
Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input, N);
- if Present (Fname) then
- Has_TSS := True;
+ if not Present (Fname) then
- else
-- If there is a Stream_Convert pragma, use it, we rewrite
-- sourcetyp'Input (stream)
-- Array type case
elsif Is_Array_Type (U_Type) then
- Build_Array_Input_Function (U_Type, Decl, Fname);
- Compile_Stream_Body_In_Scope (N, Decl, U_Type);
+ declare
+ procedure Build_And_Insert_Array_Input_Func is
+ new Build_And_Insert_Type_Attr_Subp
+ (Build_Array_Input_Function);
+ begin
+ Build_And_Insert_Array_Input_Func
+ (Typ => Full_Base (U_Type),
+ Decl => Decl,
+ Subp => Fname,
+ Attr_Ref => N);
+ end;
-- Dispatching case with class-wide type
-- Build the type's Input function, passing the subtype rather
-- than its base type, because checks are needed in the case of
-- constrained discriminants (see Ada 2012 AI05-0192).
+ --
+ -- ??? Is this correct in the case where the prefix of the
+ -- attribute is a constrained subtype of a type whose
+ -- first named subtype is unconstrained? Shouldn't we be
+ -- passing in the first named subtype of the type?
- Build_Record_Or_Elementary_Input_Function
- (U_Type, Decl, Fname);
- Insert_Action (N, Decl);
+ 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;
if Nkind (Parent (N)) = N_Object_Declaration
and then Is_Record_Type (U_Type)
Freeze_Stream_Subprogram (Fname);
end if;
- if not Has_TSS then
- Cached_Streaming_Ops.Input_Map.Set (P_Type, Fname);
+ if not Is_Tagged_Type (P_Type) then
+ Cached_Attribute_Ops.Input_Map.Set (P_Type, Fname);
end if;
end Input;
when Attribute_Output => Output : declare
P_Type : constant Entity_Id := Entity (Pref);
U_Type : constant Entity_Id := Underlying_Type (P_Type);
- Has_TSS : Boolean := False;
Pname : Entity_Id;
Decl : Node_Id;
Prag : Node_Id;
Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output, N);
- if Present (Pname) then
- Has_TSS := True;
+ if not Present (Pname) then
- else
-- If there is a Stream_Convert pragma, use it, we rewrite
-- sourcetyp'Output (stream, Item)
-- Array type case
elsif Is_Array_Type (U_Type) then
- Build_Array_Output_Procedure (U_Type, Decl, Pname);
- Compile_Stream_Body_In_Scope (N, Decl, U_Type);
+ declare
+ procedure Build_And_Insert_Array_Output_Proc is
+ new Build_And_Insert_Type_Attr_Subp
+ (Build_Array_Output_Procedure);
+ begin
+ Build_And_Insert_Array_Output_Proc
+ (Typ => Full_Base (U_Type),
+ Decl => Decl,
+ Subp => Pname,
+ Attr_Ref => N);
+ end;
-- Class-wide case, first output external tag, then dispatch
-- to the appropriate primitive Output function (RM 13.13.2(31)).
return;
end if;
- Build_Record_Or_Elementary_Output_Procedure
- (Base_Type (U_Type), Decl, Pname);
- Insert_Action (N, Decl);
+ 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;
end if;
end if;
Rewrite_Attribute_Proc_Call (Pname);
- if not Has_TSS then
- Cached_Streaming_Ops.Output_Map.Set (P_Type, Pname);
+ if not Is_Tagged_Type (P_Type) then
+ Cached_Attribute_Ops.Output_Map.Set (P_Type, Pname);
end if;
end Output;
return;
elsif Is_Array_Type (U_Type) then
- Build_Array_Put_Image_Procedure (N, U_Type, Decl, Pname);
- Insert_Action (N, Decl);
+ Pname := Cached_Attribute_Ops.Put_Image_Map.Get (U_Type);
+ Cached_Attribute_Ops.Validate_Cached_Candidate
+ (Pname, Attr_Ref => N);
+ if not Present (Pname) then
+ declare
+ procedure Build_And_Insert_Array_Put_Image_Proc is
+ new Build_And_Insert_Type_Attr_Subp
+ (Build_Array_Put_Image_Procedure);
+
+ begin
+ Build_And_Insert_Array_Put_Image_Proc
+ (Typ => U_Type,
+ Decl => Decl,
+ Subp => Pname,
+ Attr_Ref => N);
+ end;
+
+ Cached_Attribute_Ops.Put_Image_Map.Set (U_Type, Pname);
+ end if;
-- Tagged type case, use the primitive Put_Image function. Note
-- that this will dispatch in the class-wide case which is what we
else
pragma Assert (Is_Record_Type (U_Type));
- Build_Record_Put_Image_Procedure
- (Loc, Full_Base (U_Type), Decl, Pname);
- Insert_Action (N, Decl);
+ 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);
+ if not Present (Pname) then
+ declare
+ procedure Build_And_Insert_Record_Put_Image_Proc is
+ new Build_And_Insert_Type_Attr_Subp
+ (Build_Record_Put_Image_Procedure);
+
+ begin
+ Build_And_Insert_Record_Put_Image_Proc
+ (Typ => Base_Typ,
+ Decl => Decl,
+ Subp => Pname,
+ Attr_Ref => N);
+ end;
+
+ Cached_Attribute_Ops.Put_Image_Map.Set (Base_Typ, Pname);
+ end if;
+ end;
end if;
end if;
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);
- Has_TSS : Boolean := False;
Pname : Entity_Id;
Decl : Node_Id;
Prag : Node_Id;
Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read, N);
- if Present (Pname) then
- Has_TSS := True;
+ if not Present (Pname) then
- else
-- If there is a Stream_Convert pragma, use it, we rewrite
-- sourcetyp'Read (stream, Item)
-- Array type case
elsif Is_Array_Type (U_Type) then
- Build_Array_Read_Procedure (U_Type, Decl, Pname);
- Compile_Stream_Body_In_Scope (N, Decl, U_Type);
+ declare
+ procedure Build_And_Insert_Array_Read_Proc is
+ new Build_And_Insert_Type_Attr_Subp
+ (Build_Array_Read_Procedure);
+ begin
+ Build_And_Insert_Array_Read_Proc
+ (Typ => Full_Base (U_Type),
+ Decl => Decl,
+ Subp => Pname,
+ Attr_Ref => N);
+ end;
-- Tagged type case, use the primitive Read function. Note that
-- this will dispatch in the class-wide case which is what we want
return;
end if;
- if Has_Defaulted_Discriminants (U_Type) then
- Build_Mutable_Record_Read_Procedure
- (Full_Base (U_Type), Decl, Pname);
- else
- Build_Record_Read_Procedure
- (Full_Base (U_Type), Decl, Pname);
- end if;
+ declare
+ procedure Build_Record_Read_Proc
+ (Typ : Entity_Id;
+ Decl : out Node_Id;
+ Subp : out Entity_Id);
+
+ procedure Build_Record_Read_Proc
+ (Typ : Entity_Id;
+ Decl : out Node_Id;
+ Subp : out Entity_Id) is
+ begin
+ if Has_Defaulted_Discriminants (Typ) then
+ Build_Mutable_Record_Read_Procedure
+ (Typ, Decl, Subp);
+ else
+ Build_Record_Read_Procedure
+ (Typ, Decl, Subp);
+ end if;
+ end Build_Record_Read_Proc;
- Insert_Action (N, Decl);
+ procedure Build_And_Insert_Record_Read_Proc is
+ new Build_And_Insert_Type_Attr_Subp
+ (Build_Record_Read_Proc);
+ begin
+ Build_And_Insert_Record_Read_Proc
+ (Typ => Full_Base (U_Type),
+ Decl => Decl,
+ Subp => Pname,
+ Attr_Ref => N);
+ end;
end if;
end if;
Rewrite_Attribute_Proc_Call (Pname);
- if not Has_TSS then
- Cached_Streaming_Ops.Read_Map.Set (P_Type, Pname);
+ if not Is_Tagged_Type (P_Type) then
+ Cached_Attribute_Ops.Read_Map.Set (P_Type, Pname);
end if;
end Read;
when Attribute_Write => Write : declare
P_Type : constant Entity_Id := Entity (Pref);
U_Type : constant Entity_Id := Underlying_Type (P_Type);
- Has_TSS : Boolean := False;
Pname : Entity_Id;
Decl : Node_Id;
Prag : Node_Id;
Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write, N);
- if Present (Pname) then
- Has_TSS := True;
+ if not Present (Pname) then
- else
-- If there is a Stream_Convert pragma, use it, we rewrite
-- sourcetyp'Output (stream, Item)
-- Array type case
elsif Is_Array_Type (U_Type) then
- Build_Array_Write_Procedure (U_Type, Decl, Pname);
- Compile_Stream_Body_In_Scope (N, Decl, U_Type);
+ declare
+ procedure Build_And_Insert_Array_Write_Proc is
+ new Build_And_Insert_Type_Attr_Subp
+ (Build_Array_Write_Procedure);
+ begin
+ Build_And_Insert_Array_Write_Proc
+ (Typ => Full_Base (U_Type),
+ Decl => Decl,
+ Subp => Pname,
+ Attr_Ref => N);
+ end;
-- Tagged type case, use the primitive Write function. Note that
-- this will dispatch in the class-wide case which is what we want
end if;
end if;
- if Has_Defaulted_Discriminants (U_Type) then
- Build_Mutable_Record_Write_Procedure
- (Full_Base (U_Type), Decl, Pname);
- else
- Build_Record_Write_Procedure
- (Full_Base (U_Type), Decl, Pname);
- end if;
+ declare
+ procedure Build_Record_Write_Proc
+ (Typ : Entity_Id;
+ Decl : out Node_Id;
+ Subp : out Entity_Id);
+
+ procedure Build_Record_Write_Proc
+ (Typ : Entity_Id;
+ Decl : out Node_Id;
+ Subp : out Entity_Id) is
+ begin
+ if Has_Defaulted_Discriminants (Typ) then
+ Build_Mutable_Record_Write_Procedure
+ (Typ, Decl, Subp);
+ else
+ Build_Record_Write_Procedure
+ (Typ, Decl, Subp);
+ end if;
+ end Build_Record_Write_Proc;
- Insert_Action (N, Decl);
+ procedure Build_And_Insert_Record_Write_Proc is
+ new Build_And_Insert_Type_Attr_Subp
+ (Build_Record_Write_Proc);
+ begin
+ Build_And_Insert_Record_Write_Proc
+ (Typ => Full_Base (U_Type),
+ Decl => Decl,
+ Subp => Pname,
+ Attr_Ref => N);
+ end;
end if;
end if;
Rewrite_Attribute_Proc_Call (Pname);
- if not Has_TSS then
- Cached_Streaming_Ops.Write_Map.Set (P_Type, Pname);
+ if not Is_Tagged_Type (P_Type) then
+ Cached_Attribute_Ops.Write_Map.Set (P_Type, Pname);
end if;
end Write;
Nam : TSS_Name_Type;
Attr_Ref : Node_Id) return Entity_Id
is
-
- function In_Available_Context (Ent : Entity_Id) return Boolean;
- -- Ent is a candidate result for Find_Stream_Subprogram.
- -- If, for example, a subprogram is declared within a case
- -- alternative then Gigi does not want to see a call to it from
- -- outside of the case alternative. Compare placement of Ent and
- -- Attr_Ref to prevent this situation (by returning False).
-
- --------------------------
- -- In_Available_Context --
- --------------------------
-
- function In_Available_Context (Ent : Entity_Id) return Boolean is
- Decl : constant Node_Id := Enclosing_Declaration (Ent);
- begin
- if Has_Declarations (Parent (Decl)) then
- return In_Subtree (Attr_Ref, Root => Parent (Decl));
- elsif Is_List_Member (Decl) then
- declare
- List_Elem : Node_Id := Next (Decl);
- begin
- while Present (List_Elem) loop
- if In_Subtree (Attr_Ref, Root => List_Elem) then
- return True;
- end if;
- Next (List_Elem);
- end loop;
- return False;
- end;
- else
- return False; -- Can this occur ???
- end if;
- end In_Available_Context;
-
-- Local declarations
Base_Typ : constant Entity_Id := Base_Type (Typ);
end if;
if Nam = TSS_Stream_Read then
- Ent := Cached_Streaming_Ops.Read_Map.Get (Typ);
+ Ent := Cached_Attribute_Ops.Read_Map.Get (Typ);
elsif Nam = TSS_Stream_Write then
- Ent := Cached_Streaming_Ops.Write_Map.Get (Typ);
+ Ent := Cached_Attribute_Ops.Write_Map.Get (Typ);
elsif Nam = TSS_Stream_Input then
- Ent := Cached_Streaming_Ops.Input_Map.Get (Typ);
+ Ent := Cached_Attribute_Ops.Input_Map.Get (Typ);
elsif Nam = TSS_Stream_Output then
- Ent := Cached_Streaming_Ops.Output_Map.Get (Typ);
+ Ent := Cached_Attribute_Ops.Output_Map.Get (Typ);
end if;
- if Present (Ent) then
- -- Can't reuse Ent if it is no longer in scope
+ Cached_Attribute_Ops.Validate_Cached_Candidate
+ (Subp => Ent, Attr_Ref => Attr_Ref);
- if In_Open_Scopes (Scope (Ent))
-
- -- The preceding In_Open_Scopes test may not suffice if
- -- case alternatives are involved.
- and then In_Available_Context (Ent)
- then
- return Ent;
- else
- Ent := Empty;
- end if;
+ if Present (Ent) then
+ return Ent;
end if;
-- Stream attributes for strings are expanded into library calls. The
projects / thirdparty / gcc.git / commitdiff
