diff options
| author | Bob Duff <duff@adacore.com> | 2020-01-28 15:06:41 -0500 |
|---|---|---|
| committer | Pierre-Marie de Rodat <derodat@adacore.com> | 2020-06-04 05:11:15 -0400 |
| commit | 110d0820bfcb421b8c680409cf5c65aa2a0b4b8e (patch) | |
| tree | b7f7f5be5a1a3d29e95cf08be19feded42995b7c /gcc | |
| parent | a3fbeceef46546fd47ed370474feed347c86713f (diff) | |
| download | gcc-110d0820bfcb421b8c680409cf5c65aa2a0b4b8e.zip gcc-110d0820bfcb421b8c680409cf5c65aa2a0b4b8e.tar.gz gcc-110d0820bfcb421b8c680409cf5c65aa2a0b4b8e.tar.bz2 | |
[Ada] Put_Image attribute
2020-06-04 Bob Duff <duff@adacore.com>
gcc/ada/
* libgnat/a-stobbu.adb, libgnat/a-stobbu.ads,
libgnat/a-stobfi.adb, libgnat/a-stobfi.ads,
libgnat/a-stoubu.adb, libgnat/a-stoubu.ads,
libgnat/a-stoufi.adb, libgnat/a-stoufi.ads,
libgnat/a-stoufo.adb, libgnat/a-stoufo.ads,
libgnat/a-stouut.adb, libgnat/a-stouut.ads,
libgnat/a-stteou.ads, libgnat/s-putaim.adb,
libgnat/s-putaim.ads, libgnat/s-putima.adb, libgnat/s-putima.ads
(Ada.Strings.Text_Output and children, System.Put_Images): New
runtime support for Put_Image.
* gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add
exp_put_image.o.
* exp_put_image.adb, exp_put_image.ads: New compiler package
that generates calls to runtime routines that implement
Put_Image.
* Makefile.rtl: Add object files for Ada.Strings.Text_Output and
children and System.Put_Images.
* aspects.adb: Simplify initialization of Canonical_Aspect.
* aspects.ads: Improve documentation. Add Aspect_Put_Image.
* exp_attr.adb: Add support for Put_Image, by calling routines
in Exp_Put_Image.
* sem_util.adb (Is_Predefined_Dispatching_Operation): Return
True for new TSS_Put_Image operation.
* exp_ch3.adb: For tagged types, build a dispatching
TSS_Put_Image operation by calling routines in Exp_Put_Image.
* exp_disp.adb, exp_disp.ads: Make TSS_Put_Image be number 10,
adjusting other operations' numbers after 10. We choose 10
because that's the last number shared by all runtimes.
* exp_strm.adb: Use named notation as appropriate.
* exp_cg.adb, exp_tss.ads: Add TSS_Put_Image.
* libgnat/a-tags.ads: Modify Max_Predef_Prims for the new
TSS_Put_Image.
* impunit.adb: Add new runtime packages.
* rtsfind.adb, rtsfind.ads: Add support for
Ada.Strings.Text_Output, Ada.Strings.Text_Output.Utils, and
System.Put_Images.
* sem_attr.adb: Error checking for Put_Image calls.
* sem_ch12.adb (Valid_Default_Attribute): Support for passing
Put_Image as a generic formal parameter.
* sem_ch13.adb: Analysis of Put_Image aspect. Turn it into a
Put_Image attribute definition clause.
* sem_ch8.adb (Analyze_Subprogram_Renaming): Support for
renaming of the Put_Image attribute.
* snames.adb-tmpl: Fix comments.
* snames.ads-tmpl (Name_Put_Image): New Name_Id.
(Attribute_Put_Image): New Attribute_Id.
* tbuild.adb, tbuild.ads (Make_Increment): New utility.
Diffstat (limited to 'gcc')
43 files changed, 3612 insertions, 224 deletions
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 0c62df2..e1b30b9 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -52,6 +52,7 @@ GNATRTL_TASKING_OBJS= \ s-mudido$(objext) \ s-osinte$(objext) \ s-proinf$(objext) \ + s-putaim$(objext) \ s-solita$(objext) \ s-stusta$(objext) \ s-taenca$(objext) \ @@ -79,7 +80,7 @@ GNATRTL_TASKING_OBJS= \ thread$(objext) \ $(EXTRA_GNATRTL_TASKING_OBJS) -# Objects the require IEEE Float +# Objects that require IEEE Float GNATRTL_ALTIVEC_OBJS= \ g-allein$(objext) \ g-alleve$(objext) \ @@ -263,7 +264,13 @@ GNATRTL_NONTASKING_OBJS= \ a-stboha$(objext) \ a-stfiha$(objext) \ a-stmaco$(objext) \ + a-stobbu$(objext) \ + a-stobfi$(objext) \ a-storio$(objext) \ + a-stoubu$(objext) \ + a-stoufi$(objext) \ + a-stoufo$(objext) \ + a-stouut$(objext) \ a-strbou$(objext) \ a-stream$(objext) \ a-strfix$(objext) \ @@ -274,6 +281,7 @@ GNATRTL_NONTASKING_OBJS= \ a-strsup$(objext) \ a-strunb$(objext) \ a-ststio$(objext) \ + a-stteou$(objext) \ a-stunau$(objext) \ a-stunha$(objext) \ a-stuten$(objext) \ @@ -421,7 +429,6 @@ GNATRTL_NONTASKING_OBJS= \ g-excact$(objext) \ g-except$(objext) \ g-exctra$(objext) \ - s-exctra$(objext) \ g-expect$(objext) \ g-exptty$(objext) \ g-flocon$(objext) \ @@ -476,7 +483,6 @@ GNATRTL_NONTASKING_OBJS= \ g-timsta$(objext) \ g-traceb$(objext) \ g-trasym$(objext) \ - s-trasym$(objext) \ g-tty$(objext) \ g-u3spch$(objext) \ g-utf_32$(objext) \ @@ -539,7 +545,6 @@ GNATRTL_NONTASKING_OBJS= \ s-dfmkio$(objext) \ s-dfmopr$(objext) \ s-dgmgop$(objext) \ - s-dlmopr$(objext) \ s-diflio$(objext) \ s-diflmk$(objext) \ s-digemk$(objext) \ @@ -550,12 +555,14 @@ GNATRTL_NONTASKING_OBJS= \ s-dimmks$(objext) \ s-direio$(objext) \ s-dlmkio$(objext) \ + s-dlmopr$(objext) \ s-dmotpr$(objext) \ s-dsaser$(objext) \ s-elaall$(objext) \ s-excdeb$(objext) \ s-except$(objext) \ s-exctab$(objext) \ + s-exctra$(objext) \ s-exnint$(objext) \ s-exnllf$(objext) \ s-exnlli$(objext) \ @@ -672,6 +679,7 @@ GNATRTL_NONTASKING_OBJS= \ s-poosiz$(objext) \ s-powtab$(objext) \ s-purexc$(objext) \ + s-putima$(objext) \ s-rannum$(objext) \ s-ransee$(objext) \ s-regexp$(objext) \ @@ -700,6 +708,7 @@ GNATRTL_NONTASKING_OBJS= \ s-tasloc$(objext) \ s-traceb$(objext) \ s-traent$(objext) \ + s-trasym$(objext) \ s-unstyp$(objext) \ s-utf_32$(objext) \ s-valboo$(objext) \ diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 2968e21..c55f4ed 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -500,136 +500,36 @@ package body Aspects is -- Table used for Same_Aspect, maps aspect to canonical aspect - Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id := - (No_Aspect => No_Aspect, - Aspect_Abstract_State => Aspect_Abstract_State, - Aspect_Address => Aspect_Address, - Aspect_Alignment => Aspect_Alignment, - Aspect_All_Calls_Remote => Aspect_All_Calls_Remote, - Aspect_Annotate => Aspect_Annotate, - Aspect_Async_Readers => Aspect_Async_Readers, - Aspect_Async_Writers => Aspect_Async_Writers, - Aspect_Asynchronous => Aspect_Asynchronous, - Aspect_Atomic => Aspect_Atomic, - Aspect_Atomic_Components => Aspect_Atomic_Components, - Aspect_Attach_Handler => Aspect_Attach_Handler, - Aspect_Bit_Order => Aspect_Bit_Order, - Aspect_Component_Size => Aspect_Component_Size, - Aspect_Constant_After_Elaboration => Aspect_Constant_After_Elaboration, - Aspect_Constant_Indexing => Aspect_Constant_Indexing, - Aspect_Contract_Cases => Aspect_Contract_Cases, - Aspect_Convention => Aspect_Convention, - Aspect_CPU => Aspect_CPU, - Aspect_Default_Component_Value => Aspect_Default_Component_Value, - Aspect_Default_Initial_Condition => Aspect_Default_Initial_Condition, - Aspect_Default_Iterator => Aspect_Default_Iterator, - Aspect_Default_Storage_Pool => Aspect_Default_Storage_Pool, - Aspect_Default_Value => Aspect_Default_Value, - Aspect_Depends => Aspect_Depends, - Aspect_Dimension => Aspect_Dimension, - Aspect_Dimension_System => Aspect_Dimension_System, - Aspect_Disable_Controlled => Aspect_Disable_Controlled, - Aspect_Discard_Names => Aspect_Discard_Names, - Aspect_Dispatching_Domain => Aspect_Dispatching_Domain, - Aspect_Dynamic_Predicate => Aspect_Predicate, - Aspect_Effective_Reads => Aspect_Effective_Reads, - Aspect_Effective_Writes => Aspect_Effective_Writes, - Aspect_Elaborate_Body => Aspect_Elaborate_Body, - Aspect_Export => Aspect_Export, - Aspect_Extensions_Visible => Aspect_Extensions_Visible, - Aspect_External_Name => Aspect_External_Name, - Aspect_External_Tag => Aspect_External_Tag, - Aspect_Favor_Top_Level => Aspect_Favor_Top_Level, - Aspect_Ghost => Aspect_Ghost, - Aspect_Global => Aspect_Global, - Aspect_Implicit_Dereference => Aspect_Implicit_Dereference, - Aspect_Import => Aspect_Import, - Aspect_Independent => Aspect_Independent, - Aspect_Independent_Components => Aspect_Independent_Components, - Aspect_Inline => Aspect_Inline, - Aspect_Inline_Always => Aspect_Inline, - Aspect_Initial_Condition => Aspect_Initial_Condition, - Aspect_Initializes => Aspect_Initializes, - Aspect_Input => Aspect_Input, - Aspect_Interrupt_Handler => Aspect_Interrupt_Handler, - Aspect_Interrupt_Priority => Aspect_Priority, - Aspect_Invariant => Aspect_Invariant, - Aspect_Iterable => Aspect_Iterable, - Aspect_Iterator_Element => Aspect_Iterator_Element, - Aspect_Link_Name => Aspect_Link_Name, - Aspect_Linker_Section => Aspect_Linker_Section, - Aspect_Lock_Free => Aspect_Lock_Free, - Aspect_Machine_Radix => Aspect_Machine_Radix, - Aspect_Max_Entry_Queue_Depth => Aspect_Max_Entry_Queue_Depth, - Aspect_Max_Entry_Queue_Length => Aspect_Max_Entry_Queue_Length, - Aspect_Max_Queue_Length => Aspect_Max_Queue_Length, - Aspect_No_Caching => Aspect_No_Caching, - Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All, - Aspect_No_Inline => Aspect_No_Inline, - Aspect_No_Return => Aspect_No_Return, - Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams, - Aspect_Obsolescent => Aspect_Obsolescent, - Aspect_Object_Size => Aspect_Object_Size, - Aspect_Output => Aspect_Output, - Aspect_Pack => Aspect_Pack, - Aspect_Part_Of => Aspect_Part_Of, - Aspect_Persistent_BSS => Aspect_Persistent_BSS, - Aspect_Post => Aspect_Post, - Aspect_Postcondition => Aspect_Post, - Aspect_Pre => Aspect_Pre, - Aspect_Precondition => Aspect_Pre, - Aspect_Predicate => Aspect_Predicate, - Aspect_Predicate_Failure => Aspect_Predicate_Failure, - Aspect_Preelaborate => Aspect_Preelaborate, - Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization, - Aspect_Priority => Aspect_Priority, - Aspect_Pure => Aspect_Pure, - Aspect_Pure_Function => Aspect_Pure_Function, - Aspect_Refined_Depends => Aspect_Refined_Depends, - Aspect_Refined_Global => Aspect_Refined_Global, - Aspect_Refined_Post => Aspect_Refined_Post, - Aspect_Refined_State => Aspect_Refined_State, - Aspect_Remote_Access_Type => Aspect_Remote_Access_Type, - Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface, - Aspect_Remote_Types => Aspect_Remote_Types, - Aspect_Read => Aspect_Read, - Aspect_Relative_Deadline => Aspect_Relative_Deadline, - Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order, - Aspect_Secondary_Stack_Size => Aspect_Secondary_Stack_Size, - Aspect_Shared => Aspect_Atomic, - Aspect_Shared_Passive => Aspect_Shared_Passive, - Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool, - Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type, - Aspect_Size => Aspect_Size, - Aspect_Small => Aspect_Small, - Aspect_SPARK_Mode => Aspect_SPARK_Mode, - Aspect_Static_Predicate => Aspect_Predicate, - Aspect_Storage_Pool => Aspect_Storage_Pool, - Aspect_Storage_Size => Aspect_Storage_Size, - Aspect_Stream_Size => Aspect_Stream_Size, - Aspect_Suppress => Aspect_Suppress, - Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info, - Aspect_Suppress_Initialization => Aspect_Suppress_Initialization, - Aspect_Synchronization => Aspect_Synchronization, - Aspect_Test_Case => Aspect_Test_Case, - Aspect_Thread_Local_Storage => Aspect_Thread_Local_Storage, - Aspect_Type_Invariant => Aspect_Invariant, - Aspect_Unchecked_Union => Aspect_Unchecked_Union, - Aspect_Unimplemented => Aspect_Unimplemented, - Aspect_Universal_Aliasing => Aspect_Universal_Aliasing, - Aspect_Universal_Data => Aspect_Universal_Data, - Aspect_Unmodified => Aspect_Unmodified, - Aspect_Unreferenced => Aspect_Unreferenced, - Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects, - Aspect_Unsuppress => Aspect_Unsuppress, - Aspect_Variable_Indexing => Aspect_Variable_Indexing, - Aspect_Value_Size => Aspect_Value_Size, - Aspect_Volatile => Aspect_Volatile, - Aspect_Volatile_Components => Aspect_Volatile_Components, - Aspect_Volatile_Full_Access => Aspect_Volatile_Full_Access, - Aspect_Volatile_Function => Aspect_Volatile_Function, - Aspect_Warnings => Aspect_Warnings, - Aspect_Write => Aspect_Write); + type Aspect_To_Aspect_Mapping is array (Aspect_Id) of Aspect_Id; + + function Init_Canonical_Aspect return Aspect_To_Aspect_Mapping; + -- Initialize the Canonical_Aspect mapping below + + function Init_Canonical_Aspect return Aspect_To_Aspect_Mapping is + Result : Aspect_To_Aspect_Mapping; + begin + -- They all map to themselves... + + for Aspect in Aspect_Id loop + Result (Aspect) := Aspect; + end loop; + + -- ...except for these: + + Result (Aspect_Dynamic_Predicate) := Aspect_Predicate; + Result (Aspect_Inline_Always) := Aspect_Inline; + Result (Aspect_Interrupt_Priority) := Aspect_Priority; + Result (Aspect_Postcondition) := Aspect_Post; + Result (Aspect_Precondition) := Aspect_Pre; + Result (Aspect_Shared) := Aspect_Atomic; + Result (Aspect_Static_Predicate) := Aspect_Predicate; + Result (Aspect_Type_Invariant) := Aspect_Invariant; + + return Result; + end Init_Canonical_Aspect; + + Canonical_Aspect : constant Aspect_To_Aspect_Mapping := + Init_Canonical_Aspect; function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is begin diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 5766cdd..73d12f30 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -38,11 +38,11 @@ -- Adding New Aspects -- ------------------------ --- In general, each aspect should have a corresponding pragma, so that the --- newly developed functionality is available for Ada versions < Ada 2012. +-- In general, each aspect should have a corresponding pragma or attribute, so +-- that the newly developed functionality is available for old Ada versions. -- When both are defined, it is convenient to first transform the aspect into --- an equivalent pragma in Sem_Ch13.Analyze_Aspect_Specifications, and then --- analyze the pragma in Sem_Prag.Analyze_Pragma. +-- an equivalent pragma or attribute in Sem_Ch13.Analyze_Aspect_Specifications +-- and then analyze that. -- To add a new aspect, you need to do the following @@ -57,7 +57,7 @@ -- treatments later. -- 5. If the semantic analysis of expressions/names in the aspect should not --- occur at the point the aspect is defined, add code in the adequate +-- occur at the point the aspect is defined, add code in the appropriate -- semantic analysis procedure for the aspect. For example, this is the -- case for aspects Pre and Post on subprograms, which are preanalyzed -- at the end of the declaration list to which the subprogram belongs, @@ -131,6 +131,7 @@ package Aspects is Aspect_Predicate, -- GNAT Aspect_Predicate_Failure, Aspect_Priority, + Aspect_Put_Image, Aspect_Read, Aspect_Refined_Depends, -- GNAT Aspect_Refined_Global, -- GNAT @@ -392,6 +393,7 @@ package Aspects is Aspect_Predicate => Expression, Aspect_Predicate_Failure => Expression, Aspect_Priority => Expression, + Aspect_Put_Image => Name, Aspect_Read => Name, Aspect_Refined_Depends => Expression, Aspect_Refined_Global => Expression, @@ -514,6 +516,7 @@ package Aspects is Aspect_Priority => Name_Priority, Aspect_Pure => Name_Pure, Aspect_Pure_Function => Name_Pure_Function, + Aspect_Put_Image => Name_Put_Image, Aspect_Read => Name_Read, Aspect_Refined_Depends => Name_Refined_Depends, Aspect_Refined_Global => Name_Refined_Global, @@ -719,6 +722,7 @@ package Aspects is Aspect_Priority => Always_Delay, Aspect_Pure => Always_Delay, Aspect_Pure_Function => Always_Delay, + Aspect_Put_Image => Always_Delay, Aspect_Read => Always_Delay, Aspect_Relative_Deadline => Always_Delay, Aspect_Remote_Access_Type => Always_Delay, diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index d8831be..9d697961 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -37,6 +37,7 @@ with Exp_Dist; use Exp_Dist; with Exp_Imgv; use Exp_Imgv; with Exp_Pakd; use Exp_Pakd; with Exp_Strm; use Exp_Strm; +with Exp_Put_Image; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Expander; use Expander; @@ -1737,22 +1738,19 @@ package body Exp_Attr is procedure Expand_N_Attribute_Reference (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (N); - Btyp : constant Entity_Id := Base_Type (Typ); Pref : constant Node_Id := Prefix (N); - Ptyp : constant Entity_Id := Etype (Pref); Exprs : constant List_Id := Expressions (N); - Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); - procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id); - -- Rewrites a stream attribute for Read, Write or Output with the - -- procedure call. Pname is the entity for the procedure to call. + procedure Rewrite_Attribute_Proc_Call (Pname : Entity_Id); + -- Rewrites an attribute for Read, Write, Output, or Put_Image with a + -- call to the appropriate TSS procedure. Pname is the entity for the + -- procedure to call. - ------------------------------ - -- Rewrite_Stream_Proc_Call -- - ------------------------------ + --------------------------------- + -- Rewrite_Attribute_Proc_Call -- + --------------------------------- - procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is + procedure Rewrite_Attribute_Proc_Call (Pname : Entity_Id) is Item : constant Node_Id := Next (First (Exprs)); Item_Typ : constant Entity_Id := Etype (Item); Formal : constant Entity_Id := Next_Formal (First_Formal (Pname)); @@ -1847,8 +1845,8 @@ package body Exp_Attr is end if; end if; - -- The stream operation to call may be a renaming created by an - -- attribute definition clause, and may not be frozen yet. Ensure + -- The stream operation to call might be a renaming created by an + -- attribute definition clause, and might not be frozen yet. Ensure -- that it has the necessary extra formals. if not Is_Frozen (Pname) then @@ -1863,7 +1861,12 @@ package body Exp_Attr is Parameter_Associations => Exprs)); Analyze (N); - end Rewrite_Stream_Proc_Call; + end Rewrite_Attribute_Proc_Call; + + Typ : constant Entity_Id := Etype (N); + Btyp : constant Entity_Id := Base_Type (Typ); + Ptyp : constant Entity_Id := Etype (Pref); + Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); -- Start of processing for Expand_N_Attribute_Reference @@ -5110,7 +5113,7 @@ package body Exp_Attr is -- If we fall through, Pname is the name of the procedure to call - Rewrite_Stream_Proc_Call (Pname); + Rewrite_Attribute_Proc_Call (Pname); end Output; --------- @@ -5435,6 +5438,126 @@ package body Exp_Attr is Analyze_And_Resolve (N, Typ, Suppress => Access_Check); end Priority; + --------------- + -- Put_Image -- + --------------- + + when Attribute_Put_Image => Put_Image : declare + use Exp_Put_Image; + U_Type : constant Entity_Id := Underlying_Type (Entity (Pref)); + Pname : Entity_Id; + Decl : Node_Id; + + begin + -- If no underlying type, we have an error that will be diagnosed + -- elsewhere, so here we just completely ignore the expansion. + + if No (U_Type) then + return; + end if; + + -- If there is a TSS for Put_Image, just call it + + Pname := TSS (U_Type, TSS_Put_Image); + if No (Pname) then + if Is_Tagged_Type (U_Type) and then Is_Derived_Type (U_Type) then + Pname := Find_Optional_Prim_Op (U_Type, TSS_Put_Image); + pragma Assert + (Has_Interfaces (U_Type) -- ????interfaces not yet supported + or else Enable_Put_Image (U_Type) = Present (Pname)); + else + Pname := Find_Inherited_TSS (U_Type, TSS_Put_Image); + end if; + end if; + + if No (Pname) then + -- For elementary types, we call the routine in System.Put_Images + -- directly. + + if Is_Elementary_Type (U_Type) then + Rewrite (N, Build_Elementary_Put_Image_Call (N)); + Analyze (N); + return; + + -- ???It would be nice to call Build_String_Put_Image_Call below + -- if U_Type is a standard string type, but it currently generates + -- something like: + -- + -- Put_Image_String (Sink, String (X)); + -- + -- so if X is of a private type whose full type is "new String", + -- then the type conversion is illegal. To fix that, we would need + -- to do unchecked conversions of access values, taking care to + -- deal with thin and fat pointers properly. For now, we just fall + -- back to Build_Array_Put_Image_Procedure in these cases, so the + -- following says "Root_Type (Entity (Pref))" instead of "U_Type". + + elsif Is_Standard_String_Type (Root_Type (Entity (Pref))) then + Rewrite (N, Build_String_Put_Image_Call (N)); + Analyze (N); + return; + + elsif Is_Array_Type (U_Type) then + Build_Array_Put_Image_Procedure (N, U_Type, Decl, Pname); + Insert_Action (N, Decl); + + -- Tagged type case, use the primitive Put_Image function. Note + -- that this will dispatch in the class-wide case which is what we + -- want. + + elsif Is_Tagged_Type (U_Type) then + Pname := Find_Optional_Prim_Op (U_Type, TSS_Put_Image); + + -- ????Need Find_Optional_Prim_Op instead of Find_Prim_Op, + -- because we might be deriving from a predefined type, which + -- currently has Enable_Put_Image False. + + if No (Pname) then + Rewrite (N, Build_Unknown_Put_Image_Call (N)); + Analyze (N); + return; + end if; + + elsif Is_Protected_Type (U_Type) then + Rewrite (N, Build_Protected_Put_Image_Call (N)); + Analyze (N); + return; + + elsif Is_Task_Type (U_Type) then + Rewrite (N, Build_Task_Put_Image_Call (N)); + Analyze (N); + return; + + -- All other record type cases, including protected records + + else + pragma Assert (Is_Record_Type (U_Type)); + + -- Program_Error is raised when calling the default + -- implementation of the Put_Image attribute of an + -- Unchecked_Union type. ???It would be friendlier to print a + -- canned string. See handling of unchecked unions in + -- exp_put_image.adb (which is not reachable). + + if Is_Unchecked_Union (Base_Type (U_Type)) then + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + Set_Etype (N, Standard_Void_Type); + return; + end if; + + Build_Record_Put_Image_Procedure + (Loc, Full_Base (U_Type), Decl, Pname); + Insert_Action (N, Decl); + end if; + end if; + + -- If we fall through, Pname is the procedure to be called + + Rewrite_Attribute_Proc_Call (Pname); + end Put_Image; + ------------------ -- Range_Length -- ------------------ @@ -5765,7 +5888,7 @@ package body Exp_Attr is end if; end if; - Rewrite_Stream_Proc_Call (Pname); + Rewrite_Attribute_Proc_Call (Pname); end Read; --------- @@ -7411,7 +7534,7 @@ package body Exp_Attr is -- If we fall through, Pname is the procedure to be called - Rewrite_Stream_Proc_Call (Pname); + Rewrite_Attribute_Proc_Call (Pname); end Write; -- Component_Size is handled by the back end, unless the component size diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb index 20be6a0..02a0652 100644 --- a/gcc/ada/exp_cg.adb +++ b/gcc/ada/exp_cg.adb @@ -81,7 +81,7 @@ package body Exp_CG is -- Determines if E is a predefined primitive operation. -- Note: This routine should replace the routine with the same name that is -- currently available in exp_disp because it extends its functionality to - -- handle fully qualified names ??? + -- handle fully qualified names. It's actually in Sem_Util. ??? function Slot_Number (Prim : Entity_Id) return Uint; -- Returns the slot number associated with Prim. For predefined primitives @@ -261,6 +261,7 @@ package body Exp_CG is or else TSS_Name = TSS_Stream_Write or else TSS_Name = TSS_Stream_Input or else TSS_Name = TSS_Stream_Output + or else TSS_Name = TSS_Put_Image or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize then diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 0d09449..8d1b2e1 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -37,6 +37,7 @@ with Exp_Ch9; use Exp_Ch9; with Exp_Dbug; use Exp_Dbug; with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; +with Exp_Put_Image; with Exp_Smem; use Exp_Smem; with Exp_Strm; use Exp_Strm; with Exp_Tss; use Exp_Tss; @@ -265,6 +266,7 @@ package body Exp_Ch3 is -- typSW provides result of 'Write attribute -- typSI provides result of 'Input attribute -- typSO provides result of 'Output attribute + -- typPI provides result of 'Put_Image attribute -- -- The following entries are additionally present for non-limited tagged -- types, and implement additional dispatching operations for predefined @@ -9924,6 +9926,8 @@ package body Exp_Ch3 is -- Set to True if Tag_Typ has a primitive that renames the predefined -- equality operator. Used to implement (RM 8-5-4(8)). + use Exp_Put_Image; + -- Start of processing for Make_Predefined_Primitive_Specs begin @@ -9941,6 +9945,17 @@ package body Exp_Ch3 is Ret_Type => Standard_Long_Long_Integer)); + -- Spec of Put_Image + + if Enable_Put_Image (Tag_Typ) + and then No (TSS (Tag_Typ, TSS_Put_Image)) + then + Append_To (Res, Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Make_TSS_Name (Tag_Typ, TSS_Put_Image), + Profile => Build_Put_Image_Profile (Loc, Tag_Typ))); + end if; + -- Specs for dispatching stream attributes declare @@ -10450,6 +10465,8 @@ package body Exp_Ch3 is pragma Warnings (Off, Ent); + use Exp_Put_Image; + begin pragma Assert (not Is_Interface (Tag_Typ)); @@ -10532,6 +10549,15 @@ package body Exp_Ch3 is Append_To (Res, Decl); + -- Body of Put_Image + + if Enable_Put_Image (Tag_Typ) + and then No (TSS (Tag_Typ, TSS_Put_Image)) + then + Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + -- Bodies for Dispatching stream IO routines. We need these only for -- non-limited types (in the limited case there is no dispatching). -- We also skip them if dispatching or finalization are not available diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 4a475c8..69c536f 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -643,28 +643,31 @@ package body Exp_Disp is elsif TSS_Name = TSS_Deep_Finalize then return Uint_9; + elsif TSS_Name = TSS_Put_Image then + return Uint_10; + -- In VM targets unconditionally allow obtaining the position associated -- with predefined interface primitives since in these platforms any -- tagged type has these primitives. elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then if Chars (E) = Name_uDisp_Asynchronous_Select then - return Uint_10; + return Uint_11; elsif Chars (E) = Name_uDisp_Conditional_Select then - return Uint_11; + return Uint_12; elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then - return Uint_12; + return Uint_13; elsif Chars (E) = Name_uDisp_Get_Task_Id then - return Uint_13; + return Uint_14; elsif Chars (E) = Name_uDisp_Requeue then - return Uint_14; + return Uint_15; elsif Chars (E) = Name_uDisp_Timed_Select then - return Uint_15; + return Uint_16; end if; end if; @@ -4680,16 +4683,16 @@ package body Exp_Disp is end if; -- Ensure that the value of Max_Predef_Prims defined in a-tags is - -- correct. Valid values are 9 under configurable runtime or 15 + -- correct. Valid values are 10 under configurable runtime or 16 -- with full runtime. if RTE_Available (RE_Interface_Data) then - if Max_Predef_Prims /= 15 then + if Max_Predef_Prims /= 16 then Error_Msg_N ("run-time library configuration error", Typ); goto Leave; end if; else - if Max_Predef_Prims /= 9 then + if Max_Predef_Prims /= 10 then Error_Msg_N ("run-time library configuration error", Typ); Error_Msg_CRT ("tagged types", Typ); goto Leave; diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 2d3c2d7..fb1de72 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -77,37 +77,40 @@ package Exp_Disp is -- TSS_Deep_Finalize (9) - implementation of the finalization -- operation Finalize for any non-limited tagged type. - -- _Disp_Asynchronous_Select (10) - used in the expansion of ATC with + -- Put_Image (10) - implementation of Put_Image attribute for any + -- tagged type. + + -- _Disp_Asynchronous_Select (11) - used in the expansion of ATC with -- dispatching triggers. Null implementation for limited interfaces, -- full body generation for types that implement limited interfaces, -- not generated for the rest of the cases. See Expand_N_Asynchronous_ -- Select in Exp_Ch9 for more information. - -- _Disp_Conditional_Select (11) - used in the expansion of conditional + -- _Disp_Conditional_Select (12) - used in the expansion of conditional -- selects with dispatching triggers. Null implementation for limited -- interfaces, full body generation for types that implement limited -- interfaces, not generated for the rest of the cases. See Expand_N_ -- Conditional_Entry_Call in Exp_Ch9 for more information. - -- _Disp_Get_Prim_Op_Kind (12) - helper routine used in the expansion + -- _Disp_Get_Prim_Op_Kind (13) - helper routine used in the expansion -- of ATC with dispatching triggers. Null implementation for limited -- interfaces, full body generation for types that implement limited -- interfaces, not generated for the rest of the cases. - -- _Disp_Get_Task_Id (13) - helper routine used in the expansion of + -- _Disp_Get_Task_Id (14) - helper routine used in the expansion of -- Abort, attributes 'Callable and 'Terminated for task interface -- class-wide types. Full body generation for task types, null -- implementation for limited interfaces, not generated for the rest -- of the cases. See Expand_N_Attribute_Reference in Exp_Attr and -- Expand_N_Abort_Statement in Exp_Ch9 for more information. - -- _Disp_Requeue (14) - used in the expansion of dispatching requeue + -- _Disp_Requeue (15) - used in the expansion of dispatching requeue -- statements. Null implementation is provided for protected, task -- and synchronized interfaces. Protected and task types implementing -- concurrent interfaces receive full bodies. See Expand_N_Requeue_ -- Statement in Exp_Ch9 for more information. - -- _Disp_Timed_Select (15) - used in the expansion of timed selects + -- _Disp_Timed_Select (16) - used in the expansion of timed selects -- with dispatching triggers. Null implementation for limited -- interfaces, full body generation for types that implement limited -- interfaces, not generated for the rest of the cases. See Expand_N_ @@ -139,11 +142,13 @@ package Exp_Disp is -- Update the value of constant Max_Predef_Prims in a-tags.ads to -- indicate the new number of PPOs. + -- Update Exp_Disp.Default_Prim_Op_Position. + -- Introduce a new predefined name for the new PPO in Snames.ads and -- Snames.adb. -- Categorize the new PPO name as predefined by adding an entry in - -- Is_Predefined_Dispatching_Operation in Exp_Disp. + -- Is_Predefined_Dispatching_Operation in Sem_Util and Exp_Cg. -- Generate the specification of the new PPO in Make_Predefined_ -- Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining @@ -156,17 +161,9 @@ package Exp_Disp is -- If the new PPO requires a thunk, add an entry in Freeze_Subprogram -- in Exp_Ch6.adb. - -- When generating calls to a PPO, use Find_Prim_Op from Exp_Util.ads + -- When generating calls to a PPO, use Find_Prim_Op from exp_util.ads -- to retrieve the entity of the operation directly. - -- Number of predefined primitive operations added by the Expander - -- for a tagged type. If more predefined primitive operations are - -- added, the following items must be changed: - - -- Ada.Tags.Max_Predef_Prims - indirect use - -- Exp_Disp.Default_Prim_Op_Position - indirect use - -- Exp_Disp.Set_All_DT_Position - direct use - procedure Apply_Tag_Checks (Call_Node : Node_Id); -- Generate checks required on dispatching calls diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb new file mode 100644 index 0000000..af6a783 --- /dev/null +++ b/gcc/ada/exp_put_image.adb @@ -0,0 +1,891 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P U T _ I M A G E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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 Exp_Tss; use Exp_Tss; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; +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; + else + pragma Assert (P_Size <= Standard_Long_Long_Integer_Size); + Lib_RE := RE_Put_Image_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; + else + pragma Assert (P_Size <= Standard_Long_Long_Integer_Size); + Lib_RE := RE_Put_Image_Long_Long_Unsigned; + end if; + + elsif Is_Access_Type (U_Type) then + if 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)); + -- + -- This is a bit of a cheat; we should probably do it the other way + -- around (define '[[Wide_]Wide_]Image in terms of 'Put_Image). But + -- this is expedient for now. 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))); + begin + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Put_Wide_Wide_String), Loc), + Parameter_Associations => New_List + (Relocate_Node (Sink), Image)); + 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 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. + + 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), + Convert_To + (Etype (Next_Formal (First_Formal (Libent))), + Relocate_Node (Item)))); + 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 + pragma Assert (Typ = Base_Type (Typ)); + pragma Assert (not Is_Unchecked_Union (Typ)); + + 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. + + -- If the enclosing record is an unchecked_union, we use the + -- default expressions for the discriminant (it must exist) + -- because we cannot generate a reference to it, given that it is + -- not stored. ????This seems unfriendly. It should just print + -- "(unchecked union)" instead. (Note that this code is + -- unreachable -- see exp_attr.) + + if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then + D_Ref := + New_Copy_Tree + (Discriminant_Default_Value (Entity (Name (VP)))); + else + D_Ref := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => + New_Occurrence_Of (Entity (Name (VP)), Loc)); + end if; + + 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 + and then Enable_Put_Image (Component_Typ) + 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_In (Item, 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; + Typt : Entity_Id; + Type_Decl : Node_Id; + + -- Start of processing for Build_Record_Put_Image_Procedure + + begin + -- For the protected type case, use corresponding record + + if Is_Protected_Type (Typ) then + Typt := Corresponding_Record_Type (Typ); + else + Typt := Typ; + end if; + + Type_Decl := Declaration_Node (Base_Type (Underlying_Type (Typt))); + + 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 + -- If the type is an unchecked union, use the default values of + -- the discriminants, because they are not stored. + + 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, Typ); + Build_Put_Image_Proc (Loc, Typ, 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))); + end Build_Unknown_Put_Image_Call; + + ---------------------- + -- Enable_Put_Image -- + ---------------------- + + function Enable_Put_Image (T : Entity_Id) return Boolean is + begin + if True then -- ????True to disable for all types. + return False; + end if; + + -- 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. + + -- ???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 (T)); + begin + if Present (Parent_Scope) + and then Is_RTU (Parent_Scope, Ada_Strings) + and then Chars (Scope (T)) = Name_Find ("text_output") + then + return False; + end if; + end; + + return Is_Scalar_Type (T) or else not In_Predefined_Unit (T); + 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; + + ---------------------- + -- 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; diff --git a/gcc/ada/exp_put_image.ads b/gcc/ada/exp_put_image.ads new file mode 100644 index 0000000..b245b05 --- /dev/null +++ b/gcc/ada/exp_put_image.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P U T _ I M A G E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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 Types; use Types; + +package Exp_Put_Image is + + -- Routines to build Put_Image calls. See Ada.Strings.Text_Output.Utils and + -- System.Put_Images for the run-time routines we are generating calls to. + + -- For a call to T'Put_Image, if T is elementary, we expand the code + -- inline. If T is a tagged type, then Put_Image is a primitive procedure + -- of T, and can be dispatched to in the class-wide case. For untagged + -- composite types, we generate a procedure the first time we see a call, + -- and call it. Subsequent calls call the same procedure. Thus, if there + -- are calls to T'Put_Image in different units, there will be duplicates; + -- each unit will get a copy of the T'Put_Image procedure. + + function Enable_Put_Image (T : Entity_Id) return Boolean; + -- True if Put_Image should be enabled for type T + + function Build_Put_Image_Profile + (Loc : Source_Ptr; Typ : Entity_Id) return List_Id; + -- Builds the parameter profile for Put_Image. This is used for the tagged + -- case to build the spec for the primitive operation. + + -- In the following Build_... routines, N is the attribute reference node, + -- from which the procedure to call and the parameters to pass can be + -- determined. + + function Build_Elementary_Put_Image_Call (N : Node_Id) return Node_Id; + -- Builds a Put_Image call for an elementary type. + + function Build_String_Put_Image_Call (N : Node_Id) return Node_Id; + -- Builds a Put_Image call for a standard string type. + + function Build_Protected_Put_Image_Call (N : Node_Id) return Node_Id; + -- Builds a Put_Image call for a protected type. + + function Build_Task_Put_Image_Call (N : Node_Id) return Node_Id; + -- Builds a Put_Image call for a task type. + + -- The following routines build the Put_Image procedure for composite + -- types. Typ is the base type to which the procedure applies (i.e. the + -- base type of the Put_Image attribute prefix). The returned results are + -- the declaration and name (entity) of the procedure. + + procedure Build_Array_Put_Image_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Nod provides the Sloc value for the generated code + + procedure Build_Record_Put_Image_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Loc is the location of the subprogram declaration + + function Build_Unknown_Put_Image_Call (N : Node_Id) return Node_Id; + -- Build a call to Put_Image_Unknown + +end Exp_Put_Image; diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 045305b..5d73498 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -297,7 +297,7 @@ package body Exp_Strm is Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output)); - Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False); + Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False); end Build_Array_Output_Procedure; -------------------------------- @@ -420,7 +420,7 @@ package body Exp_Strm is end loop; Build_Stream_Procedure - (Loc, Typ, Decl, Pnam, New_List (Stm), Nam = Name_Read); + (Loc, Typ, Decl, Pnam, New_List (Stm), Outp => Nam = Name_Read); end Build_Array_Read_Write_Procedure; --------------------------------- @@ -1320,7 +1320,7 @@ package body Exp_Strm is Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output); - Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False); + Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False); end Build_Record_Or_Elementary_Output_Procedure; --------------------------------- @@ -1585,7 +1585,7 @@ package body Exp_Strm is end if; Build_Stream_Procedure - (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read); + (Loc, Typ, Decl, Pnam, Stms, Outp => Nam = Name_Read); end Build_Record_Read_Write_Procedure; ---------------------------------- diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads index e1133d7..37b0418 100644 --- a/gcc/ada/exp_tss.ads +++ b/gcc/ada/exp_tss.ads @@ -94,6 +94,7 @@ package Exp_Tss is TSS_Stream_Output : constant TNT := "SO"; -- Stream Output attribute TSS_Stream_Read : constant TNT := "SR"; -- Stream Read attribute TSS_Stream_Write : constant TNT := "SW"; -- Stream Write attribute + TSS_Put_Image : constant TNT := "PI"; -- Put_Image attribute TSS_To_Any : constant TNT := "TA"; -- PolyORB/DSA To_Any TSS_TypeCode : constant TNT := "TC"; -- PolyORB/DSA TypeCode @@ -116,6 +117,7 @@ package Exp_Tss is TSS_Stream_Output, TSS_Stream_Read, TSS_Stream_Write, + TSS_Put_Image, TSS_To_Any, TSS_TypeCode); diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 12a0c58..7d2ea52 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -302,6 +302,7 @@ GNAT_ADA_OBJS = \ ada/exp_intr.o \ ada/exp_pakd.o \ ada/exp_prag.o \ + ada/exp_put_image.o \ ada/exp_sel.o \ ada/exp_smem.o \ ada/exp_strm.o \ diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index e64a496..70c0b0b 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -620,14 +620,21 @@ package body Impunit is -- The following units should be used only in Ada 202X mode Non_Imp_File_Names_2X : constant File_List := ( - ("a-stteou", T), -- Ada.Strings.Text_Output ("a-nubinu", T), -- Ada.Numerics.Big_Numbers ("a-nbnbin", T), -- Ada.Numerics.Big_Numbers.Big_Integers ("a-nbnbre", T), -- Ada.Numerics.Big_Numbers.Big_Reals ("s-aotase", T), -- System.Atomic_Operations.Test_And_Set ("s-atoope", T), -- System.Atomic_Operations ("s-atopar", T), -- System.Atomic_Operations.Arithmetic - ("s-atopex", T)); -- System.Atomic_Operations.Exchange + ("s-atopex", T), -- System.Atomic_Operations.Exchange + ("a-stteou", T), -- Ada.Strings.Text_Output + ("a-stouut", T), -- Ada.Strings.Text_Output.Utils + ("a-stoubu", T), -- Ada.Strings.Text_Output.Buffers + ("a-stoufi", T), -- Ada.Strings.Text_Output.Files + ("a-stobfi", T), -- Ada.Strings.Text_Output.Basic_Files + ("a-stobbu", T), -- Ada.Strings.Text_Output.Bit_Buckets + ("a-stoufo", T) -- Ada.Strings.Text_Output.Formatting + ); ----------------------- -- Alternative Units -- diff --git a/gcc/ada/libgnat/a-stobbu.adb b/gcc/ada/libgnat/a-stobbu.adb new file mode 100644 index 0000000..64f2b6d --- /dev/null +++ b/gcc/ada/libgnat/a-stobbu.adb @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BIT_BUCKETS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +package body Ada.Strings.Text_Output.Bit_Buckets is + + type Bit_Bucket_Type is new Sink with null record; + overriding procedure Full_Method (S : in out Bit_Bucket_Type); + overriding procedure Flush_Method (S : in out Bit_Bucket_Type); + + The_Bit_Bucket : aliased Bit_Bucket_Type + (Chunk_Length => Default_Chunk_Length); + function Bit_Bucket return Sink_Access is (The_Bit_Bucket'Access); + + overriding procedure Full_Method (S : in out Bit_Bucket_Type) + renames Flush_Method; + + overriding procedure Flush_Method (S : in out Bit_Bucket_Type) is + begin + S.Last := 0; + end Flush_Method; + +begin + The_Bit_Bucket.Indent_Amount := 0; + The_Bit_Bucket.Cur_Chunk := The_Bit_Bucket.Initial_Chunk'Access; +end Ada.Strings.Text_Output.Bit_Buckets; diff --git a/gcc/ada/libgnat/a-stobbu.ads b/gcc/ada/libgnat/a-stobbu.ads new file mode 100644 index 0000000..d2b1011 --- /dev/null +++ b/gcc/ada/libgnat/a-stobbu.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BIT_BUCKETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +package Ada.Strings.Text_Output.Bit_Buckets is + function Bit_Bucket return Sink_Access; +end Ada.Strings.Text_Output.Bit_Buckets; diff --git a/gcc/ada/libgnat/a-stobfi.adb b/gcc/ada/libgnat/a-stobfi.adb new file mode 100644 index 0000000..91edf3f --- /dev/null +++ b/gcc/ada/libgnat/a-stobfi.adb @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BASIC_FILES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils; +package body Ada.Strings.Text_Output.Basic_Files is + use type OS.File_Descriptor; + + function Create_From_FD + (FD : OS.File_Descriptor; + Indent_Amount : Natural; + Chunk_Length : Positive) return File; + -- Create a file from an OS file descriptor + + function Create_From_FD + (FD : OS.File_Descriptor; + Indent_Amount : Natural; + Chunk_Length : Positive) return File + is + begin + if FD = OS.Invalid_FD then + raise Program_Error with OS.Errno_Message; + end if; + return Result : File (Chunk_Length) do + Result.Indent_Amount := Indent_Amount; + Result.Cur_Chunk := Result.Initial_Chunk'Unchecked_Access; + Result.FD := FD; + end return; + end Create_From_FD; + + function Create_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File + is + begin + return Create_From_FD + (OS.Create_File (Name, Fmode => OS.Text), + Indent_Amount, Chunk_Length); + end Create_File; + + function Create_New_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File + is + begin + return Create_From_FD + (OS.Create_New_File (Name, Fmode => OS.Text), + Indent_Amount, Chunk_Length); + end Create_New_File; + + procedure Close (S : in out File'Class) is + Status : Boolean; + begin + Flush (S); + + if S.FD not in OS.Standout | OS.Standerr then -- Don't close these + OS.Close (S.FD, Status); + if not Status then + raise Program_Error with OS.Errno_Message; + end if; + end if; + end Close; + + overriding procedure Full_Method (S : in out File) renames Flush_Method; + + overriding procedure Flush_Method (S : in out File) is + pragma Assert (S.Cur_Chunk = S.Initial_Chunk'Unchecked_Access); + Res : constant Integer := + OS.Write (S.FD, S.Cur_Chunk.Chars'Address, S.Last); + begin + if Res /= S.Last then + raise Program_Error with OS.Errno_Message; + end if; + S.Last := 0; + end Flush_Method; + + The_Stdout : aliased File := + Create_From_FD (OS.Standout, + Indent_Amount => Default_Indent_Amount, + Chunk_Length => Default_Chunk_Length); + The_Stderr : aliased File := + Create_From_FD (OS.Standerr, + Indent_Amount => Default_Indent_Amount, + Chunk_Length => Default_Chunk_Length); + + function Standard_Output return Sink_Access is (The_Stdout'Access); + function Standard_Error return Sink_Access is (The_Stderr'Access); + +end Ada.Strings.Text_Output.Basic_Files; diff --git a/gcc/ada/libgnat/a-stobfi.ads b/gcc/ada/libgnat/a-stobfi.ads new file mode 100644 index 0000000..a2892f0 --- /dev/null +++ b/gcc/ada/libgnat/a-stobfi.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BASIC_FILES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +private with GNAT.OS_Lib; +package Ada.Strings.Text_Output.Basic_Files is + -- Normally, you should use Ada.Strings.Text_Output.Files, which + -- automatically Closes files via finalization. If you don't want to use + -- finalization, use this package instead. You must then Close the file by + -- hand. The semantics is otherwise the same as Files. + + function Standard_Output return Sink_Access; + function Standard_Error return Sink_Access; + + type File (<>) is new Sink with private; + + function Create_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File; + function Create_New_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File; + + procedure Close (S : in out File'Class); + +private + + package OS renames GNAT.OS_Lib; + + type File is new Sink with record + FD : OS.File_Descriptor := OS.Invalid_FD; + end record; + + overriding procedure Full_Method (S : in out File); + overriding procedure Flush_Method (S : in out File); + +end Ada.Strings.Text_Output.Basic_Files; diff --git a/gcc/ada/libgnat/a-stoubu.adb b/gcc/ada/libgnat/a-stoubu.adb new file mode 100644 index 0000000..f563ea5 --- /dev/null +++ b/gcc/ada/libgnat/a-stoubu.adb @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BUFFERS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +with Unchecked_Deallocation; +with Ada.Strings.UTF_Encoding.Strings; +with Ada.Strings.UTF_Encoding.Wide_Strings; +with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; +package body Ada.Strings.Text_Output.Buffers is + + function New_Buffer + (Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return Buffer + is + begin + return Result : Buffer (Chunk_Length) do + Result.Indent_Amount := Indent_Amount; + Result.Cur_Chunk := Result.Initial_Chunk'Unchecked_Access; + end return; + end New_Buffer; + + procedure Destroy (S : in out Buffer) is + procedure Free is new Unchecked_Deallocation (Chunk, Chunk_Access); + Cur : Chunk_Access := S.Initial_Chunk.Next; + begin + while Cur /= null loop + declare + Temp : constant Chunk_Access := Cur.Next; + begin + Free (Cur); + Cur := Temp; + end; + end loop; + + S.Cur_Chunk := null; + end Destroy; + + overriding procedure Full_Method (S : in out Buffer) is + begin + pragma Assert (S.Cur_Chunk.Next = null); + pragma Assert (S.Last = S.Cur_Chunk.Chars'Length); + S.Cur_Chunk.Next := new Chunk (S.Chunk_Length); + S.Cur_Chunk := S.Cur_Chunk.Next; + S.Num_Extra_Chunks := @ + 1; + S.Last := 0; + end Full_Method; + + function UTF_8_Length (S : Buffer'Class) return Natural is + begin + return S.Num_Extra_Chunks * S.Chunk_Length + S.Last; + end UTF_8_Length; + + procedure Get_UTF_8 + (S : Buffer'Class; Result : out UTF_8_Lines) + is + Cur : access constant Chunk := S.Initial_Chunk'Access; + First : Positive := 1; + begin + loop + if Cur.Next = null then + pragma Assert (Result'Last = First + S.Last - 1); + Result (First .. Result'Last) := Cur.Chars (1 .. S.Last); + exit; + end if; + + pragma Assert (S.Chunk_Length = Cur.Chars'Length); + Result (First .. First + S.Chunk_Length - 1) := Cur.Chars; + First := First + S.Chunk_Length; + Cur := Cur.Next; + end loop; + end Get_UTF_8; + + function Get_UTF_8 (S : Buffer'Class) return UTF_8_Lines is + begin + return Result : String (1 .. UTF_8_Length (S)) do + Get_UTF_8 (S, Result); + end return; + end Get_UTF_8; + + function Get (S : Buffer'Class) return String is + begin + -- If all characters are 7 bits, we don't need to decode; + -- this is an optimization. + + -- Otherwise, if all are 8 bits, we need to decode to get Latin-1. + -- Otherwise, the result is implementation defined, so we return a + -- String encoded as UTF-8. (Note that the AI says "if any character + -- in the sequence is not defined in Character, the result is + -- implementation-defined", so we are not obliged to decode ANY + -- Latin-1 characters if ANY character is bigger than 8 bits. + + if S.All_7_Bits then + return Get_UTF_8 (S); + elsif S.All_8_Bits then + return UTF_Encoding.Strings.Decode (Get_UTF_8 (S)); + else + return Get_UTF_8 (S); + end if; + end Get; + + function Wide_Get (S : Buffer'Class) return Wide_String is + begin + return UTF_Encoding.Wide_Strings.Decode (Get_UTF_8 (S)); + end Wide_Get; + + function Wide_Wide_Get (S : Buffer'Class) return Wide_Wide_String is + begin + return UTF_Encoding.Wide_Wide_Strings.Decode (Get_UTF_8 (S)); + end Wide_Wide_Get; + +end Ada.Strings.Text_Output.Buffers; diff --git a/gcc/ada/libgnat/a-stoubu.ads b/gcc/ada/libgnat/a-stoubu.ads new file mode 100644 index 0000000..519e473 --- /dev/null +++ b/gcc/ada/libgnat/a-stoubu.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.BUFFERS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +package Ada.Strings.Text_Output.Buffers is + + type Buffer (<>) is new Sink with private; + + function New_Buffer + (Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return Buffer; + + procedure Destroy (S : in out Buffer); + -- Reclaim any heap-allocated data, and render the Buffer unusable. + -- It would make sense to do this via finalization, but we wish to + -- avoid controlled types in the generated code for 'Image. + + function Get_UTF_8 (S : Buffer'Class) return UTF_8_Lines; + -- Get the characters in S, encoded as UTF-8. + + function UTF_8_Length (S : Buffer'Class) return Natural; + procedure Get_UTF_8 + (S : Buffer'Class; Result : out UTF_8_Lines) with + Pre => Result'First = 1 and Result'Last = UTF_8_Length (S); + -- This is a procedure version of the Get_UTF_8 function, for + -- efficiency. The Result String must be the exact right length. + + function Get (S : Buffer'Class) return String; + function Wide_Get (S : Buffer'Class) return Wide_String; + function Wide_Wide_Get (S : Buffer'Class) return Wide_Wide_String; + -- Get the characters in S, decoded as [[Wide_]Wide_]String. + -- There is no need for procedure versions of these, because + -- they are intended primarily to implement the [[Wide_]Wide_]Image + -- attribute, which is already a function. + +private + type Chunk_Count is new Natural; + type Buffer is new Sink with record + Num_Extra_Chunks : Natural := 0; + -- Number of chunks in the linked list, not including Initial_Chunk. + end record; + + overriding procedure Full_Method (S : in out Buffer); + overriding procedure Flush_Method (S : in out Buffer) is null; + +end Ada.Strings.Text_Output.Buffers; diff --git a/gcc/ada/libgnat/a-stoufi.adb b/gcc/ada/libgnat/a-stoufi.adb new file mode 100644 index 0000000..90c03da --- /dev/null +++ b/gcc/ada/libgnat/a-stoufi.adb @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.FILES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils; +package body Ada.Strings.Text_Output.Files is + use type OS.File_Descriptor; + + function Create_From_FD + (FD : OS.File_Descriptor; + Indent_Amount : Natural; + Chunk_Length : Positive) return File; + -- Create a file from an OS file descriptor + + function Create_From_FD + (FD : OS.File_Descriptor; + Indent_Amount : Natural; + Chunk_Length : Positive) return File + is + begin + if FD = OS.Invalid_FD then + raise Program_Error with OS.Errno_Message; + end if; + return Result : File (Chunk_Length) do + Result.Indent_Amount := Indent_Amount; + Result.Cur_Chunk := Result.Initial_Chunk'Unchecked_Access; + Result.FD := FD; + end return; + end Create_From_FD; + + function Create_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File + is + begin + return Create_From_FD + (OS.Create_File (Name, Fmode => OS.Text), + Indent_Amount, Chunk_Length); + end Create_File; + + function Create_New_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File + is + begin + return Create_From_FD + (OS.Create_New_File (Name, Fmode => OS.Text), + Indent_Amount, Chunk_Length); + end Create_New_File; + + overriding procedure Finalize (Ref : in out Self_Ref) is + begin + Close (Ref.Self.all); + end Finalize; + + procedure Close (S : in out File'Class) is + Status : Boolean; + begin + Flush (S); + + if S.FD not in OS.Standout | OS.Standerr then -- Don't close these + OS.Close (S.FD, Status); + if not Status then + raise Program_Error with OS.Errno_Message; + end if; + end if; + end Close; + + overriding procedure Full_Method (S : in out File) renames Flush_Method; + + overriding procedure Flush_Method (S : in out File) is + pragma Assert (S.Cur_Chunk = S.Initial_Chunk'Unchecked_Access); + Res : constant Integer := + OS.Write (S.FD, S.Cur_Chunk.Chars'Address, S.Last); + begin + if Res /= S.Last then + raise Program_Error with OS.Errno_Message; + end if; + S.Last := 0; + end Flush_Method; + + The_Stdout : aliased File := + Create_From_FD (OS.Standout, + Indent_Amount => Default_Indent_Amount, + Chunk_Length => Default_Chunk_Length); + The_Stderr : aliased File := + Create_From_FD (OS.Standerr, + Indent_Amount => Default_Indent_Amount, + Chunk_Length => Default_Chunk_Length); + + function Standard_Output return Sink_Access is (The_Stdout'Access); + function Standard_Error return Sink_Access is (The_Stderr'Access); + +end Ada.Strings.Text_Output.Files; diff --git a/gcc/ada/libgnat/a-stoufi.ads b/gcc/ada/libgnat/a-stoufi.ads new file mode 100644 index 0000000..a94124b --- /dev/null +++ b/gcc/ada/libgnat/a-stoufi.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.FILES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +private with GNAT.OS_Lib; +private with Ada.Finalization; +package Ada.Strings.Text_Output.Files is + -- This package supports a Sink type that sends output to a file. The file + -- is automatically closed when finalized. + + function Standard_Output return Sink_Access; + function Standard_Error return Sink_Access; + + type File (<>) is new Sink with private; + + function Create_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File; + function Create_New_File + (Name : String; + Indent_Amount : Natural := Default_Indent_Amount; + Chunk_Length : Positive := Default_Chunk_Length) return File; + -- Create a file. Create_New_File raises an exception if the file already + -- exists; Create_File overwrites. + + procedure Close (S : in out File'Class); + +private + + package OS renames GNAT.OS_Lib; + + type Self_Ref (Self : access File) is new Finalization.Limited_Controlled + with null record; + overriding procedure Finalize (Ref : in out Self_Ref); + + type File is new Sink with record + FD : OS.File_Descriptor := OS.Invalid_FD; + Ref : Self_Ref (File'Access); + end record; + + overriding procedure Full_Method (S : in out File); + overriding procedure Flush_Method (S : in out File); + +end Ada.Strings.Text_Output.Files; diff --git a/gcc/ada/libgnat/a-stoufo.adb b/gcc/ada/libgnat/a-stoufo.adb new file mode 100644 index 0000000..0cbcd56 --- /dev/null +++ b/gcc/ada/libgnat/a-stoufo.adb @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.FORMATTING -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +with Ada.Strings.Text_Output.Files; +with Ada.Strings.Text_Output.Buffers; use Ada.Strings.Text_Output.Buffers; +with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils; +package body Ada.Strings.Text_Output.Formatting is + + procedure Put + (S : in out Sink'Class; T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := "") + is + J : Positive := T'First; + Used : array (1 .. 6) of Boolean := (others => False); + begin + while J <= T'Last loop + if T (J) = '\' then + J := J + 1; + case T (J) is + when 'n' => + New_Line (S); + when '\' => + Put_7bit (S, '\'); + when 'i' => + Indent (S); + when 'o' => + Outdent (S); + when 'I' => + Indent (S, 1); + when 'O' => + Outdent (S, 1); + + when '1' => + Used (1) := True; + Put_UTF_8 (S, X1); + when '2' => + Used (2) := True; + Put_UTF_8 (S, X2); + when '3' => + Used (3) := True; + Put_UTF_8 (S, X3); + when '4' => + Used (4) := True; + Put_UTF_8 (S, X4); + when '5' => + Used (5) := True; + Put_UTF_8 (S, X5); + when '6' => + Used (6) := True; + Put_UTF_8 (S, X6); + + when others => + raise Program_Error; + end case; + else + Put_7bit (S, T (J)); + end if; + + J := J + 1; + end loop; + + if not Used (1) then + pragma Assert (X1 = ""); + end if; + if not Used (2) then + pragma Assert (X2 = ""); + end if; + if not Used (3) then + pragma Assert (X3 = ""); + end if; + if not Used (4) then + pragma Assert (X4 = ""); + end if; + if not Used (5) then + pragma Assert (X5 = ""); + end if; + if not Used (6) then + pragma Assert (X6 = ""); + end if; + + Flush (S); + end Put; + + procedure Put + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := "") is + begin + Put (Files.Standard_Output.all, T, X1, X2, X3, X4, X5, X6); + end Put; + + procedure Err + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := "") is + begin + Put (Files.Standard_Error.all, T, X1, X2, X3, X4, X5, X6); + end Err; + + function Format + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := "") + return UTF_8_Lines + is + Buf : Buffer := New_Buffer; + begin + Put (Buf, T, X1, X2, X3, X4, X5, X6); + return Get_UTF_8 (Buf); + end Format; + +end Ada.Strings.Text_Output.Formatting; diff --git a/gcc/ada/libgnat/a-stoufo.ads b/gcc/ada/libgnat/a-stoufo.ads new file mode 100644 index 0000000..3636ae6 --- /dev/null +++ b/gcc/ada/libgnat/a-stoufo.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.FORMATTING -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +package Ada.Strings.Text_Output.Formatting is + + -- Template-based output, based loosely on C's printf family. Unlike + -- printf, it is type safe. We don't support myriad formatting options; the + -- caller is expected to call 'Image, or other functions that might have + -- various formatting capabilities. + -- + -- Each of the following calls Flush + + type Template is new UTF_8; + procedure Put + (S : in out Sink'Class; T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := ""); + -- Prints the template as is, except for the following escape sequences: + -- "\n" is end of line. + -- "\i" indents by the default amount, and "\o" outdents. + -- "\I" indents by one space, and "\O" outdents. + -- "\1" is replaced with X1, and similarly for 2, 3, .... + -- "\\" is "\". + + -- Note that the template is not type UTF_8, to avoid this sort of thing: + -- + -- https://xkcd.com/327/ + + procedure Put + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := ""); + -- Sends to standard output + + procedure Err + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := ""); + -- Sends to standard error + + function Format + (T : Template; + X1, X2, X3, X4, X5, X6 : UTF_8 := "") + return UTF_8_Lines; + -- Returns a UTF-8-encoded String + +end Ada.Strings.Text_Output.Formatting; diff --git a/gcc/ada/libgnat/a-stouut.adb b/gcc/ada/libgnat/a-stouut.adb new file mode 100644 index 0000000..9d5d163 --- /dev/null +++ b/gcc/ada/libgnat/a-stouut.adb @@ -0,0 +1,261 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.UTILS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; +package body Ada.Strings.Text_Output.Utils is + + procedure Put_Octet (S : in out Sink'Class; Item : Character) with Inline; + -- Send a single octet to the current Chunk + + procedure Adjust_Column (S : in out Sink'Class) with Inline; + -- Adjust the column for a non-NL character. + + procedure Full (S : in out Sink'Class) is + begin + pragma Assert (S.Last = S.Chunk_Length); + Full_Method (S); + pragma Assert (S.Last = 0); + end Full; + + procedure Flush (S : in out Sink'Class) is + begin + Flush_Method (S); + end Flush; + + procedure Put_Octet (S : in out Sink'Class; Item : Character) is + begin + S.Last := @ + 1; + S.Cur_Chunk.Chars (S.Last) := Item; + pragma Assert (S.Chunk_Length = S.Cur_Chunk.Chars'Length); + if S.Last = S.Chunk_Length then + Full (S); + end if; + end Put_Octet; + + procedure Adjust_Column (S : in out Sink'Class) is + begin + -- If we're in the first column, indent. This is handled here, rather + -- than when we see NL, because we don't want spaces in a blank line. + -- The character we're about to put is not NL; NL is handled in + -- New_Line. So after indenting, we simply increment the Column. + + if S.Column = 1 then + Tab_To_Column (S, S.Indentation + 1); + end if; + S.Column := @ + 1; + end Adjust_Column; + + procedure Put_7bit (S : in out Sink'Class; Item : Character_7) is + begin + Adjust_Column (S); + Put_Octet (S, Item); + end Put_7bit; + + procedure Put_7bit_NL (S : in out Sink'Class; Item : Character_7) is + begin + if Item = NL then + New_Line (S); + else + Put_7bit (S, Item); + end if; + end Put_7bit_NL; + + procedure Put_Character (S : in out Sink'Class; Item : Character) is + begin + if Character'Pos (Item) < 2**7 then + Put_7bit_NL (S, Item); + else + Put_Wide_Wide_Character (S, To_Wide_Wide (Item)); + end if; + end Put_Character; + + procedure Put_Wide_Character + (S : in out Sink'Class; Item : Wide_Character) is + begin + if Wide_Character'Pos (Item) < 2**7 then + Put_7bit_NL (S, From_Wide (Item)); + else + Put_Wide_Wide_Character (S, To_Wide_Wide (Item)); + end if; + end Put_Wide_Character; + + procedure Put_Wide_Wide_Character + (S : in out Sink'Class; Item : Wide_Wide_Character) is + begin + if Wide_Wide_Character'Pos (Item) < 2**7 then + Put_7bit_NL (S, From_Wide_Wide (Item)); + else + S.All_7_Bits := False; + if Wide_Wide_Character'Pos (Item) >= 2**8 then + S.All_8_Bits := False; + end if; + declare + Temp : constant UTF_8_Lines := + UTF_Encoding.Wide_Wide_Strings.Encode ((1 => Item)); + begin + for X of Temp loop + pragma Assert (X /= NL); + Adjust_Column (S); + Put_Octet (S, X); + end loop; + end; + end if; + end Put_Wide_Wide_Character; + + procedure Put_UTF_8 (S : in out Sink'Class; Item : UTF_8) is + begin + Adjust_Column (S); + + if S.Last + Item'Length < S.Chunk_Length then + -- Item fits in current chunk + + S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item; + S.Last := S.Last + Item'Length; + elsif S.Last + Item'Length = S.Chunk_Length then + -- Item fits exactly in current chunk + + S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item; + S.Last := S.Last + Item'Length; + Full (S); + -- ???Seems like maybe we shouldn't call Full until we have MORE + -- characters. But then we can't pass Chunk_Length => 1 to + -- Create_File to get unbuffered output. + else + -- We get here only if Item doesn't fit in the current chunk, which + -- should be fairly rare. We split Item into Left and Right, where + -- Left exactly fills the current chunk, and recurse on Left and + -- Right. Right will fit into the next chunk unless it's very long, + -- so another level of recursion will be extremely rare. + + declare + Left_Length : constant Natural := S.Chunk_Length - S.Last; + Right_First : constant Natural := Item'First + Left_Length; + Left : UTF_8 renames Item (Item'First .. Right_First - 1); + Right : UTF_8 renames Item (Right_First .. Item'Last); + pragma Assert (Left & Right = Item); + begin + Put_UTF_8 (S, Left); -- This will call Full. + Put_UTF_8 (S, Right); -- This might call Full, but probably not. + end; + end if; + end Put_UTF_8; + + procedure Put_UTF_8_Lines (S : in out Sink'Class; Item : UTF_8_Lines) is + Line_Start, Index : Integer := Item'First; + -- Needs to be Integer, because Item'First might be negative for empty + -- Items. + begin + while Index <= Item'Last loop + if Item (Index) = NL then + if Index > Line_Start then + Put_UTF_8 (S, Item (Line_Start .. Index - 1)); + end if; + New_Line (S); + S.Column := 1; + Line_Start := Index + 1; + end if; + + Index := @ + 1; + end loop; + + if Index > Line_Start then + Put_UTF_8 (S, Item (Line_Start .. Index - 1)); + end if; + end Put_UTF_8_Lines; + + procedure Put_String (S : in out Sink'Class; Item : String) is + begin + for X of Item loop + Put_Character (S, X); + end loop; + end Put_String; + + procedure Put_Wide_String (S : in out Sink'Class; Item : Wide_String) is + begin + for X of Item loop + Put_Wide_Character (S, X); + end loop; + end Put_Wide_String; + + procedure Put_Wide_Wide_String + (S : in out Sink'Class; Item : Wide_Wide_String) is + begin + for X of Item loop + Put_Wide_Wide_Character (S, X); + end loop; + end Put_Wide_Wide_String; + + procedure New_Line (S : in out Sink'Class) is + begin + S.Column := 1; + Put_Octet (S, NL); + end New_Line; + + function Column (S : Sink'Class) return Positive is (S.Column); + + procedure Tab_To_Column (S : in out Sink'Class; Column : Positive) is + begin + if S.Column < Column then + for X in 1 .. Column - S.Column loop + Put_Octet (S, ' '); + end loop; + S.Column := Column; + end if; + end Tab_To_Column; + + procedure Set_Indentation (S : in out Sink'Class; Amount : Natural) is + begin + S.Indentation := Amount; + end Set_Indentation; + + function Indentation (S : Sink'Class) return Natural is (S.Indentation); + + procedure Indent + (S : in out Sink'Class; Amount : Optional_Indentation := Default) + is + By : constant Natural := + (if Amount = Default then S.Indent_Amount else Amount); + begin + Set_Indentation (S, Indentation (S) + By); + end Indent; + + procedure Outdent + (S : in out Sink'Class; Amount : Optional_Indentation := Default) + is + By : constant Natural := + (if Amount = Default then S.Indent_Amount else Amount); + begin + Set_Indentation (S, Indentation (S) - By); + end Outdent; + +end Ada.Strings.Text_Output.Utils; diff --git a/gcc/ada/libgnat/a-stouut.ads b/gcc/ada/libgnat/a-stouut.ads new file mode 100644 index 0000000..c02885e --- /dev/null +++ b/gcc/ada/libgnat/a-stouut.ads @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT.UTILS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +package Ada.Strings.Text_Output.Utils is + + -- This package provides utility functions on Sink'Class. These are + -- intended for use by Put_Image attributes, both the default versions + -- generated by the compiler, and user-defined ones. + + procedure Full (S : in out Sink'Class) with Inline; + -- Must be called when the current chunk is full. Dispatches to + -- Full_Method. + + procedure Flush (S : in out Sink'Class) with Inline; + -- Dispatches to Flush_Method + + -- Full_Method and Flush_Method should be called only via Full and Flush + + procedure Put_Character (S : in out Sink'Class; Item : Character); + procedure Put_Wide_Character (S : in out Sink'Class; Item : Wide_Character); + procedure Put_Wide_Wide_Character + (S : in out Sink'Class; Item : Wide_Wide_Character); + procedure Put_String (S : in out Sink'Class; Item : String); + procedure Put_Wide_String (S : in out Sink'Class; Item : Wide_String); + procedure Put_Wide_Wide_String + (S : in out Sink'Class; Item : Wide_Wide_String); + -- Encode characters or strings as UTF-8, and send them to S. + + subtype Character_7 is + Character range Character'Val (0) .. Character'Val (2**7 - 1); + -- 7-bit character. These are the same in both Latin-1 and UTF-8. + + procedure Put_7bit (S : in out Sink'Class; Item : Character_7) + with Inline, Pre => Item /= NL; + procedure Put_7bit_NL (S : in out Sink'Class; Item : Character_7) + with Inline; + -- Put a 7-bit character, and adjust the Column. For Put_7bit_NL, Item can + -- be NL. + + procedure Put_UTF_8 (S : in out Sink'Class; Item : UTF_8) with Inline; + procedure Put_UTF_8_Lines (S : in out Sink'Class; Item : UTF_8_Lines); + -- Send data that is already UTF-8 encoded (including 7-bit ASCII) to + -- S. These are more efficient than Put_String. + + procedure New_Line (S : in out Sink'Class) with Inline; + -- Puts the new-line character. + + function Column (S : Sink'Class) return Positive with Inline; + -- Current output column. The Column is initially 1, and is incremented for + -- each 7-bit character output, except for the new-line character, which + -- sets Column back to 1. The next character to be output will go in this + -- column. + + procedure Tab_To_Column (S : in out Sink'Class; Column : Positive); + -- Put spaces until we're at or past Column. + + procedure Set_Indentation (S : in out Sink'Class; Amount : Natural) + with Inline; + function Indentation (S : Sink'Class) return Natural with Inline; + -- Indentation is initially 0. Set_Indentation sets it, and Indentation + -- returns it. This number of space characters are put at the start of + -- each nonempty line. + + subtype Optional_Indentation is Integer range -1 .. Natural'Last; + Default : constant Optional_Indentation := -1; + + procedure Indent + (S : in out Sink'Class; Amount : Optional_Indentation := Default) + with Inline; + procedure Outdent + (S : in out Sink'Class; Amount : Optional_Indentation := Default) + with Inline; + -- Increase/decrease Indentation by Amount. If Amount = Default, the amount + -- specified by the Indent_Amount parameter of the sink creation function + -- is used. The sink creation functions are New_Buffer, Create_File, and + -- Create_New_File. + +end Ada.Strings.Text_Output.Utils; diff --git a/gcc/ada/libgnat/a-stteou.ads b/gcc/ada/libgnat/a-stteou.ads new file mode 100644 index 0000000..1240f4a --- /dev/null +++ b/gcc/ada/libgnat/a-stteou.ads @@ -0,0 +1,192 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.TEXT_OUTPUT -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +with Ada.Strings.UTF_Encoding; +with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; +package Ada.Strings.Text_Output is + + -- This package provides a "Sink" abstraction, to which characters of type + -- Character, Wide_Character, and Wide_Wide_Character can be sent. This + -- type is used by the Put_Image attribute. In particular, T'Put_Image has + -- the following parameter types: + -- + -- procedure T'Put_Image (S : in out Sink'Class; V : T); + -- + -- The default generated code for Put_Image of a composite type will + -- typically call Put_Image on the components. + -- + -- This is not a fully general abstraction that can be arbitrarily + -- extended. It is designed with particular extensions in mind, and these + -- extensions are declared in child packages of this package, because they + -- depend on implementation details in the private part of this + -- package. The primary extensions of Sink are: + -- + -- Buffer. The characters sent to a Buffer are stored in memory, and can + -- be retrieved via Get functions. This is intended for the + -- implementation of the 'Image attribute. The compiler will generate a + -- T'Image function that declares a local Buffer, sends characters to + -- it, and then returns a call to Get, Destroying the Buffer on return. + -- + -- function T'Image (V : T) return String is + -- Buf : Buffer := New_Buffer (...); + -- begin + -- T'Put_Image (Buf, V); + -- return Result : constant String := Get (Buf) do + -- Destroy (Buf); + -- end return; + -- end T'Image; + -- ????Perhaps Buffer should be controlled; if you don't like + -- controlled types, call Put_Image directly. + -- + -- File. The characters are sent to a file, possibly opened by file + -- name, or possibly standard output or standard error. 'Put_Image + -- can be called directly on a File, thus avoiding any heap allocation. + + type Sink (<>) is abstract tagged limited private; + type Sink_Access is access all Sink'Class with Storage_Size => 0; + -- Sink is a character sink; you can send characters to a Sink. + -- UTF-8 encoding is used. + + procedure Full_Method (S : in out Sink) is abstract; + procedure Flush_Method (S : in out Sink) is abstract; + -- There is an internal buffer to store the characters. Full_Method is + -- called when the buffer is full, and Flush_Method may be called to flush + -- the buffer. For Buffer, Full_Method allocates more space for more + -- characters, and Flush_Method does nothing. For File, Full_Method and + -- Flush_Method do the same thing: write the characters to the file, and + -- empty the internal buffer. + -- + -- These are the only dispatching subprograms on Sink. This is for + -- efficiency; we don't dispatch on every write to the Sink, but only when + -- the internal buffer is full (or upon client request). + -- + -- Full_Method and Flush_Method must make the current chunk empty. + -- + -- Additional operations operating on Sink'Class are declared in the Utils + -- child, including Full and Flush, which call the above. + + function To_Wide (C : Character) return Wide_Character is + (Wide_Character'Val (Character'Pos (C))); + function To_Wide_Wide (C : Character) return Wide_Wide_Character is + (Wide_Wide_Character'Val (Character'Pos (C))); + function To_Wide_Wide (C : Wide_Character) return Wide_Wide_Character is + (Wide_Wide_Character'Val (Wide_Character'Pos (C))); + -- Conversions [Wide_]Character --> [Wide_]Wide_Character. + -- These cannot fail. + + function From_Wide (C : Wide_Character) return Character is + (Character'Val (Wide_Character'Pos (C))); + function From_Wide_Wide (C : Wide_Wide_Character) return Character is + (Character'Val (Wide_Wide_Character'Pos (C))); + function From_Wide_Wide (C : Wide_Wide_Character) return Wide_Character is + (Wide_Character'Val (Wide_Wide_Character'Pos (C))); + -- Conversions [Wide_]Wide_Character --> [Wide_]Character. + -- These fail if the character is out of range. + + function NL return Character is (ASCII.LF) with Inline; + function Wide_NL return Wide_Character is (To_Wide (Character'(NL))) + with Inline; + function Wide_Wide_NL return Wide_Wide_Character is + (To_Wide_Wide (Character'(NL))) with Inline; + -- Character representing new line. There is no support for CR/LF line + -- endings. + + -- We have two subtypes of String that are encoded in UTF-8. UTF_8 cannot + -- contain newline characters; UTF_8_Lines can. Sending UTF_8 data to a + -- Sink is more efficient, because end-of-line processing is not needed. + -- Both of these are more efficient than [[Wide_]Wide_]String, because no + -- encoding is needed. + + subtype UTF_8_Lines is UTF_Encoding.UTF_8_String with + Predicate => + UTF_Encoding.Wide_Wide_Strings.Encode + (UTF_Encoding.Wide_Wide_Strings.Decode (UTF_8_Lines)) = UTF_8_Lines; + + subtype UTF_8 is UTF_8_Lines with + Predicate => (for all C of UTF_8 => C /= NL); + + Default_Indent_Amount : constant Natural := 4; + + Default_Chunk_Length : constant Positive := 500; + -- Experiment shows this value to be reasonably efficient; decreasing it + -- slows things down, but increasing it doesn't gain much. + +private + type String_Access is access all String; + + -- For Buffer, the "internal buffer" mentioned above is implemented as a + -- linked list of chunks. When the current chunk is full, we allocate a new + -- one. For File, there is only one chunk. When it is full, we send the + -- data to the file, and empty it. + + type Chunk; + type Chunk_Access is access all Chunk; + type Chunk (Length : Positive) is limited record + Next : Chunk_Access := null; + Chars : UTF_8_Lines (1 .. Length); + end record; + + type Sink (Chunk_Length : Positive) is abstract tagged limited record + Indent_Amount : Natural; + Column : Positive := 1; + Indentation : Natural := 0; + + All_7_Bits : Boolean := True; + -- For optimization of Text_Output.Buffers.Get (cf). + -- True if all characters seen so far fit in 7 bits. + -- 7-bit characters are represented the same in Character + -- and in UTF-8, so they don't need translation. + + All_8_Bits : Boolean := True; + -- True if all characters seen so far fit in 8 bits. + -- This is needed in Text_Output.Buffers.Get to distinguish + -- the case where all characters are Latin-1 (so it should + -- decode) from the case where some characters are bigger than + -- 8 bits (so the result is implementation defined). + + Cur_Chunk : Chunk_Access; + -- Points to the chunk we are currently sending characters to. + -- We want to say: + -- Cur_Chunk : Chunk_Access := Initial_Chunk'Access; + -- but that's illegal, so we have some horsing around to do. + + Last : Natural := 0; + -- Last-used character in Cur_Chunk.all. + + Initial_Chunk : aliased Chunk (Length => Chunk_Length); + -- For Buffer, this is the first chunk. Subsequent chunks are allocated + -- on the heap. For File, this is the only chunk, and there is no heap + -- allocation. + end record; + +end Ada.Strings.Text_Output; diff --git a/gcc/ada/libgnat/a-tags.ads b/gcc/ada/libgnat/a-tags.ads index cb174be..5c83701 100644 --- a/gcc/ada/libgnat/a-tags.ads +++ b/gcc/ada/libgnat/a-tags.ads @@ -588,7 +588,7 @@ private procedure Unregister_Tag (T : Tag); -- Remove a particular tag from the external tag hash table - Max_Predef_Prims : constant Positive := 15; + Max_Predef_Prims : constant Positive := 16; -- Number of reserved slots for the following predefined ada primitives: -- -- 1. Size @@ -600,12 +600,13 @@ private -- 7. assignment -- 8. deep adjust -- 9. deep finalize - -- 10. async select - -- 11. conditional select - -- 12. prim_op kind - -- 13. task_id - -- 14. dispatching requeue - -- 15. timed select + -- 10. Put_Image + -- 11. async select + -- 12. conditional select + -- 13. prim_op kind + -- 14. task_id + -- 15. dispatching requeue + -- 16. timed select -- -- The compiler checks that the value here is correct diff --git a/gcc/ada/libgnat/s-putaim.adb b/gcc/ada/libgnat/s-putaim.adb new file mode 100644 index 0000000..ed8cfe4 --- /dev/null +++ b/gcc/ada/libgnat/s-putaim.adb @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.PUT_TASK_IMAGES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; +with Unchecked_Conversion; +with Ada.Strings.Text_Output.Utils; +use Ada.Strings.Text_Output; +use Ada.Strings.Text_Output.Utils; + +package body System.Put_Task_Images is + + procedure Put_Image_Protected (S : in out Sink'Class) is + begin + Put_UTF_8 (S, "(protected object)"); + end Put_Image_Protected; + + procedure Put_Image_Task + (S : in out Sink'Class; Id : Ada.Task_Identification.Task_Id) + is + begin + Put_UTF_8 (S, "(task " & Ada.Task_Identification.Image (Id) & ")"); + end Put_Image_Task; + +end System.Put_Task_Images; diff --git a/gcc/ada/libgnat/s-putaim.ads b/gcc/ada/libgnat/s-putaim.ads new file mode 100644 index 0000000..c06b751 --- /dev/null +++ b/gcc/ada/libgnat/s-putaim.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.PUT_TASK_IMAGES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; +with Ada.Strings.Text_Output; +with Ada.Task_Identification; +package System.Put_Task_Images is + + -- This package contains subprograms that are called by the generated code + -- for the 'Put_Image attribute for protected and task types. This is + -- separate from System.Put_Images to avoid dragging the tasking runtimes + -- into nontasking programs. + + subtype Sink is Ada.Strings.Text_Output.Sink; + + procedure Put_Image_Protected (S : in out Sink'Class); + procedure Put_Image_Task + (S : in out Sink'Class; Id : Ada.Task_Identification.Task_Id); + +end System.Put_Task_Images; diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb new file mode 100644 index 0000000..cad693f --- /dev/null +++ b/gcc/ada/libgnat/s-putima.adb @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.PUT_IMAGES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; +with Unchecked_Conversion; +with Ada.Strings.Text_Output.Utils; +use Ada.Strings.Text_Output; +use Ada.Strings.Text_Output.Utils; + +package body System.Put_Images is + + generic + type Integer_Type is range <>; + type Unsigned_Type is mod <>; + Base : Unsigned_Type; + package Generic_Integer_Images is + pragma Assert (Integer_Type'Size = Unsigned_Type'Size); + pragma Assert (Base in 2 .. 36); + procedure Put_Image (S : in out Sink'Class; X : Integer_Type); + procedure Put_Image (S : in out Sink'Class; X : Unsigned_Type); + end Generic_Integer_Images; + + package body Generic_Integer_Images is + + A : constant := Character'Pos ('a'); + Z : constant := Character'Pos ('0'); + subtype Digit is Unsigned_Type range 0 .. Base - 1; + function Digit_To_Character (X : Digit) return Character is + (Character'Val (if X < 10 then X + Z else X + A - 10)); + + procedure Put_Digits (S : in out Sink'Class; X : Unsigned_Type); + -- Put just the digits of X, without any leading minus sign or space. + + procedure Put_Digits (S : in out Sink'Class; X : Unsigned_Type) is + begin + if X >= Base then + Put_Digits (S, X / Base); -- recurse + Put_7bit (S, Digit_To_Character (X mod Base)); + else + Put_7bit (S, Digit_To_Character (X)); + end if; + end Put_Digits; + + procedure Put_Image (S : in out Sink'Class; X : Integer_Type) is + begin + -- Put the space or the minus sign, then pass the absolute value to + -- Put_Digits. + + if X >= 0 then + Put_7bit (S, ' '); + Put_Digits (S, Unsigned_Type (X)); + else + Put_7bit (S, '-'); + Put_Digits (S, -Unsigned_Type'Mod (X)); + -- Convert to Unsigned_Type before negating, to avoid overflow + -- on Integer_Type'First. + end if; + end Put_Image; + + procedure Put_Image (S : in out Sink'Class; X : Unsigned_Type) is + begin + Put_7bit (S, ' '); + Put_Digits (S, X); + end Put_Image; + + end Generic_Integer_Images; + + package Small is new Generic_Integer_Images (Integer, Unsigned, Base => 10); + package Large is new Generic_Integer_Images + (Long_Long_Integer, Long_Long_Unsigned, Base => 10); + + procedure Put_Image_Integer (S : in out Sink'Class; X : Integer) + renames Small.Put_Image; + procedure Put_Image_Long_Long_Integer + (S : in out Sink'Class; X : Long_Long_Integer) + renames Large.Put_Image; + + procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned) + renames Small.Put_Image; + procedure Put_Image_Long_Long_Unsigned + (S : in out Sink'Class; X : Long_Long_Unsigned) + renames Large.Put_Image; + + type Signed_Address is range + -2**(Standard'Address_Size - 1) .. 2**(Standard'Address_Size - 1) - 1; + type Unsigned_Address is mod 2**Standard'Address_Size; + package Hex is new Generic_Integer_Images + (Signed_Address, Unsigned_Address, Base => 16); + + generic + type Designated (<>) is private; + type Pointer is access all Designated; + procedure Put_Image_Pointer (S : in out Sink'Class; X : Pointer); + + procedure Put_Image_Pointer (S : in out Sink'Class; X : Pointer) is + function Cast is new Unchecked_Conversion + (System.Address, Unsigned_Address); + begin + if X = null then + Put_UTF_8 (S, "null"); + else + Put_UTF_8 (S, "(access "); + Hex.Put_Image (S, Cast (X.all'Address)); + Put_UTF_8 (S, ")"); + end if; + end Put_Image_Pointer; + + procedure Thin_Instance is new Put_Image_Pointer (Byte, Thin_Pointer); + procedure Put_Image_Thin_Pointer + (S : in out Sink'Class; X : Thin_Pointer) renames Thin_Instance; + procedure Fat_Instance is new Put_Image_Pointer (Byte_String, Fat_Pointer); + procedure Put_Image_Fat_Pointer + (S : in out Sink'Class; X : Fat_Pointer) renames Fat_Instance; + + procedure Put_Image_String (S : in out Sink'Class; X : String) is + begin + -- ????We should double double quotes, and maybe do something nice with + -- control characters. + Put_UTF_8 (S, """"); + Put_String (S, X); + Put_UTF_8 (S, """"); + end Put_Image_String; + + procedure Put_Image_Wide_String (S : in out Sink'Class; X : Wide_String) is + begin + Put_UTF_8 (S, """"); + Put_Wide_String (S, X); + Put_UTF_8 (S, """"); + end Put_Image_Wide_String; + + procedure Put_Image_Wide_Wide_String + (S : in out Sink'Class; X : Wide_Wide_String) is + begin + Put_UTF_8 (S, """"); + Put_Wide_Wide_String (S, X); + Put_UTF_8 (S, """"); + end Put_Image_Wide_Wide_String; + + procedure Array_Before (S : in out Sink'Class) is + begin + New_Line (S); + Put_7bit (S, '['); + Indent (S, 1); + end Array_Before; + + procedure Array_Between (S : in out Sink'Class) is + begin + Put_7bit (S, ','); + New_Line (S); + end Array_Between; + + procedure Array_After (S : in out Sink'Class) is + begin + Outdent (S, 1); + Put_7bit (S, ']'); + end Array_After; + + procedure Simple_Array_Between (S : in out Sink'Class) is + begin + Put_7bit (S, ','); + if Column (S) > 60 then + New_Line (S); + else + Put_7bit (S, ' '); + end if; + end Simple_Array_Between; + + procedure Record_Before (S : in out Sink'Class) is + begin + New_Line (S); + Put_7bit (S, '('); + Indent (S, 1); + end Record_Before; + + procedure Record_Between (S : in out Sink'Class) is + begin + Put_7bit (S, ','); + New_Line (S); + end Record_Between; + + procedure Record_After (S : in out Sink'Class) is + begin + Outdent (S, 1); + Put_7bit (S, ')'); + end Record_After; + + procedure Put_Image_Unknown (S : in out Sink'Class) is + begin + Put_UTF_8 (S, "{unknown image}"); + end Put_Image_Unknown; + +end System.Put_Images; diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads new file mode 100644 index 0000000..0cfe217 --- /dev/null +++ b/gcc/ada/libgnat/s-putima.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.PUT_IMAGES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; +with Ada.Strings.Text_Output; +with System.Unsigned_Types; +package System.Put_Images is + + -- This package contains subprograms that are called by the generated code + -- for the 'Put_Image attribute. + -- + -- For an integer type that fits in Integer, the actual parameter is + -- converted to Integer, and Put_Image_Integer is called. For larger types, + -- Put_Image_Long_Long_Integer is used. Other numeric types are treated + -- similarly. Access values are unchecked-converted to either Thin_Pointer + -- or Fat_Pointer, and Put_Image_Thin_Pointer or Put_Image_Fat_Pointer is + -- called. The Before/Between/After procedures are called before printing + -- the components of a composite type, between pairs of components, and + -- after them. See Exp_Put_Image in the compiler for details of these + -- calls. + + subtype Sink is Ada.Strings.Text_Output.Sink; + + procedure Put_Image_Integer (S : in out Sink'Class; X : Integer); + procedure Put_Image_Long_Long_Integer + (S : in out Sink'Class; X : Long_Long_Integer); + + subtype Unsigned is System.Unsigned_Types.Unsigned; + subtype Long_Long_Unsigned is System.Unsigned_Types.Long_Long_Unsigned; + + procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned); + procedure Put_Image_Long_Long_Unsigned + (S : in out Sink'Class; X : Long_Long_Unsigned); + + type Byte is new Character with Alignment => 1; + type Byte_String is array (Positive range <>) of Byte with Alignment => 1; + type Thin_Pointer is access all Byte; + type Fat_Pointer is access all Byte_String; + procedure Put_Image_Thin_Pointer (S : in out Sink'Class; X : Thin_Pointer); + procedure Put_Image_Fat_Pointer (S : in out Sink'Class; X : Fat_Pointer); + -- Print "null", or the address of the designated object as an unsigned + -- hexadecimal integer. + + procedure Put_Image_String (S : in out Sink'Class; X : String); + procedure Put_Image_Wide_String (S : in out Sink'Class; X : Wide_String); + procedure Put_Image_Wide_Wide_String + (S : in out Sink'Class; X : Wide_Wide_String); + + procedure Array_Before (S : in out Sink'Class); + procedure Array_Between (S : in out Sink'Class); + procedure Array_After (S : in out Sink'Class); + + procedure Simple_Array_Between (S : in out Sink'Class); + -- For "simple" arrays, where we don't want a newline between every + -- component. + + procedure Record_Before (S : in out Sink'Class); + procedure Record_Between (S : in out Sink'Class); + procedure Record_After (S : in out Sink'Class); + + procedure Put_Image_Unknown (S : in out Sink'Class); + -- For Put_Image of types that don't have the attribute, such as type + -- Sink. Prints a canned string. + +end System.Put_Images; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 14371b4..5983ba9 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -572,6 +572,10 @@ package body Rtsfind is elsif U_Id in Ada_Strings_Child then Name_Buffer (12) := '.'; + if U_Id in Ada_Strings_Text_Output_Child then + Name_Buffer (24) := '.'; + end if; + elsif U_Id in Ada_Text_IO_Child then Name_Buffer (12) := '.'; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 51c96e6..a86b98e 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -46,10 +46,10 @@ package Rtsfind is -- in the package entity table. The units must be either library level -- package declarations, or library level subprogram declarations. Generic -- units, library level instantiations and subprogram bodies acting as - -- specs may not be referenced (all these cases could be added at the + -- specs must not be referenced. (All these cases could be added at the -- expense of additional complexity in the body of Rtsfind, but it doesn't -- seem worthwhile, since the implementation controls the set of units that - -- are referenced, and this restriction is easily met. + -- are referenced, and this restriction is easily met.) -- IMPORTANT NOTE: the specs of packages and procedures with'ed using -- this mechanism must not contain use clauses. This is because these @@ -122,6 +122,11 @@ package Rtsfind is Ada_Strings_Wide_Superbounded, Ada_Strings_Wide_Wide_Superbounded, Ada_Strings_Unbounded, + Ada_Strings_Text_Output, + + -- Children of Ada.Strings.Text_Output + + Ada_Strings_Text_Output_Utils, -- Children of Ada.Text_IO (for Check_Text_IO_Special_Unit) @@ -303,6 +308,8 @@ package Rtsfind is System_Pool_Empty, System_Pool_Local, System_Pool_Size, + System_Put_Images, + System_Put_Task_Images, System_Relative_Delays, System_RPC, System_Scalar_Values, @@ -375,7 +382,7 @@ package Rtsfind is subtype Ada_Child is RTU_Id range Ada_Calendar .. Ada_Wide_Wide_Text_IO_Modular_IO; - -- Range of values for children or grand-children of Ada + -- Range of values for children or grandchildren of Ada subtype Ada_Calendar_Child is Ada_Child range Ada_Calendar_Delays .. Ada_Calendar_Delays; @@ -403,8 +410,12 @@ package Rtsfind is -- Range of values for children of Ada.Streams subtype Ada_Strings_Child is Ada_Child - range Ada_Strings_Superbounded .. Ada_Strings_Unbounded; - -- Range of values for children of Ada.Strings + range Ada_Strings_Superbounded .. Ada_Strings_Text_Output_Utils; + -- Range of values for children and grandchildren of Ada.Strings + + subtype Ada_Strings_Text_Output_Child is Ada_Child + range Ada_Strings_Text_Output_Utils .. Ada_Strings_Text_Output_Utils; + -- Range of values for children of Ada.Strings.Text_Output subtype Ada_Text_IO_Child is Ada_Child range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO; @@ -563,6 +574,11 @@ package Rtsfind is RE_Unbounded_String, -- Ada.Strings.Unbounded + RE_Sink, -- Ada.Strings.Text_Output + + RE_Put_UTF_8, -- Ada.Strings.Text_Output.Utils + RE_Put_Wide_Wide_String, -- Ada.Strings.Text_Output.Utils + RE_Wait_For_Release, -- Ada.Synchronous_Barriers RE_Suspend_Until_True, -- Ada.Synchronous_Task_Control @@ -1244,6 +1260,27 @@ package Rtsfind is RE_Stack_Bounded_Pool, -- System.Pool_Size + RE_Put_Image_Integer, -- System.Put_Images + RE_Put_Image_Long_Long_Integer, -- System.Put_Images + RE_Put_Image_Unsigned, -- System.Put_Images + RE_Put_Image_Long_Long_Unsigned, -- System.Put_Images + RE_Put_Image_Thin_Pointer, -- System.Put_Images + RE_Put_Image_Fat_Pointer, -- System.Put_Images + RE_Put_Image_String, -- System.Put_Images + RE_Put_Image_Wide_String, -- System.Put_Images + RE_Put_Image_Wide_Wide_String, -- System.Put_Images + RE_Array_Before, -- System.Put_Images + RE_Array_Between, -- System.Put_Images + RE_Array_After, -- System.Put_Images + RE_Simple_Array_Between, -- System.Put_Images + RE_Record_Before, -- System.Put_Images + RE_Record_Between, -- System.Put_Images + RE_Record_After, -- System.Put_Images + RE_Put_Image_Unknown, -- System.Put_Images + + RE_Put_Image_Protected, -- System.Put_Task_Images + RE_Put_Image_Task, -- System.Put_Task_Images + RE_Do_Apc, -- System.RPC RE_Do_Rpc, -- System.RPC RE_Params_Stream_Type, -- System.RPC @@ -1807,6 +1844,11 @@ package Rtsfind is RE_Unbounded_String => Ada_Strings_Unbounded, + RE_Sink => Ada_Strings_Text_Output, + + RE_Put_UTF_8 => Ada_Strings_Text_Output_Utils, + RE_Put_Wide_Wide_String => Ada_Strings_Text_Output_Utils, + RE_Wait_For_Release => Ada_Synchronous_Barriers, RE_Suspend_Until_True => Ada_Synchronous_Task_Control, @@ -2612,6 +2654,27 @@ package Rtsfind is RE_Stack_Bounded_Pool => System_Pool_Size, + RE_Put_Image_Integer => System_Put_Images, + RE_Put_Image_Long_Long_Integer => System_Put_Images, + RE_Put_Image_Unsigned => System_Put_Images, + RE_Put_Image_Long_Long_Unsigned => System_Put_Images, + RE_Put_Image_Thin_Pointer => System_Put_Images, + RE_Put_Image_Fat_Pointer => System_Put_Images, + RE_Put_Image_String => System_Put_Images, + RE_Put_Image_Wide_String => System_Put_Images, + RE_Put_Image_Wide_Wide_String => System_Put_Images, + RE_Array_Before => System_Put_Images, + RE_Array_Between => System_Put_Images, + RE_Array_After => System_Put_Images, + RE_Simple_Array_Between => System_Put_Images, + RE_Record_Before => System_Put_Images, + RE_Record_Between => System_Put_Images, + RE_Record_After => System_Put_Images, + RE_Put_Image_Unknown => System_Put_Images, + + RE_Put_Image_Protected => System_Put_Task_Images, + RE_Put_Image_Task => System_Put_Task_Images, + RO_RD_Delay_For => System_Relative_Delays, RE_Do_Apc => System_RPC, diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 005add8c..160a206 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -391,6 +391,9 @@ package body Sem_Attr is -- corresponding possible defined attribute function (e.g. for the -- Read attribute, Nam will be TSS_Stream_Read). + procedure Check_Put_Image_Attribute; + -- Validity checking for Put_Image attribute + procedure Check_System_Prefix; -- Verify that prefix of attribute N is package System @@ -2323,6 +2326,49 @@ package body Sem_Attr is end if; end Check_Standard_Prefix; + ------------------------------- + -- Check_Put_Image_Attribute -- + ------------------------------- + + procedure Check_Put_Image_Attribute is + begin + -- Put_Image is a procedure, and can only appear at the position of a + -- procedure call. If it's a list member and it's parent is a + -- procedure call or aggregate, then this is appearing as an actual + -- parameter or component association, which is wrong. + + if Is_List_Member (N) + and then not Nkind_In (Parent (N), N_Procedure_Call_Statement, + N_Aggregate) + then + null; + else + Error_Attr + ("invalid context for attribute%, which is a procedure", N); + end if; + + Check_Type; + Analyze_And_Resolve (E1); + + -- Check that the first argument is + -- Ada.Strings.Text_Output.Sink'Class. + + -- Note: the double call to Root_Type here is needed because the + -- root type of a class-wide type is the corresponding type (e.g. + -- X for X'Class, and we really want to go to the root.) + + if Root_Type (Root_Type (Etype (E1))) /= RTE (RE_Sink) then + Error_Attr + ("expected Ada.Strings.Text_Output.Sink''Class", E1); + end if; + + -- Check that the second argument is of the right type + + Analyze (E2); + Resolve (E2, P_Type); + Check_Not_CPP_Type; + end Check_Put_Image_Attribute; + ---------------------------- -- Check_Stream_Attribute -- ---------------------------- @@ -5281,6 +5327,16 @@ package body Sem_Attr is Validate_Non_Static_Attribute_Function_Call; + --------------- + -- Put_Image -- + --------------- + + when Attribute_Put_Image => + Check_E2; + Check_Put_Image_Attribute; + Set_Etype (N, Standard_Void_Type); + Resolve (N, Standard_Void_Type); + ----------- -- Range -- ----------- @@ -10262,6 +10318,7 @@ package body Sem_Attr is | Attribute_Pool_Address | Attribute_Position | Attribute_Priority + | Attribute_Put_Image | Attribute_Read | Attribute_Result | Attribute_Scalar_Storage_Order diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 1068056..d4d383f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -16423,6 +16423,7 @@ package body Sem_Ch12 is OK := (Is_Fun and then Num_F = 1); when Attribute_Output + | Attribute_Put_Image | Attribute_Read | Attribute_Write => diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index bdb2b6a..bd3010c 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -186,6 +186,12 @@ package body Sem_Ch13 is -- We can't allow this, otherwise we have predicate-static applying to a -- larger class than static expressions, which was never intended. + procedure New_Put_Image_Subprogram + (N : Node_Id; + Ent : Entity_Id; + Subp : Entity_Id); + -- Similar to New_Stream_Subprogram, but for the Put_Image attribute + procedure New_Stream_Subprogram (N : Node_Id; Ent : Entity_Id; @@ -2227,6 +2233,7 @@ package body Sem_Ch13 is | Aspect_Machine_Radix | Aspect_Object_Size | Aspect_Output + | Aspect_Put_Image | Aspect_Read | Aspect_Scalar_Storage_Order | Aspect_Simple_Storage_Pool @@ -4149,6 +4156,8 @@ package body Sem_Ch13 is -- Storage_Size for derived task types, but that is also clearly -- unintentional. + procedure Analyze_Put_Image_TSS_Definition; + procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type); -- Common processing for 'Read, 'Write, 'Input and 'Output attribute -- definition clauses. @@ -4172,6 +4181,152 @@ package body Sem_Ch13 is -- Common legality check for the previous two ----------------------------------- + -- Analyze_Put_Image_TSS_Definition -- + ----------------------------------- + + procedure Analyze_Put_Image_TSS_Definition is + Subp : Entity_Id := Empty; + I : Interp_Index; + It : Interp; + Pnam : Entity_Id; + + function Has_Good_Profile + (Subp : Entity_Id; + Report : Boolean := False) return Boolean; + -- Return true if the entity is a subprogram with an appropriate + -- profile for the attribute being defined. If result is False and + -- Report is True, function emits appropriate error. + + ---------------------- + -- Has_Good_Profile -- + ---------------------- + + function Has_Good_Profile + (Subp : Entity_Id; + Report : Boolean := False) return Boolean + is + F : Entity_Id; + Typ : Entity_Id; + + begin + if Ekind (Subp) /= E_Procedure then + return False; + end if; + + F := First_Formal (Subp); + + if No (F) or else Etype (F) /= Class_Wide_Type (RTE (RE_Sink)) then + return False; + end if; + + Next_Formal (F); + + if Parameter_Mode (F) /= E_In_Parameter then + return False; + end if; + + Typ := Etype (F); + + -- Verify that the prefix of the attribute and the local name for + -- the type of the formal match. + + if Typ /= Ent then + return False; + end if; + + if Present (Next_Formal (F)) then + return False; + + elsif not Is_Scalar_Type (Typ) + and then not Is_First_Subtype (Typ) + then + if Report and not Is_First_Subtype (Typ) then + Error_Msg_N + ("subtype of formal in Put_Image operation must be a " + & "first subtype", Parameter_Type (Parent (F))); + end if; + + return False; + + else + return True; + end if; + end Has_Good_Profile; + + -- Start of processing for Analyze_Put_Image_TSS_Definition + + begin + if not Is_Type (U_Ent) then + Error_Msg_N ("local name must be a subtype", Nam); + return; + + elsif not Is_First_Subtype (U_Ent) then + Error_Msg_N ("local name must be a first subtype", Nam); + return; + end if; + + Pnam := TSS (Base_Type (U_Ent), TSS_Put_Image); + + -- If Pnam is present, it can be either inherited from an ancestor + -- type (in which case it is legal to redefine it for this type), or + -- be a previous definition of the attribute for the same type (in + -- which case it is illegal). + + -- In the first case, it will have been analyzed already, and we can + -- check that its profile does not match the expected profile for the + -- Put_Image attribute of U_Ent. In the second case, either Pnam has + -- been analyzed (and has the expected profile), or it has not been + -- analyzed yet (case of a type that has not been frozen yet and for + -- which Put_Image has been set using Set_TSS). + + if Present (Pnam) + and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam)) + then + Error_Msg_Sloc := Sloc (Pnam); + Error_Msg_Name_1 := Attr; + Error_Msg_N ("% attribute already defined #", Nam); + return; + end if; + + Analyze (Expr); + + if Is_Entity_Name (Expr) then + if not Is_Overloaded (Expr) then + if Has_Good_Profile (Entity (Expr), Report => True) then + Subp := Entity (Expr); + end if; + + else + Get_First_Interp (Expr, I, It); + while Present (It.Nam) loop + if Has_Good_Profile (It.Nam) then + Subp := It.Nam; + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end if; + + if Present (Subp) then + if Is_Abstract_Subprogram (Subp) then + Error_Msg_N ("Put_Image subprogram must not be abstract", Expr); + return; + end if; + + Set_Entity (Expr, Subp); + Set_Etype (Expr, Etype (Subp)); + + New_Put_Image_Subprogram (N, U_Ent, Subp); + + else + Error_Msg_Name_1 := Attr; + Error_Msg_N ("incorrect expression for% attribute", Expr); + end if; + end Analyze_Put_Image_TSS_Definition; + + ----------------------------------- -- Analyze_Stream_TSS_Definition -- ----------------------------------- @@ -4891,6 +5046,7 @@ package body Sem_Ch13 is when Attribute_External_Tag | Attribute_Input | Attribute_Output + | Attribute_Put_Image | Attribute_Read | Attribute_Simple_Storage_Pool | Attribute_Storage_Pool @@ -5892,6 +6048,13 @@ package body Sem_Ch13 is ("attribute& cannot be set with definition clause", N); end if; + --------------- + -- Put_Image -- + --------------- + + when Attribute_Put_Image => + Analyze_Put_Image_TSS_Definition; + ---------- -- Read -- ---------- @@ -9299,16 +9462,16 @@ package body Sem_Ch13 is elsif A_Id = Aspect_Synchronization then return; - -- Case of stream attributes, just have to compare entities. However, - -- the expression is just a name (possibly overloaded), and there may - -- be stream operations declared for unrelated types, so we just need - -- to verify that one of these interpretations is the one available at - -- at the freeze point. + -- Case of stream attributes and Put_Image, just have to compare + -- entities. However, the expression is just a possibly-overloaded + -- name, so we need to verify that one of these interpretations is + -- the one available at at the freeze point. elsif A_Id = Aspect_Input or else A_Id = Aspect_Output or else A_Id = Aspect_Read or else - A_Id = Aspect_Write + A_Id = Aspect_Write or else + A_Id = Aspect_Put_Image then Analyze (End_Decl_Expr); Check_Overloaded_Name; @@ -9564,6 +9727,7 @@ package body Sem_Ch13 is when Aspect_Input | Aspect_Output + | Aspect_Put_Image | Aspect_Read | Aspect_Suppress | Aspect_Unsuppress @@ -12515,6 +12679,138 @@ package body Sem_Ch13 is end Minimum_Size; --------------------------- + -- New_Put_Image_Subprogram -- + --------------------------- + + procedure New_Put_Image_Subprogram + (N : Node_Id; + Ent : Entity_Id; + Subp : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Sname : constant Name_Id := + Make_TSS_Name (Base_Type (Ent), TSS_Put_Image); + Subp_Id : Entity_Id; + Subp_Decl : Node_Id; + F : Entity_Id; + Etyp : Entity_Id; + + Defer_Declaration : constant Boolean := + Is_Tagged_Type (Ent) or else Is_Private_Type (Ent); + -- For a tagged type, there is a declaration at the freeze point, and + -- we must generate only a completion of this declaration. We do the + -- same for private types, because the full view might be tagged. + -- Otherwise we generate a declaration at the point of the attribute + -- definition clause. If the attribute definition comes from an aspect + -- specification the declaration is part of the freeze actions of the + -- type. + + function Build_Spec return Node_Id; + -- Used for declaration and renaming declaration, so that this is + -- treated as a renaming_as_body. + + ---------------- + -- Build_Spec -- + ---------------- + + function Build_Spec return Node_Id is + Formals : List_Id; + Spec : Node_Id; + T_Ref : constant Node_Id := New_Occurrence_Of (Etyp, Loc); + + begin + Subp_Id := Make_Defining_Identifier (Loc, Sname); + + -- S : Sink'Class + + Formals := 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 (Etype (F), Loc))); + + -- V : T + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Parameter_Type => T_Ref)); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => Formals); + + return Spec; + end Build_Spec; + + -- Start of processing for New_Put_Image_Subprogram + + begin + F := First_Formal (Subp); + + Etyp := Etype (Next_Formal (F)); + + -- Prepare subprogram declaration and insert it as an action on the + -- clause node. The visibility for this entity is used to test for + -- visibility of the attribute definition clause (in the sense of + -- 8.3(23) as amended by AI-195). + + if not Defer_Declaration then + Subp_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Build_Spec); + + -- For a tagged type, there is always a visible declaration for the + -- Put_Image TSS (it is a predefined primitive operation), and the + -- completion of this declaration occurs at the freeze point, which is + -- not always visible at places where the attribute definition clause is + -- visible. So, we create a dummy entity here for the purpose of + -- tracking the visibility of the attribute definition clause itself. + + else + Subp_Id := + Make_Defining_Identifier (Loc, New_External_Name (Sname, 'V')); + Subp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Id, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc)); + end if; + + if not Defer_Declaration + and then From_Aspect_Specification (N) + and then Has_Delayed_Freeze (Ent) + then + Append_Freeze_Action (Ent, Subp_Decl); + + else + Insert_Action (N, Subp_Decl); + Set_Entity (N, Subp_Id); + end if; + + Subp_Decl := + Make_Subprogram_Renaming_Declaration (Loc, + Specification => Build_Spec, + Name => New_Occurrence_Of (Subp, Loc)); + + if Defer_Declaration then + Set_TSS (Base_Type (Ent), Subp_Id); + + else + if From_Aspect_Specification (N) then + Append_Freeze_Action (Ent, Subp_Decl); + else + Insert_Action (N, Subp_Decl); + end if; + + Copy_TSS (Subp_Id, Base_Type (Ent)); + end if; + end New_Put_Image_Subprogram; + + --------------------------- -- New_Stream_Subprogram -- --------------------------- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 4a730fc..41e2850 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -2838,12 +2838,12 @@ package body Sem_Ch8 is if Nkind (Nam) = N_Attribute_Reference then -- In the case of an abstract formal subprogram association, rewrite - -- an actual given by a stream attribute as the name of the - -- corresponding stream primitive of the type. + -- an actual given by a stream or Put_Image attribute as the name of + -- the corresponding stream or Put_Image primitive of the type. - -- In a generic context the stream operations are not generated, and - -- this must be treated as a normal attribute reference, to be - -- expanded in subsequent instantiations. + -- In a generic context the stream and Put_Image operations are not + -- generated, and this must be treated as a normal attribute + -- reference, to be expanded in subsequent instantiations. if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) @@ -2851,12 +2851,12 @@ package body Sem_Ch8 is then declare Prefix_Type : constant Entity_Id := Entity (Prefix (Nam)); - Stream_Prim : Entity_Id; + Prim : Entity_Id; begin - -- The class-wide forms of the stream attributes are not - -- primitive dispatching operations (even though they - -- internally dispatch to a stream attribute). + -- The class-wide forms of the stream and Put_Image attributes + -- are not primitive dispatching operations (even though they + -- internally dispatch). if Is_Class_Wide_Type (Prefix_Type) then Error_Msg_N @@ -2873,21 +2873,25 @@ package body Sem_Ch8 is case Attribute_Name (Nam) is when Name_Input => - Stream_Prim := + Prim := Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Input); when Name_Output => - Stream_Prim := + Prim := Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Output); when Name_Read => - Stream_Prim := + Prim := Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Read); when Name_Write => - Stream_Prim := + Prim := Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Write); + when Name_Put_Image => + Prim := + Find_Optional_Prim_Op (Prefix_Type, TSS_Put_Image); + when others => Error_Msg_N ("attribute must be a primitive dispatching operation", @@ -2895,10 +2899,13 @@ package body Sem_Ch8 is return; end case; - -- If no operation was found, and the type is limited, the user - -- should have defined one. + -- If no stream operation was found, and the type is limited, + -- the user should have defined one. This rule does not apply + -- to Put_Image. - if No (Stream_Prim) then + if No (Prim) + and then Attribute_Name (Nam) /= Name_Put_Image + then if Is_Limited_Type (Prefix_Type) then Error_Msg_NE ("stream operation not defined for type&", @@ -2919,9 +2926,9 @@ package body Sem_Ch8 is declare Prim_Name : constant Node_Id := Make_Identifier (Sloc (Nam), - Chars => Chars (Stream_Prim)); + Chars => Chars (Prim)); begin - Set_Entity (Prim_Name, Stream_Prim); + Set_Entity (Prim_Name, Prim); Rewrite (Nam, Prim_Name); Analyze (Nam); end; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 49594e4..6a51703 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -17235,6 +17235,7 @@ package body Sem_Util is or else TSS_Name = TSS_Stream_Output or else TSS_Name = TSS_Stream_Read or else TSS_Name = TSS_Stream_Write + or else TSS_Name = TSS_Put_Image or else Is_Predefined_Interface_Primitive (E) then return True; diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index f085b84..a03cafb 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -103,8 +103,10 @@ package body Snames is -- xxxDF deep finalize routine for type xxx (Exp_TSS) -- xxxDI deep initialize routine for type xxx (Exp_TSS) -- xxxEQ composite equality routine for record type xxx (Exp_TSS) + -- xxxFD finalize address routine for type xxx (Exp_TSS) -- xxxFA PolyORB/DSA From_Any converter for type xxx (Exp_TSS) -- xxxIP initialization procedure for type xxx (Exp_TSS) + -- xxxIC init C++ dispatch tables procedure for type xxx (Exp_TSS) -- xxxRA RAS type access routine for type xxx (Exp_TSS) -- xxxRD RAS type dereference routine for type xxx (Exp_TSS) -- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS) @@ -113,6 +115,7 @@ package body Snames is -- xxxSO stream output attribute subprogram for type xxx (Exp_TSS) -- xxxSR stream read attribute subprogram for type xxx (Exp_TSS) -- xxxSW stream write attribute subprogram for type xxx (Exp_TSS) + -- xxxPI Put_Image attribute subprogram for type xxx (Exp_TSS) -- xxxTA PolyORB/DSA To_Any converter for type xxx (Exp_TSS) -- xxxTC PolyORB/DSA Typecode for type xxx (Exp_TSS) diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 337ce19..9534bff 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1057,6 +1057,7 @@ package Snames is First_Procedure_Attribute : constant Name_Id := N + $; Name_Output : constant Name_Id := N + $; + Name_Put_Image : constant Name_Id := N + $; Name_Read : constant Name_Id := N + $; Name_Write : constant Name_Id := N + $; Last_Procedure_Attribute : constant Name_Id := N + $; @@ -1725,6 +1726,7 @@ package Snames is -- Attributes designating procedures Attribute_Output, + Attribute_Put_Image, Attribute_Read, Attribute_Write, diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index f71b0db..140cb21 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -365,6 +365,24 @@ package body Tbuild is End_Label => End_Label); end Make_Implicit_Loop_Statement; + -------------------- + -- Make_Increment -- + -------------------- + + function Make_Increment + (Loc : Source_Ptr; Index : Entity_Id; Typ : Entity_Id) return Node_Id is + begin + return Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Index, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List ( + New_Occurrence_Of (Index, Loc)))); + end Make_Increment; + -------------------------- -- Make_Integer_Literal -- --------------------------- diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 923e3b9..3256804 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -140,6 +140,10 @@ package Tbuild is -- all cases, and the second only for while loops), and if one of these -- restrictions is being violated, an error message is posted on Node. + function Make_Increment + (Loc : Source_Ptr; Index : Entity_Id; Typ : Entity_Id) return Node_Id; + -- Return an assignment statement of the form "Index := Typ'Succ (Index);" + function Make_Integer_Literal (Loc : Source_Ptr; Intval : Int) return Node_Id; |