fsrcdir := $(shell cd $(srcdir);${PWD_COMMAND})
GEN_IL_INCLUDES = -I$(fsrcdir)/ada
-GEN_IL_FLAGS = -a -q -g -gnata -j0 -gnat2012 -gnatw.g -gnatyg -gnatU $(GEN_IL_INCLUDES)
+GEN_IL_FLAGS = -gnata -gnat2012 -gnatw.g -gnatyg -gnatU $(GEN_IL_INCLUDES)
ada/seinfo_tables.ads ada/seinfo_tables.adb ada/sinfo.h ada/einfo.h ada/nmake.ads ada/nmake.adb ada/seinfo.ads ada/sinfo-nodes.ads ada/sinfo-nodes.adb ada/einfo-entities.ads ada/einfo-entities.adb: ada/stamp-gen_il ; @true
-ada/stamp-gen_il: $(fsrcdir)/ada/gen_il* $(fsrcdir)/ada/libgnat/a-sto*.ad? $(fsrcdir)/ada/libgnat/a-stteou__bootstrap.ads
+ada/stamp-gen_il: $(fsrcdir)/ada/gen_il*
$(MKDIR) ada/gen_il
- # Copy recent runtime files needed by gen_il that may not be available
- # in the base compiler.
- $(CP) -f $(fsrcdir)/ada/libgnat/a-sto*.ad? ada/gen_il
- $(CP) -f $(fsrcdir)/ada/libgnat/a-stteou__bootstrap.ads ada/gen_il/a-stteou.ads
- cd ada/gen_il ; gnatmake $(GEN_IL_FLAGS) gen_il-main.adb
- # ignore errors when running gen_il-main due to bootstrap
- # considerations
- -cd ada/gen_il ; ./gen_il-main
+ cd ada/gen_il ; gnatmake -q -g $(GEN_IL_FLAGS) gen_il-main ; ./gen_il-main
$(fsrcdir)/../move-if-change ada/gen_il/seinfo_tables.ads ada/seinfo_tables.ads
$(fsrcdir)/../move-if-change ada/gen_il/seinfo_tables.adb ada/seinfo_tables.adb
$(fsrcdir)/../move-if-change ada/gen_il/sinfo.h ada/sinfo.h
a-strunb$(objext) \
a-ststio$(objext) \
a-stteou$(objext) \
+ a-sttebu$(objext) \
+ a-stbuun$(objext) \
+ a-stbubo$(objext) \
+ a-stbuut$(objext) \
+ a-stbufi$(objext) \
+ a-stbufo$(objext) \
a-stunau$(objext) \
a-stunha$(objext) \
a-stuten$(objext) \
-- For other elementary types, generate:
--
- -- Put_Wide_Wide_String (Sink, U_Type'Wide_Wide_Image (Item));
+ -- Wide_Wide_Put (Sink, U_Type'Wide_Wide_Image (Item));
--
-- It would be more elegant to do it the other way around (define
-- '[[Wide_]Wide_]Image in terms of 'Put_Image). But this is easier
Put_Call : constant Node_Id :=
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Occurrence_Of (RTE (RE_Put_Wide_Wide_String), Loc),
+ New_Occurrence_Of (RTE (RE_Wide_Wide_Put), Loc),
Parameter_Associations => New_List
(Relocate_Node (Sink), Image));
begin
In_Present => True,
Out_Present => True,
Parameter_Type =>
- New_Occurrence_Of (Class_Wide_Type (RTE (RE_Sink)), Loc)),
+ New_Occurrence_Of
+ (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
function Enable_Put_Image (Typ : Entity_Id) return Boolean is
begin
+ -- The name "Sink" here is a short nickname for
+ -- "Ada.Strings.Text_Buffers.Root_Buffer_Type".
+
-- 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
+ -- Likewise, the Ada.Strings.Buffer 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
-- If type Sink is unavailable in this runtime, disable Put_Image
-- altogether.
- if No_Run_Time_Mode or else not RTE_Available (RE_Sink) then
+ if No_Run_Time_Mode or else not RTE_Available (RE_Root_Buffer_Type) then
return False;
end if;
- -- ???Disable Put_Image on type Sink declared in
- -- Ada.Strings.Text_Output. Note that we can't call Is_RTU on
- -- Ada_Strings_Text_Output, because it's not known yet (we might be
+ -- ???Disable Put_Image on type Root_Buffer_Type declared in
+ -- Ada.Strings.Text_Buffers. Note that we can't call Is_RTU on
+ -- Ada_Strings_Text_Buffers, because it's not known yet (we might be
-- compiling it). But this is insufficient to allow support for tagged
-- predefined types.
begin
if Present (Parent_Scope)
and then Is_RTU (Parent_Scope, Ada_Strings)
- and then Chars (Scope (Typ)) = Name_Find ("text_output")
+ and then Chars (Scope (Typ)) = Name_Find ("text_buffers")
then
return False;
end if;
Make_Object_Declaration (Loc,
Defining_Identifier => Sink_Entity,
Object_Definition =>
- New_Occurrence_Of (RTE (RE_Buffer), Loc),
- Expression =>
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_New_Buffer), Loc),
- Parameter_Associations => Empty_List));
+ New_Occurrence_Of (RTE (RE_Buffer_Type), Loc));
+
Put_Im : constant Node_Id :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (U_Type, Loc),
return Image;
end Build_Image_Call;
- ------------------
- -- Preload_Sink --
- ------------------
+ ------------------------------
+ -- Preload_Root_Buffer_Type --
+ ------------------------------
- procedure Preload_Sink (Compilation_Unit : Node_Id) is
+ procedure Preload_Root_Buffer_Type (Compilation_Unit : Node_Id) is
begin
- -- We can't call RTE (RE_Sink) for at least some predefined units,
- -- because it would introduce cyclic dependences. The package where Sink
- -- is declared, for example, and things it depends on.
+ -- We can't call RTE (RE_Root_Buffer_Type) for at least some
+ -- predefined units, because it would introduce cyclic dependences.
+ -- The package where Root_Buffer_Type is declared, for example, and
+ -- things it depends on.
--
-- It's only needed for tagged types, so don't do it unless Put_Image is
-- enabled for tagged types, and we've seen a tagged type. Note that
-- It's unfortunate to have this Tagged_Seen processing so scattered
-- about, but we need to know if there are tagged types where this is
-- called in Analyze_Compilation_Unit, before we have analyzed any type
- -- declarations. This mechanism also prevents doing RTE (RE_Sink) when
- -- compiling the compiler itself. Packages Ada.Strings.Text_Output and
- -- friends are not included in the compiler.
+ -- declarations. This mechanism also prevents doing
+ -- RTE (RE_Root_Buffer_Type) when compiling the compiler itself.
+ -- Packages Ada.Strings.Buffer_Types and friends are not included
+ -- in the compiler.
--
- -- Don't do it if type Sink is unavailable in the runtime.
+ -- Don't do it if type Root_Buffer_Type is unavailable in the runtime.
if not In_Predefined_Unit (Compilation_Unit)
and then Tagged_Put_Image_Enabled
and then Tagged_Seen
and then not No_Run_Time_Mode
- and then RTE_Available (RE_Sink)
+ and then RTE_Available (RE_Root_Buffer_Type)
then
declare
- Ignore : constant Entity_Id := RTE (RE_Sink);
+ Ignore : constant Entity_Id := RTE (RE_Root_Buffer_Type);
begin
null;
end;
end if;
- end Preload_Sink;
+ end Preload_Root_Buffer_Type;
-------------------------
-- Put_Image_Base_Type --
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.
+ -- Routines to build Put_Image calls. See Ada.Strings.Text_Buffers.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
-- to call T'Put_Image into a buffer and then extract the string from the
-- buffer.
- procedure Preload_Sink (Compilation_Unit : Node_Id);
- -- Call RTE (RE_Sink) if necessary, to load the packages involved in
- -- Put_Image. We need to do this explicitly, fairly early during
- -- compilation, because otherwise it happens during freezing, which
+ procedure Preload_Root_Buffer_Type (Compilation_Unit : Node_Id);
+ -- Call RTE (RE_Root_Buffer_Type) if necessary, to load the packages
+ -- involved in Put_Image. We need to do this explicitly, fairly early
+ -- during compilation, because otherwise it happens during freezing, which
-- triggers visibility bugs in generic instantiations.
end Exp_Put_Image;
------------------------------------------------------------------------------
with Ada.Containers; use type Ada.Containers.Count_Type;
+with Ada.Text_IO;
package body Gen_IL.Gen is
-- Print out the Einfo.Entities package spec and body
procedure Put_Type_And_Subtypes
- (S : in out Sink'Class; Root : Root_Type);
+ (S : in out Sink; Root : Root_Type);
-- Called by Put_Nodes and Put_Entities to print out the main type
-- and subtype declarations in Sinfo.Nodes and Einfo.Entities.
- procedure Put_Subp_Decls (S : in out Sink'Class; Root : Root_Type);
+ procedure Put_Subp_Decls (S : in out Sink; Root : Root_Type);
-- Called by Put_Nodes and Put_Entities to print out the subprogram
-- declarations in Sinfo.Nodes and Einfo.Entities.
- procedure Put_Subp_Bodies (S : in out Sink'Class; Root : Root_Type);
+ procedure Put_Subp_Bodies (S : in out Sink; Root : Root_Type);
-- Called by Put_Nodes and Put_Entities to print out the subprogram
-- bodies in Sinfo.Nodes and Einfo.Entities.
-- parameter N). But if Type_Only was specified, we need to fetch the
-- corresponding base (etc) type.
- procedure Put_Getter_Spec (S : in out Sink'Class; F : Field_Enum);
- procedure Put_Setter_Spec (S : in out Sink'Class; F : Field_Enum);
- procedure Put_Getter_Decl (S : in out Sink'Class; F : Field_Enum);
- procedure Put_Setter_Decl (S : in out Sink'Class; F : Field_Enum);
- procedure Put_Getter_Body (S : in out Sink'Class; F : Field_Enum);
- procedure Put_Setter_Body (S : in out Sink'Class; F : Field_Enum);
+ procedure Put_Getter_Spec (S : in out Sink; F : Field_Enum);
+ procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum);
+ procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum);
+ procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum);
+ procedure Put_Getter_Body (S : in out Sink; F : Field_Enum);
+ procedure Put_Setter_Body (S : in out Sink; F : Field_Enum);
-- Print out the specification, declaration, or body of a getter or
-- setter for the given field.
procedure Put_Precondition
- (S : in out Sink'Class; F : Field_Enum);
+ (S : in out Sink; F : Field_Enum);
-- Print out the precondition, if any, for a getter or setter for the
-- given field.
procedure Put_Low_Level_Accessor_Instantiations
- (S : in out Sink'Class; T : Type_Enum);
+ (S : in out Sink; T : Type_Enum);
-- Print out the low-level getter and setter for a given type
- procedure Put_Traversed_Fields (S : in out Sink'Class);
+ procedure Put_Traversed_Fields (S : in out Sink);
-- Called by Put_Nodes to print out the Traversed_Fields table in
-- Sinfo.Nodes.
- procedure Put_Tables (S : in out Sink'Class; Root : Root_Type);
+ procedure Put_Tables (S : in out Sink; Root : Root_Type);
-- Called by Put_Nodes and Put_Entities to print out the various tables
-- in Sinfo.Nodes and Einfo.Entities.
-- Print out the Nmake package spec and body, containing
-- Make_... functions for each concrete node type.
- procedure Put_Make_Decls (S : in out Sink'Class; Root : Root_Type);
+ procedure Put_Make_Decls (S : in out Sink; Root : Root_Type);
-- Called by Put_Nmake to print out the Make_... function declarations
- procedure Put_Make_Bodies (S : in out Sink'Class; Root : Root_Type);
+ procedure Put_Make_Bodies (S : in out Sink; Root : Root_Type);
-- Called by Put_Nmake to print out the Make_... function bodies
procedure Put_Make_Spec
- (S : in out Sink'Class; Root : Root_Type; T : Concrete_Type);
+ (S : in out Sink; Root : Root_Type; T : Concrete_Type);
-- Called by Put_Make_Decls and Put_Make_Bodies to print out the spec of
-- a single Make_... function.
-- Print out the einfo.h file
procedure Put_C_Type_And_Subtypes
- (S : in out Sink'Class; Root : Root_Type);
+ (S : in out Sink; Root : Root_Type);
-- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out the C code
-- corresponding to the Ada Node_Kind, Entity_Kind, and subtypes
-- thereof.
procedure Put_Low_Level_C_Getter
- (S : in out Sink'Class; T : Type_Enum);
+ (S : in out Sink; T : Type_Enum);
-- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out low-level
-- getters.
procedure Put_High_Level_C_Getters
- (S : in out Sink'Class; Root : Root_Type);
+ (S : in out Sink; Root : Root_Type);
-- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out high-level
-- getters.
procedure Put_High_Level_C_Getter
- (S : in out Sink'Class; F : Field_Enum);
+ (S : in out Sink; F : Field_Enum);
-- Used by Put_High_Level_C_Getters to print out one high-level getter.
procedure Put_Union_Membership
- (S : in out Sink'Class; Root : Root_Type);
+ (S : in out Sink; Root : Root_Type);
-- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out functions to
-- test membership in a union type.
for F of Type_Table (CT).Fields loop
if Fields_Per_Node (CT) (F) then
- Put ("duplicate field \1.\2\n", Image (CT), Image (F));
+ Ada.Text_IO.Put_Line
+ ("duplicate field" & Image (CT) & Image (F));
Duplicate_Fields_Found := True;
end if;
---------------------------
procedure Put_Type_And_Subtypes
- (S : in out Sink'Class; Root : Root_Type)
+ (S : in out Sink; Root : Root_Type)
is
procedure Put_Enum_Type;
if First_Time then
First_Time := False;
else
- Put (S, ",\n");
+ Put (S, "," & LF);
end if;
- Put (S, "\1", Image (T));
+ Put (S, Image (T));
end if;
end Put_Enum_Lit;
Num_Types : constant Root_Int := Dummy'Length;
begin
- Put (S, "type \1 is -- \2 \1s\n", Image (Root), Image (Num_Types));
- Indent (S, 2);
+ Put (S, "type " & Image (Root) & " is -- " &
+ Image (Num_Types) & " " & Image (Root) & "s" & LF);
+ Increase_Indent (S, 2);
Put (S, "(");
- Indent (S, 1);
+ Increase_Indent (S, 1);
Iterate_Types (Root, Pre => Put_Enum_Lit'Access);
- Outdent (S, 1);
- Put (S, "\n) with Size => 8; -- \1\n\n", Image (Root));
- Outdent (S, 2);
+ Decrease_Indent (S, 1);
+ Put (S, LF & ") with Size => 8; -- " & Image (Root) & LF & LF);
+ Decrease_Indent (S, 2);
end Put_Enum_Type;
procedure Put_Kind_Subtype (T : Node_Or_Entity_Type) is
if Type_Table (T).Is_Union then
pragma Assert (Type_Table (T).Parent = Root);
- Put (S, "subtype \1 is\n", Image (T));
- Indent (S, 2);
- Put (S, "\1 with Predicate =>\n",
- Image (Root));
- Indent (S, 2);
- Put (S, "\1 in\n", Image (T));
+ Put (S, "subtype " & Image (T) & " is" & LF);
+ Increase_Indent (S, 2);
+ Put (S, Image (Root) & " with Predicate =>" & LF);
+ Increase_Indent (S, 2);
+ Put (S, Image (T) & " in" & LF);
Put_Types_With_Bars (S, Type_Table (T).Children);
- Outdent (S, 2);
- Put (S, ";\n");
- Outdent (S, 2);
+ Decrease_Indent (S, 2);
+ Put (S, ";" & LF);
+ Decrease_Indent (S, 2);
elsif Type_Table (T).Parent /= No_Type then
- Put (S, "subtype \1 is \2 range\n",
- Image (T),
- Image (Type_Table (T).Parent));
- Indent (S, 2);
- Put (S, "\1 .. \2;\n",
- Image (Type_Table (T).First),
- Image (Type_Table (T).Last));
- Outdent (S, 2);
+ Put (S, "subtype " & Image (T) & " is " &
+ Image (Type_Table (T).Parent) & " range" & LF);
+ Increase_Indent (S, 2);
+ Put (S, Image (Type_Table (T).First) & " .. " &
+ Image (Type_Table (T).Last) & ";" & LF);
+ Decrease_Indent (S, 2);
- Indent (S, 3);
+ Increase_Indent (S, 3);
for J in 1 .. Type_Table (T).Concrete_Descendants.Last_Index loop
- Put (S, "-- \1\n",
- Image (Type_Table (T).Concrete_Descendants (J)));
+ Put (S, "-- " &
+ Image (Type_Table (T).Concrete_Descendants (J)) & LF);
end loop;
- Outdent (S, 3);
+ Decrease_Indent (S, 3);
end if;
end if;
end Put_Kind_Subtype;
procedure Put_Id_Subtype (T : Node_Or_Entity_Type) is
begin
if Type_Table (T).Parent /= No_Type then
- Put (S, "subtype \1 is\n", Id_Image (T));
- Indent (S, 2);
- Put (S, "\1", Id_Image (Type_Table (T).Parent));
+ Put (S, "subtype " & Id_Image (T) & " is" & LF);
+ Increase_Indent (S, 2);
+ Put (S, Id_Image (Type_Table (T).Parent));
if Enable_Assertions then
- Put (S, " with Predicate =>\n");
- Indent (S, 2);
- Put (S, "K (\1) in \2", Id_Image (T), Image (T));
- Outdent (S, 2);
+ Put (S, " with Predicate =>" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "K (" & Id_Image (T) & ") in " & Image (T));
+ Decrease_Indent (S, 2);
end if;
- Put (S, ";\n");
- Outdent (S, 2);
+ Put (S, ";" & LF);
+ Decrease_Indent (S, 2);
end if;
end Put_Id_Subtype;
case Root is
when Node_Kind =>
Put_Getter_Decl (S, Nkind);
- Put (S, "function K (N : Node_Id) return Node_Kind renames Nkind;\n");
- Put (S, "-- Shorthand for use in predicates and preconditions below\n");
- Put (S, "-- There is no procedure Set_Nkind.\n");
- Put (S, "-- See Init_Nkind and Mutate_Nkind in Atree.\n\n");
+ Put (S, "function K (N : Node_Id) return Node_Kind renames Nkind;" & LF);
+ Put (S, "-- Shorthand for use in predicates and preconditions below" & LF);
+ Put (S, "-- There is no procedure Set_Nkind." & LF);
+ Put (S, "-- See Init_Nkind and Mutate_Nkind in Atree." & LF & LF);
when Entity_Kind =>
Put_Getter_Decl (S, Ekind);
- Put (S, "function K (N : Entity_Id) return Entity_Kind renames Ekind;\n");
- Put (S, "-- Shorthand for use in predicates and preconditions below\n");
- Put (S, "-- There is no procedure Set_Ekind here.\n");
- Put (S, "-- See Mutate_Ekind in Atree.\n\n");
+ Put (S, "function K (N : Entity_Id) return Entity_Kind renames Ekind;" & LF);
+ Put (S, "-- Shorthand for use in predicates and preconditions below" & LF);
+ Put (S, "-- There is no procedure Set_Ekind here." & LF);
+ Put (S, "-- See Mutate_Ekind in Atree." & LF & LF);
when others => raise Program_Error;
end case;
- Put (S, "-- Subtypes of \1 for each abstract type:\n\n",
- Image (Root));
+ Put (S, "-- Subtypes of " & Image (Root) & " for each abstract type:" & LF & LF);
- Put (S, "pragma Style_Checks (""M200"");\n");
+ Put (S, "pragma Style_Checks (""M200"");" & LF);
Iterate_Types (Root, Pre => Put_Kind_Subtype'Access);
- Put (S, "\n-- Subtypes of \1 with specified \2.\n",
- Id_Image (Root), Image (Root));
- Put (S, "-- These may be used in place of \1 for better documentation,\n",
- Id_Image (Root));
- Put (S, "-- and if assertions are enabled, for run-time checking.\n\n");
+ Put (S, LF & "-- Subtypes of " & Id_Image (Root) &
+ " with specified " & Image (Root) & "." & LF);
+ Put (S, "-- These may be used in place of " & Id_Image (Root) &
+ " for better documentation," & LF);
+ Put (S, "-- and if assertions are enabled, for run-time checking." & LF & LF);
Iterate_Types (Root, Pre => Put_Id_Subtype'Access);
- Put (S, "\n");
- Put (S, "-- Union types (nonhierarchical subtypes of \1)\n\n",
- Id_Image (Root));
+ Put (S, LF & "-- Union types (nonhierarchical subtypes of " &
+ Id_Image (Root) & ")" & LF & LF);
for T in First_Abstract (Root) .. Last_Abstract (Root) loop
if Type_Table (T) /= null and then Type_Table (T).Is_Union then
Put_Kind_Subtype (T);
Put_Id_Subtype (T);
- Put (S, "\n");
end if;
end loop;
- Put (S, "subtype Flag is Boolean;\n\n");
+ Put (S, "subtype Flag is Boolean;" & LF & LF);
end Put_Type_And_Subtypes;
function Low_Level_Getter_Name (T : Type_Enum) return String is
-------------------------------------------
procedure Put_Low_Level_Accessor_Instantiations
- (S : in out Sink'Class; T : Type_Enum)
+ (S : in out Sink; T : Type_Enum)
is
begin
-- Special case for types that have defaults; instantiate
(if T = Elist_Id then "No_Elist" else "Uint_0");
begin
- Put (S, "\nfunction \1 is new Get_32_Bit_Field_With_Default (\2, \3) with \4;\n",
- Low_Level_Getter_Name (T),
- Get_Set_Id_Image (T),
- Default_Val,
- Inline);
+ Put (S, LF & "function " & Low_Level_Getter_Name (T) &
+ " is new Get_32_Bit_Field_With_Default (" &
+ Get_Set_Id_Image (T) & ", " & Default_Val &
+ ") with " & Inline & ";" & LF);
end;
-- Otherwise, instantiate the normal getter for the right size in
-- bits.
else
- Put (S, "\nfunction \1 is new Get_\2_Bit_Field (\3) with \4;\n",
- Low_Level_Getter_Name (T),
- Image (Field_Size (T)),
- Get_Set_Id_Image (T),
- Inline);
+ Put (S, LF & "function " & Low_Level_Getter_Name (T) &
+ " is new Get_" & Image (Field_Size (T)) & "_Bit_Field (" &
+ Get_Set_Id_Image (T) & ") with " & Inline & ";" & LF);
end if;
-- No special case for the setter
if T in Node_Kind_Type | Entity_Kind_Type then
- Put (S, "pragma Warnings (Off);\n");
+ Put (S, "pragma Warnings (Off);" & LF);
-- Set_Node_Kind_Type and Set_Entity_Kind_Type might not be called
end if;
- Put (S, "procedure \1 is new Set_\2_Bit_Field (\3) with \4;\n",
- Low_Level_Setter_Name (T),
- Image (Field_Size (T)),
- Get_Set_Id_Image (T),
- Inline);
+ Put (S, "procedure " & Low_Level_Setter_Name (T) & " is new Set_" &
+ Image (Field_Size (T)) & "_Bit_Field (" & Get_Set_Id_Image (T) &
+ ") with " & Inline & ";" & LF);
if T in Node_Kind_Type | Entity_Kind_Type then
- Put (S, "pragma Warnings (On);\n");
+ Put (S, "pragma Warnings (On);" & LF);
end if;
end Put_Low_Level_Accessor_Instantiations;
----------------------
procedure Put_Precondition
- (S : in out Sink'Class; F : Field_Enum)
+ (S : in out Sink; F : Field_Enum)
is
-- If the field is present in all entities, we want to assert that
-- N in N_Entity_Id. If the field is present in only some entities,
or else Field_Table (F).Have_This_Field = Nodes_And_Entities
then
if Is_Entity /= "" then
- Indent (S, 1);
- Put (S, ", Pre =>\n");
- Put (S, "\1", Is_Entity);
- Outdent (S, 1);
+ Increase_Indent (S, 1);
+ Put (S, ", Pre =>" & LF);
+ Put (S, Is_Entity);
+ Decrease_Indent (S, 1);
end if;
else
- Put (S, ", Pre =>\n");
- Indent (S, 1);
+ Put (S, ", Pre =>" & LF);
+ Increase_Indent (S, 1);
Put (S, "N in ");
Put_Type_Ids_With_Bars (S, Field_Table (F).Have_This_Field);
pragma Assert (Is_Entity = "");
- Outdent (S, 1);
+ Decrease_Indent (S, 1);
end if;
end if;
end Put_Precondition;
-- Put_Getter_Spec --
---------------------
- procedure Put_Getter_Spec (S : in out Sink'Class; F : Field_Enum) is
+ procedure Put_Getter_Spec (S : in out Sink; F : Field_Enum) is
begin
- Put (S, "function \1\n", Image (F));
- Indent (S, 2);
- Put (S, "(N : \1) return \2",
- N_Type (F), Get_Set_Id_Image (Field_Table (F).Field_Type));
- Outdent (S, 2);
+ Put (S, "function " & Image (F) & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(N : " & N_Type (F) & ") return " &
+ Get_Set_Id_Image (Field_Table (F).Field_Type));
+ Decrease_Indent (S, 2);
end Put_Getter_Spec;
---------------------
-- Put_Getter_Decl --
---------------------
- procedure Put_Getter_Decl (S : in out Sink'Class; F : Field_Enum) is
+ procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum) is
begin
Put_Getter_Spec (S, F);
- Put (S, " with \1", Inline);
- Indent (S, 2);
+ Put (S, " with " & Inline);
+ Increase_Indent (S, 2);
Put_Precondition (S, F);
- Outdent (S, 2);
- Put (S, ";\n");
+ Decrease_Indent (S, 2);
+ Put (S, ";" & LF);
end Put_Getter_Decl;
---------------------
-- Put_Getter_Body --
---------------------
- procedure Put_Getter_Body (S : in out Sink'Class; F : Field_Enum) is
+ procedure Put_Getter_Body (S : in out Sink; F : Field_Enum) is
Rec : Field_Info renames Field_Table (F).all;
begin
-- Note that we store the result in a local constant below, so that
-- and setter.
Put_Getter_Spec (S, F);
- Put (S, " is\n");
- Indent (S, 3);
- Put (S, "Val : constant \1 := \2 (\3, \4);\n",
- Get_Set_Id_Image (Rec.Field_Type),
- Low_Level_Getter_Name (Rec.Field_Type),
- Node_To_Fetch_From (F),
- Image (Rec.Offset));
- Outdent (S, 3);
- Put (S, "begin\n");
- Indent (S, 3);
+ Put (S, " is" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "Val : constant " & Get_Set_Id_Image (Rec.Field_Type) &
+ " := " & Low_Level_Getter_Name (Rec.Field_Type) &
+ " (" & Node_To_Fetch_From (F) & ", " &
+ Image (Rec.Offset) & ");" & LF);
+ Decrease_Indent (S, 3);
+ Put (S, "begin" & LF);
+ Increase_Indent (S, 3);
if Rec.Pre.all /= "" then
- Put (S, "pragma Assert (\1);\n", Rec.Pre.all);
+ Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
end if;
if Rec.Pre_Get.all /= "" then
- Put (S, "pragma Assert (\1);\n", Rec.Pre_Get.all);
+ Put (S, "pragma Assert (" & Rec.Pre_Get.all & ");" & LF);
end if;
- Put (S, "return Val;\n");
- Outdent (S, 3);
- Put (S, "end \1;\n\n", Image (F));
+ Put (S, "return Val;" & LF);
+ Decrease_Indent (S, 3);
+ Put (S, "end " & Image (F) & ";" & LF & LF);
end Put_Getter_Body;
---------------------
-- Put_Setter_Spec --
---------------------
- procedure Put_Setter_Spec (S : in out Sink'Class; F : Field_Enum) is
+ procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum) is
Rec : Field_Info renames Field_Table (F).all;
Default : constant String :=
(if Rec.Field_Type = Flag then " := True" else "");
begin
- Put (S, "procedure Set_\1\n", Image (F));
- Indent (S, 2);
- Put (S, "(N : \1; Val : \2\3)",
- N_Type (F), Get_Set_Id_Image (Rec.Field_Type),
- Default);
- Outdent (S, 2);
+ Put (S, "procedure Set_" & Image (F) & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(N : " & N_Type (F) & "; Val : " &
+ Get_Set_Id_Image (Rec.Field_Type) & Default & ")");
+ Decrease_Indent (S, 2);
end Put_Setter_Spec;
---------------------
-- Put_Setter_Decl --
---------------------
- procedure Put_Setter_Decl (S : in out Sink'Class; F : Field_Enum) is
+ procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum) is
begin
Put_Setter_Spec (S, F);
- Put (S, " with \1", Inline);
- Indent (S, 2);
+ Put (S, " with " & Inline);
+ Increase_Indent (S, 2);
Put_Precondition (S, F);
- Outdent (S, 2);
- Put (S, ";\n");
+ Decrease_Indent (S, 2);
+ Put (S, ";" & LF);
end Put_Setter_Decl;
---------------------
-- Put_Setter_Body --
---------------------
- procedure Put_Setter_Body (S : in out Sink'Class; F : Field_Enum) is
+ procedure Put_Setter_Body (S : in out Sink; F : Field_Enum) is
Rec : Field_Info renames Field_Table (F).all;
-- If Type_Only was specified in the call to Create_Semantic_Field,
"Is_Base_Type (N)");
begin
Put_Setter_Spec (S, F);
- Put (S, " is\n");
- Put (S, "begin\n");
- Indent (S, 3);
+ Put (S, " is" & LF);
+ Put (S, "begin" & LF);
+ Increase_Indent (S, 3);
if Rec.Pre.all /= "" then
- Put (S, "pragma Assert (\1);\n", Rec.Pre.all);
+ Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
end if;
if Rec.Pre_Set.all /= "" then
- Put (S, "pragma Assert (\1);\n", Rec.Pre_Set.all);
+ Put (S, "pragma Assert (" & Rec.Pre_Set.all & ");" & LF);
end if;
if Type_Only_Assertion /= "" then
- Put (S, "pragma Assert (\1);\n", Type_Only_Assertion);
+ Put (S, "pragma Assert (" & Type_Only_Assertion & ");" & LF);
end if;
- Put (S, "\1 (N, \2, Val);\n",
- Low_Level_Setter_Name (F),
- Image (Rec.Offset));
- Outdent (S, 3);
- Put (S, "end Set_\1;\n\n", Image (F));
+ Put (S, Low_Level_Setter_Name (F) & " (N, " & Image (Rec.Offset)
+ & ", Val);" & LF);
+ Decrease_Indent (S, 3);
+ Put (S, "end Set_" & Image (F) & ";" & LF & LF);
end Put_Setter_Body;
--------------------
-- Put_Subp_Decls --
--------------------
- procedure Put_Subp_Decls (S : in out Sink'Class; Root : Root_Type) is
+ procedure Put_Subp_Decls (S : in out Sink; Root : Root_Type) is
-- Note that there are several fields that are defined for both nodes
-- and entities, such as Nkind. These are allocated slots in both,
-- but here we only put out getters and setters in Sinfo.Nodes, not
-- Einfo.Entities.
begin
- Put (S, "-- Getters and setters for fields\n");
+ Put (S, "-- Getters and setters for fields" & LF);
for F in First_Field (Root) .. Last_Field (Root) loop
-- Nkind/Ekind getter is already done (see Put_Type_And_Subtypes),
-- and there is no setter for these.
if F = Nkind then
- Put (S, "\n-- Nkind getter is above\n");
+ Put (S, LF & "-- Nkind getter is above" & LF);
elsif F = Ekind then
- Put (S, "\n-- Ekind getter is above\n");
+ Put (S, LF & "-- Ekind getter is above" & LF);
else
Put_Getter_Decl (S, F);
Put_Setter_Decl (S, F);
end if;
- Put (S, "\n");
+ Put (S, LF);
end loop;
end Put_Subp_Decls;
-- Put_Subp_Bodies --
---------------------
- procedure Put_Subp_Bodies (S : in out Sink'Class; Root : Root_Type) is
+ procedure Put_Subp_Bodies (S : in out Sink; Root : Root_Type) is
begin
- Put (S, "\n-- Getters and setters for fields\n\n");
+ Put (S, LF & "-- Getters and setters for fields" & LF & LF);
for F in First_Field (Root) .. Last_Field (Root) loop
Put_Getter_Body (S, F);
-- Put_Traversed_Fields --
--------------------------
- procedure Put_Traversed_Fields (S : in out Sink'Class) is
+ procedure Put_Traversed_Fields (S : in out Sink) is
function Is_Traversed_Field
(T : Concrete_Node; F : Field_Enum) return Boolean;
if First_Time then
First_Time := False;
else
- Put (S, ",\n");
+ Put (S, "," & LF);
end if;
- Put (S, "\1 => (", Image (T));
- Indent (S, 2);
+ Put (S, Image (T) & " => (");
+ Increase_Indent (S, 2);
for FI in 1 .. Last_Index (Type_Table (T).Fields) loop
declare
Left_Opnd_Skipped := True; -- see comment below
else
- Put (S, "\1, ", Image (Field_Table (F).Offset));
+ Put (S, Image (Field_Table (F).Offset) & ", ");
end if;
end if;
end;
-- that.
if Left_Opnd_Skipped then
- Put (S, "\1, ", Image (Field_Table (Left_Opnd).Offset));
+ Put (S, Image (Field_Table (Left_Opnd).Offset) & ", ");
end if;
Put (S, "others => No_Field_Offset");
- Outdent (S, 2);
+ Decrease_Indent (S, 2);
Put (S, ")");
end if;
end Put_Aggregate;
Init_Max_Traversed_Fields;
begin
- Put (S, "-- Table of fields that should be traversed by Traverse subprograms.\n");
- Put (S, "-- Each entry is an array of offsets in slots of fields to be\n");
- Put (S, "-- traversed, terminated by a sentinel equal to No_Field_Offset.\n\n");
+ Put (S, "-- Table of fields that should be traversed by Traverse subprograms." & LF);
+ Put (S, "-- Each entry is an array of offsets in slots of fields to be" & LF);
+ Put (S, "-- traversed, terminated by a sentinel equal to No_Field_Offset." & LF & LF);
- Put (S, "subtype Traversed_Offset_Array is Offset_Array (0 .. \1 + 1);\n",
- Image (Max_Traversed_Fields - 1));
- Put (S, "Traversed_Fields : constant array (Node_Kind) of Traversed_Offset_Array :=\n");
+ Put (S, "subtype Traversed_Offset_Array is Offset_Array (0 .. " &
+ Image (Max_Traversed_Fields - 1) & " + 1);" & LF);
+ Put (S, "Traversed_Fields : constant array (Node_Kind) of Traversed_Offset_Array :=" & LF);
-- One extra for the sentinel
- Indent (S, 2);
+ Increase_Indent (S, 2);
Put (S, "(");
- Indent (S, 1);
+ Increase_Indent (S, 1);
Iterate_Types (Node_Kind, Pre => Put_Aggregate'Access);
- Outdent (S, 1);
- Put (S, ");\n\n");
- Outdent (S, 2);
+ Decrease_Indent (S, 1);
+ Put (S, ");" & LF & LF);
+ Decrease_Indent (S, 2);
end Put_Traversed_Fields;
----------------
-- Put_Tables --
----------------
- procedure Put_Tables (S : in out Sink'Class; Root : Root_Type) is
+ procedure Put_Tables (S : in out Sink; Root : Root_Type) is
First_Time : Boolean := True;
if First_Time then
First_Time := False;
else
- Put (S, ",\n");
+ Put (S, "," & LF);
end if;
- Put (S, "\1 => \2", Image (T), Image (Type_Size_In_Slots (T)));
+ Put (S, Image (T) & " => " & Image (Type_Size_In_Slots (T)));
end if;
end Put_Size;
if First_Time then
First_Time := False;
else
- Put (S, ",\n");
+ Put (S, "," & LF);
end if;
- Put (S, "\1", F_Image (F));
+ Put (S, F_Image (F));
end if;
end loop;
end Put_Field_Array;
when others => "Entity_Field"); -- Entity_Kind
begin
- Put (S, "-- Table of sizes in 32-bit slots for given \1, for use by Atree:\n",
- Image (Root));
+ Put (S, "-- Table of sizes in 32-bit slots for given " &
+ Image (Root) & ", for use by Atree:" & LF);
case Root is
when Node_Kind =>
- Put (S, "\nMin_Node_Size : constant Field_Offset := \1;\n",
- Image (Min_Node_Size));
- Put (S, "Max_Node_Size : constant Field_Offset := \1;\n\n",
- Image (Max_Node_Size));
- Put (S, "Average_Node_Size_In_Slots : constant := \1;\n\n",
- Average_Node_Size_In_Slots'Img);
+ Put (S, LF & "Min_Node_Size : constant Field_Offset := " &
+ Image (Min_Node_Size) & ";" & LF);
+ Put (S, "Max_Node_Size : constant Field_Offset := " &
+ Image (Max_Node_Size) & ";" & LF & LF);
+ Put (S, "Average_Node_Size_In_Slots : constant := " &
+ Average_Node_Size_In_Slots'Img & ";" & LF & LF);
when Entity_Kind =>
- Put (S, "\nMin_Entity_Size : constant Field_Offset := \1;\n",
- Image (Min_Entity_Size));
- Put (S, "Max_Entity_Size : constant Field_Offset := \1;\n\n",
- Image (Max_Entity_Size));
+ Put (S, LF & "Min_Entity_Size : constant Field_Offset := " &
+ Image (Min_Entity_Size) & ";" & LF);
+ Put (S, "Max_Entity_Size : constant Field_Offset := " &
+ Image (Max_Entity_Size) & ";" & LF & LF);
when others => raise Program_Error;
end case;
- Put (S, "Size : constant array (\1) of Field_Offset :=\n", Image (Root));
- Indent (S, 2);
+ Put (S, "Size : constant array (" & Image (Root) &
+ ") of Field_Offset :=" & LF);
+ Increase_Indent (S, 2);
Put (S, "(");
- Indent (S, 1);
+ Increase_Indent (S, 1);
Iterate_Types (Root, Pre => Put_Size'Access);
- Outdent (S, 1);
- Put (S, "); -- Size\n");
- Outdent (S, 2);
+ Decrease_Indent (S, 1);
+ Put (S, "); -- Size" & LF);
+ Decrease_Indent (S, 2);
declare
type Dummy is array
Num_Fields : constant Root_Int := Dummy'Length;
First_Time : Boolean := True;
begin
- Put (S, "\n-- Enumeration of all \1 fields:\n\n",
- Image (Num_Fields));
+ Put (S, LF & "-- Enumeration of all " & Image (Num_Fields)
+ & " fields:" & LF & LF);
- Put (S, "type \1 is\n", Field_Enum_Type_Name);
- Indent (S, 2);
+ Put (S, "type " & Field_Enum_Type_Name & " is" & LF);
+ Increase_Indent (S, 2);
Put (S, "(");
- Indent (S, 1);
+ Increase_Indent (S, 1);
for F in First_Field (Root) .. Last_Field (Root) loop
if First_Time then
First_Time := False;
else
- Put (S, ",\n");
+ Put (S, "," & LF);
end if;
- Put (S, "\1", F_Image (F));
+ Put (S, F_Image (F));
end loop;
- Outdent (S, 1);
- Put (S, "); -- \1\n", Field_Enum_Type_Name);
- Outdent (S, 2);
+ Decrease_Indent (S, 1);
+ Put (S, "); -- " & Field_Enum_Type_Name & LF);
+ Decrease_Indent (S, 2);
end;
- Put (S, "\ntype \1_Index is new Pos;\n", Field_Enum_Type_Name);
- Put (S, "type \1_Array is array (\1_Index range <>) of \1;\n",
- Field_Enum_Type_Name);
- Put (S, "type \1_Array_Ref is access constant \1_Array;\n",
- Field_Enum_Type_Name);
- Put (S, "subtype A is \1_Array;\n", Field_Enum_Type_Name);
+ Put (S, LF & "type " & Field_Enum_Type_Name & "_Index is new Pos;" & LF);
+ Put (S, "type " & Field_Enum_Type_Name & "_Array is array (" &
+ Field_Enum_Type_Name & "_Index range <>) of " &
+ Field_Enum_Type_Name & ";" & LF);
+ Put (S, "type " & Field_Enum_Type_Name &
+ "_Array_Ref is access constant " & Field_Enum_Type_Name &
+ "_Array;" & LF);
+ Put (S, "subtype A is " & Field_Enum_Type_Name & "_Array;" & LF);
-- Short name to make allocators below more readable
declare
if First_Time then
First_Time := False;
else
- Put (S, ",\n");
+ Put (S, "," & LF);
end if;
- Put (S, "\1 =>\n", Image (T));
- Indent (S, 2);
+ Put (S, Image (T) & " =>" & LF);
+ Increase_Indent (S, 2);
Put (S, "new A'(");
- Indent (S, 6);
- Indent (S, 1);
+ Increase_Indent (S, 6);
+ Increase_Indent (S, 1);
Put_Field_Array (T);
- Outdent (S, 1);
+ Decrease_Indent (S, 1);
Put (S, ")");
- Outdent (S, 6);
- Outdent (S, 2);
+ Decrease_Indent (S, 6);
+ Decrease_Indent (S, 2);
end if;
end Do_One_Type;
begin
- Put (S, "\n-- Table mapping \1s to the sequence of fields that exist in that \1:\n\n",
- Image (Root));
+ Put (S, LF & "-- Table mapping " & Image (Root) &
+ "s to the sequence of fields that exist in that " &
+ Image (Root) & ":" & LF & LF);
- Put (S, "\1_Table : constant array (\2) of \1_Array_Ref :=\n",
- Field_Enum_Type_Name, Image (Root));
+ Put (S, Field_Enum_Type_Name & "_Table : constant array (" &
+ Image (Root) & ") of " & Field_Enum_Type_Name &
+ "_Array_Ref :=" & LF);
- Indent (S, 2);
+ Increase_Indent (S, 2);
Put (S, "(");
- Indent (S, 1);
+ Increase_Indent (S, 1);
Iterate_Types (Root, Pre => Do_One_Type'Access);
- Outdent (S, 1);
- Put (S, "); -- \1_Table\n", Field_Enum_Type_Name);
- Outdent (S, 2);
+ Decrease_Indent (S, 1);
+ Put (S, "); -- " & Field_Enum_Type_Name & "_Table" & LF);
+ Decrease_Indent (S, 2);
end;
declare
First_Time : Boolean := True;
begin
- Put (S, "\n-- Table mapping fields to kind and offset:\n\n");
+ Put (S, LF & "-- Table mapping fields to kind and offset:" & LF & LF);
- Put (S, "\1_Descriptors : constant array (\1) of Field_Descriptor :=\n",
- Field_Enum_Type_Name);
+ Put (S, Field_Enum_Type_Name & "_Descriptors : constant array (" &
+ Field_Enum_Type_Name & ") of Field_Descriptor :=" & LF);
- Indent (S, 2);
+ Increase_Indent (S, 2);
Put (S, "(");
- Indent (S, 1);
+ Increase_Indent (S, 1);
for F in First_Field (Root) .. Last_Field (Root) loop
if First_Time then
First_Time := False;
else
- Put (S, ",\n");
+ Put (S, "," & LF);
end if;
- Put (S, "\1 => (\2_Field, \3)", F_Image (F),
- Image (Field_Table (F).Field_Type), Image (Field_Table (F).Offset));
+ Put (S, F_Image (F) & " => (" &
+ Image (Field_Table (F).Field_Type) & "_Field, " &
+ Image (Field_Table (F).Offset) & ")");
end loop;
- Outdent (S, 1);
- Put (S, "); -- Field_Descriptors\n");
- Outdent (S, 2);
+ Decrease_Indent (S, 1);
+ Put (S, "); -- Field_Descriptors" & LF);
+ Decrease_Indent (S, 2);
end;
end Put_Tables;
----------------
procedure Put_Seinfo is
- S : Sink'Class := Create_File ("seinfo.ads");
+ S : Sink;
begin
- Put (S, "with Types; use Types;\n");
- Put (S, "\npackage Seinfo is\n\n");
- Indent (S, 3);
+ Create_File (S, "seinfo.ads");
+ Put (S, "with Types; use Types;" & LF);
+ Put (S, LF & "package Seinfo is" & LF & LF);
+ Increase_Indent (S, 3);
- Put (S, "-- This package is automatically generated.\n\n");
+ Put (S, "-- This package is automatically generated." & LF & LF);
- Put (S, "-- Common declarations visible in both Sinfo.Nodes and Einfo.Entities.\n");
+ Put (S, "-- Common declarations visible in both Sinfo.Nodes and Einfo.Entities." & LF);
- Put (S, "\ntype Field_Kind is\n");
- Indent (S, 2);
+ Put (S, LF & "type Field_Kind is" & LF);
+ Increase_Indent (S, 2);
Put (S, "(");
- Indent (S, 1);
+ Increase_Indent (S, 1);
declare
First_Time : Boolean := True;
if First_Time then
First_Time := False;
else
- Put (S, ",\n");
+ Put (S, "," & LF);
end if;
- Put (S, "\1_Field", Image (T));
+ Put (S, Image (T) & "_Field");
end loop;
end;
- Outdent (S, 1);
- Outdent (S, 2);
- Put (S, ");\n");
+ Decrease_Indent (S, 1);
+ Decrease_Indent (S, 2);
+ Put (S, ");" & LF);
- Put (S, "\nField_Size : constant array (Field_Kind) of Field_Size_In_Bits :=\n");
- Indent (S, 2);
+ Put (S, LF & "Field_Size : constant array (Field_Kind) of Field_Size_In_Bits :=" & LF);
+ Increase_Indent (S, 2);
Put (S, "(");
- Indent (S, 1);
+ Increase_Indent (S, 1);
declare
First_Time : Boolean := True;
if First_Time then
First_Time := False;
else
- Put (S, ",\n");
+ Put (S, "," & LF);
end if;
- Put (S, "\1_Field => \2", Image (T), Image (Field_Size (T)));
+ Put (S, Image (T) & "_Field => " & Image (Field_Size (T)));
end loop;
end;
- Outdent (S, 1);
- Outdent (S, 2);
- Put (S, ");\n\n");
+ Decrease_Indent (S, 1);
+ Decrease_Indent (S, 2);
+ Put (S, ");" & LF & LF);
- Put (S, "type Field_Descriptor is record\n");
- Indent (S, 3);
- Put (S, "Kind : Field_Kind;\n");
- Put (S, "Offset : Field_Offset;\n");
- Outdent (S, 3);
- Put (S, "end record;\n");
+ Put (S, "type Field_Descriptor is record" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "Kind : Field_Kind;" & LF);
+ Put (S, "Offset : Field_Offset;" & LF);
+ Decrease_Indent (S, 3);
+ Put (S, "end record;" & LF);
- Outdent (S, 3);
- Put (S, "\nend Seinfo;\n");
+ Decrease_Indent (S, 3);
+ Put (S, LF & "end Seinfo;" & LF);
end Put_Seinfo;
---------------
---------------
procedure Put_Nodes is
- S : Sink'Class := Create_File ("sinfo-nodes.ads");
- B : Sink'Class := Create_File ("sinfo-nodes.adb");
+ S : Sink;
+ B : Sink;
procedure Put_Setter_With_Parent (Kind : String);
-- Put the low-level ..._With_Parent setter. Kind is either "Node" or
procedure Put_Setter_With_Parent (Kind : String) is
Error : constant String := (if Kind = "Node" then "" else "_" & Kind);
begin
- Put (B, "\nprocedure Set_\1_Id_With_Parent\n", Kind);
- Indent (B, 2);
- Put (B, "(N : Node_Id; Offset : Field_Offset; Val : \1_Id);\n\n", Kind);
- Outdent (B, 2);
-
- Put (B, "procedure Set_\1_Id_With_Parent\n", Kind);
- Indent (B, 2);
- Put (B, "(N : Node_Id; Offset : Field_Offset; Val : \1_Id) is\n", Kind);
- Outdent (B, 2);
- Put (B, "begin\n");
- Indent (B, 3);
- Put (B, "if Present (Val) and then Val /= Error\1 then\n", Error);
- Indent (B, 3);
- Put (B, "pragma Warnings (Off, ""actuals for this call may be in wrong order"");\n");
- Put (B, "Set_Parent (Val, N);\n");
- Put (B, "pragma Warnings (On, ""actuals for this call may be in wrong order"");\n");
- Outdent (B, 3);
- Put (B, "end if;\n\n");
-
- Put (B, "Set_\1_Id (N, Offset, Val);\n", Kind);
- Outdent (B, 3);
- Put (B, "end Set_\1_Id_With_Parent;\n", Kind);
+ Put (B, LF & "procedure Set_" & Kind & "_Id_With_Parent" & LF);
+ Increase_Indent (B, 2);
+ Put (B, "(N : Node_Id; Offset : Field_Offset; Val : " & Kind & "_Id);" & LF & LF);
+ Decrease_Indent (B, 2);
+
+ Put (B, "procedure Set_" & Kind & "_Id_With_Parent" & LF);
+ Increase_Indent (B, 2);
+ Put (B, "(N : Node_Id; Offset : Field_Offset; Val : " & Kind & "_Id) is" & LF);
+ Decrease_Indent (B, 2);
+ Put (B, "begin" & LF);
+ Increase_Indent (B, 3);
+ Put (B, "if Present (Val) and then Val /= Error" & Error & " then" & LF);
+ Increase_Indent (B, 3);
+ Put (B, "pragma Warnings (Off, ""actuals for this call may be in wrong order"");" & LF);
+ Put (B, "Set_Parent (Val, N);" & LF);
+ Put (B, "pragma Warnings (On, ""actuals for this call may be in wrong order"");" & LF);
+ Decrease_Indent (B, 3);
+ Put (B, "end if;" & LF & LF);
+
+ Put (B, "Set_" & Kind & "_Id (N, Offset, Val);" & LF);
+ Decrease_Indent (B, 3);
+ Put (B, "end Set_" & Kind & "_Id_With_Parent;" & LF);
end Put_Setter_With_Parent;
-- Start of processing for Put_Nodes
begin
- Put (S, "with Seinfo; use Seinfo;\n");
- Put (S, "pragma Warnings (Off);\n");
+ Create_File (S, "sinfo-nodes.ads");
+ Create_File (B, "sinfo-nodes.adb");
+ Put (S, "with Seinfo; use Seinfo;" & LF);
+ Put (S, "pragma Warnings (Off);" & LF);
-- With's included in case they are needed; so we don't have to keep
-- switching back and forth.
- Put (S, "with Output; use Output;\n");
- Put (S, "pragma Warnings (On);\n");
+ Put (S, "with Output; use Output;" & LF);
+ Put (S, "pragma Warnings (On);" & LF);
- Put (S, "\npackage Sinfo.Nodes is\n\n");
- Indent (S, 3);
+ Put (S, LF & "package Sinfo.Nodes is" & LF & LF);
+ Increase_Indent (S, 3);
- Put (S, "-- This package is automatically generated.\n\n");
+ Put (S, "-- This package is automatically generated." & LF & LF);
Put_Type_Hierarchy (S, Node_Kind);
Put_Type_And_Subtypes (S, Node_Kind);
- Put (S, "pragma Assert (Node_Kind'Pos (N_Unused_At_Start) = 0);\n\n");
- Put (S, "pragma Assert (Node_Kind'Last = N_Unused_At_End);\n\n");
+ Put (S, "pragma Assert (Node_Kind'Pos (N_Unused_At_Start) = 0);" & LF & LF);
+ Put (S, "pragma Assert (Node_Kind'Last = N_Unused_At_End);" & LF & LF);
Put_Subp_Decls (S, Node_Kind);
Put_Tables (S, Node_Kind);
- Outdent (S, 3);
- Put (S, "\nend Sinfo.Nodes;\n");
+ Decrease_Indent (S, 3);
+ Put (S, LF & "end Sinfo.Nodes;" & LF);
- Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;\n");
- Put (B, "with Nlists; use Nlists;\n");
- Put (B, "pragma Warnings (Off);\n");
- Put (B, "with Einfo.Utils; use Einfo.Utils;\n");
- Put (B, "pragma Warnings (On);\n");
+ Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
+ Put (B, "with Nlists; use Nlists;" & LF);
+ Put (B, "pragma Warnings (Off);" & LF);
+ Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF);
+ Put (B, "pragma Warnings (On);" & LF);
- Put (B, "\npackage body Sinfo.Nodes is\n\n");
- Indent (B, 3);
+ Put (B, LF & "package body Sinfo.Nodes is" & LF & LF);
+ Increase_Indent (B, 3);
- Put (B, "-- This package is automatically generated.\n\n");
+ Put (B, "-- This package is automatically generated." & LF & LF);
- Put (B, "-- Instantiations of low-level getters and setters that take offsets\n");
- Put (B, "-- in units of the size of the field.\n");
+ Put (B, "-- Instantiations of low-level getters and setters that take offsets" & LF);
+ Put (B, "-- in units of the size of the field." & LF);
- Put (B, "pragma Style_Checks (""M200"");\n");
+ Put (B, "pragma Style_Checks (""M200"");" & LF);
for T in Special_Type loop
if Node_Field_Types_Used (T) then
Put_Low_Level_Accessor_Instantiations (B, T);
Put_Subp_Bodies (B, Node_Kind);
- Outdent (B, 3);
- Put (B, "end Sinfo.Nodes;\n");
+ Decrease_Indent (B, 3);
+ Put (B, "end Sinfo.Nodes;" & LF);
end Put_Nodes;
------------------
procedure Put_Entities is
- S : Sink'Class := Create_File ("einfo-entities.ads");
- B : Sink'Class := Create_File ("einfo-entities.adb");
+ S : Sink;
+ B : Sink;
begin
- Put (S, "with Seinfo; use Seinfo;\n");
- Put (S, "with Sinfo.Nodes; use Sinfo.Nodes;\n");
+ Create_File (S, "einfo-entities.ads");
+ Create_File (B, "einfo-entities.adb");
+ Put (S, "with Seinfo; use Seinfo;" & LF);
+ Put (S, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF);
- Put (S, "\npackage Einfo.Entities is\n\n");
- Indent (S, 3);
+ Put (S, LF & "package Einfo.Entities is" & LF & LF);
+ Increase_Indent (S, 3);
- Put (S, "-- This package is automatically generated.\n\n");
+ Put (S, "-- This package is automatically generated." & LF & LF);
Put_Type_Hierarchy (S, Entity_Kind);
Put_Tables (S, Entity_Kind);
- Outdent (S, 3);
- Put (S, "\nend Einfo.Entities;\n");
+ Decrease_Indent (S, 3);
+ Put (S, LF & "end Einfo.Entities;" & LF);
- Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;\n");
- Put (B, "with Einfo.Utils; use Einfo.Utils;\n");
+ Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
+ Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF);
-- This forms a cycle between packages (via bodies, which is OK)
- Put (B, "\npackage body Einfo.Entities is\n\n");
- Indent (B, 3);
+ Put (B, LF & "package body Einfo.Entities is" & LF & LF);
+ Increase_Indent (B, 3);
- Put (B, "-- This package is automatically generated.\n\n");
+ Put (B, "-- This package is automatically generated." & LF & LF);
- Put (B, "-- Instantiations of low-level getters and setters that take offsets\n");
- Put (B, "-- in units of the size of the field.\n");
+ Put (B, "-- Instantiations of low-level getters and setters that take offsets" & LF);
+ Put (B, "-- in units of the size of the field." & LF);
- Put (B, "pragma Style_Checks (""M200"");\n");
+ Put (B, "pragma Style_Checks (""M200"");" & LF);
for T in Special_Type loop
if Entity_Field_Types_Used (T) then
Put_Low_Level_Accessor_Instantiations (B, T);
Put_Subp_Bodies (B, Entity_Kind);
- Outdent (B, 3);
- Put (B, "end Einfo.Entities;\n");
+ Decrease_Indent (B, 3);
+ Put (B, "end Einfo.Entities;" & LF);
end Put_Entities;
-------------------
procedure Put_Make_Spec
- (S : in out Sink'Class; Root : Root_Type; T : Concrete_Type)
+ (S : in out Sink; Root : Root_Type; T : Concrete_Type)
is
begin
- Put (S, "function Make_\1\n", Image_Sans_N (T));
- Indent (S, 2);
+ Put (S, "function Make_" & Image_Sans_N (T) & "" & LF);
+ Increase_Indent (S, 2);
Put (S, "(Sloc : Source_Ptr");
- Indent (S, 1);
+ Increase_Indent (S, 1);
for F of Type_Table (T).Fields loop
pragma Assert (Fields_Per_Node (T) (F));
else " := " & Value_Image (Field_Table (F).Default_Value));
begin
- Put (S, ";\n");
- Put (S, "\1", Image (F));
- Put (S, " : \1\2", Typ, Default);
+ Put (S, ";" & LF);
+ Put (S, Image (F));
+ Put (S, " : " & Typ & Default);
end;
end if;
end loop;
- Put (S, ")\nreturn \1_Id", Node_Or_Entity (Root));
- Outdent (S, 2);
- Outdent (S, 1);
+ Put (S, ")" & LF & "return " & Node_Or_Entity (Root) & "_Id");
+ Decrease_Indent (S, 2);
+ Decrease_Indent (S, 1);
end Put_Make_Spec;
--------------------
-- Put_Make_Decls --
--------------------
- procedure Put_Make_Decls (S : in out Sink'Class; Root : Root_Type) is
+ procedure Put_Make_Decls (S : in out Sink; Root : Root_Type) is
begin
for T in First_Concrete (Root) .. Last_Concrete (Root) loop
if T not in N_Unused_At_Start | N_Unused_At_End then
Put_Make_Spec (S, Root, T);
- Put (S, ";\npragma \1 (Make_\2);\n\n", Inline, Image_Sans_N (T));
+ Put (S, ";" & LF & "pragma " & Inline & " (Make_" &
+ Image_Sans_N (T) & ");" & LF & LF);
end if;
end loop;
end Put_Make_Decls;
-- Put_Make_Bodies --
---------------------
- procedure Put_Make_Bodies (S : in out Sink'Class; Root : Root_Type) is
+ procedure Put_Make_Bodies (S : in out Sink; Root : Root_Type) is
begin
for T in First_Concrete (Root) .. Last_Concrete (Root) loop
if T not in N_Unused_At_Start | N_Unused_At_End then
Put_Make_Spec (S, Root, T);
- Put (S, "\nis\n");
+ Put (S, LF & "is" & LF);
- Indent (S, 3);
- Put (S, "N : constant Node_Id :=\n");
+ Increase_Indent (S, 3);
+ Put (S, "N : constant Node_Id :=" & LF);
if T in Entity_Node then
- Put (S, " New_Entity (\1, Sloc);\n", Image (T));
+ Put (S, " New_Entity (" & Image (T) & ", Sloc);" & LF);
else
- Put (S, " New_Node (\1, Sloc);\n", Image (T));
+ Put (S, " New_Node (" & Image (T) & ", Sloc);" & LF);
end if;
- Outdent (S, 3);
+ Decrease_Indent (S, 3);
- Put (S, "begin\n");
+ Put (S, "begin" & LF);
- Indent (S, 3);
+ Increase_Indent (S, 3);
for F of Type_Table (T).Fields loop
pragma Assert (Fields_Per_Node (T) (F));
begin
if F_Name'Length < NWidth then
- Put (S, "Set_\1 (N, \1);\n", F_Name);
+ Put (S, "Set_" & F_Name & " (N, " & F_Name & ");" & LF);
-- Wrap the line
else
- Put (S, "Set_\1\n", F_Name);
- Indent (S, 2);
- Put (S, "(N, \1);\n", F_Name);
- Outdent (S, 2);
+ Put (S, "Set_" & F_Name & "" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(N, " & F_Name & ");" & LF);
+ Decrease_Indent (S, 2);
end if;
end;
end if;
-- "Op_", but the Name_Id constant does not.
begin
- Put (S, "Set_Chars (N, Name_\1);\n", Op_Name);
- Put (S, "Set_Entity (N, Standard_\1);\n", Op);
+ Put (S, "Set_Chars (N, Name_" & Op_Name & ");" & LF);
+ Put (S, "Set_Entity (N, Standard_" & Op & ");" & LF);
end;
end if;
- Put (S, "return N;\n");
- Outdent (S, 3);
+ Put (S, "return N;" & LF);
+ Decrease_Indent (S, 3);
- Put (S, "end Make_\1;\n\n", Image_Sans_N (T));
+ Put (S, "end Make_" & Image_Sans_N (T) & ";" & LF & LF);
end if;
end loop;
end Put_Make_Bodies;
-- argument can have side effects (e.g. be a call to a parse routine).
procedure Put_Nmake is
- S : Sink'Class := Create_File ("nmake.ads");
- B : Sink'Class := Create_File ("nmake.adb");
+ S : Sink;
+ B : Sink;
begin
- Put (S, "with Namet; use Namet;\n");
- Put (S, "with Nlists; use Nlists;\n");
- Put (S, "with Types; use Types;\n");
- Put (S, "with Uintp; use Uintp;\n");
- Put (S, "with Urealp; use Urealp;\n");
+ Create_File (S, "nmake.ads");
+ Create_File (B, "nmake.adb");
+ Put (S, "with Namet; use Namet;" & LF);
+ Put (S, "with Nlists; use Nlists;" & LF);
+ Put (S, "with Types; use Types;" & LF);
+ Put (S, "with Uintp; use Uintp;" & LF);
+ Put (S, "with Urealp; use Urealp;" & LF);
- Put (S, "\npackage Nmake is\n\n");
- Indent (S, 3);
+ Put (S, LF & "package Nmake is" & LF & LF);
+ Increase_Indent (S, 3);
- Put (S, "-- This package is automatically generated.\n\n");
- Put (S, "-- See Put_Nmake in gen_il-gen.adb for documentation.\n\n");
+ Put (S, "-- This package is automatically generated." & LF & LF);
+ Put (S, "-- See Put_Nmake in gen_il-gen.adb for documentation." & LF & LF);
Put_Make_Decls (S, Node_Kind);
- Outdent (S, 3);
- Put (S, "end Nmake;\n");
+ Decrease_Indent (S, 3);
+ Put (S, "end Nmake;" & LF);
- Put (B, "with Atree; use Atree;\n");
- Put (B, "with Sinfo.Nodes; use Sinfo.Nodes;\n");
- Put (B, "with Sinfo.Utils; use Sinfo.Utils;\n");
- Put (B, "with Snames; use Snames;\n");
- Put (B, "with Stand; use Stand;\n");
+ Put (B, "with Atree; use Atree;" & LF);
+ Put (B, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF);
+ Put (B, "with Sinfo.Utils; use Sinfo.Utils;" & LF);
+ Put (B, "with Snames; use Snames;" & LF);
+ Put (B, "with Stand; use Stand;" & LF);
- Put (B, "\npackage body Nmake is\n\n");
- Indent (B, 3);
+ Put (B, LF & "package body Nmake is" & LF & LF);
+ Increase_Indent (B, 3);
- Put (B, "-- This package is automatically generated.\n\n");
+ Put (B, "-- This package is automatically generated." & LF & LF);
Put_Make_Bodies (B, Node_Kind);
- Outdent (B, 3);
- Put (B, "end Nmake;\n");
+ Decrease_Indent (B, 3);
+ Put (B, "end Nmake;" & LF);
end Put_Nmake;
-----------------------
-----------------------
procedure Put_Seinfo_Tables is
- S : Sink'Class := Create_File ("seinfo_tables.ads");
- B : Sink'Class := Create_File ("seinfo_tables.adb");
+ S : Sink;
+ B : Sink;
Type_Layout : Concrete_Type_Layout_Array;
if First_Time then
First_Time := False;
else
- Put (B, ",\n");
+ Put (B, "," & LF);
end if;
- Put (B, "\1", Image (F));
+ Put (B, Image (F));
end if;
end loop;
end Put_Field_List;
begin -- Put_Seinfo_Tables
+ Create_File (S, "seinfo_tables.ads");
+ Create_File (B, "seinfo_tables.adb");
for T in Concrete_Type loop
Type_Layout (T) := new Field_Array'
end loop;
end loop;
- Put (S, "\npackage Seinfo_Tables is\n\n");
- Indent (S, 3);
+ Put (S, LF & "package Seinfo_Tables is" & LF & LF);
+ Increase_Indent (S, 3);
- Put (S, "-- This package is automatically generated.\n\n");
+ Put (S, "-- This package is automatically generated." & LF & LF);
- Put (S, "-- This package is not used by the compiler.\n");
- Put (S, "-- The body contains tables that are intended to be used by humans to\n");
- Put (S, "-- help understand the layout of various data structures.\n\n");
+ Put (S, "-- This package is not used by the compiler." & LF);
+ Put (S, "-- The body contains tables that are intended to be used by humans to" & LF);
+ Put (S, "-- help understand the layout of various data structures." & LF & LF);
- Put (S, "pragma Elaborate_Body;\n");
+ Put (S, "pragma Elaborate_Body;" & LF);
- Outdent (S, 3);
- Put (S, "\nend Seinfo_Tables;\n");
+ Decrease_Indent (S, 3);
+ Put (S, LF & "end Seinfo_Tables;" & LF);
- Put (B, "with Gen_IL.Types; use Gen_IL.Types;\n");
- Put (B, "with Gen_IL.Fields; use Gen_IL.Fields;\n");
- Put (B, "with Gen_IL.Internals; use Gen_IL.Internals;\n");
+ Put (B, "with Gen_IL.Types; use Gen_IL.Types;" & LF);
+ Put (B, "with Gen_IL.Fields; use Gen_IL.Fields;" & LF);
+ Put (B, "with Gen_IL.Internals; use Gen_IL.Internals;" & LF);
- Put (B, "\npackage body Seinfo_Tables is\n\n");
- Indent (B, 3);
+ Put (B, LF & "package body Seinfo_Tables is" & LF & LF);
+ Increase_Indent (B, 3);
- Put (B, "-- This package is automatically generated.\n\n");
+ Put (B, "-- This package is automatically generated." & LF & LF);
- Put (B, "Num_Wasted_Bits : Bit_Offset'Base := \1 with Unreferenced;\n",
- Image (Num_Wasted_Bits));
+ Put (B, "Num_Wasted_Bits : Bit_Offset'Base := " & Image (Num_Wasted_Bits) &
+ " with Unreferenced;" & LF);
- Put (B, "\nWasted_Bits : constant Opt_Field_Enum := No_Field;\n");
+ Put (B, LF & "Wasted_Bits : constant Opt_Field_Enum := No_Field;" & LF);
- Put (B, "\n-- Table showing the layout of each Node_Or_Entity_Type. For each\n");
- Put (B, "-- concrete type, we show the bits used by each field. Each field\n");
- Put (B, "-- uses the same bit range in all types. This table is not used by\n");
- Put (B, "-- the compiler; it is for information only.\n\n");
+ Put (B, LF & "-- Table showing the layout of each Node_Or_Entity_Type. For each" & LF);
+ Put (B, "-- concrete type, we show the bits used by each field. Each field" & LF);
+ Put (B, "-- uses the same bit range in all types. This table is not used by" & LF);
+ Put (B, "-- the compiler; it is for information only." & LF & LF);
- Put (B, "-- Wasted_Bits are unused bits between fields, and padding at the end\n");
- Put (B, "-- to round up to a multiple of the slot size.\n");
+ Put (B, "-- Wasted_Bits are unused bits between fields, and padding at the end" & LF);
+ Put (B, "-- to round up to a multiple of the slot size." & LF);
- Put (B, "\n-- Type_Layout is \1 bytes.\n", Image (Type_Layout_Size / 8));
+ Put (B, LF & "-- Type_Layout is " & Image (Type_Layout_Size / 8) & " bytes." & LF);
- Put (B, "\npragma Style_Checks (Off);\n");
- Put (B, "Type_Layout : constant Concrete_Type_Layout_Array := \n");
- Indent (B, 2);
- Put (B, "-- Concrete node types:\n");
+ Put (B, LF & "pragma Style_Checks (Off);" & LF);
+ Put (B, "Type_Layout : constant Concrete_Type_Layout_Array := " & LF);
+ Increase_Indent (B, 2);
+ Put (B, "-- Concrete node types:" & LF);
Put (B, "(");
- Indent (B, 1);
+ Increase_Indent (B, 1);
declare
First_Time : Boolean := True;
if First_Time then
First_Time := False;
else
- Put (B, ",\n\n");
+ Put (B, "," & LF & LF);
end if;
if T = Concrete_Entity'First then
- Put (B, "-- Concrete entity types:\n\n");
+ Put (B, "-- Concrete entity types:" & LF & LF);
end if;
- Put (B, "\1 => new Field_Array'\n", Image (T));
+ Put (B, Image (T) & " => new Field_Array'" & LF);
- Indent (B, 2);
+ Increase_Indent (B, 2);
Put (B, "(");
- Indent (B, 1);
+ Increase_Indent (B, 1);
declare
First_Time : Boolean := True;
if First_Time then
First_Time := False;
else
- Put (B, ",\n");
+ Put (B, "," & LF);
end if;
declare
(First_Bit .. Last_Bit => F));
if Last_Bit = First_Bit then
- Put (B, "\1 => \2",
- First_Bit_Image (First_Bit),
+ Put (B, First_Bit_Image (First_Bit) & " => " &
Image_Or_Waste (F));
else
pragma Assert
(if F /= No_Field then
First_Bit mod Field_Size (F) = 0);
- Put (B, "\1 .. \2 => \3",
- First_Bit_Image (First_Bit),
- Last_Bit_Image (Last_Bit),
+ Put (B, First_Bit_Image (First_Bit) & " .. " &
+ Last_Bit_Image (Last_Bit) & " => " &
Image_Or_Waste (F));
end if;
end loop;
end;
- Outdent (B, 1);
+ Decrease_Indent (B, 1);
Put (B, ")");
- Outdent (B, 2);
+ Decrease_Indent (B, 2);
end loop;
end;
- Outdent (B, 1);
- Put (B, ") -- Type_Layout\n");
- Indent (B, 6);
- Put (B, "with Export, Convention => Ada;\n");
- Outdent (B, 6);
- Outdent (B, 2);
+ Decrease_Indent (B, 1);
+ Put (B, ") -- Type_Layout" & LF);
+ Increase_Indent (B, 6);
+ Put (B, "with Export, Convention => Ada;" & LF);
+ Decrease_Indent (B, 6);
+ Decrease_Indent (B, 2);
- Put (B, "\n-- Table mapping bit offsets to the set of fields at that offset\n\n");
- Put (B, "Bit_Used : constant Offset_To_Fields_Mapping :=\n");
+ Put (B, LF & "-- Table mapping bit offsets to the set of fields at that offset" & LF & LF);
+ Put (B, "Bit_Used : constant Offset_To_Fields_Mapping :=" & LF);
- Indent (B, 2);
+ Increase_Indent (B, 2);
Put (B, "(");
- Indent (B, 1);
+ Increase_Indent (B, 1);
declare
First_Time : Boolean := True;
if First_Time then
First_Time := False;
else
- Put (B, ",\n\n");
+ Put (B, "," & LF & LF);
end if;
- Put (B, "\1 => new Field_Array'\n", First_Bit_Image (Bit));
+ Put (B, First_Bit_Image (Bit) & " => new Field_Array'" & LF);
-- Use [...] notation here, to get around annoying Ada
-- limitations on empty and singleton aggregates. This code is
-- not used in the compiler, so there are no bootstrap issues.
- Indent (B, 2);
+ Increase_Indent (B, 2);
Put (B, "[");
- Indent (B, 1);
+ Increase_Indent (B, 1);
Put_Field_List (Bit);
- Outdent (B, 1);
+ Decrease_Indent (B, 1);
Put (B, "]");
- Outdent (B, 2);
+ Decrease_Indent (B, 2);
end loop;
end;
- Outdent (B, 1);
- Put (B, "); -- Bit_Used\n");
- Outdent (B, 2);
+ Decrease_Indent (B, 1);
+ Put (B, "); -- Bit_Used" & LF);
+ Decrease_Indent (B, 2);
- Outdent (B, 3);
- Put (B, "\nend Seinfo_Tables;\n");
+ Decrease_Indent (B, 3);
+ Put (B, LF & "end Seinfo_Tables;" & LF);
end Put_Seinfo_Tables;
-----------------------------
procedure Put_C_Type_And_Subtypes
- (S : in out Sink'Class; Root : Root_Type) is
+ (S : in out Sink; Root : Root_Type) is
procedure Put_Enum_Lit (T : Node_Or_Entity_Type);
-- Print out the #define corresponding to the Ada enumeration literal
procedure Put_Enum_Lit (T : Node_Or_Entity_Type) is
begin
if T in Concrete_Type then
- Put (S, "#define \1 \2\n", Image (T), Image (Pos (T)));
+ Put (S, "#define " & Image (T) & " " & Image (Pos (T)) & "" & LF);
end if;
end Put_Enum_Lit;
procedure Put_Kind_Subtype (T : Node_Or_Entity_Type) is
begin
if T in Abstract_Type and then Type_Table (T).Parent /= No_Type then
- Put (S, "SUBTYPE (\1, \2,\n",
- Image (T),
- Image (Type_Table (T).Parent));
- Indent (S, 3);
- Put (S, "\1,\n\2)\n",
- Image (Type_Table (T).First),
- Image (Type_Table (T).Last));
- Outdent (S, 3);
+ Put (S, "SUBTYPE (" & Image (T) & ", " &
+ Image (Type_Table (T).Parent) & "," & LF);
+ Increase_Indent (S, 3);
+ Put (S, Image (Type_Table (T).First) & "," & LF);
+ Put (S, Image (Type_Table (T).Last) & ")" & LF);
+ Decrease_Indent (S, 3);
end if;
end Put_Kind_Subtype;
begin
- Indent (S, 6);
Iterate_Types (Root, Pre => Put_Enum_Lit'Access);
- Put (S, "\n#define Number_\1_Kinds \2\n",
- Node_Or_Entity (Root),
- Image (Pos (Last_Concrete (Root)) + 1));
+ Put (S, "#define Number_" & Node_Or_Entity (Root) & "_Kinds " &
+ Image (Pos (Last_Concrete (Root)) + 1) & "" & LF & LF);
- Outdent (S, 6);
-
- Indent (S, 3);
Iterate_Types (Root, Pre => Put_Kind_Subtype'Access);
- Outdent (S, 3);
Put_Union_Membership (S, Root);
end Put_C_Type_And_Subtypes;
----------------------------
procedure Put_Low_Level_C_Getter
- (S : in out Sink'Class; T : Type_Enum)
+ (S : in out Sink; T : Type_Enum)
is
T_Image : constant String := Get_Set_Id_Image (T);
begin
- Put (S, "static \1 Get_\2(Node_Id N, Field_Offset Offset);\n\n",
- T_Image, Image (T));
- Put (S, "INLINE \1\n", T_Image);
- Put (S, "Get_\1(Node_Id N, Field_Offset Offset)\n", Image (T));
+ Put (S, "INLINE " & T_Image & "" & LF);
+ Put (S, "Get_" & Image (T) & " (Node_Id N, Field_Offset Offset)" & LF);
- Indent (S, 3);
+ Increase_Indent (S, 3);
-- Same special case as in Put_Low_Level_Accessor_Instantiations
(if T = Elist_Id then "No_Elist" else "Uint_0");
begin
- Put (S, "{ return (\1) Get_32_Bit_Field_With_Default(N, Offset, \2); }\n\n",
- T_Image, Default_Val);
+ Put (S, "{ return (" & T_Image &
+ ") Get_32_Bit_Field_With_Default(N, Offset, " &
+ Default_Val & "); }" & LF & LF);
end;
else
- Put (S, "{ return (\1) Get_\2_Bit_Field(N, Offset); }\n\n",
- T_Image, Image (Field_Size (T)));
+ Put (S, "{ return (" & T_Image & ") Get_" &
+ Image (Field_Size (T)) & "_Bit_Field(N, Offset); }" & LF & LF);
end if;
- Outdent (S, 3);
+ Decrease_Indent (S, 3);
end Put_Low_Level_C_Getter;
-----------------------------
-----------------------------
procedure Put_High_Level_C_Getter
- (S : in out Sink'Class; F : Field_Enum)
+ (S : in out Sink; F : Field_Enum)
is
begin
- Put (S, "INLINE \1 \2\n",
- Get_Set_Id_Image (Field_Table (F).Field_Type), Image (F));
- Put (S, "(Node_Id N)\n");
-
- Indent (S, 3);
- Put (S, "{ return \1(\2, \3); }\n\n",
- Low_Level_Getter_Name (Field_Table (F).Field_Type),
- Node_To_Fetch_From (F),
- Image (Field_Table (F).Offset));
- Outdent (S, 3);
+ Put (S, "INLINE " & Get_Set_Id_Image (Field_Table (F).Field_Type) &
+ " " & Image (F) & " (Node_Id N)" & LF);
+
+ Increase_Indent (S, 3);
+ Put (S, "{ return " &
+ Low_Level_Getter_Name (Field_Table (F).Field_Type) &
+ "(" & Node_To_Fetch_From (F) & ", " &
+ Image (Field_Table (F).Offset) & "); }" & LF & LF);
+ Decrease_Indent (S, 3);
end Put_High_Level_C_Getter;
------------------------------
------------------------------
procedure Put_High_Level_C_Getters
- (S : in out Sink'Class; Root : Root_Type)
+ (S : in out Sink; Root : Root_Type)
is
begin
- Put (S, "// Getters for fields\n\n");
+ Put (S, "// Getters for fields" & LF & LF);
for F in First_Field (Root) .. Last_Field (Root) loop
Put_High_Level_C_Getter (S, F);
--------------------------
procedure Put_Union_Membership
- (S : in out Sink'Class; Root : Root_Type) is
+ (S : in out Sink; Root : Root_Type) is
procedure Put_Ors (T : Abstract_Type);
-- Print the "or" (i.e. "||") of tests whether kind is in each child
if First_Time then
First_Time := False;
else
- Put (S, " ||\n");
+ Put (S, " ||" & LF);
end if;
-- Unions, other abstract types, and concrete types each have
if Child in Abstract_Type then
if Type_Table (Child).Is_Union then
- Put (S, "Is_In_\1 (kind)", Image (Child));
+ Put (S, "Is_In_" & Image (Child) & " (kind)");
else
- Put (S, "IN (kind, \1)", Image (Child));
+ Put (S, "IN (kind, " & Image (Child) & ")");
end if;
else
- Put (S, "kind == \1", Image (Child));
+ Put (S, "kind == " & Image (Child));
end if;
end loop;
end Put_Ors;
begin
- Put (S, "\n// Membership tests for union types\n\n");
+ Put (S, LF & "// Membership tests for union types" & LF & LF);
for T in First_Abstract (Root) .. Last_Abstract (Root) loop
if Type_Table (T) /= null and then Type_Table (T).Is_Union then
- Put (S, "static Boolean Is_In_\1(\2_Kind kind);\n",
- Image (T), Node_Or_Entity (Root));
- Put (S, "INLINE Boolean\n");
- Put (S, "Is_In_\1(\2_Kind kind)\n",
- Image (T), Node_Or_Entity (Root));
-
- Put (S, "{\n");
- Indent (S, 3);
- Put (S, "return\n");
- Indent (S, 3);
+ Put (S, "INLINE Boolean" & LF);
+ Put (S, "Is_In_" & Image (T) & " (" &
+ Node_Or_Entity (Root) & "_Kind kind)" & LF);
+
+ Put (S, "{" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "return" & LF);
+ Increase_Indent (S, 3);
Put_Ors (T);
- Outdent (S, 3);
- Outdent (S, 3);
- Put (S, ";\n}\n");
+ Decrease_Indent (S, 3);
+ Decrease_Indent (S, 3);
+ Put (S, ";" & LF & "}" & LF);
- Put (S, "\n");
+ Put (S, "" & LF);
end if;
end loop;
end Put_Union_Membership;
---------------------
procedure Put_Sinfo_Dot_H is
- S : Sink'Class := Create_File ("sinfo.h");
+ S : Sink;
begin
- Put (S, "#ifdef __cplusplus\n");
- Put (S, "extern ""C"" {\n");
- Put (S, "#endif\n\n");
+ Create_File (S, "sinfo.h");
+ Put (S, "#ifdef __cplusplus" & LF);
+ Put (S, "extern ""C"" {" & LF);
+ Put (S, "#endif" & LF & LF);
- Put (S, "typedef Boolean Flag;\n\n");
+ Put (S, "typedef Boolean Flag;" & LF & LF);
Put_C_Type_And_Subtypes (S, Node_Kind);
- Put (S, "\n// Getters corresponding to instantiations of Atree.Get_n_Bit_Field\n");
- Put (S, "// generic functions.\n\n");
+ Put (S, "// Getters corresponding to instantiations of Atree.Get_n_Bit_Field"
+ & LF & LF);
for T in Special_Type loop
Put_Low_Level_C_Getter (S, T);
Put_High_Level_C_Getters (S, Node_Kind);
- Put (S, "#ifdef __cplusplus\n");
- Put (S, "}\n");
- Put (S, "#endif\n");
+ Put (S, "#ifdef __cplusplus" & LF);
+ Put (S, "}" & LF);
+ Put (S, "#endif" & LF);
end Put_Sinfo_Dot_H;
---------------------
---------------------
procedure Put_Einfo_Dot_H is
- S : Sink'Class := Create_File ("einfo.h");
+ S : Sink;
procedure Put_Membership_Query_Spec (T : Node_Or_Entity_Type);
- procedure Put_Membership_Query_Decl (T : Node_Or_Entity_Type);
procedure Put_Membership_Query_Defn (T : Node_Or_Entity_Type);
-- Print out the Is_... function for T that calls the IN macro on the
-- SUBTYPE.
begin
pragma Assert (not Type_Table (T).Is_Union);
- Put (S, "INLINE B Is_\1\2 ", Im2, Typ);
- Tab_To_Column (S, 49);
- Put (S, "(E Id)");
+ Put (S, "INLINE B Is_" & Im2 & Typ & " (E Id)");
end Put_Membership_Query_Spec;
- procedure Put_Membership_Query_Decl (T : Node_Or_Entity_Type) is
- begin
- if T in Abstract_Type and T not in Root_Type then
- Put_Membership_Query_Spec (T);
- Put (S, ";\n");
- end if;
- end Put_Membership_Query_Decl;
-
procedure Put_Membership_Query_Defn (T : Node_Or_Entity_Type) is
begin
if T in Abstract_Type and T not in Root_Type then
Put_Membership_Query_Spec (T);
- Put (S, "\n");
- Indent (S, 3);
- Put (S, "{ return IN (Ekind (Id), \1); }\n", Image (T));
- Outdent (S, 3);
+ Put (S, "" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "{ return IN (Ekind (Id), " & Image (T) & "); }" & LF);
+ Decrease_Indent (S, 3);
end if;
end Put_Membership_Query_Defn;
begin
- Put (S, "#ifdef __cplusplus\n");
- Put (S, "extern ""C"" {\n");
- Put (S, "#endif\n\n");
+ Create_File (S, "einfo.h");
+ Put (S, "#ifdef __cplusplus" & LF);
+ Put (S, "extern ""C"" {" & LF);
+ Put (S, "#endif" & LF & LF);
- Put (S, "typedef Boolean Flag;\n\n");
+ Put (S, "typedef Boolean Flag;" & LF & LF);
Put_C_Type_And_Subtypes (S, Entity_Kind);
- Put (S, "\n// Getters corresponding to instantiations of Atree.Get_n_Bit_Field\n");
- Put (S, "// generic functions.\n\n");
-
-- Note that we do not call Put_Low_Level_C_Getter here. Those are in
-- sinfo.h, so every file that #includes einfo.h must #include
-- sinfo.h first.
Put_High_Level_C_Getters (S, Entity_Kind);
- Put (S, "\n// Abstract type queries\n\n");
+ Put (S, "// Abstract type queries" & LF & LF);
- Indent (S, 3);
- Iterate_Types (Entity_Kind, Pre => Put_Membership_Query_Decl'Access);
- Put (S, "\n");
Iterate_Types (Entity_Kind, Pre => Put_Membership_Query_Defn'Access);
- Outdent (S, 3);
- Put (S, "#ifdef __cplusplus\n");
- Put (S, "}\n");
- Put (S, "#endif\n");
+ Put (S, LF & "#ifdef __cplusplus" & LF);
+ Put (S, "}" & LF);
+ Put (S, "#endif" & LF);
end Put_Einfo_Dot_H;
begin -- Compile
-- Put_Types_With_Bars --
-------------------------
- procedure Put_Types_With_Bars (S : in out Sink'Class; U : Type_Vector) is
+ procedure Put_Types_With_Bars (S : in out Sink; U : Type_Vector) is
First_Time : Boolean := True;
begin
- Indent (S, 3);
+ Increase_Indent (S, 3);
for T of U loop
if First_Time then
First_Time := False;
else
- Put (S, "\n| ");
+ Put (S, LF & "| ");
end if;
- Put (S, "\1", Image (T));
+ Put (S, Image (T));
end loop;
- Outdent (S, 3);
+ Decrease_Indent (S, 3);
end Put_Types_With_Bars;
----------------------------
-- Put_Type_Ids_With_Bars --
----------------------------
- procedure Put_Type_Ids_With_Bars (S : in out Sink'Class; U : Type_Vector) is
+ procedure Put_Type_Ids_With_Bars (S : in out Sink; U : Type_Vector) is
First_Time : Boolean := True;
begin
- Indent (S, 3);
+ Increase_Indent (S, 3);
for T of U loop
if First_Time then
First_Time := False;
else
- Put (S, "\n| ");
+ Put (S, LF & "| ");
end if;
- Put (S, "\1", Id_Image (T));
+ Put (S, Id_Image (T));
end loop;
- Outdent (S, 3);
+ Decrease_Indent (S, 3);
end Put_Type_Ids_With_Bars;
-----------
-- Put_Type_Hierarchy --
------------------------
- procedure Put_Type_Hierarchy (S : in out Sink'Class; Root : Root_Type) is
+ procedure Put_Type_Hierarchy (S : in out Sink; Root : Root_Type) is
Level : Natural := 0;
function Indentation return String is ((1 .. 3 * Level => ' '));
procedure Pre (T : Node_Or_Entity_Type) is
begin
- Put (S, "-- \1\2\n", Indentation, Image (T));
+ Put (S, "-- " & Indentation & Image (T) & LF);
Level := Level + 1;
end Pre;
-- an arbitrary definition of "many".
if Num_Concrete_Descendants (T) > 10 then
- Put (S, "-- \1end \2\n", Indentation, Image (T));
+ Put (S, "-- " & Indentation & "end " & Image (T) & LF);
end if;
end Post;
-- Start of processing for Put_Type_Hierarchy
begin
- Put (S, "-- Type hierarchy for \1\n", N_Or_E);
- Put (S, "--\n");
+ Put (S, "-- Type hierarchy for " & N_Or_E & LF);
+ Put (S, "--" & LF);
Iterate_Types (Root, Pre'Access, Post'Access);
- Put (S, "--\n");
- Put (S, "-- End type hierarchy for \1\n\n", N_Or_E);
+ Put (S, "--" & LF);
+ Put (S, "-- End type hierarchy for " & N_Or_E & LF & LF);
end Put_Type_Hierarchy;
---------
return Type_Enum'Pos (T) - Type_Enum'Pos (First);
end Pos;
- Stdout : Sink'Class renames Files.Standard_Output.all;
-
- -- The following procedures are for use in gdb. They use the 'Put_Image
- -- attribute. That is commented out, because we don't want this new feature
- -- used in the compiler. If you need this for debugging, just uncomment
- -- those lines back in, and rebuild.
-
- pragma Warnings (Off);
- procedure Ptypes (V : Type_Vector) is
- begin
--- Type_Vector'Put_Image (Stdout, V);
- New_Line (Stdout);
- Flush (Stdout);
- end Ptypes;
-
- procedure Pfields (V : Field_Vector) is
- begin
--- Field_Vector'Put_Image (Stdout, V);
- New_Line (Stdout);
- Flush (Stdout);
- end Pfields;
- pragma Warnings (On);
-
end Gen_IL.Internals;
use Type_Vectors;
subtype Type_Vector is Type_Vectors.Vector;
- procedure Ptypes (V : Type_Vector); -- for debugging
-
type Type_Array is array (Type_Index range <>) of Type_Enum;
----------------
- procedure Put_Types_With_Bars (S : in out Sink'Class; U : Type_Vector);
- procedure Put_Type_Ids_With_Bars (S : in out Sink'Class; U : Type_Vector);
+ procedure Put_Types_With_Bars (S : in out Sink; U : Type_Vector);
+ procedure Put_Type_Ids_With_Bars (S : in out Sink; U : Type_Vector);
-- Put the types with vertical bars in between, as in
-- N_This | N_That | N_Other
-- or
type Field_Index is new Positive;
package Field_Vectors is new Vectors (Field_Index, Field_Enum);
subtype Field_Vector is Field_Vectors.Vector;
- procedure Pfields (V : Field_Vector); -- for debugging
type Bit_Offset is new Root_Nat range 0 .. 32_000 - 1;
-- Offset in bits. The number 32_000 is chosen because there are fewer than
-- True if Ancestor is an ancestor of Descendant. True for
-- a type itself.
- procedure Put_Type_Hierarchy (S : in out Sink'Class; Root : Root_Type);
+ procedure Put_Type_Hierarchy (S : in out Sink; Root : Root_Type);
function Pos (T : Concrete_Type) return Root_Nat;
-- Return Node_Kind'Pos (T) or Entity_Kind'Pos (T)
-- --
------------------------------------------------------------------------------
+with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
+
package body Gen_IL is
+ procedure Put (F : File_Type; S : String);
+ -- The output primitive
+
-----------
-- Image --
-----------
end return;
end Capitalize;
+ -----------------
+ -- Create_File --
+ -----------------
+
+ procedure Create_File (Buffer : in out Sink; Name : String) is
+ begin
+ Create (Buffer.File, Out_File, Name);
+ Buffer.Indent := 0;
+ Buffer.New_Line := True;
+ end Create_File;
+
+ ---------------------
+ -- Increase_Indent --
+ ---------------------
+
+ procedure Increase_Indent (Buffer : in out Sink; Amount : Natural) is
+ begin
+ Buffer.Indent := Buffer.Indent + Amount;
+ end Increase_Indent;
+
+ ---------------------
+ -- Decrease_Indent --
+ ---------------------
+
+ procedure Decrease_Indent (Buffer : in out Sink; Amount : Natural) is
+ begin
+ Buffer.Indent := Buffer.Indent - Amount;
+ end Decrease_Indent;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (F : File_Type; S : String) is
+ begin
+ String'Write (Stream (F), S);
+ end Put;
+
+ procedure Put (Buffer : in out Sink; Item : String) is
+ begin
+ -- If the first character is LF, indent after it only
+
+ if Item (Item'First) = ASCII.LF then
+ Put (Buffer.File, LF);
+ Buffer.New_Line := True;
+
+ if Item'Length > 1 then
+ Put (Buffer, Item (Item'First + 1 .. Item'Last));
+ end if;
+
+ return;
+ end if;
+
+ -- If this is a new line, indent
+
+ if Buffer.New_Line and then Buffer.Indent > 0 then
+ declare
+ S : constant String (1 .. Buffer.Indent) := (others => ' ');
+ begin
+ Put (Buffer.File, S);
+ end;
+ end if;
+
+ Put (Buffer.File, Item);
+
+ Buffer.New_Line := Item (Item'Last) = ASCII.LF;
+ end Put;
+
end Gen_IL;
------------------------------------------------------------------------------
pragma Warnings (Off); -- with clauses for children
-with Ada.Strings.Text_Output.Formatting;
-use Ada.Strings.Text_Output, Ada.Strings.Text_Output.Formatting;
-with Ada.Strings.Text_Output.Files; use Ada.Strings.Text_Output.Files;
-with Ada.Strings.Text_Output.Utils; use Ada.Strings.Text_Output.Utils;
-with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Streams.Stream_IO;
pragma Warnings (On);
package Gen_IL is -- generate intermediate language
procedure Capitalize (S : in out String);
-- Turns an identifier into Mixed_Case
+ -- The following declares a minimal implementation of formatted output
+ -- that is piggybacked on Ada.Streams.Stream_IO for bootstrap reasons.
+ -- It uses LF as universal line terminator to make it host independent.
+
+ type Sink is record
+ File : Ada.Streams.Stream_IO.File_Type;
+ Indent : Natural;
+ New_Line : Boolean;
+ end record;
+
+ procedure Create_File (Buffer : in out Sink; Name : String);
+
+ procedure Increase_Indent (Buffer : in out Sink; Amount : Natural);
+
+ procedure Decrease_Indent (Buffer : in out Sink; Amount : Natural);
+
+ procedure Put (Buffer : in out Sink; Item : String);
+
+ LF : constant String := "" & ASCII.LF;
+
end Gen_IL;
("s-aotase", T), -- System.Atomic_Operations.Test_And_Set
("s-atoope", T), -- System.Atomic_Operations
("s-atopex", T), -- System.Atomic_Operations.Exchange
+ ("a-sttebu", T), -- Ada.Strings.Text_Buffers
+ ("a-stbuun", T), -- Ada.Strings.Text_Buffers.Unbounded
+ ("a-stbubo", T), -- Ada.Strings.Text_Buffers.Bounded
("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
("a-strsto", T), -- Ada.Streams.Storage
("a-ststbo", T), -- Ada.Streams.Storage.Bounded
- ("a-ststun", T) -- Ada.Streams.Storage.Unbounded
+ ("a-ststun", T), -- Ada.Streams.Storage.Unbounded
+
+ ----------------------------------------
+ -- GNAT Defined Additions to Ada 2022 --
+ ----------------------------------------
+
+ ("a-stbufi", T), -- Ada.Strings.Text_Buffers.Files
+ ("a-stbufo", T), -- Ada.Strings.Text_Buffers.Formatting
+ ("a-stbuut", T) -- Ada.Strings.Text_Buffers.Utils
);
-----------------------
-- --
------------------------------------------------------------------------------
-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
+ use Ada.Strings.Text_Buffers;
+
procedure Put_Image_Protected (S : in out Sink'Class) is
begin
Put_UTF_8 (S, "(protected object)");
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Text_Output;
+with Ada.Strings.Text_Buffers;
with Ada.Task_Identification;
package System.Put_Task_Images is
-- separate from System.Put_Images to avoid dragging the tasking runtimes
-- into nontasking programs.
- subtype Sink is Ada.Strings.Text_Output.Sink;
+ subtype Sink is Ada.Strings.Text_Buffers.Root_Buffer_Type;
procedure Put_Image_Protected (S : in out Sink'Class);
procedure Put_Image_Task
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List)
is
First_Time : Boolean := True;
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List);
procedure Read
(Stream : not null access Root_Stream_Type'Class;
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
private with Ada.Containers.Hash_Tables;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Key_Type is private;
with null record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
use HT_Types, HT_Types.Implementation;
use Ada.Streams;
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
with null record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
use HT_Types, HT_Types.Implementation;
use Ada.Streams;
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree)
is
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree);
procedure Write
(Stream : not null access Root_Stream_Type'Class;
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Key_Type is private;
with null record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
use Red_Black_Trees;
use Tree_Types, Tree_Types.Implementation;
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
with null record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
use Tree_Types, Tree_Types.Implementation;
use Ada.Finalization;
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List)
is
First_Time : Boolean := True;
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List);
overriding procedure Adjust (Container : in out List);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List)
is
First_Time : Boolean := True;
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List);
overriding procedure Adjust (Container : in out List);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
private with Ada.Containers.Hash_Tables;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Key_Type (<>) is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
overriding procedure Adjust (Container : in out Map);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree)
is
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree);
overriding procedure Adjust (Container : in out Tree);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Key_Type (<>) is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
overriding procedure Adjust (Container : in out Map);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
with Ada.Iterator_Interfaces;
generic
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder)
is
use System.Put_Images;
begin
------------------------------------------------------------------------------
private with System;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
-- (default) alignment instead.
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder);
type Element_Access is access all Element_Type;
pragma Assert (Element_Access'Size = Standard'Address_Size,
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Vector)
is
First_Time : Boolean := True;
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Index_Type is range <>;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Vector);
procedure Write
(Stream : not null access Root_Stream_Type'Class;
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
private with Ada.Containers.Hash_Tables;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
-- The language-defined generic package Containers.Hashed_Maps provides
-- private types Map and Cursor, and a set of operations for each type. A map
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
overriding procedure Adjust (Container : in out Map);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder)
is
use System.Put_Images;
begin
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder);
for Holder'Read use Read;
for Holder'Write use Write;
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder)
is
use System.Put_Images;
begin
private with Ada.Streams;
private with System.Atomic_Counters;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder);
for Holder'Read use Read;
for Holder'Write use Write;
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Vector)
is
First_Time : Boolean := True;
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Index_Type is range <>;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Vector);
overriding procedure Adjust (Container : in out Vector);
overriding procedure Finalize (Container : in out Vector);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree)
is
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree);
overriding procedure Adjust (Container : in out Tree);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Vector)
is
First_Time : Boolean := True;
use System.Put_Images;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
-- The language-defined generic package Containers.Vectors provides private
-- types Vector and Cursor, and a set of operations for each type. A vector
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Vector);
overriding procedure Adjust (Container : in out Vector);
overriding procedure Finalize (Container : in out Vector);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Key_Type is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
overriding procedure Adjust (Container : in out Map);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
with Ada.Iterator_Interfaces;
generic
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
-with Ada.Strings.Text_Output.Utils;
with Interfaces; use Interfaces;
-- Put_Image --
---------------
- procedure Put_Image (S : in out Sink'Class; V : Big_Integer) is
+ procedure Put_Image (S : in out Root_Buffer_Type'Class; V : Big_Integer) is
-- This is implemented in terms of To_String. It might be more elegant
-- and more efficient to do it the other way around, but this is the
-- most expedient implementation for now.
begin
- Strings.Text_Output.Utils.Put_UTF_8 (S, To_String (V));
+ Strings.Text_Buffers.Put_UTF_8 (S, To_String (V));
end Put_Image;
---------
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Text_Output; use Ada.Strings.Text_Output;
+with Ada.Strings.Text_Buffers; use Ada.Strings.Text_Buffers;
private with Ada.Finalization;
private with System;
function From_Universal_Image (Arg : String) return Valid_Big_Integer
renames From_String;
- procedure Put_Image (S : in out Sink'Class; V : Big_Integer);
+ procedure Put_Image (S : in out Root_Buffer_Type'Class; V : Big_Integer);
function "+" (L : Valid_Big_Integer) return Valid_Big_Integer
with Global => null;
with Ada.Unchecked_Deallocation;
with Interfaces.C; use Interfaces.C;
with Interfaces.C.Strings; use Interfaces.C.Strings;
-with Ada.Strings.Text_Output.Utils;
with Ada.Characters.Handling; use Ada.Characters.Handling;
package body Ada.Numerics.Big_Numbers.Big_Integers is
-- Put_Image --
---------------
- procedure Put_Image (S : in out Sink'Class; V : Big_Integer) is
+ procedure Put_Image (S : in out Root_Buffer_Type'Class; V : Big_Integer) is
-- This is implemented in terms of To_String. It might be more elegant
-- and more efficient to do it the other way around, but this is the
-- most expedient implementation for now.
begin
- Strings.Text_Output.Utils.Put_UTF_8 (S, To_String (V));
+ Strings.Text_Buffers.Put_UTF_8 (S, To_String (V));
end Put_Image;
---------
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Text_Output.Utils;
with System.Unsigned_Types; use System.Unsigned_Types;
package body Ada.Numerics.Big_Numbers.Big_Reals is
-- Put_Image --
---------------
- procedure Put_Image (S : in out Sink'Class; V : Big_Real) is
+ procedure Put_Image (S : in out Root_Buffer_Type'Class; V : Big_Real) is
-- This is implemented in terms of To_String. It might be more elegant
-- and more efficient to do it the other way around, but this is the
-- most expedient implementation for now.
begin
- Strings.Text_Output.Utils.Put_UTF_8 (S, To_String (V));
+ Strings.Text_Buffers.Put_UTF_8 (S, To_String (V));
end Put_Image;
---------
with Ada.Numerics.Big_Numbers.Big_Integers;
-with Ada.Strings.Text_Output; use Ada.Strings.Text_Output;
+with Ada.Strings.Text_Buffers; use Ada.Strings.Text_Buffers;
package Ada.Numerics.Big_Numbers.Big_Reals
with Preelaborate
function From_Quotient_String (Arg : String) return Valid_Big_Real
with Global => null;
- procedure Put_Image (S : in out Sink'Class; V : Big_Real);
+ procedure Put_Image (S : in out Root_Buffer_Type'Class; V : Big_Real);
function "+" (L : Valid_Big_Real) return Valid_Big_Real
with Global => null;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.BOUNDED --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.UTF_Encoding.Conversions;
+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_Buffers.Bounded is
+
+ -- Pretty much the same as the Unbounded version, except where different.
+ --
+ -- One could imagine inventing an Input_Mapping generic analogous to
+ -- the existing Output_Mapping generic to address the Get-related
+ -- Bounded/Unbounded code duplication issues, but let's not. In the
+ -- Output case, there was more substantial duplication and there were
+ -- 3 clients (Bounded, Unbounded, and Files) instead of 2.
+
+ function Text_Truncated (Buffer : Buffer_Type) return Boolean is
+ (Buffer.Truncated);
+
+ function Get (Buffer : in out Buffer_Type) return String is
+ -- 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 RM 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.
+ begin
+ if Buffer.All_8_Bits and not Buffer.All_7_Bits then
+ return UTF_Encoding.Strings.Decode (Get_UTF_8 (Buffer));
+ else
+ return Get_UTF_8 (Buffer);
+ end if;
+ end Get;
+
+ function Wide_Get (Buffer : in out Buffer_Type) return Wide_String is
+ begin
+ return UTF_Encoding.Wide_Strings.Decode (Get_UTF_8 (Buffer));
+ end Wide_Get;
+
+ function Wide_Wide_Get (Buffer : in out Buffer_Type) return Wide_Wide_String
+ is
+ begin
+ return UTF_Encoding.Wide_Wide_Strings.Decode (Get_UTF_8 (Buffer));
+ end Wide_Wide_Get;
+
+ function Get_UTF_8
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_8_String
+ is
+ begin
+ return
+ Result : constant UTF_Encoding.UTF_8_String :=
+ UTF_Encoding.UTF_8_String
+ (Buffer.Chars (1 .. Text_Buffer_Count (Buffer.UTF_8_Length)))
+ do
+ -- Reset buffer to default initial value.
+ declare
+ Defaulted : Buffer_Type (0);
+
+ -- If this aggregate becomes illegal due to new field, don't
+ -- forget to add corresponding assignment statement below.
+ Dummy : array (1 .. 0) of Buffer_Type (0) :=
+ (others =>
+ (Max_Characters => 0, Chars => <>, Indentation => <>,
+ Indent_Pending => <>, UTF_8_Length => <>, UTF_8_Column => <>,
+ All_7_Bits => <>, All_8_Bits => <>, Truncated => <>));
+ begin
+ Buffer.Indentation := Defaulted.Indentation;
+ Buffer.Indent_Pending := Defaulted.Indent_Pending;
+ Buffer.UTF_8_Length := Defaulted.UTF_8_Length;
+ Buffer.UTF_8_Column := Defaulted.UTF_8_Column;
+ Buffer.All_7_Bits := Defaulted.All_7_Bits;
+ Buffer.All_8_Bits := Defaulted.All_8_Bits;
+ Buffer.Truncated := Defaulted.Truncated;
+ end;
+ end return;
+ end Get_UTF_8;
+
+ function Wide_Get_UTF_16
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_16_Wide_String
+ is
+ begin
+ return
+ UTF_Encoding.Conversions.Convert
+ (Get_UTF_8 (Buffer), Input_Scheme => UTF_Encoding.UTF_8);
+ end Wide_Get_UTF_16;
+
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String)
+ is
+ procedure Buffer_Type_Implementation (Buffer : in out Buffer_Type);
+ -- View the passed-in Buffer parameter as being of type Buffer_Type,
+ -- not of Root_Buffer_Type'Class.
+
+ procedure Buffer_Type_Implementation (Buffer : in out Buffer_Type) is
+ begin
+ for Char of Item loop
+ if Buffer.UTF_8_Length = Integer (Buffer.Max_Characters) then
+ Buffer.Truncated := True;
+ return;
+ end if;
+
+ Buffer.All_7_Bits := @ and then Character'Pos (Char) < 128;
+
+ Buffer.UTF_8_Length := @ + 1;
+ Buffer.UTF_8_Column := @ + 1;
+ Buffer.Chars (Text_Buffer_Count (Buffer.UTF_8_Length)) := Char;
+ end loop;
+ end Buffer_Type_Implementation;
+ begin
+ if Item'Length > 0 then
+ Buffer_Type_Implementation (Buffer_Type (Buffer));
+ end if;
+ end Put_UTF_8_Implementation;
+
+end Ada.Strings.Text_Buffers.Bounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.BOUNDED --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Strings.Text_Buffers.Bounded with
+ Pure
+is
+
+ type Buffer_Type (Max_Characters : Text_Buffer_Count) is
+ new Root_Buffer_Type with private with
+ Default_Initial_Condition => not Text_Truncated (Buffer_Type);
+
+ function Text_Truncated (Buffer : Buffer_Type) return Boolean;
+
+ function Get (Buffer : in out Buffer_Type) return String with
+ Post'Class => Get'Result'First = 1 and then Current_Indent (Buffer) = 0;
+
+ function Wide_Get (Buffer : in out Buffer_Type) return Wide_String with
+ Post'Class => Wide_Get'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Wide_Wide_Get
+ (Buffer : in out Buffer_Type) return Wide_Wide_String with
+ Post'Class => Wide_Wide_Get'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Get_UTF_8
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_8_String with
+ Post'Class => Get_UTF_8'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Wide_Get_UTF_16
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_16_Wide_String with
+ Post'Class => Wide_Get_UTF_16'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+private
+
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String)
+ with Pre => Buffer in Buffer_Type'Class;
+
+ package Mapping is new Output_Mapping (Put_UTF_8_Implementation);
+
+ subtype Positive_Text_Buffer_Count is
+ Text_Buffer_Count range 1 .. Text_Buffer_Count'Last;
+
+ type Convertible_To_UTF_8_String is
+ array (Positive_Text_Buffer_Count range <>) of Character;
+
+ type Buffer_Type (Max_Characters : Text_Buffer_Count)
+ is new Mapping.Buffer_Type with record
+ Truncated : Boolean := False;
+ -- True if we ran out of space on a Put
+
+ Chars : Convertible_To_UTF_8_String (1 .. Max_Characters);
+ end record;
+
+end Ada.Strings.Text_Buffers.Bounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.FILES --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Strings.Text_Buffers.Files is
+
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String) is
+ Result : Integer;
+ begin
+ Result := OS.Write (File_Buffer (Buffer).FD,
+ Item (Item'First)'Address,
+ Item'Length);
+ if Result /= Item'Length then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ end Put_UTF_8_Implementation;
+
+ function Create_From_FD
+ (FD : GNAT.OS_Lib.File_Descriptor;
+ Close_Upon_Finalization : Boolean := True) return File_Buffer
+ is
+ use OS;
+ begin
+ if FD = Invalid_FD then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ return Result : File_Buffer do
+ Result.FD := FD;
+ Result.Close_Upon_Finalization := Close_Upon_Finalization;
+ end return;
+ end Create_From_FD;
+
+ function Create_File (Name : String) return File_Buffer is
+ begin
+ return Create_From_FD (OS.Create_File (Name, Fmode => OS.Binary));
+ end Create_File;
+
+ procedure Finalize (Ref : in out Self_Ref) is
+ Success : Boolean;
+ use OS;
+ begin
+ if Ref.Self.FD /= OS.Invalid_FD
+ and then Ref.Self.Close_Upon_Finalization
+ then
+ Close (Ref.Self.FD, Success);
+ if not Success then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ end if;
+ Ref.Self.FD := OS.Invalid_FD;
+ end Finalize;
+
+end Ada.Strings.Text_Buffers.Files;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.FILES --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+with GNAT.OS_Lib;
+
+package Ada.Strings.Text_Buffers.Files is
+
+ type File_Buffer is new Root_Buffer_Type with private;
+ -- Output written to a File_Buffer is written to the associated file.
+
+ function Create_From_FD
+ (FD : GNAT.OS_Lib.File_Descriptor;
+ Close_Upon_Finalization : Boolean := True)
+ return File_Buffer;
+ -- file closed upon finalization if specified
+
+ function Create_File (Name : String) return File_Buffer;
+ -- file closed upon finalization
+
+ function Create_Standard_Output_Buffer return File_Buffer is
+ (Create_From_FD (GNAT.OS_Lib.Standout, Close_Upon_Finalization => False));
+ function Create_Standard_Error_Buffer return File_Buffer is
+ (Create_From_FD (GNAT.OS_Lib.Standerr, Close_Upon_Finalization => False));
+
+private
+
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String)
+ with Pre => Buffer in File_Buffer'Class;
+
+ package Mapping is new Output_Mapping (Put_UTF_8_Implementation);
+
+ package OS renames GNAT.OS_Lib;
+
+ type Self_Ref (Self : not null access File_Buffer)
+ is new Finalization.Limited_Controlled with null record;
+ overriding procedure Finalize (Ref : in out Self_Ref);
+
+ type File_Buffer is new Mapping.Buffer_Type with record
+ FD : OS.File_Descriptor := OS.Invalid_FD;
+ Ref : Self_Ref (File_Buffer'Access);
+ Close_Upon_Finalization : Boolean := False;
+ end record;
+
+end Ada.Strings.Text_Buffers.Files;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.FORMATTING --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Text_Buffers.Unbounded;
+with Ada.Strings.Text_Buffers.Files;
+
+package body Ada.Strings.Text_Buffers.Formatting is
+
+ use Ada.Strings.Text_Buffers.Files;
+ use Ada.Strings.Text_Buffers.Utils;
+
+ procedure Put
+ (S : in out Root_Buffer_Type'Class; T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "")
+ is
+ J : Positive := T'First;
+ Used : array (1 .. 9) 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' =>
+ Increase_Indent (S);
+ when 'o' =>
+ Decrease_Indent (S);
+ when 'I' =>
+ Increase_Indent (S, 1);
+ when 'O' =>
+ Decrease_Indent (S, 1);
+
+ when '1' =>
+ Used (1) := True;
+ Put_UTF_8_Lines (S, X1);
+ when '2' =>
+ Used (2) := True;
+ Put_UTF_8_Lines (S, X2);
+ when '3' =>
+ Used (3) := True;
+ Put_UTF_8_Lines (S, X3);
+ when '4' =>
+ Used (4) := True;
+ Put_UTF_8_Lines (S, X4);
+ when '5' =>
+ Used (5) := True;
+ Put_UTF_8_Lines (S, X5);
+ when '6' =>
+ Used (6) := True;
+ Put_UTF_8_Lines (S, X6);
+ when '7' =>
+ Used (7) := True;
+ Put_UTF_8_Lines (S, X7);
+ when '8' =>
+ Used (8) := True;
+ Put_UTF_8_Lines (S, X8);
+ when '9' =>
+ Used (9) := True;
+ Put_UTF_8_Lines (S, X9);
+
+ 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;
+ if not Used (7) then
+ pragma Assert (X7 = "");
+ end if;
+ if not Used (8) then
+ pragma Assert (X8 = "");
+ end if;
+ if not Used (9) then
+ pragma Assert (X9 = "");
+ end if;
+ end Put;
+
+ function Format
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "")
+ return Utils.UTF_8_Lines
+ is
+ Buffer : Unbounded.Buffer_Type;
+ begin
+ Put (Buffer, T, X1, X2, X3, X4, X5, X6, X7, X8, X9);
+ return Buffer.Get_UTF_8;
+ end Format;
+
+ procedure Put
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "") is
+ Buffer : File_Buffer := Create_Standard_Output_Buffer;
+ begin
+ Put (Buffer, T, X1, X2, X3, X4, X5, X6, X7, X8, X9);
+ end Put;
+
+ procedure Err
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "") is
+ Buffer : File_Buffer := Create_Standard_Error_Buffer;
+ begin
+ Put (Buffer, T, X1, X2, X3, X4, X5, X6, X7, X8, X9);
+ end Err;
+
+end Ada.Strings.Text_Buffers.Formatting;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.FORMATTING --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Text_Buffers.Utils;
+
+package Ada.Strings.Text_Buffers.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.
+
+ type Template is new Utils.UTF_8;
+
+ procedure Put
+ (S : in out Root_Buffer_Type'Class; T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "");
+ -- 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 String, to avoid this sort of thing:
+ --
+ -- https://xkcd.com/327/
+
+ procedure Put
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "");
+ -- Sends to standard output
+
+ procedure Err
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "");
+ -- Sends to standard error
+
+ function Format
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "")
+ return Utils.UTF_8_Lines;
+ -- Returns a UTF-8-encoded String
+
+end Ada.Strings.Text_Buffers.Formatting;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.UNBOUNDED --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+with Ada.Strings.UTF_Encoding.Conversions;
+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_Buffers.Unbounded is
+
+ function Get (Buffer : in out Buffer_Type) return String is
+ -- 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 RM 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.
+ begin
+ if Buffer.All_8_Bits and not Buffer.All_7_Bits then
+ return UTF_Encoding.Strings.Decode (Get_UTF_8 (Buffer));
+ else
+ return Get_UTF_8 (Buffer);
+ end if;
+ end Get;
+
+ function Wide_Get (Buffer : in out Buffer_Type) return Wide_String is
+ begin
+ return UTF_Encoding.Wide_Strings.Decode (Get_UTF_8 (Buffer));
+ end Wide_Get;
+
+ function Wide_Wide_Get (Buffer : in out Buffer_Type) return Wide_Wide_String
+ is
+ begin
+ return UTF_Encoding.Wide_Wide_Strings.Decode (Get_UTF_8 (Buffer));
+ end Wide_Wide_Get;
+
+ function Get_UTF_8
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_8_String
+ is
+ begin
+ return Result : UTF_Encoding.UTF_8_String (1 .. Buffer.UTF_8_Length) do
+ declare
+ Target_First : Positive := 1;
+ Ptr : Chunk_Access := Buffer.List.First_Chunk'Unchecked_Access;
+ Target_Last : Positive;
+ begin
+ while Ptr /= null loop
+ Target_Last := Target_First + Ptr.Chars'Length - 1;
+ if Target_Last <= Result'Last then
+ -- all of chunk is assigned to Result
+ Result (Target_First .. Target_Last) := Ptr.Chars;
+ Target_First := Target_First + Ptr.Chars'Length;
+ else
+ -- only part of (last) chunk is assigned to Result
+ declare
+ Final_Target : UTF_Encoding.UTF_8_String renames
+ Result (Target_First .. Result'Last);
+ begin
+ Final_Target := Ptr.Chars (1 .. Final_Target'Length);
+ end;
+ pragma Assert (Ptr.Next = null);
+ Target_First := Integer'Last;
+ end if;
+
+ Ptr := Ptr.Next;
+ end loop;
+ end;
+
+ -- Reset buffer to default initial value.
+ declare
+ Defaulted : Buffer_Type;
+
+ -- If this aggregate becomes illegal due to new field, don't
+ -- forget to add corresponding assignment statement below.
+ Dummy : array (1 .. 0) of Buffer_Type :=
+ (others =>
+ (Indentation => <>, Indent_Pending => <>, UTF_8_Length => <>,
+ UTF_8_Column => <>, All_7_Bits => <>, All_8_Bits => <>,
+ List => <>, Last_Used => <>));
+ begin
+ Buffer.Indentation := Defaulted.Indentation;
+ Buffer.Indent_Pending := Defaulted.Indent_Pending;
+ Buffer.UTF_8_Length := Defaulted.UTF_8_Length;
+ Buffer.UTF_8_Column := Defaulted.UTF_8_Column;
+ Buffer.All_7_Bits := Defaulted.All_7_Bits;
+ Buffer.All_8_Bits := Defaulted.All_8_Bits;
+ Buffer.Last_Used := Defaulted.Last_Used;
+ Finalize (Buffer.List); -- free any allocated chunks
+ end;
+ end return;
+ end Get_UTF_8;
+
+ function Wide_Get_UTF_16
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_16_Wide_String
+ is
+ begin
+ return
+ UTF_Encoding.Conversions.Convert
+ (Get_UTF_8 (Buffer), Input_Scheme => UTF_Encoding.UTF_8);
+ end Wide_Get_UTF_16;
+
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String)
+ is
+ procedure Buffer_Type_Implementation (Buffer : in out Buffer_Type);
+ -- View the passed-in Buffer parameter as being of type Buffer_Type,
+ -- not of type Root_Buffer_Type'Class.
+
+ procedure Buffer_Type_Implementation (Buffer : in out Buffer_Type) is
+ begin
+ for Char of Item loop
+ Buffer.All_7_Bits := @ and then Character'Pos (Char) < 128;
+
+ if Buffer.Last_Used = Buffer.List.Current_Chunk.Length then
+ -- Current chunk is full; allocate a new one with doubled size
+
+ declare
+ Cc : Chunk renames Buffer.List.Current_Chunk.all;
+ Max : constant Positive := Integer'Last / 2;
+ Length : constant Natural :=
+ Integer'Min (Max, 2 * Cc.Length);
+ begin
+ pragma Assert (Cc.Next = null);
+ Cc.Next := new Chunk (Length => Length);
+ Buffer.List.Current_Chunk := Cc.Next;
+ Buffer.Last_Used := 0;
+ end;
+ end if;
+
+ Buffer.UTF_8_Length := @ + 1;
+ Buffer.UTF_8_Column := @ + 1;
+ Buffer.Last_Used := @ + 1;
+ Buffer.List.Current_Chunk.Chars (Buffer.Last_Used) := Char;
+ end loop;
+ end Buffer_Type_Implementation;
+ begin
+ Buffer_Type_Implementation (Buffer_Type (Buffer));
+ end Put_UTF_8_Implementation;
+
+ procedure Initialize (List : in out Managed_Chunk_List) is
+ begin
+ List.Current_Chunk := List.First_Chunk'Unchecked_Access;
+ end Initialize;
+
+ procedure Finalize (List : in out Managed_Chunk_List) is
+ procedure Free is new Ada.Unchecked_Deallocation (Chunk, Chunk_Access);
+ Ptr : Chunk_Access := List.First_Chunk.Next;
+ begin
+ while Ptr /= null loop
+ declare
+ Old_Ptr : Chunk_Access := Ptr;
+ begin
+ Ptr := Ptr.Next;
+ Free (Old_Ptr);
+ end;
+ end loop;
+
+ List.First_Chunk.Next := null;
+ Initialize (List);
+ end Finalize;
+
+end Ada.Strings.Text_Buffers.Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.UNBOUNDED --
+-- --
+-- S p e c --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+package Ada.Strings.Text_Buffers.Unbounded with
+ Preelaborate
+ -- , Nonblocking
+ -- , Global => null
+is
+
+ type Buffer_Type is new Root_Buffer_Type with private;
+
+ function Get (Buffer : in out Buffer_Type) return String with
+ Post'Class => Get'Result'First = 1 and then Current_Indent (Buffer) = 0;
+
+ function Wide_Get (Buffer : in out Buffer_Type) return Wide_String with
+ Post'Class => Wide_Get'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Wide_Wide_Get
+ (Buffer : in out Buffer_Type) return Wide_Wide_String with
+ Post'Class => Wide_Wide_Get'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Get_UTF_8
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_8_String with
+ Post'Class => Get_UTF_8'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Wide_Get_UTF_16
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_16_Wide_String with
+ Post'Class => Wide_Get_UTF_16'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+private
+
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String)
+ with Pre => Buffer in Buffer_Type'Class;
+
+ package Mapping is new Output_Mapping (Put_UTF_8_Implementation);
+
+ type Chunk;
+ type Chunk_Access is access all Chunk;
+ type Chunk (Length : Positive) is record
+ Next : Chunk_Access := null;
+ Chars : UTF_Encoding.UTF_8_String (1 .. Length);
+ end record;
+
+ type Managed_Chunk_List is new Ada.Finalization.Limited_Controlled with
+ record
+ First_Chunk : aliased Chunk (64);
+ -- First chunk in list is not created by an allocator; it is
+ -- large enough to suffice for many common images.
+
+ Current_Chunk : Chunk_Access;
+ -- Chunk we are currrently writing to.
+ -- Initialized to Managed_Chunk_List.First'Access.
+ end record;
+
+ overriding procedure Initialize (List : in out Managed_Chunk_List);
+ -- List.Current_Chunk := List.First_Chunk'Unchecked_Access;
+
+ overriding procedure Finalize (List : in out Managed_Chunk_List);
+ -- Free any allocated chunks.
+
+ type Buffer_Type is new Mapping.Buffer_Type with record
+ List : Managed_Chunk_List;
+
+ Last_Used : Natural := 0;
+ -- Index of last used char in List.Current_Chunk.all; 0 if none used.
+ end record;
+
+end Ada.Strings.Text_Buffers.Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.UTILS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Strings.Text_Buffers.Utils is
+
+ procedure Put_7bit
+ (Buffer : in out Root_Buffer_Type'Class; Item : Character_7)
+ is
+ begin
+ Put (Buffer, (1 => Item));
+ end Put_7bit;
+
+ procedure Put_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Character)
+ is
+ begin
+ Put (Buffer, (1 => Item));
+ end Put_Character;
+
+ procedure Put_Wide_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Wide_Character)
+ is
+ begin
+ Wide_Put (Buffer, (1 => Item));
+ end Put_Wide_Character;
+
+ procedure Put_Wide_Wide_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Wide_Wide_Character)
+ is
+ begin
+ Wide_Wide_Put (Buffer, (1 => Item));
+ end Put_Wide_Wide_Character;
+
+ procedure Put_UTF_8_Lines
+ (Buffer : in out Root_Buffer_Type'Class; Item : UTF_8_Lines)
+ is
+ begin
+ Put (Buffer, Item);
+ end Put_UTF_8_Lines;
+
+ function Column (Buffer : Root_Buffer_Type'Class) return Positive is
+ begin
+ return Buffer.UTF_8_Column;
+ end Column;
+
+ procedure Tab_To_Column
+ (Buffer : in out Root_Buffer_Type'Class; Column : Positive)
+ is
+ begin
+ Put (Buffer, String'(1 .. Column - Utils.Column (Buffer) => ' '));
+ end Tab_To_Column;
+
+end Ada.Strings.Text_Buffers.Utils;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.UTILS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
+
+package Ada.Strings.Text_Buffers.Utils with Pure is
+
+ -- Ada.Strings.Text_Buffers is a predefined unit (see Ada RM A.4.12).
+ -- This is a GNAT-defined child unit of that parent.
+
+ subtype Character_7 is
+ Character range Character'Val (0) .. Character'Val (2**7 - 1);
+
+ procedure Put_7bit
+ (Buffer : in out Root_Buffer_Type'Class; Item : Character_7);
+ procedure Put_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Character);
+ procedure Put_Wide_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Wide_Character);
+ procedure Put_Wide_Wide_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Wide_Wide_Character);
+ -- Single character output procedures.
+
+ function Column (Buffer : Root_Buffer_Type'Class) return Positive with
+ Inline;
+ -- Current output column. The Column is initially 1, and is incremented for
+ -- each 8-bit character output. A call to New_Line sets Column back to 1.
+ -- The next character to be output will go in this column.
+
+ procedure Tab_To_Column
+ (Buffer : in out Root_Buffer_Type'Class; Column : Positive);
+ -- Put spaces until we're at or past Column.
+
+ subtype Sink is Root_Buffer_Type;
+
+ function NL return Character is (ASCII.LF) with Inline;
+
+ function UTF_8_Length (Buffer : Root_Buffer_Type'Class) return Natural;
+
+ 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 UTF_8_Char of UTF_8 => UTF_8_Char /= NL);
+
+ procedure Put_UTF_8_Lines
+ (Buffer : in out Root_Buffer_Type'Class; Item : UTF_8_Lines);
+
+private
+ function UTF_8_Length (Buffer : Root_Buffer_Type'Class) return Natural
+ is (Buffer.UTF_8_Length);
+end Ada.Strings.Text_Buffers.Utils;
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String) is
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class;
+ V : Unbounded_String) is
begin
String'Put_Image (S, To_String (V));
end Put_Image;
with Ada.Strings.Maps;
with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
-- The language-defined package Strings.Unbounded provides a private type
-- Unbounded_String and a set of operations. An object of type
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class;
+ V : Unbounded_String);
-- The Unbounded_String is using a buffered implementation to increase
-- speed of the Append/Delete/Insert procedures. The Reference string
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String) is
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class;
+ V : Unbounded_String) is
begin
String'Put_Image (S, To_String (V));
end Put_Image;
with Ada.Strings.Maps;
private with Ada.Finalization;
private with System.Atomic_Counters;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
package Ada.Strings.Unbounded with
Initial_Condition => Length (Null_Unbounded_String) = 0
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class;
+ V : Unbounded_String);
pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String);
-- Provide stream routines without dragging in Ada.Streams
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.UTF_Encoding.Wide_Strings;
+with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
+
+package body Ada.Strings.Text_Buffers is
+ function Current_Indent
+ (Buffer : Root_Buffer_Type) return Text_Buffer_Count is
+ (Text_Buffer_Count (Buffer.Indentation));
+
+ procedure Increase_Indent
+ (Buffer : in out Root_Buffer_Type;
+ Amount : Text_Buffer_Count := Standard_Indent)
+ is
+ begin
+ Buffer.Indentation := @ + Natural (Amount);
+ end Increase_Indent;
+
+ procedure Decrease_Indent
+ (Buffer : in out Root_Buffer_Type;
+ Amount : Text_Buffer_Count := Standard_Indent)
+ is
+ begin
+ Buffer.Indentation := @ - Natural (Amount);
+ end Decrease_Indent;
+
+ package body Output_Mapping is
+ -- Implement indentation in Put_UTF_8 and New_Line.
+ -- Implement other output procedures using Put_UTF_8.
+
+ procedure Put (Buffer : in out Buffer_Type; Item : String) is
+ begin
+ Put_UTF_8 (Buffer, Item);
+ end Put;
+
+ procedure Wide_Put (Buffer : in out Buffer_Type; Item : Wide_String) is
+ begin
+ Buffer.All_8_Bits :=
+ @ and then
+ (for all WChar of Item => Wide_Character'Pos (WChar) < 256);
+
+ Put_UTF_8 (Buffer, UTF_Encoding.Wide_Strings.Encode (Item));
+ end Wide_Put;
+
+ procedure Wide_Wide_Put
+ (Buffer : in out Buffer_Type; Item : Wide_Wide_String)
+ is
+ begin
+ Buffer.All_8_Bits :=
+ @ and then
+ (for all WWChar of Item => Wide_Wide_Character'Pos (WWChar) < 256);
+
+ Put_UTF_8 (Buffer, UTF_Encoding.Wide_Wide_Strings.Encode (Item));
+ end Wide_Wide_Put;
+
+ procedure Put_UTF_8
+ (Buffer : in out Buffer_Type;
+ Item : UTF_Encoding.UTF_8_String) is
+ begin
+ if Item'Length = 0 then
+ return;
+ end if;
+
+ if Buffer.Indent_Pending then
+ Buffer.Indent_Pending := False;
+ if Buffer.Indentation > 0 then
+ Put_UTF_8_Implementation
+ (Buffer, (1 .. Buffer.Indentation => ' '));
+ end if;
+ end if;
+
+ Put_UTF_8_Implementation (Buffer, Item);
+ end Put_UTF_8;
+
+ procedure Wide_Put_UTF_16
+ (Buffer : in out Buffer_Type; Item : UTF_Encoding.UTF_16_Wide_String)
+ is
+ begin
+ Wide_Wide_Put (Buffer, UTF_Encoding.Wide_Wide_Strings.Decode (Item));
+ end Wide_Put_UTF_16;
+
+ procedure New_Line (Buffer : in out Buffer_Type) is
+ begin
+ Buffer.Indent_Pending := False; -- just for a moment
+ Put (Buffer, (1 => ASCII.LF));
+ Buffer.Indent_Pending := True;
+ Buffer.UTF_8_Column := 1;
+ end New_Line;
+
+ end Output_Mapping;
+
+end Ada.Strings.Text_Buffers;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS --
+-- --
+-- S p e c --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.UTF_Encoding;
+package Ada.Strings.Text_Buffers with
+ Pure
+is
+
+ type Text_Buffer_Count is range 0 .. Integer'Last;
+
+ New_Line_Count : constant Text_Buffer_Count := 1;
+ -- There is no support for two-character CR/LF line endings.
+
+ type Root_Buffer_Type is abstract tagged limited private with
+ Default_Initial_Condition => Current_Indent (Root_Buffer_Type) = 0;
+
+ procedure Put (Buffer : in out Root_Buffer_Type; Item : String) is abstract;
+
+ procedure Wide_Put
+ (Buffer : in out Root_Buffer_Type; Item : Wide_String) is abstract;
+
+ procedure Wide_Wide_Put
+ (Buffer : in out Root_Buffer_Type; Item : Wide_Wide_String) is abstract;
+
+ procedure Put_UTF_8
+ (Buffer : in out Root_Buffer_Type;
+ Item : UTF_Encoding.UTF_8_String) is abstract;
+
+ procedure Wide_Put_UTF_16
+ (Buffer : in out Root_Buffer_Type;
+ Item : UTF_Encoding.UTF_16_Wide_String) is abstract;
+
+ procedure New_Line (Buffer : in out Root_Buffer_Type) is abstract;
+
+ Standard_Indent : constant Text_Buffer_Count := 3;
+
+ function Current_Indent
+ (Buffer : Root_Buffer_Type) return Text_Buffer_Count;
+
+ procedure Increase_Indent
+ (Buffer : in out Root_Buffer_Type;
+ Amount : Text_Buffer_Count := Standard_Indent) with
+ Post'Class => Current_Indent (Buffer) =
+ Current_Indent (Buffer)'Old + Amount;
+
+ procedure Decrease_Indent
+ (Buffer : in out Root_Buffer_Type;
+ Amount : Text_Buffer_Count := Standard_Indent) with
+ Pre'Class => Current_Indent (Buffer) >= Amount
+ or else raise Constraint_Error,
+ Post'Class => Current_Indent (Buffer) =
+ Current_Indent (Buffer)'Old - Amount;
+
+private
+
+ type Root_Buffer_Type is abstract tagged limited record
+ Indentation : Natural := 0;
+ -- Current indentation
+
+ Indent_Pending : Boolean := True;
+ -- Set by calls to New_Line, cleared when indentation emitted.
+
+ UTF_8_Length : Natural := 0;
+ -- Count of UTF_8 characters in the buffer
+
+ UTF_8_Column : Positive := 1;
+ -- Column in which next character will be written.
+ -- Calling New_Line resets to 1.
+
+ All_7_Bits : Boolean := True;
+ -- True if all characters seen so far fit in 7 bits
+ All_8_Bits : Boolean := True;
+ -- True if all characters seen so far fit in 8 bits
+
+ end record;
+
+ generic
+ -- This generic allows a client to extend Root_Buffer_Type without
+ -- having to implement any of the abstract subprograms other than
+ -- Put_UTF_8 (i.e., Put, Wide_Put, Wide_Wide_Put, Wide_Put_UTF_16,
+ -- and New_Line). Without this generic, each client would have to
+ -- duplicate the implementations of those 5 subprograms.
+ -- This generic also takes care of handling indentation, thereby
+ -- avoiding further code duplication. The name "Output_Mapping" isn't
+ -- wonderful, but it refers to the idea that this package knows how
+ -- to implement all the other output operations in terms of
+ -- just Put_UTF_8.
+ --
+ -- The classwide parameter type here is somewhat tricky;
+ -- there are no dispatching calls associated with this parameter.
+ -- It would be more accurate to say that the parameter is of type
+ -- Output_Mapping.Buffer_Type'Class, but that type hasn't been declared
+ -- yet. Instantiators will typically declare a non-abstract extension,
+ -- B2, of the buffer type, B1, declared in their instantiation. The
+ -- actual Put_UTF_8_Implementation parameter may then have a
+ -- precondition "Buffer in B2'Class" and that subprogram can safely
+ -- access components declared as part of the declaration of B2.
+
+ with procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String);
+ package Output_Mapping is
+ type Buffer_Type is abstract new Root_Buffer_Type with null record;
+
+ overriding procedure Put (Buffer : in out Buffer_Type; Item : String);
+
+ overriding procedure Wide_Put
+ (Buffer : in out Buffer_Type; Item : Wide_String);
+
+ overriding procedure Wide_Wide_Put
+ (Buffer : in out Buffer_Type; Item : Wide_Wide_String);
+
+ overriding procedure Put_UTF_8
+ (Buffer : in out Buffer_Type;
+ Item : UTF_Encoding.UTF_8_String);
+
+ overriding procedure Wide_Put_UTF_16
+ (Buffer : in out Buffer_Type; Item : UTF_Encoding.UTF_16_Wide_String);
+
+ overriding procedure New_Line (Buffer : in out Buffer_Type);
+ end Output_Mapping;
+
+end Ada.Strings.Text_Buffers;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- ADA.STRINGS.TEXT_OUTPUT --
--- --
--- S p e c --
--- --
--- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- 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. --
--- --
-------------------------------------------------------------------------------
-
--- Simplified version used during bootstrap only
-
-with Ada.Strings.UTF_Encoding;
-
-package Ada.Strings.Text_Output with Pure 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.
- --
- -- Users are not expected to extend type Sink.
- --
- -- 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;
-
- subtype UTF_8 is UTF_8_Lines;
-
- 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
- -- 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 with Storage_Size => 0;
- 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;
-- --
------------------------------------------------------------------------------
+with Ada.Strings.Text_Buffers.Utils;
+use Ada.Strings.Text_Buffers;
+use Ada.Strings.Text_Buffers.Utils;
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
begin
New_Line (S);
Put_7bit (S, '[');
- Indent (S, 1);
+ Increase_Indent (S, 1);
end Array_Before;
procedure Array_Between (S : in out Sink'Class) is
procedure Array_After (S : in out Sink'Class) is
begin
- Outdent (S, 1);
+ Decrease_Indent (S, 1);
Put_7bit (S, ']');
end Array_After;
begin
New_Line (S);
Put_7bit (S, '(');
- Indent (S, 1);
+ Increase_Indent (S, 1);
end Record_Before;
procedure Record_Between (S : in out Sink'Class) is
procedure Record_After (S : in out Sink'Class) is
begin
- Outdent (S, 1);
+ Decrease_Indent (S, 1);
Put_7bit (S, ')');
end Record_After;
procedure Put_Image_Unknown (S : in out Sink'Class; Type_Name : String) is
begin
Put_UTF_8 (S, "{");
- Put_String (S, Type_Name);
+ Put (S, Type_Name);
Put_UTF_8 (S, " object}");
end Put_Image_Unknown;
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Text_Output;
+with Ada.Strings.Text_Buffers;
with System.Unsigned_Types;
package System.Put_Images with Pure is
pragma Preelaborate;
- subtype Sink is Ada.Strings.Text_Output.Sink;
+ subtype Sink is Ada.Strings.Text_Buffers.Root_Buffer_Type;
procedure Put_Image_Integer (S : in out Sink'Class; X : Integer);
procedure Put_Image_Long_Long_Integer
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Text_Output.Utils;
with Ada.Unchecked_Conversion;
with System.Random_Seed;
---------------
procedure Put_Image
- (S : in out Strings.Text_Output.Sink'Class; V : State) is
+ (S : in out Strings.Text_Buffers.Root_Buffer_Type'Class; V : State) is
begin
- Strings.Text_Output.Utils.Put_String (S, Image (V));
+ Strings.Text_Buffers.Put (S, Image (V));
end Put_Image;
-----------
with Interfaces;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
package System.Random_Numbers with
SPARK_Mode => Off
type State is array (0 .. N - 1) of State_Val with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : State);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : State);
type Writable_Access (Self : access Generator) is limited null record;
-- Auxiliary type to make Generator a self-referential type
range Ada_Streams_Stream_IO .. Ada_Streams_Stream_IO;
subtype Ada_Strings_Descendant is Ada_Descendant
- range Ada_Strings_Superbounded .. Ada_Strings_Text_Output_Buffers;
+ range Ada_Strings_Superbounded .. Ada_Strings_Text_Buffers_Unbounded;
- subtype Ada_Strings_Text_Output_Descendant is Ada_Strings_Descendant
- range Ada_Strings_Text_Output_Utils .. Ada_Strings_Text_Output_Buffers;
+ subtype Ada_Strings_Text_Buffers_Descendant is Ada_Strings_Descendant
+ range Ada_Strings_Text_Buffers_Unbounded ..
+ Ada_Strings_Text_Buffers_Unbounded;
subtype Ada_Text_IO_Descendant is Ada_Descendant
range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO;
elsif U_Id in Ada_Strings_Descendant then
Name_Buffer (12) := '.';
- if U_Id in Ada_Strings_Text_Output_Descendant then
- Name_Buffer (24) := '.';
+ if U_Id in Ada_Strings_Text_Buffers_Descendant then
+ Name_Buffer (25) := '.';
end if;
elsif U_Id in Ada_Text_IO_Descendant then
Ada_Strings_Wide_Superbounded,
Ada_Strings_Wide_Wide_Superbounded,
Ada_Strings_Unbounded,
- Ada_Strings_Text_Output,
+ Ada_Strings_Text_Buffers,
- -- Children of Ada.Strings.Text_Output
+ -- Children of Ada.Strings.Text_Buffers
- Ada_Strings_Text_Output_Utils,
- Ada_Strings_Text_Output_Buffers,
+ Ada_Strings_Text_Buffers_Unbounded,
-- Children of Ada.Text_IO (for Check_Text_IO_Special_Unit)
RE_Unbounded_String, -- Ada.Strings.Unbounded
- RE_Sink, -- Ada.Strings.Text_Output
+ RE_Root_Buffer_Type, -- Ada.Strings.Text_Buffers
+ RE_Put_UTF_8, -- Ada.Strings.Text_Buffers
+ RE_Wide_Wide_Put, -- Ada.Strings.Text_Buffers
- RE_Put_UTF_8, -- Ada.Strings.Text_Output.Utils
- RE_Put_Wide_Wide_String, -- Ada.Strings.Text_Output.Utils
-
- RE_Buffer, -- Ada.Strings.Text_Output.Buffers
- RE_New_Buffer, -- Ada.Strings.Text_Output.Buffers
- RE_Destroy, -- Ada.Strings.Text_Output.Buffers
- RE_Get, -- Ada.Strings.Text_Output.Buffers
+ RE_Buffer_Type, -- Ada.Strings.Text_Buffers.Unbounded
+ RE_Get, -- Ada.Strings.Text_Buffers.Unbounded
+ RE_Wide_Get, -- Ada.Strings.Text_Buffers.Unbounded
+ RE_Wide_Wide_Get, -- Ada.Strings.Text_Buffers.Unbounded
RE_Wait_For_Release, -- Ada.Synchronous_Barriers
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_Root_Buffer_Type => Ada_Strings_Text_Buffers,
+ RE_Put_UTF_8 => Ada_Strings_Text_Buffers,
+ RE_Wide_Wide_Put => Ada_Strings_Text_Buffers,
- RE_Buffer => Ada_Strings_Text_Output_Buffers,
- RE_New_Buffer => Ada_Strings_Text_Output_Buffers,
- RE_Destroy => Ada_Strings_Text_Output_Buffers,
- RE_Get => Ada_Strings_Text_Output_Buffers,
+ RE_Buffer_Type => Ada_Strings_Text_Buffers_Unbounded,
+ RE_Get => Ada_Strings_Text_Buffers_Unbounded,
+ RE_Wide_Get => Ada_Strings_Text_Buffers_Unbounded,
+ RE_Wide_Wide_Get => Ada_Strings_Text_Buffers_Unbounded,
RE_Wait_For_Release => Ada_Synchronous_Barriers,
Analyze_And_Resolve (E1);
-- Check that the first argument is
- -- Ada.Strings.Text_Output.Sink'Class.
+ -- Ada.Strings.Text_Buffers.Root_Buffer_Type'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 not Is_RTE (Root_Type (Root_Type (Etype (E1))), RE_Sink) then
+ if not Is_RTE (Root_Type (Root_Type (Etype (E1))),
+ RE_Root_Buffer_Type)
+ then
Error_Attr
- ("expected Ada.Strings.Text_Output.Sink''Class", E1);
+ ("expected Ada.Strings.Text_Buffers.Root_Buffer_Type''Class",
+ E1);
end if;
-- Check that the second argument is of the right type
-- Start of processing for Analyze_Compilation_Unit
begin
- Exp_Put_Image.Preload_Sink (N);
+ Exp_Put_Image.Preload_Root_Buffer_Type (N);
Process_Compilation_Unit_Pragmas (N);
F := First_Formal (Subp);
- if No (F) or else Etype (F) /= Class_Wide_Type (RTE (RE_Sink)) then
+ if No (F)
+ or else Etype (F) /= Class_Wide_Type (RTE (RE_Root_Buffer_Type))
+ then
return False;
end if;
begin
Subp_Id := Make_Defining_Identifier (Loc, Sname);
- -- S : Sink'Class
+ -- S : Root_Buffer_Type'Class
Formals := New_List (
Make_Parameter_Specification (Loc,
projects / thirdparty / gcc.git / commitdiff
