s-mudido$(objext) \
s-osinte$(objext) \
s-proinf$(objext) \
+ s-putaim$(objext) \
s-solita$(objext) \
s-stusta$(objext) \
s-taenca$(objext) \
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) \
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) \
a-strsup$(objext) \
a-strunb$(objext) \
a-ststio$(objext) \
+ a-stteou$(objext) \
a-stunau$(objext) \
a-stunha$(objext) \
a-stuten$(objext) \
g-excact$(objext) \
g-except$(objext) \
g-exctra$(objext) \
- s-exctra$(objext) \
g-expect$(objext) \
g-exptty$(objext) \
g-flocon$(objext) \
g-timsta$(objext) \
g-traceb$(objext) \
g-trasym$(objext) \
- s-trasym$(objext) \
g-tty$(objext) \
g-u3spch$(objext) \
g-utf_32$(objext) \
s-dfmkio$(objext) \
s-dfmopr$(objext) \
s-dgmgop$(objext) \
- s-dlmopr$(objext) \
s-diflio$(objext) \
s-diflmk$(objext) \
s-digemk$(objext) \
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) \
s-poosiz$(objext) \
s-powtab$(objext) \
s-purexc$(objext) \
+ s-putima$(objext) \
s-rannum$(objext) \
s-ransee$(objext) \
s-regexp$(objext) \
s-tasloc$(objext) \
s-traceb$(objext) \
s-traent$(objext) \
+ s-trasym$(objext) \
s-unstyp$(objext) \
s-utf_32$(objext) \
s-valboo$(objext) \
-- 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
-- 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
-- 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,
Aspect_Predicate, -- GNAT
Aspect_Predicate_Failure,
Aspect_Priority,
+ Aspect_Put_Image,
Aspect_Read,
Aspect_Refined_Depends, -- GNAT
Aspect_Refined_Global, -- GNAT
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,
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,
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,
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;
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));
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
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
-- 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;
---------
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 --
------------------
end if;
end if;
- Rewrite_Stream_Proc_Call (Pname);
+ Rewrite_Attribute_Proc_Call (Pname);
end Read;
---------
-- 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
-- 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
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
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;
-- 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
-- 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
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
pragma Warnings (Off, Ent);
+ use Exp_Put_Image;
+
begin
pragma Assert (not Is_Interface (Tag_Typ));
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
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;
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;
-- 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_
-- 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
-- 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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
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;
--------------------------------
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;
---------------------------------
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;
---------------------------------
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;
----------------------------------
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
TSS_Stream_Output,
TSS_Stream_Read,
TSS_Stream_Write,
+ TSS_Put_Image,
TSS_To_Any,
TSS_TypeCode);
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 \
-- 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 --
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
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
-- 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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
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) := '.';
-- 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
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)
System_Pool_Empty,
System_Pool_Local,
System_Pool_Size,
+ System_Put_Images,
+ System_Put_Task_Images,
System_Relative_Delays,
System_RPC,
System_Scalar_Values,
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;
-- 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;
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
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
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,
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,
-- 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
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 --
----------------------------
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 --
-----------
| Attribute_Pool_Address
| Attribute_Position
| Attribute_Priority
+ | Attribute_Put_Image
| Attribute_Read
| Attribute_Result
| Attribute_Scalar_Storage_Order
OK := (Is_Fun and then Num_F = 1);
when Attribute_Output
+ | Attribute_Put_Image
| Attribute_Read
| Attribute_Write
=>
-- 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;
| Aspect_Machine_Radix
| Aspect_Object_Size
| Aspect_Output
+ | Aspect_Put_Image
| Aspect_Read
| Aspect_Scalar_Storage_Order
| Aspect_Simple_Storage_Pool
-- 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.
function Check_Primitive_Function (Subp : Entity_Id) return Boolean;
-- 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 --
-----------------------------------
when Attribute_External_Tag
| Attribute_Input
| Attribute_Output
+ | Attribute_Put_Image
| Attribute_Read
| Attribute_Simple_Storage_Pool
| Attribute_Storage_Pool
("attribute& cannot be set with definition clause", N);
end if;
+ ---------------
+ -- Put_Image --
+ ---------------
+
+ when Attribute_Put_Image =>
+ Analyze_Put_Image_TSS_Definition;
+
----------
-- Read --
----------
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;
when Aspect_Input
| Aspect_Output
+ | Aspect_Put_Image
| Aspect_Read
| Aspect_Suppress
| Aspect_Unsuppress
return S;
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 --
---------------------------
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)
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
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",
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&",
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;
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;
-- 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)
-- 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)
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 + $;
-- Attributes designating procedures
Attribute_Output,
+ Attribute_Put_Image,
Attribute_Read,
Attribute_Write,
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 --
---------------------------
-- 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;
projects / gcc.git / commitdiff