| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ P U T _ I M A G E -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2020-2021, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Einfo; use Einfo; |
| with Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Exp_Tss; use Exp_Tss; |
| with Exp_Util; |
| with Debug; use Debug; |
| 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 Sem_Aux; use Sem_Aux; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| with Snames; use Snames; |
| with Stand; |
| with Tbuild; use Tbuild; |
| with Ttypes; use Ttypes; |
| with Uintp; use Uintp; |
| |
| package body Exp_Put_Image is |
| |
| Tagged_Put_Image_Enabled : Boolean renames Debug_Flag_Underscore_Z; |
| -- ???Set True to enable Put_Image for at least some tagged types |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Build_Put_Image_Proc |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decl : out Node_Id; |
| Pnam : Entity_Id; |
| Stms : List_Id); |
| -- Build an array or record Put_Image procedure. Stms is the list of |
| -- statements for the body and Pnam is the name of the constructed |
| -- procedure. (The declaration list is always null.) |
| |
| function Make_Put_Image_Name |
| (Loc : Source_Ptr; Typ : Entity_Id) return Entity_Id; |
| -- Return the entity that identifies the Put_Image subprogram for Typ. This |
| -- procedure deals with the difference between tagged types (where a single |
| -- subprogram associated with the type is generated) and all other cases |
| -- (where a subprogram is generated at the point of the attribute |
| -- reference). The Loc parameter is used as the Sloc of the created entity. |
| |
| function Put_Image_Base_Type (E : Entity_Id) return Entity_Id; |
| -- Returns the base type, except for an array type whose whose first |
| -- subtype is constrained, in which case it returns the first subtype. |
| |
| ------------------------------------- |
| -- Build_Array_Put_Image_Procedure -- |
| ------------------------------------- |
| |
| procedure Build_Array_Put_Image_Procedure |
| (Nod : Node_Id; |
| Typ : Entity_Id; |
| Decl : out Node_Id; |
| Pnam : out Entity_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Nod); |
| |
| function Wrap_In_Loop |
| (Stms : List_Id; |
| Dim : Pos; |
| Index_Subtype : Entity_Id; |
| Between_Proc : RE_Id) return Node_Id; |
| -- Wrap Stms in a loop and if statement of the form: |
| -- |
| -- if V'First (Dim) <= V'Last (Dim) then -- nonempty range? |
| -- declare |
| -- LDim : Index_Type_For_Dim := V'First (Dim); |
| -- begin |
| -- loop |
| -- Stms; |
| -- exit when LDim = V'Last (Dim); |
| -- Between_Proc (S); |
| -- LDim := Index_Type_For_Dim'Succ (LDim); |
| -- end loop; |
| -- end; |
| -- end if; |
| -- |
| -- This is called once per dimension, from inner to outer. |
| |
| function Wrap_In_Loop |
| (Stms : List_Id; |
| Dim : Pos; |
| Index_Subtype : Entity_Id; |
| Between_Proc : RE_Id) return Node_Id |
| is |
| Index : constant Entity_Id := |
| Make_Defining_Identifier |
| (Loc, Chars => New_External_Name ('L', Dim)); |
| Decl : constant Node_Id := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Index, |
| Object_Definition => |
| New_Occurrence_Of (Index_Subtype, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Attribute_Name => Name_First, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Dim)))); |
| Loop_Stm : constant Node_Id := |
| Make_Implicit_Loop_Statement (Nod, Statements => Stms); |
| Exit_Stm : constant Node_Id := |
| Make_Exit_Statement (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (Index, Loc), |
| Right_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Identifier (Loc, Name_V), |
| Attribute_Name => Name_Last, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Dim))))); |
| Increment : constant Node_Id := |
| Make_Increment (Loc, Index, Index_Subtype); |
| Between : constant Node_Id := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (Between_Proc), Loc), |
| Parameter_Associations => New_List |
| (Make_Identifier (Loc, Name_S))); |
| Block : constant Node_Id := |
| Make_Block_Statement (Loc, |
| Declarations => New_List (Decl), |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Loop_Stm))); |
| begin |
| Append_To (Stms, Exit_Stm); |
| Append_To (Stms, Between); |
| Append_To (Stms, Increment); |
| -- Note that we're appending to the Stms list passed in |
| |
| return |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Op_Le (Loc, |
| Left_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Attribute_Name => Name_First, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Dim))), |
| Right_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Attribute_Name => Name_Last, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Dim)))), |
| Then_Statements => New_List (Block)); |
| end Wrap_In_Loop; |
| |
| Ndim : constant Pos := Number_Dimensions (Typ); |
| Ctyp : constant Entity_Id := Component_Type (Typ); |
| |
| Stm : Node_Id; |
| Exl : constant List_Id := New_List; |
| PI_Entity : Entity_Id; |
| |
| Indices : array (1 .. Ndim) of Entity_Id; |
| |
| -- Start of processing for Build_Array_Put_Image_Procedure |
| |
| begin |
| Pnam := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_TSS_Name_Local (Typ, TSS_Put_Image)); |
| |
| -- Get the Indices |
| |
| declare |
| Index_Subtype : Node_Id := First_Index (Typ); |
| begin |
| for Dim in 1 .. Ndim loop |
| Indices (Dim) := Etype (Index_Subtype); |
| Next_Index (Index_Subtype); |
| end loop; |
| pragma Assert (No (Index_Subtype)); |
| end; |
| |
| -- Build the inner attribute call |
| |
| for Dim in 1 .. Ndim loop |
| Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', Dim))); |
| end loop; |
| |
| Stm := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Put_Image_Base_Type (Ctyp), Loc), |
| Attribute_Name => Name_Put_Image, |
| Expressions => New_List ( |
| Make_Identifier (Loc, Name_S), |
| Make_Indexed_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Expressions => Exl))); |
| |
| -- The corresponding attribute for the component type of the array might |
| -- be user-defined, and frozen after the array type. In that case, |
| -- freeze the Put_Image attribute of the component type, whose |
| -- declaration could not generate any additional freezing actions in any |
| -- case. |
| |
| PI_Entity := TSS (Base_Type (Ctyp), TSS_Put_Image); |
| |
| if Present (PI_Entity) and then not Is_Frozen (PI_Entity) then |
| Set_Is_Frozen (PI_Entity); |
| end if; |
| |
| -- Loop through the dimensions, innermost first, generating a loop for |
| -- each dimension. |
| |
| declare |
| Stms : List_Id := New_List (Stm); |
| begin |
| for Dim in reverse 1 .. Ndim loop |
| declare |
| New_Stms : constant List_Id := New_List; |
| Between_Proc : RE_Id; |
| begin |
| -- For a one-dimensional array of elementary type, use |
| -- RE_Simple_Array_Between. The same applies to the last |
| -- dimension of a multidimensional array. |
| |
| if Is_Elementary_Type (Ctyp) and then Dim = Ndim then |
| Between_Proc := RE_Simple_Array_Between; |
| else |
| Between_Proc := RE_Array_Between; |
| end if; |
| |
| Append_To (New_Stms, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Array_Before), Loc), |
| Parameter_Associations => New_List |
| (Make_Identifier (Loc, Name_S)))); |
| |
| Append_To |
| (New_Stms, |
| Wrap_In_Loop (Stms, Dim, Indices (Dim), Between_Proc)); |
| |
| Append_To (New_Stms, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Array_After), Loc), |
| Parameter_Associations => New_List |
| (Make_Identifier (Loc, Name_S)))); |
| |
| Stms := New_Stms; |
| end; |
| end loop; |
| |
| Build_Put_Image_Proc (Loc, Typ, Decl, Pnam, Stms); |
| end; |
| end Build_Array_Put_Image_Procedure; |
| |
| ------------------------------------- |
| -- Build_Elementary_Put_Image_Call -- |
| ------------------------------------- |
| |
| function Build_Elementary_Put_Image_Call (N : Node_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (N); |
| P_Type : constant Entity_Id := Entity (Prefix (N)); |
| U_Type : constant Entity_Id := Underlying_Type (P_Type); |
| FST : constant Entity_Id := First_Subtype (U_Type); |
| Sink : constant Node_Id := First (Expressions (N)); |
| Item : constant Node_Id := Next (Sink); |
| P_Size : constant Uint := Esize (FST); |
| Lib_RE : RE_Id; |
| |
| begin |
| if Is_Signed_Integer_Type (U_Type) then |
| if P_Size <= Standard_Integer_Size then |
| Lib_RE := RE_Put_Image_Integer; |
| elsif P_Size <= Standard_Long_Long_Integer_Size then |
| Lib_RE := RE_Put_Image_Long_Long_Integer; |
| else |
| pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size); |
| Lib_RE := RE_Put_Image_Long_Long_Long_Integer; |
| end if; |
| |
| elsif Is_Modular_Integer_Type (U_Type) then |
| if P_Size <= Standard_Integer_Size then -- Yes, Integer |
| Lib_RE := RE_Put_Image_Unsigned; |
| elsif P_Size <= Standard_Long_Long_Integer_Size then |
| Lib_RE := RE_Put_Image_Long_Long_Unsigned; |
| else |
| pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size); |
| Lib_RE := RE_Put_Image_Long_Long_Long_Unsigned; |
| end if; |
| |
| elsif Is_Access_Type (U_Type) then |
| if Is_Access_Protected_Subprogram_Type (Base_Type (U_Type)) then |
| Lib_RE := RE_Put_Image_Access_Prot_Subp; |
| elsif Is_Access_Subprogram_Type (Base_Type (U_Type)) then |
| Lib_RE := RE_Put_Image_Access_Subp; |
| elsif P_Size = System_Address_Size then |
| Lib_RE := RE_Put_Image_Thin_Pointer; |
| else |
| pragma Assert (P_Size = 2 * System_Address_Size); |
| Lib_RE := RE_Put_Image_Fat_Pointer; |
| end if; |
| |
| else |
| pragma Assert |
| (Is_Enumeration_Type (U_Type) or else Is_Real_Type (U_Type)); |
| |
| -- For other elementary types, generate: |
| -- |
| -- Put_Wide_Wide_String (Sink, U_Type'Wide_Wide_Image (Item)); |
| -- |
| -- It would be more elegant to do it the other way around (define |
| -- '[[Wide_]Wide_]Image in terms of 'Put_Image). But this is easier |
| -- to implement, because we already have support for |
| -- 'Wide_Wide_Image. Furthermore, we don't want to remove the |
| -- existing support for '[[Wide_]Wide_]Image, because we don't |
| -- currently plan to support 'Put_Image on restricted runtimes. |
| |
| -- We can't do this: |
| -- |
| -- Put_UTF_8 (Sink, U_Type'Image (Item)); |
| -- |
| -- because we need to generate UTF-8, but 'Image for enumeration |
| -- types uses the character encoding of the source file. |
| -- |
| -- Note that this is putting a leading space for reals. |
| |
| declare |
| Image : constant Node_Id := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (U_Type, Loc), |
| Attribute_Name => Name_Wide_Wide_Image, |
| Expressions => New_List (Relocate_Node (Item))); |
| Put_Call : constant Node_Id := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Put_Wide_Wide_String), Loc), |
| Parameter_Associations => New_List |
| (Relocate_Node (Sink), Image)); |
| begin |
| return Put_Call; |
| end; |
| end if; |
| |
| -- Unchecked-convert parameter to the required type (i.e. the type of |
| -- the corresponding parameter), and call the appropriate routine. |
| -- We could use a normal type conversion for scalars, but the |
| -- "unchecked" is needed for access and private types. |
| |
| declare |
| Libent : constant Entity_Id := RTE (Lib_RE); |
| begin |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Libent, Loc), |
| Parameter_Associations => New_List ( |
| Relocate_Node (Sink), |
| Unchecked_Convert_To |
| (Etype (Next_Formal (First_Formal (Libent))), |
| Relocate_Node (Item)))); |
| end; |
| end Build_Elementary_Put_Image_Call; |
| |
| ------------------------------------- |
| -- Build_String_Put_Image_Call -- |
| ------------------------------------- |
| |
| function Build_String_Put_Image_Call (N : Node_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (N); |
| P_Type : constant Entity_Id := Entity (Prefix (N)); |
| U_Type : constant Entity_Id := Underlying_Type (P_Type); |
| R : constant Entity_Id := Root_Type (U_Type); |
| Sink : constant Node_Id := First (Expressions (N)); |
| Item : constant Node_Id := Next (Sink); |
| Lib_RE : RE_Id; |
| use Stand; |
| begin |
| if R = Standard_String then |
| Lib_RE := RE_Put_Image_String; |
| elsif R = Standard_Wide_String then |
| Lib_RE := RE_Put_Image_Wide_String; |
| elsif R = Standard_Wide_Wide_String then |
| Lib_RE := RE_Put_Image_Wide_Wide_String; |
| else |
| raise Program_Error; |
| end if; |
| |
| -- Convert parameter to the required type (i.e. the type of the |
| -- corresponding parameter), and call the appropriate routine. |
| -- We set the Conversion_OK flag in case the type is private. |
| |
| declare |
| Libent : constant Entity_Id := RTE (Lib_RE); |
| Conv : constant Node_Id := |
| OK_Convert_To |
| (Etype (Next_Formal (First_Formal (Libent))), |
| Relocate_Node (Item)); |
| begin |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Libent, Loc), |
| Parameter_Associations => New_List ( |
| Relocate_Node (Sink), |
| Conv)); |
| end; |
| end Build_String_Put_Image_Call; |
| |
| ------------------------------------ |
| -- Build_Protected_Put_Image_Call -- |
| ------------------------------------ |
| |
| -- For "Protected_Type'Put_Image (S, Protected_Object)", build: |
| -- |
| -- Put_Image_Protected (S); |
| -- |
| -- The protected object is not passed. |
| |
| function Build_Protected_Put_Image_Call (N : Node_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (N); |
| Sink : constant Node_Id := First (Expressions (N)); |
| Lib_RE : constant RE_Id := RE_Put_Image_Protected; |
| Libent : constant Entity_Id := RTE (Lib_RE); |
| begin |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Libent, Loc), |
| Parameter_Associations => New_List ( |
| Relocate_Node (Sink))); |
| end Build_Protected_Put_Image_Call; |
| |
| ------------------------------------ |
| -- Build_Task_Put_Image_Call -- |
| ------------------------------------ |
| |
| -- For "Task_Type'Put_Image (S, Task_Object)", build: |
| -- |
| -- Put_Image_Task (S, Task_Object'Identity); |
| -- |
| -- The task object is not passed; its Task_Id is. |
| |
| function Build_Task_Put_Image_Call (N : Node_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (N); |
| Sink : constant Node_Id := First (Expressions (N)); |
| Item : constant Node_Id := Next (Sink); |
| Lib_RE : constant RE_Id := RE_Put_Image_Task; |
| Libent : constant Entity_Id := RTE (Lib_RE); |
| |
| Task_Id : constant Node_Id := |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Item), |
| Attribute_Name => Name_Identity, |
| Expressions => No_List); |
| |
| begin |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Libent, Loc), |
| Parameter_Associations => New_List ( |
| Relocate_Node (Sink), |
| Task_Id)); |
| end Build_Task_Put_Image_Call; |
| |
| -------------------------------------- |
| -- Build_Record_Put_Image_Procedure -- |
| -------------------------------------- |
| |
| -- The form of the record Put_Image procedure is as shown by the |
| -- following example: |
| |
| -- procedure Put_Image (S : in out Sink'Class; V : Typ) is |
| -- begin |
| -- Component_Type'Put_Image (S, V.component); |
| -- Component_Type'Put_Image (S, V.component); |
| -- ... |
| -- Component_Type'Put_Image (S, V.component); |
| -- |
| -- case V.discriminant is |
| -- when choices => |
| -- Component_Type'Put_Image (S, V.component); |
| -- Component_Type'Put_Image (S, V.component); |
| -- ... |
| -- Component_Type'Put_Image (S, V.component); |
| -- |
| -- when choices => |
| -- Component_Type'Put_Image (S, V.component); |
| -- Component_Type'Put_Image (S, V.component); |
| -- ... |
| -- Component_Type'Put_Image (S, V.component); |
| -- ... |
| -- end case; |
| -- end Put_Image; |
| |
| procedure Build_Record_Put_Image_Procedure |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decl : out Node_Id; |
| Pnam : out Entity_Id) |
| is |
| Btyp : constant Entity_Id := Base_Type (Typ); |
| pragma Assert (not Is_Unchecked_Union (Btyp)); |
| |
| First_Time : Boolean := True; |
| |
| function Make_Component_List_Attributes (CL : Node_Id) return List_Id; |
| -- Returns a sequence of Component_Type'Put_Image attribute_references |
| -- to process the components that are referenced in the given component |
| -- list. Called for the main component list, and then recursively for |
| -- variants. |
| |
| function Make_Component_Attributes (Clist : List_Id) return List_Id; |
| -- Given Clist, a component items list, construct series of |
| -- Component_Type'Put_Image attribute_references for componentwise |
| -- processing of the corresponding components. Called for the |
| -- discriminants, and then from Make_Component_List_Attributes for each |
| -- list (including in variants). |
| |
| procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id); |
| -- Given C, the entity for a discriminant or component, build a call to |
| -- Component_Type'Put_Image for the corresponding component value, and |
| -- append it onto Clist. Called from Make_Component_Attributes. |
| |
| function Make_Component_Name (C : Entity_Id) return Node_Id; |
| -- Create a call that prints "Comp_Name => " |
| |
| ------------------------------------ |
| -- Make_Component_List_Attributes -- |
| ------------------------------------ |
| |
| function Make_Component_List_Attributes (CL : Node_Id) return List_Id is |
| CI : constant List_Id := Component_Items (CL); |
| VP : constant Node_Id := Variant_Part (CL); |
| |
| Result : List_Id; |
| Alts : List_Id; |
| V : Node_Id; |
| DC : Node_Id; |
| DCH : List_Id; |
| D_Ref : Node_Id; |
| |
| begin |
| Result := Make_Component_Attributes (CI); |
| |
| if Present (VP) then |
| Alts := New_List; |
| |
| V := First_Non_Pragma (Variants (VP)); |
| while Present (V) loop |
| DCH := New_List; |
| |
| DC := First (Discrete_Choices (V)); |
| while Present (DC) loop |
| Append_To (DCH, New_Copy_Tree (DC)); |
| Next (DC); |
| end loop; |
| |
| Append_To (Alts, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => DCH, |
| Statements => |
| Make_Component_List_Attributes (Component_List (V)))); |
| Next_Non_Pragma (V); |
| end loop; |
| |
| -- Note: in the following, we use New_Occurrence_Of for the |
| -- selector, since there are cases in which we make a reference |
| -- to a hidden discriminant that is not visible. |
| |
| D_Ref := |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Selector_Name => |
| New_Occurrence_Of (Entity (Name (VP)), Loc)); |
| |
| Append_To (Result, |
| Make_Case_Statement (Loc, |
| Expression => D_Ref, |
| Alternatives => Alts)); |
| end if; |
| |
| return Result; |
| end Make_Component_List_Attributes; |
| |
| -------------------------------- |
| -- Append_Component_Attr -- |
| -------------------------------- |
| |
| procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id) is |
| Component_Typ : constant Entity_Id := Put_Image_Base_Type (Etype (C)); |
| begin |
| if Ekind (C) /= E_Void then |
| Append_To (Clist, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Component_Typ, Loc), |
| Attribute_Name => Name_Put_Image, |
| Expressions => New_List ( |
| Make_Identifier (Loc, Name_S), |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Selector_Name => New_Occurrence_Of (C, Loc))))); |
| end if; |
| end Append_Component_Attr; |
| |
| ------------------------------- |
| -- Make_Component_Attributes -- |
| ------------------------------- |
| |
| function Make_Component_Attributes (Clist : List_Id) return List_Id is |
| Item : Node_Id; |
| Result : List_Id; |
| |
| begin |
| Result := New_List; |
| |
| if Present (Clist) then |
| Item := First (Clist); |
| |
| -- Loop through components, skipping all internal components, |
| -- which are not part of the value (e.g. _Tag), except that we |
| -- don't skip the _Parent, since we do want to process that |
| -- recursively. If _Parent is an interface type, being abstract |
| -- with no components there is no need to handle it. |
| |
| while Present (Item) loop |
| if Nkind (Item) in |
| N_Component_Declaration | N_Discriminant_Specification |
| and then |
| ((Chars (Defining_Identifier (Item)) = Name_uParent |
| and then not Is_Interface |
| (Etype (Defining_Identifier (Item)))) |
| or else |
| not Is_Internal_Name (Chars (Defining_Identifier (Item)))) |
| then |
| if First_Time then |
| First_Time := False; |
| else |
| Append_To (Result, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Record_Between), Loc), |
| Parameter_Associations => New_List |
| (Make_Identifier (Loc, Name_S)))); |
| end if; |
| |
| Append_To (Result, Make_Component_Name (Item)); |
| Append_Component_Attr (Result, Defining_Identifier (Item)); |
| end if; |
| |
| Next (Item); |
| end loop; |
| end if; |
| |
| return Result; |
| end Make_Component_Attributes; |
| |
| ------------------------- |
| -- Make_Component_Name -- |
| ------------------------- |
| |
| function Make_Component_Name (C : Entity_Id) return Node_Id is |
| Name : constant Name_Id := Chars (Defining_Identifier (C)); |
| begin |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Put_UTF_8), Loc), |
| Parameter_Associations => New_List |
| (Make_Identifier (Loc, Name_S), |
| Make_String_Literal (Loc, Get_Name_String (Name) & " => "))); |
| end Make_Component_Name; |
| |
| Stms : constant List_Id := New_List; |
| Rdef : Node_Id; |
| Type_Decl : constant Node_Id := |
| Declaration_Node (Base_Type (Underlying_Type (Btyp))); |
| |
| -- Start of processing for Build_Record_Put_Image_Procedure |
| |
| begin |
| Append_To (Stms, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Record_Before), Loc), |
| Parameter_Associations => New_List |
| (Make_Identifier (Loc, Name_S)))); |
| |
| -- Generate Put_Images for the discriminants of the type |
| |
| Append_List_To (Stms, |
| Make_Component_Attributes (Discriminant_Specifications (Type_Decl))); |
| |
| Rdef := Type_Definition (Type_Decl); |
| |
| -- In the record extension case, the components we want, including the |
| -- _Parent component representing the parent type, are to be found in |
| -- the extension. We will process the _Parent component using the type |
| -- of the parent. |
| |
| if Nkind (Rdef) = N_Derived_Type_Definition then |
| Rdef := Record_Extension_Part (Rdef); |
| end if; |
| |
| if Present (Component_List (Rdef)) then |
| Append_List_To (Stms, |
| Make_Component_List_Attributes (Component_List (Rdef))); |
| end if; |
| |
| Append_To (Stms, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Record_After), Loc), |
| Parameter_Associations => New_List |
| (Make_Identifier (Loc, Name_S)))); |
| |
| Pnam := Make_Put_Image_Name (Loc, Btyp); |
| Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms); |
| end Build_Record_Put_Image_Procedure; |
| |
| ------------------------------- |
| -- Build_Put_Image_Profile -- |
| ------------------------------- |
| |
| function Build_Put_Image_Profile |
| (Loc : Source_Ptr; Typ : Entity_Id) return List_Id |
| is |
| begin |
| return New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), |
| In_Present => True, |
| Out_Present => True, |
| Parameter_Type => |
| New_Occurrence_Of (Class_Wide_Type (RTE (RE_Sink)), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), |
| Parameter_Type => New_Occurrence_Of (Typ, Loc))); |
| end Build_Put_Image_Profile; |
| |
| -------------------------- |
| -- Build_Put_Image_Proc -- |
| -------------------------- |
| |
| procedure Build_Put_Image_Proc |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decl : out Node_Id; |
| Pnam : Entity_Id; |
| Stms : List_Id) |
| is |
| Spec : constant Node_Id := |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Pnam, |
| Parameter_Specifications => Build_Put_Image_Profile (Loc, Typ)); |
| begin |
| Decl := |
| Make_Subprogram_Body (Loc, |
| Specification => Spec, |
| Declarations => Empty_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stms)); |
| end Build_Put_Image_Proc; |
| |
| ------------------------------------ |
| -- Build_Unknown_Put_Image_Call -- |
| ------------------------------------ |
| |
| function Build_Unknown_Put_Image_Call (N : Node_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (N); |
| Sink : constant Node_Id := First (Expressions (N)); |
| Lib_RE : constant RE_Id := RE_Put_Image_Unknown; |
| Libent : constant Entity_Id := RTE (Lib_RE); |
| begin |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Libent, Loc), |
| Parameter_Associations => New_List ( |
| Relocate_Node (Sink), |
| Make_String_Literal (Loc, |
| Exp_Util.Fully_Qualified_Name_String ( |
| Entity (Prefix (N)), Append_NUL => False)))); |
| end Build_Unknown_Put_Image_Call; |
| |
| ---------------------- |
| -- Enable_Put_Image -- |
| ---------------------- |
| |
| function Enable_Put_Image (Typ : Entity_Id) return Boolean is |
| begin |
| -- There's a bit of a chicken&egg problem. The compiler is likely to |
| -- have trouble if we refer to the Put_Image of Sink itself, because |
| -- Sink is part of the parameter profile: |
| -- |
| -- function Sink'Put_Image (S : in out Sink'Class; V : T); |
| -- |
| -- Likewise, the Ada.Strings.Text_Output package, where Sink is |
| -- declared, depends on various other packages, so if we refer to |
| -- Put_Image of types declared in those other packages, we could create |
| -- cyclic dependencies. Therefore, we disable Put_Image for some |
| -- types. It's not clear exactly what types should be disabled. Scalar |
| -- types are OK, even if predefined, because calls to Put_Image of |
| -- scalar types are expanded inline. We certainly want to be able to use |
| -- Integer'Put_Image, for example. |
| |
| -- ???Temporarily disable to work around bugs: |
| -- |
| -- Put_Image does not work for Remote_Types. We check the containing |
| -- package, rather than the type itself, because we want to include |
| -- types in the private part of a Remote_Types package. |
| -- |
| -- Put_Image on tagged types triggers some bugs. |
| |
| if Is_Remote_Types (Scope (Typ)) |
| or else (Is_Tagged_Type (Typ) and then In_Predefined_Unit (Typ)) |
| or else (Is_Tagged_Type (Typ) and then not Tagged_Put_Image_Enabled) |
| then |
| return False; |
| end if; |
| |
| -- End of workarounds. |
| |
| -- No sense in generating code for Put_Image if there are errors. This |
| -- avoids certain cascade errors. |
| |
| if Total_Errors_Detected > 0 then |
| return False; |
| end if; |
| |
| -- If type Sink is unavailable in this runtime, disable Put_Image |
| -- altogether. |
| |
| if No_Run_Time_Mode or else not RTE_Available (RE_Sink) then |
| return False; |
| end if; |
| |
| -- ???Disable Put_Image on type Sink declared in |
| -- Ada.Strings.Text_Output. Note that we can't call Is_RTU on |
| -- Ada_Strings_Text_Output, because it's not known yet (we might be |
| -- compiling it). But this is insufficient to allow support for tagged |
| -- predefined types. |
| |
| declare |
| Parent_Scope : constant Entity_Id := Scope (Scope (Typ)); |
| begin |
| if Present (Parent_Scope) |
| and then Is_RTU (Parent_Scope, Ada_Strings) |
| and then Chars (Scope (Typ)) = Name_Find ("text_output") |
| then |
| return False; |
| end if; |
| end; |
| |
| -- Disable for CPP types, because the components are unavailable on the |
| -- Ada side. |
| |
| if Is_Tagged_Type (Typ) |
| and then Convention (Typ) = Convention_CPP |
| and then Is_CPP_Class (Root_Type (Typ)) |
| then |
| return False; |
| end if; |
| |
| -- Disable for unchecked unions, because there is no way to know the |
| -- discriminant value, and therefore no way to know which components |
| -- should be printed. |
| |
| if Is_Unchecked_Union (Typ) then |
| return False; |
| end if; |
| |
| return True; |
| end Enable_Put_Image; |
| |
| --------------------------------- |
| -- Make_Put_Image_Name -- |
| --------------------------------- |
| |
| function Make_Put_Image_Name |
| (Loc : Source_Ptr; Typ : Entity_Id) return Entity_Id |
| is |
| Sname : Name_Id; |
| begin |
| -- For tagged types, we are dealing with a TSS associated with the |
| -- declaration, so we use the standard primitive function name. For |
| -- other types, generate a local TSS name since we are generating |
| -- the subprogram at the point of use. |
| |
| if Is_Tagged_Type (Typ) then |
| Sname := Make_TSS_Name (Typ, TSS_Put_Image); |
| else |
| Sname := Make_TSS_Name_Local (Typ, TSS_Put_Image); |
| end if; |
| |
| return Make_Defining_Identifier (Loc, Sname); |
| end Make_Put_Image_Name; |
| |
| function Image_Should_Call_Put_Image (N : Node_Id) return Boolean is |
| begin |
| if Ada_Version < Ada_2020 then |
| return False; |
| end if; |
| |
| -- In Ada 2020, T'Image calls T'Put_Image if there is an explicit |
| -- aspect_specification for Put_Image, or if U_Type'Image is illegal |
| -- in pre-2020 versions of Ada. |
| |
| declare |
| U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N))); |
| begin |
| if Present (TSS (U_Type, TSS_Put_Image)) then |
| return True; |
| end if; |
| |
| return not Is_Scalar_Type (U_Type); |
| end; |
| end Image_Should_Call_Put_Image; |
| |
| function Build_Image_Call (N : Node_Id) return Node_Id is |
| -- For T'Image (X) Generate an Expression_With_Actions node: |
| -- |
| -- do |
| -- S : Buffer := New_Buffer; |
| -- U_Type'Put_Image (S, X); |
| -- Result : constant String := Get (S); |
| -- Destroy (S); |
| -- in Result end |
| -- |
| -- where U_Type is the underlying type, as needed to bypass privacy. |
| |
| Loc : constant Source_Ptr := Sloc (N); |
| U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N))); |
| Sink_Entity : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); |
| Sink_Decl : constant Node_Id := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Sink_Entity, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Buffer), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_New_Buffer), Loc), |
| Parameter_Associations => Empty_List)); |
| Put_Im : constant Node_Id := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (U_Type, Loc), |
| Attribute_Name => Name_Put_Image, |
| Expressions => New_List ( |
| New_Occurrence_Of (Sink_Entity, Loc), |
| New_Copy_Tree (First (Expressions (N))))); |
| Result_Entity : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('R')); |
| Result_Decl : constant Node_Id := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Result_Entity, |
| Object_Definition => |
| New_Occurrence_Of (Stand.Standard_String, Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Sink_Entity, Loc)))); |
| Image : constant Node_Id := |
| Make_Expression_With_Actions (Loc, |
| Actions => New_List (Sink_Decl, Put_Im, Result_Decl), |
| Expression => New_Occurrence_Of (Result_Entity, Loc)); |
| begin |
| return Image; |
| end Build_Image_Call; |
| |
| ------------------ |
| -- Preload_Sink -- |
| ------------------ |
| |
| procedure Preload_Sink (Compilation_Unit : Node_Id) is |
| begin |
| -- We can't call RTE (RE_Sink) for at least some predefined units, |
| -- because it would introduce cyclic dependences. The package where Sink |
| -- is declared, for example, and things it depends on. |
| -- |
| -- It's only needed for tagged types, so don't do it unless Put_Image is |
| -- enabled for tagged types, and we've seen a tagged type. Note that |
| -- Tagged_Seen is set True by the parser if the "tagged" reserved word |
| -- is seen; this flag tells us whether we have any tagged types. |
| -- It's unfortunate to have this Tagged_Seen processing so scattered |
| -- about, but we need to know if there are tagged types where this is |
| -- called in Analyze_Compilation_Unit, before we have analyzed any type |
| -- declarations. This mechanism also prevents doing RTE (RE_Sink) when |
| -- compiling the compiler itself. Packages Ada.Strings.Text_Output and |
| -- friends are not included in the compiler. |
| -- |
| -- Don't do it if type Sink is unavailable in the runtime. |
| |
| if not In_Predefined_Unit (Compilation_Unit) |
| and then Tagged_Put_Image_Enabled |
| and then Tagged_Seen |
| and then not No_Run_Time_Mode |
| and then RTE_Available (RE_Sink) |
| then |
| declare |
| Ignore : constant Entity_Id := RTE (RE_Sink); |
| begin |
| null; |
| end; |
| end if; |
| end Preload_Sink; |
| |
| ------------------------- |
| -- Put_Image_Base_Type -- |
| ------------------------- |
| |
| function Put_Image_Base_Type (E : Entity_Id) return Entity_Id is |
| begin |
| if Is_Array_Type (E) and then Is_First_Subtype (E) then |
| return E; |
| else |
| return Base_Type (E); |
| end if; |
| end Put_Image_Base_Type; |
| |
| end Exp_Put_Image; |
