| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ P U T _ I M A G E -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2020-2022, 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 Aspects; use Aspects; |
| with Atree; use Atree; |
| with Csets; use Csets; |
| 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; use Exp_Util; |
| 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 Stringt; use Stringt; |
| with Tbuild; use Tbuild; |
| with Ttypes; use Ttypes; |
| with Uintp; use Uintp; |
| |
| package body Exp_Put_Image is |
| |
| ----------------------- |
| -- 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: |
| -- |
| -- Wide_Wide_Put (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_Wide_Wide_Put), 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_Class_Wide_Type (Btyp)); |
| 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. |
| |
| while Present (Item) loop |
| if Nkind (Item) in |
| N_Component_Declaration | N_Discriminant_Specification |
| then |
| if Chars (Defining_Identifier (Item)) = Name_uParent then |
| declare |
| Parent_Type : constant Entity_Id := |
| Implementation_Base_Type |
| (Etype (Defining_Identifier (Item))); |
| |
| Parent_Aspect_Spec : constant Node_Id := |
| Find_Aspect (Parent_Type, Aspect_Put_Image); |
| |
| Parent_Type_Decl : constant Node_Id := |
| Declaration_Node (Parent_Type); |
| |
| Parent_Rdef : Node_Id := |
| Type_Definition (Parent_Type_Decl); |
| begin |
| -- If parent type has an noninherited |
| -- explicitly-specified Put_Image aspect spec, then |
| -- display parent part by calling specified procedure, |
| -- and then use extension-aggregate syntax for the |
| -- remaining components as per RM 4.10(15/5); |
| -- otherwise, "look through" the parent component |
| -- to its components - we don't want the image text |
| -- to include mention of an "_parent" component. |
| |
| if Present (Parent_Aspect_Spec) and then |
| Entity (Parent_Aspect_Spec) = Parent_Type |
| then |
| Append_Component_Attr |
| (Result, Defining_Identifier (Item)); |
| |
| -- Omit the " with " if no subsequent components. |
| |
| if not Is_Null_Extension_Of |
| (Descendant => Typ, |
| Ancestor => Parent_Type) |
| then |
| Append_To (Result, |
| 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, " with ")))); |
| end if; |
| else |
| if Nkind (Parent_Rdef) = N_Derived_Type_Definition |
| then |
| Parent_Rdef := |
| Record_Extension_Part (Parent_Rdef); |
| end if; |
| |
| if Present (Component_List (Parent_Rdef)) then |
| Append_List_To (Result, |
| Make_Component_List_Attributes |
| (Component_List (Parent_Rdef))); |
| end if; |
| end if; |
| end; |
| |
| elsif 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; |
| 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)); |
| pragma Assert (Name /= Name_uParent); |
| |
| function To_Upper (S : String) return String; |
| -- Same as Ada.Characters.Handling.To_Upper, but withing |
| -- Ada.Characters.Handling seems to cause mailserver problems. |
| |
| -------------- |
| -- To_Upper -- |
| -------------- |
| |
| function To_Upper (S : String) return String is |
| begin |
| return Result : String := S do |
| for Char of Result loop |
| Char := Fold_Upper (Char); |
| end loop; |
| end return; |
| end To_Upper; |
| |
| -- Start of processing for Make_Component_Name |
| |
| 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, |
| To_Upper (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 |
| if (Ada_Version < Ada_2022) |
| or else not Enable_Put_Image (Btyp) |
| then |
| -- generate a very simple Put_Image implementation |
| |
| if Is_RTE (Typ, RE_Root_Buffer_Type) then |
| -- Avoid introducing a cyclic dependency between |
| -- Ada.Strings.Text_Buffers and System.Put_Images. |
| |
| Append_To (Stms, |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Explicit_Raise)); |
| else |
| Append_To (Stms, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Put_Image_Unknown), Loc), |
| Parameter_Associations => New_List |
| (Make_Identifier (Loc, Name_S), |
| Make_String_Literal (Loc, |
| To_String (Fully_Qualified_Name_String (Btyp)))))); |
| end if; |
| elsif Is_Null_Record_Type (Btyp, Ignore_Privacy => True) then |
| |
| -- Interface types take this path. |
| |
| Append_To (Stms, |
| 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, "(NULL RECORD)")))); |
| else |
| 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 are to be |
| -- found in the extension (although we have to process the |
| -- _Parent component to find inherited components). |
| |
| 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)))); |
| end if; |
| |
| 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_Root_Buffer_Type)), 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 |
| -- If this function returns False for a non-scalar type Typ, then |
| -- a) calls to Typ'Image will result in calls to |
| -- System.Put_Images.Put_Image_Unknown to generate the image. |
| -- b) If Typ is a tagged type, then similarly the implementation |
| -- of Typ's Put_Image procedure will call Put_Image_Unknown |
| -- and will ignore its formal parameter of type Typ. |
| -- Note that Typ will still have a Put_Image procedure |
| -- in this case, albeit one with a simplified implementation. |
| -- |
| -- The name "Sink" here is a short nickname for |
| -- "Ada.Strings.Text_Buffers.Root_Buffer_Type". |
| -- |
| -- 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. |
| |
| if Is_Remote_Types (Scope (Typ)) |
| or else Is_Remote_Call_Interface (Typ) |
| or else (Is_Tagged_Type (Typ) and then In_Predefined_Unit (Typ)) |
| then |
| return False; |
| end if; |
| |
| -- 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_Root_Buffer_Type) then |
| return False; |
| end if; |
| |
| -- ???Disable Put_Image on type Root_Buffer_Type declared in |
| -- Ada.Strings.Text_Buffers. Note that we can't call Is_RTU on |
| -- Ada_Strings_Text_Buffers, 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_buffers") |
| 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; |
| |
| --------------------------------- |
| -- Image_Should_Call_Put_Image -- |
| --------------------------------- |
| |
| function Image_Should_Call_Put_Image (N : Node_Id) return Boolean is |
| begin |
| if Ada_Version < Ada_2022 then |
| return False; |
| end if; |
| |
| -- In Ada 2022, 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-2022 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; |
| |
| ---------------------- |
| -- Build_Image_Call -- |
| ---------------------- |
| |
| function Build_Image_Call (N : Node_Id) return Node_Id is |
| -- For T'Image (X) Generate an Expression_With_Actions node: |
| -- |
| -- do |
| -- S : 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_Temporary (Loc, 'S'); |
| Sink_Decl : constant Node_Id := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Sink_Entity, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Buffer_Type), Loc)); |
| |
| Image_Prefix : constant Node_Id := |
| Duplicate_Subexpr (First (Expressions (N))); |
| |
| 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), |
| Image_Prefix)); |
| Result_Entity : constant Entity_Id := |
| Make_Temporary (Loc, '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)))); |
| Actions : List_Id; |
| |
| function Put_String_Exp (String_Exp : Node_Id; |
| Wide_Wide : Boolean := False) return Node_Id; |
| -- Generate a call to evaluate a String (or Wide_Wide_String, depending |
| -- on the Wide_Wide Boolean parameter) expression and output it into |
| -- the buffer. |
| |
| -------------------- |
| -- Put_String_Exp -- |
| -------------------- |
| |
| function Put_String_Exp (String_Exp : Node_Id; |
| Wide_Wide : Boolean := False) return Node_Id is |
| Put_Id : constant RE_Id := |
| (if Wide_Wide then RE_Wide_Wide_Put else RE_Put_UTF_8); |
| |
| -- We could build a nondispatching call here, but to make |
| -- that work we'd have to change Rtsfind spec to make available |
| -- corresponding callees out of Ada.Strings.Text_Buffers.Unbounded |
| -- (as opposed to from Ada.Strings.Text_Buffers). Seems simpler to |
| -- introduce a type conversion and leave it to the optimizer to |
| -- eliminate the dispatching. This does not *introduce* any problems |
| -- if a no-dispatching-allowed restriction is in effect, since we |
| -- are already in the middle of generating a call to T'Class'Image. |
| |
| Sink_Exp : constant Node_Id := |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of |
| (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc), |
| Expression => New_Occurrence_Of (Sink_Entity, Loc)); |
| begin |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (Put_Id), Loc), |
| Parameter_Associations => New_List (Sink_Exp, String_Exp)); |
| end Put_String_Exp; |
| |
| -- Start of processing for Build_Image_Call |
| |
| begin |
| if Is_Class_Wide_Type (U_Type) then |
| -- Generate qualified-expression syntax; qualification name comes |
| -- from calling Ada.Tags.Wide_Wide_Expanded_Name. |
| |
| declare |
| -- The copy of Image_Prefix will be evaluated before the |
| -- original, which is ok if no side effects are involved. |
| |
| pragma Assert (Side_Effect_Free (Image_Prefix)); |
| |
| Specific_Type_Name : constant Node_Id := |
| Put_String_Exp |
| (Make_Function_Call (Loc, |
| Name => New_Occurrence_Of |
| (RTE (RE_Wide_Wide_Expanded_Name), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => Duplicate_Subexpr (Image_Prefix), |
| Attribute_Name => Name_Tag))), |
| Wide_Wide => True); |
| |
| Qualification : constant Node_Id := |
| Put_String_Exp (Make_String_Literal (Loc, "'")); |
| begin |
| Actions := New_List |
| (Sink_Decl, |
| Specific_Type_Name, |
| Qualification, |
| Put_Im, |
| Result_Decl); |
| end; |
| else |
| Actions := New_List (Sink_Decl, Put_Im, Result_Decl); |
| end if; |
| |
| return Make_Expression_With_Actions (Loc, |
| Actions => Actions, |
| Expression => New_Occurrence_Of (Result_Entity, Loc)); |
| end Build_Image_Call; |
| |
| ------------------------------ |
| -- Preload_Root_Buffer_Type -- |
| ------------------------------ |
| |
| procedure Preload_Root_Buffer_Type (Compilation_Unit : Node_Id) is |
| begin |
| -- We can't call RTE (RE_Root_Buffer_Type) for at least some |
| -- predefined units, because it would introduce cyclic dependences. |
| -- The package where Root_Buffer_Type 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_Root_Buffer_Type) when compiling the compiler itself. |
| -- Packages Ada.Strings.Buffer_Types and friends are not included |
| -- in the compiler. |
| -- |
| -- Don't do it if type Root_Buffer_Type is unavailable in the runtime. |
| |
| if not In_Predefined_Unit (Compilation_Unit) |
| and then Tagged_Seen |
| and then not No_Run_Time_Mode |
| and then RTE_Available (RE_Root_Buffer_Type) |
| then |
| declare |
| Ignore : constant Entity_Id := RTE (RE_Root_Buffer_Type); |
| begin |
| null; |
| end; |
| end if; |
| end Preload_Root_Buffer_Type; |
| |
| ------------------------- |
| -- 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; |
