with Einfo; use Einfo;
with Nlists; use Nlists;
with Sinfo; use Sinfo;
-with Tree_IO; use Tree_IO;
with GNAT.HTable;
Aspect_Variable_Indexing => True,
others => False);
- procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id);
- -- Same as Set_Aspect_Specifications, but does not contain the assertion
- -- that checks that N does not already have aspect specifications. This
- -- subprogram is supposed to be used as a part of Tree_Read. When reading
- -- tree, first read nodes with their basic properties (as Atree.Tree_Read),
- -- this includes reading the Has_Aspects flag for each node, then we reed
- -- all the list tables and only after that we call Tree_Read for Aspects.
- -- That is, when reading the tree, the list of aspects is attached to the
- -- node that already has Has_Aspects flag set ON.
-
------------------------------------------
-- Hash Table for Aspect Specifications --
------------------------------------------
Aspect_Specifications_Hash_Table.Set (N, L);
end Set_Aspect_Specifications;
- ----------------------------------------
- -- Set_Aspect_Specifications_No_Check --
- ----------------------------------------
-
- procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is
- begin
- pragma Assert (Permits_Aspect_Specifications (N));
- pragma Assert (L /= No_List);
-
- Set_Has_Aspects (N);
- Set_Parent (L, N);
- Aspect_Specifications_Hash_Table.Set (N, L);
- end Set_Aspect_Specifications_No_Check;
-
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- Node : Node_Id;
- List : List_Id;
- begin
- loop
- Tree_Read_Int (Int (Node));
- Tree_Read_Int (Int (List));
- exit when List = No_List;
- Set_Aspect_Specifications_No_Check (Node, List);
- end loop;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- Node : Node_Id := Empty;
- List : List_Id;
- begin
- Aspect_Specifications_Hash_Table.Get_First (Node, List);
- loop
- Tree_Write_Int (Int (Node));
- Tree_Write_Int (Int (List));
- exit when List = No_List;
- Aspect_Specifications_Hash_Table.Get_Next (Node, List);
- end loop;
- end Tree_Write;
-
-- Package initialization sets up Aspect Id hash table
begin
-- node that has its Has_Aspects flag set True on entry, or with L being an
-- empty list or No_List.
- procedure Tree_Read;
- -- Reads contents of Aspect_Specifications hash table from the tree file
-
- procedure Tree_Write;
- -- Writes contents of Aspect_Specifications hash table to the tree file
-
end Aspects;
with Opt; use Opt;
with Output; use Output;
with Sinput; use Sinput;
-with Tree_IO; use Tree_IO;
with GNAT.Heap_Sort_G;
Discard := Traverse (Node);
end Traverse_Proc;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Tree_Read_Int (Node_Count);
- Nodes.Tree_Read;
- Flags.Tree_Read;
- Orig_Nodes.Tree_Read;
- Paren_Counts.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Tree_Write_Int (Node_Count);
- Nodes.Tree_Write;
- Flags.Tree_Write;
- Orig_Nodes.Tree_Write;
- Paren_Counts.Tree_Write;
- end Tree_Write;
-
------------------------------
-- Unchecked Access Package --
------------------------------
procedure Initialize;
-- Called at the start of compilation to initialize the allocation of
-- the node and list tables and make the standard entries for Empty,
- -- Error and Error_List. Note that Initialize must not be called if
- -- Tree_Read is used.
+ -- Error and Error_List.
procedure Lock;
-- Called before the back end is invoked to lock the nodes table
-- Called to unlock entity modifications when assertions are enabled; if
-- assertions are not enabled calling this subprogram has no effect.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
function New_Node
(New_Node_Kind : Node_Kind;
New_Sloc : Source_Ptr) return Node_Id;
Note that this option should be used only for compiling -- the
code is likely to malfunction at run time.
- Note that when :switch:`-gnatct` is used to generate trees for input
- into ASIS tools, these representation clauses are removed
- from the tree and ignored. This means that the tool will not see them.
-
.. index:: -gnatjnn (gcc)
Print package Standard.
-.. index:: -gnatt (gcc)
-
-:switch:`-gnatt`
- Generate tree output file.
-
-
.. index:: -gnatT (gcc)
:switch:`-gnatT{nnn}`
implies :switch:`-gnatq`, since the semantic phase must be run to get a
meaningful ALI file.
- In addition, if :switch:`-gnatt` is also specified, then the tree file is
- generated even if there are illegalities. It may be useful in this case
- to also specify :switch:`-gnatq` to ensure that full semantic processing
- occurs. The resulting tree file can be processed by ASIS, for the purpose
- of providing partial information about illegal units, but if the error
- causes the tree to be badly malformed, then ASIS may crash during the
- analysis.
-
When :switch:`-gnatQ` is used and the generated :file:`ALI` file is marked as
being in error, ``gnatmake`` will attempt to recompile the source when it
finds such an :file:`ALI` file, including with switch :switch:`-gnatc`.
Auxiliary Output Control
------------------------
-.. index:: -gnatt (gcc)
-.. index:: Writing internal trees
-.. index:: Internal trees, writing to file
-
-:switch:`-gnatt`
- Causes GNAT to write the internal tree for a unit to a file (with the
- extension :file:`.adt`.
- This not normally required, but is used by separate analysis tools.
- Typically
- these tools do the necessary compilations automatically, so you should
- not have to specify this switch in normal operation.
- Note that the combination of switches :switch:`-gnatct`
- generates a tree in the form required by ASIS applications.
-
-
.. index:: -gnatu (gcc)
:switch:`-gnatu`
Elmts.Table (Elmt).Node := New_Node;
end Replace_Elmt;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Elists.Tree_Read;
- Elmts.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Elists.Tree_Write;
- Elmts.Tree_Write;
- end Tree_Write;
-
------------
-- Unlock --
------------
procedure Initialize;
-- Initialize allocation of element list tables. Called at the start of
- -- compiling each new main source file. Note that Initialize must not be
- -- called if Tree_Read is used.
+ -- compiling each new main source file.
procedure Lock;
-- Lock tables used for element lists before calling backend
procedure Unlock;
-- Unlock list tables, in cases where the back end needs to modify them
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
function Last_Elist_Id return Elist_Id;
-- Returns Id of last allocated element list header
-- --
------------------------------------------------------------------------------
-with Alloc;
-with Table;
-with Types; use Types;
-
package body Fname is
- -----------------------------
- -- Dummy Table Definitions --
- -----------------------------
-
- -- The following table was used in old versions of the compiler. We retain
- -- the declarations here for compatibility with old tree files. The new
- -- version of the compiler does not use this table, and will write out a
- -- dummy empty table for Tree_Write.
-
- type SFN_Entry is record
- U : Unit_Name_Type;
- F : File_Name_Type;
- end record;
-
- package SFN_Table is new Table.Table (
- Table_Component_Type => SFN_Entry,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => Alloc.SFN_Table_Initial,
- Table_Increment => Alloc.SFN_Table_Increment,
- Table_Name => "Fname_Dummy_Table");
-
function Has_Internal_Extension (Fname : String) return Boolean;
pragma Inline (Has_Internal_Extension);
-- True if the extension is appropriate for an internal/predefined unit.
return Result;
end Is_Predefined_Renaming_File_Name;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- SFN_Table.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- SFN_Table.Tree_Write;
- end Tree_Write;
-
end Fname;
function Is_GNAT_File_Name (Fname : File_Name_Type) return Boolean;
-- True for units in the GNAT hierarchy
- procedure Tree_Read;
- -- Dummy procedure (reads dummy table values from tree file)
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using Tree_Write
- -- This is actually a dummy routine, since the relevant table is
- -- no longer used, but we retain it for now, to avoid a tree file
- -- incompatibility with the 3.13 compiler. Should be removed for
- -- the 3.14a release ???
-
end Fname;
ada/table.o \
ada/targparm.o \
ada/tbuild.o \
- ada/tree_gen.o \
- ada/tree_in.o \
- ada/tree_io.o \
ada/treepr.o \
ada/treeprs.o \
ada/ttypes.o \
ada/table.o \
ada/targext.o \
ada/targparm.o \
- ada/tree_io.o \
ada/types.o \
ada/uintp.o \
ada/uname.o \
ada/libgnat/s-exctab.ads ada/libgnat/s-memory.ads ada/libgnat/s-os_lib.ads ada/libgnat/s-parame.ads \
ada/libgnat/s-stalib.ads ada/libgnat/s-strops.ads ada/libgnat/s-sopco3.ads ada/libgnat/s-sopco4.ads \
ada/libgnat/s-sopco5.ads ada/libgnat/s-string.ads ada/libgnat/s-traent.ads ada/libgnat/s-unstyp.ads \
- ada/libgnat/s-wchcon.ads ada/libgnat/system.ads ada/table.adb ada/table.ads ada/tree_io.ads \
+ ada/libgnat/s-wchcon.ads ada/libgnat/system.ads ada/table.adb ada/table.ads \
ada/types.ads ada/libgnat/unchdeal.ads ada/libgnat/unchconv.ads
# Special flags - see gcc-interface/Makefile.in for the template.
a-except.o ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o \
gnatvsn.o hostparm.o indepsw.o interfac.o i-c.o i-cstrin.o namet.o opt.o \
osint.o output.o rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \
- sdefault.o snames.o stylesw.o switch.o system.o table.o targparm.o tree_io.o \
+ sdefault.o snames.o stylesw.o switch.o system.o table.o targparm.o \
types.o validsw.o widechar.o
GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \
s-secsta.o s-stalib.o s-stoele.o scans.o scng.o sdefault.o sfn_scan.o \
s-purexc.o s-htable.o scil_ll.o sem_aux.o sinfo.o sinput.o sinput-c.o \
snames.o stand.o stringt.o styleg.o stylesw.o system.o validsw.o \
- switch.o switch-m.o table.o targparm.o tempdir.o tree_io.o types.o uintp.o \
+ switch.o switch-m.o table.o targparm.o tempdir.o types.o uintp.o \
uname.o urealp.o usage.o widechar.o \
$(EXTRA_GNATMAKE_OBJS)
with Stylesw; use Stylesw;
with Targparm; use Targparm;
with Tbuild;
-with Tree_Gen;
with Treepr; use Treepr;
with Ttypes;
with Types; use Types;
-- Always perform semantics and generate ali files in CodePeer mode,
-- so that a gnatmake -c -k will proceed further when possible.
- Force_ALI_Tree_File := True;
+ Force_ALI_File := True;
Try_Semantics := True;
-- Make the Ada front end more liberal so that the compiler will
-- Generate ALI file if specially requested
- if Opt.Force_ALI_Tree_File then
+ if Opt.Force_ALI_File then
Write_ALI (Object => False);
- Tree_Gen;
end if;
Exit_Program (E_Errors);
Treepr.Tree_Dump;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
- Tree_Gen;
Namet.Finalize;
Check_Rep_Info;
-- Force generation of ALI file, for backward compatibility
- Opt.Force_ALI_Tree_File := True;
+ Opt.Force_ALI_File := True;
elsif Main_Unit_Kind = N_Subunit then
Write_Str (" (subunit)");
-- Force generation of ALI file, for backward compatibility
- Opt.Force_ALI_Tree_File := True;
+ Opt.Force_ALI_File := True;
-- Only other case is a package spec
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Treepr.Tree_Dump;
- Tree_Gen;
-- Generate ALI file if specially requested, or for missing subunits,
-- subunits or predefined generic. For ignored ghost code, the object
-- an object file without an ALI file.
if Is_Ignored_Ghost_Unit (Main_Unit_Node)
- or else Opt.Force_ALI_Tree_File
+ or else Opt.Force_ALI_File
then
Write_ALI (Object => Is_Ignored_Ghost_Unit (Main_Unit_Node));
end if;
Exit_Program (Ecode);
end if;
- -- In -gnatc mode we only do annotation if -gnatt or -gnatR is also set,
- -- or if -gnatwz is enabled (default setting) and there is an unchecked
+ -- In -gnatc mode we only do annotation if -gnatR is also set, or if
+ -- -gnatwz is enabled (default setting) and there is an unchecked
-- conversion that involves a type whose size is not statically known,
-- as indicated by Back_Annotate_Rep_Info being set to True.
Errout.Output_Messages;
Write_ALI (Object => False);
Tree_Dump;
- Tree_Gen;
Namet.Finalize;
if not (Generate_SCIL or GNATprove_Mode) then
-- fact result in further tree decoration from the original tree file.
-- Note that we dump the tree just before generating it, so that the
-- dump will exactly reflect what is written out.
- -- Should we remove Tree_Dump completely now that ASIS is no longer
- -- supported???
Treepr.Tree_Dump;
- Tree_Gen;
-- Finalize name table and we are all done
@copying
@quotation
-GNAT User's Guide for Native Platforms , Dec 10, 2019
+GNAT User's Guide for Native Platforms , May 04, 2020
AdaCore
and Value_Size. Pragma Default_Scalar_Storage_Order is also ignored.
Note that this option should be used only for compiling -- the
code is likely to malfunction at run time.
-
-Note that when @code{-gnatct} is used to generate trees for input
-into ASIS tools, these representation clauses are removed
-from the tree and ignored. This means that the tool will not see them.
@end table
@geindex -gnatjnn (gcc)
Print package Standard.
@end table
-@geindex -gnatt (gcc)
-
-
-@table @asis
-
-@item @code{-gnatt}
-
-Generate tree output file.
-@end table
-
@geindex -gnatT (gcc)
implies @code{-gnatq}, since the semantic phase must be run to get a
meaningful ALI file.
-In addition, if @code{-gnatt} is also specified, then the tree file is
-generated even if there are illegalities. It may be useful in this case
-to also specify @code{-gnatq} to ensure that full semantic processing
-occurs. The resulting tree file can be processed by ASIS, for the purpose
-of providing partial information about illegal units, but if the error
-causes the tree to be badly malformed, then ASIS may crash during the
-analysis.
-
When @code{-gnatQ} is used and the generated @code{ALI} file is marked as
being in error, @code{gnatmake} will attempt to recompile the source when it
finds such an @code{ALI} file, including with switch @code{-gnatc}.
@subsection Auxiliary Output Control
-@geindex -gnatt (gcc)
-
-@geindex Writing internal trees
-
-@geindex Internal trees
-@geindex writing to file
-
-
-@table @asis
-
-@item @code{-gnatt}
-
-Causes GNAT to write the internal tree for a unit to a file (with the
-extension @code{.adt}.
-This not normally required, but is used by separate analysis tools.
-Typically
-these tools do the necessary compilations automatically, so you should
-not have to specify this switch in normal operation.
-Note that the combination of switches @code{-gnatct}
-generates a tree in the form required by ASIS applications.
-@end table
-
@geindex -gnatu (gcc)
with Sinput; use Sinput;
with Stand; use Stand;
with Stringt; use Stringt;
-with Tree_IO; use Tree_IO;
with Uname; use Uname;
with Widechar; use Widechar;
TSN := TSN + 1;
end Synchronize_Serial_Number;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- N : Nat;
- S : String_Ptr;
-
- begin
- Units.Tree_Read;
-
- -- Read Compilation_Switches table. First release the memory occupied
- -- by the previously loaded switches.
-
- for J in Compilation_Switches.First .. Compilation_Switches.Last loop
- Free (Compilation_Switches.Table (J));
- end loop;
-
- Tree_Read_Int (N);
- Compilation_Switches.Set_Last (N);
-
- for J in 1 .. N loop
- Tree_Read_Str (S);
- Compilation_Switches.Table (J) := S;
- end loop;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Units.Tree_Write;
-
- -- Write Compilation_Switches table
-
- Tree_Write_Int (Compilation_Switches.Last);
-
- for J in 1 .. Compilation_Switches.Last loop
- Tree_Write_Str (Compilation_Switches.Table (J));
- end loop;
- end Tree_Write;
-
--------------------
-- Unit_Name_Hash --
--------------------
-- important to keep the serial numbers synchronized in the two cases (e.g.
-- when the references in a package and a client must be kept consistent).
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
procedure Unlock;
-- Unlock internal tables, in cases where the back end needs to modify them
-- This table is set as part of the compiler argument scanning in
-- Back_End. It can also be reset in -gnatc mode from the data in an
- -- existing ali file, and is read and written by the Tree_Read and
- -- Tree_Write routines.
+ -- existing ali file.
package Compilation_Switches is new Table.Table (
Table_Component_Type => String_Ptr,
-- source file must be properly reflected in the C header file namet.h
-- which is created manually from namet.ads and namet.adb.
-with Debug; use Debug;
-with Opt; use Opt;
-with Output; use Output;
-with System; use System;
-with Tree_IO; use Tree_IO;
+with Debug; use Debug;
+with Opt; use Opt;
+with Output; use Output;
with Widechar;
with Interfaces; use Interfaces;
return Buf.Chars (1 .. Buf.Length);
end To_String;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Name_Chars.Tree_Read;
- Name_Entries.Tree_Read;
-
- Tree_Read_Data
- (Hash_Table'Address,
- Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Name_Chars.Tree_Write;
- Name_Entries.Tree_Write;
-
- Tree_Write_Data
- (Hash_Table'Address,
- Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
- end Tree_Write;
-
------------
-- Unlock --
------------
-- Unlocks the name table to allow use of the extra space reserved by the
-- call to Lock. See gnat1drv for details of the need for this.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
procedure Write_Name (Id : Valid_Name_Id);
-- Write_Name writes the characters of the specified name using the
-- standard output procedures in package Output. The name is written
Next_Node.Set_Last (N);
Prev_Node.Set_Last (N);
- -- Make sure we have no uninitialized junk in any new entires added.
- -- This ensures that Tree_Gen will not write out any uninitialized junk.
+ -- Make sure we have no uninitialized junk in any new entries added.
for J in Old_Last + 1 .. N loop
Next_Node.Table (J) := Empty;
Prev_Node.Table (Node) := To;
end Set_Prev;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- pragma Assert (not Locked);
- Lists.Tree_Read;
- Next_Node.Tree_Read;
- Prev_Node.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Lists.Tree_Write;
- Next_Node.Tree_Write;
- Prev_Node.Tree_Write;
- end Tree_Write;
-
------------
-- Unlock --
------------
procedure Initialize;
-- Called at the start of compilation of each new main source file to
- -- initialize the allocation of the list table. Note that Initialize
- -- must not be called if Tree_Read is used.
+ -- initialize the allocation of the list table.
procedure Lock;
-- Called to lock tables before back end is called
-- Called to unlock list contents when assertions are enabled; if
-- assertions are not enabled calling this subprogram has no effect.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
function Parent (List : List_Id) return Node_Or_Entity_Id;
pragma Inline (Parent);
-- Node lists may have a parent in the same way as a node. The function
-- --
------------------------------------------------------------------------------
-with Gnatvsn; use Gnatvsn;
-with System; use System;
-with Tree_IO; use Tree_IO;
-
package body Opt is
- SU : constant := Storage_Unit;
- -- Shorthand for System.Storage_Unit
-
-------------------------
-- Back_End_Exceptions --
-------------------------
Polling_Required := Polling_Required_Config;
end Set_Config_Switches;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- Tree_Version_String_Len : Nat;
- Ada_Version_Config_Val : Nat;
- Ada_Version_Explicit_Config_Val : Nat;
- Assertions_Enabled_Config_Val : Nat;
-
- begin
- Tree_Read_Bool (Address_Is_Private);
- Tree_Read_Bool (Brief_Output);
- Tree_Read_Bool (GNAT_Mode);
- Tree_Read_Char (Identifier_Character_Set);
- Tree_Read_Bool (Ignore_Rep_Clauses);
- Tree_Read_Bool (Ignore_Style_Checks_Pragmas);
- Tree_Read_Int (Maximum_File_Name_Length);
- Tree_Read_Data (Suppress_Options'Address,
- (Suppress_Options'Size + SU - 1) / SU);
- Tree_Read_Bool (Verbose_Mode);
- Tree_Read_Data (Warning_Mode'Address,
- (Warning_Mode'Size + SU - 1) / SU);
- Tree_Read_Int (Ada_Version_Config_Val);
- Tree_Read_Int (Ada_Version_Explicit_Config_Val);
- Tree_Read_Int (Assertions_Enabled_Config_Val);
- Tree_Read_Bool (All_Errors_Mode);
- Tree_Read_Bool (Assertions_Enabled);
- Tree_Read_Bool (Check_Float_Overflow);
- Tree_Read_Int (Int (Check_Policy_List));
- Tree_Read_Int (Int (Default_Pool));
- Tree_Read_Bool (Full_List);
-
- Ada_Version_Config :=
- Ada_Version_Type'Val (Ada_Version_Config_Val);
- Ada_Version_Explicit_Config :=
- Ada_Version_Type'Val (Ada_Version_Explicit_Config_Val);
- Assertions_Enabled_Config :=
- Boolean'Val (Assertions_Enabled_Config_Val);
-
- -- Read version string: we have to get the length first
-
- Tree_Read_Int (Tree_Version_String_Len);
-
- declare
- Tmp : String (1 .. Integer (Tree_Version_String_Len));
- begin
- Tree_Read_Data
- (Tmp'Address, Tree_Version_String_Len);
- System.Strings.Free (Tree_Version_String);
- Free (Tree_Version_String);
- Tree_Version_String := new String'(Tmp);
- end;
-
- Tree_Read_Data (Distribution_Stub_Mode'Address,
- (Distribution_Stub_Mode'Size + SU - 1) / Storage_Unit);
- Tree_Read_Bool (Inline_Active);
- Tree_Read_Bool (Inline_Processing_Required);
- Tree_Read_Bool (List_Units);
- Tree_Read_Int (Multiple_Unit_Index);
- Tree_Read_Bool (Configurable_Run_Time_Mode);
- Tree_Read_Data (Operating_Mode'Address,
- (Operating_Mode'Size + SU - 1) / Storage_Unit);
- Tree_Read_Bool (Suppress_Checks);
- Tree_Read_Bool (Try_Semantics);
- Tree_Read_Data (Wide_Character_Encoding_Method'Address,
- (Wide_Character_Encoding_Method'Size + SU - 1) / SU);
- Tree_Read_Bool (Upper_Half_Encoding);
- Tree_Read_Bool (Force_ALI_Tree_File);
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- Version_String : String := Gnat_Version_String;
-
- begin
- Tree_Write_Bool (Address_Is_Private);
- Tree_Write_Bool (Brief_Output);
- Tree_Write_Bool (GNAT_Mode);
- Tree_Write_Char (Identifier_Character_Set);
- Tree_Write_Bool (Ignore_Rep_Clauses);
- Tree_Write_Bool (Ignore_Style_Checks_Pragmas);
- Tree_Write_Int (Maximum_File_Name_Length);
- Tree_Write_Data (Suppress_Options'Address,
- (Suppress_Options'Size + SU - 1) / SU);
- Tree_Write_Bool (Verbose_Mode);
- Tree_Write_Data (Warning_Mode'Address,
- (Warning_Mode'Size + SU - 1) / Storage_Unit);
- Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Config));
- Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Explicit_Config));
- Tree_Write_Int (Boolean'Pos (Assertions_Enabled_Config));
- Tree_Write_Bool (All_Errors_Mode);
- Tree_Write_Bool (Assertions_Enabled);
- Tree_Write_Bool (Check_Float_Overflow);
- Tree_Write_Int (Int (Check_Policy_List));
- Tree_Write_Int (Int (Default_Pool));
- Tree_Write_Bool (Full_List);
- Tree_Write_Int (Int (Version_String'Length));
- Tree_Write_Data (Version_String'Address, Version_String'Length);
- Tree_Write_Data (Distribution_Stub_Mode'Address,
- (Distribution_Stub_Mode'Size + SU - 1) / SU);
- Tree_Write_Bool (Inline_Active);
- Tree_Write_Bool (Inline_Processing_Required);
- Tree_Write_Bool (List_Units);
- Tree_Write_Int (Multiple_Unit_Index);
- Tree_Write_Bool (Configurable_Run_Time_Mode);
- Tree_Write_Data (Operating_Mode'Address,
- (Operating_Mode'Size + SU - 1) / SU);
- Tree_Write_Bool (Suppress_Checks);
- Tree_Write_Bool (Try_Semantics);
- Tree_Write_Data (Wide_Character_Encoding_Method'Address,
- (Wide_Character_Encoding_Method'Size + SU - 1) / SU);
- Tree_Write_Bool (Upper_Half_Encoding);
- Tree_Write_Bool (Force_ALI_Tree_File);
- end Tree_Write;
-
end Opt;
-- GNAT
-- If set True, enables back annotation of representation information
-- by gigi, even in -gnatc mode. This is set True by the use of -gnatR
- -- (list representation information) or -gnatt (generate tree). It is
- -- also set true if certain Unchecked_Conversion instantiations require
- -- checking based on annotated values.
+ -- (list representation information). It is also set true if certain
+ -- Unchecked_Conversion instantiations require checking based on annotated
+ -- values.
Back_End_Handles_Limited_Types : Boolean;
-- This flag is set true if the back end can properly handle limited or
-- Indicates the current setting of Fast_Math mode, as set by the use
-- of a Fast_Math pragma (set True by Fast_Math (On)).
- Force_ALI_Tree_File : Boolean := False;
+ Force_ALI_File : Boolean := False;
-- GNAT
- -- Force generation of ALI file even if errors are encountered. Also forces
- -- generation of tree file if -gnatt is also set. Set on by use of -gnatQ.
+ -- Force generation of ALI file even if errors are encountered.
+ -- Set on by use of -gnatQ.
Disable_ALI_File : Boolean := False;
-- GNAT
-- Set True to treat pragma Restrictions as Restriction_Warnings. Set by
-- -gnatr switch.
- Tree_Output : Boolean := False;
- -- GNAT
- -- Set to True (-gnatt) to generate output tree file
-
Try_Semantics : Boolean := False;
-- GNAT
-- Flag set to force attempt at semantic analysis, even if parser errors
-- be in the spec of Expander, but it is referenced by Errout, and it
-- really seems wrong for Errout to depend on Expander.
- -----------------------
- -- Tree I/O Routines --
- -----------------------
-
- procedure Tree_Read;
- -- Reads switch settings from current tree file using Tree_Read
-
- procedure Tree_Write;
- -- Writes out switch settings to current tree file using Tree_Write
-
- Tree_Version_String : String_Access;
- -- Used to store the compiler version string read from a tree file to check
- -- if it is from the same date as stored in the version string in Gnatvsn.
-
-----------------------------------
-- Modes for Formal Verification --
-----------------------------------
-- --
------------------------------------------------------------------------------
-with Opt; use Opt;
-with Tree_IO; use Tree_IO;
+with Opt; use Opt;
package body Osint.C is
Output_Object_File_Name := new String'(Name);
end Set_Output_Object_File_Name;
- ----------------
- -- Tree_Close --
- ----------------
-
- procedure Tree_Close is
- Status : Boolean;
- begin
- Tree_Write_Terminate;
- Close (Output_FD, Status);
-
- if not Status then
- Fail
- ("error while closing tree file "
- & Get_Name_String (Output_File_Name));
- end if;
- end Tree_Close;
-
- -----------------
- -- Tree_Create --
- -----------------
-
- procedure Tree_Create is
- Dot_Index : Natural;
-
- begin
- Get_Name_String (Current_Main);
-
- -- If an object file has been specified, then the ALI file
- -- will be in the same directory as the object file;
- -- so, we put the tree file in this same directory,
- -- even though no object file needs to be generated.
-
- if Output_Object_File_Name /= null then
- Name_Len := Output_Object_File_Name'Length;
- Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
- end if;
-
- Dot_Index := Name_Len + 1;
-
- for J in reverse 1 .. Name_Len loop
- if Name_Buffer (J) = '.' then
- Dot_Index := J;
- exit;
- end if;
- end loop;
-
- -- Should be impossible to not have an extension
-
- pragma Assert (Dot_Index /= 0);
-
- -- Change extension to adt
-
- Name_Buffer (Dot_Index) := '.';
- Name_Buffer (Dot_Index + 1) := 'a';
- Name_Buffer (Dot_Index + 2) := 'd';
- Name_Buffer (Dot_Index + 3) := 't';
- Name_Buffer (Dot_Index + 4) := ASCII.NUL;
- Name_Len := Dot_Index + 3;
- Create_File_And_Check (Output_FD, Binary);
-
- Tree_Write_Initialize (Output_FD);
- end Tree_Create;
-
-----------------------
-- Write_Debug_Info --
-----------------------
procedure Close_List_File;
-- Close file previously opened by Create_List_File
- --------------------------------
- -- Semantic Tree Input-Output --
- --------------------------------
-
- procedure Tree_Create;
- -- Creates the tree output file for the source file which is currently
- -- being compiled (i.e. the file which was most recently returned by
- -- Next_Main_Source), and initializes Tree_IO.Tree_Write for output.
-
- procedure Tree_Close;
- -- Closes the file previously opened by Tree_Create
-
end Osint.C;
---------------------------------------
-- A table internal to this unit is used to hold the values of back
- -- annotated expressions. This table is written out by -gnatt and read
- -- back in for ASIS processing.
+ -- annotated expressions.
-- Node values are stored as Uint values using the negative of the node
-- index in this table. Constants appear as non-negative Uint values.
-- The following representation clause ensures that the above record
-- has no holes. We do this so that when instances of this record are
- -- written by Tree_Gen, we do not write uninitialized values to the file.
+ -- written, we do not write uninitialized values to the file.
for Exp_Node use record
Expr at 0 range 0 .. 31;
end loop;
end Spaces;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Rep_Table.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Rep_Table.Tree_Write;
- end Tree_Write;
-
---------------------
-- Write_Info_Line --
---------------------
-- as an argument value, and return it unmodified. A No_Uint value is
-- also returned unmodified.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines.
-
------------------------
-- Compiler Interface --
------------------------
-- Procedure to list representation information. Bytes_Big_Endian is the
-- value from Ttypes (Repinfo cannot have a dependency on Ttypes).
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
--------------------------
-- Debugging Procedures --
--------------------------
return N;
end Subprogram_Specification;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Obsolescent_Warnings.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Obsolescent_Warnings.Tree_Write;
- end Tree_Write;
-
--------------------
-- Ultimate_Alias --
--------------------
procedure Initialize;
-- Called at the start of compilation of each new main source file to
- -- initialize the allocation of the Obsolescent_Warnings table. Note that
- -- Initialize must not be called if Tree_Read is used.
-
- procedure Tree_Read;
- -- Initializes Obsolescent_Warnings table from current tree file using the
- -- relevant Table.Tree_Read routine.
-
- procedure Tree_Write;
- -- Writes out Obsolescent_Warnings table to current tree file using the
- -- relevant Table.Tree_Write routine.
+ -- initialize the allocation of the Obsolescent_Warnings table.
-----------------
-- Subprograms --
with Opt; use Opt;
with Output; use Output;
with Scans; use Scans;
-with Tree_IO; use Tree_IO;
with Widechar; use Widechar;
with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
return Oldloc;
end Top_Level_Location;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- -- First we must free any old source buffer pointers
-
- for J in Source_File.First .. Source_File.Last loop
- declare
- S : Source_File_Record renames Source_File.Table (J);
- begin
- if S.Instance = No_Instance_Id then
- Free_Source_Buffer (S.Source_Text);
-
- if S.Lines_Table /= null then
- Memory.Free (To_Address (S.Lines_Table));
- S.Lines_Table := null;
- end if;
-
- if S.Logical_Lines_Table /= null then
- Memory.Free (To_Address (S.Logical_Lines_Table));
- S.Logical_Lines_Table := null;
- end if;
-
- else
- Free_Dope (S.Source_Text'Address);
- S.Source_Text := null;
- end if;
- end;
- end loop;
-
- -- Read in source file table and instance table
-
- Source_File.Tree_Read;
- Instances.Tree_Read;
-
- -- The pointers we read in there for the source buffer and lines table
- -- pointers are junk. We now read in the actual data that is referenced
- -- by these two fields.
-
- for J in Source_File.First .. Source_File.Last loop
- declare
- S : Source_File_Record renames Source_File.Table (J);
- begin
- -- Normal case (non-instantiation)
-
- if S.Instance = No_Instance_Id then
- S.Lines_Table := null;
- S.Logical_Lines_Table := null;
- Alloc_Line_Tables (S, Int (S.Last_Source_Line));
-
- for J in 1 .. S.Last_Source_Line loop
- Tree_Read_Int (Int (S.Lines_Table (J)));
- end loop;
-
- if S.Num_SRef_Pragmas /= 0 then
- for J in 1 .. S.Last_Source_Line loop
- Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
- end loop;
- end if;
-
- -- Allocate source buffer and read in the data
-
- declare
- T : constant Source_Buffer_Ptr_Var :=
- new Source_Buffer (S.Source_First .. S.Source_Last);
- begin
- Tree_Read_Data (T (S.Source_First)'Address,
- Int (S.Source_Last) - Int (S.Source_First) + 1);
- S.Source_Text := T.all'Access;
- end;
-
- -- For the instantiation case, we do not read in any data. Instead
- -- we share the data for the generic template entry. Since the
- -- template always occurs first, we can safely refer to its data.
-
- else
- declare
- ST : Source_File_Record renames
- Source_File.Table (S.Template);
-
- begin
- -- The lines tables are copied from the template entry
-
- S.Lines_Table := ST.Lines_Table;
- S.Logical_Lines_Table := ST.Logical_Lines_Table;
-
- -- The Source_Text of the instance is the same data as that
- -- of the template, but with different bounds.
-
- declare
- Dope : constant Dope_Ptr :=
- new Dope_Rec'(S.Source_First, S.Source_Last);
- begin
- S.Source_Text := ST.Source_Text;
- Set_Dope (S.Source_Text'Address, Dope);
- end;
- end;
- end if;
- end;
-
- Set_Source_File_Index_Table (J);
- end loop;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Source_File.Tree_Write;
- Instances.Tree_Write;
-
- -- The pointers we wrote out there for the source buffer and lines
- -- table pointers are junk, we now write out the actual data that
- -- is referenced by these two fields.
-
- for J in Source_File.First .. Source_File.Last loop
- declare
- S : Source_File_Record renames Source_File.Table (J);
-
- begin
- -- For instantiations, there is nothing to do, since the data is
- -- shared with the generic template. When the tree is read, the
- -- pointers must be set, but no extra data needs to be written.
- -- For the normal case, write out the data of the tables.
-
- if S.Instance = No_Instance_Id then
- -- Lines table
-
- for J in 1 .. S.Last_Source_Line loop
- Tree_Write_Int (Int (S.Lines_Table (J)));
- end loop;
-
- -- Logical lines table if present
-
- if S.Num_SRef_Pragmas /= 0 then
- for J in 1 .. S.Last_Source_Line loop
- Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
- end loop;
- end if;
-
- -- Source buffer
-
- Tree_Write_Data
- (S.Source_Text (S.Source_First)'Address,
- Int (S.Source_Last) - Int (S.Source_First) + 1);
- end if;
- end;
- end loop;
- end Tree_Write;
-
--------------------
-- Write_Location --
--------------------
procedure Write_Time_Stamp (S : Source_File_Index);
-- Writes time stamp of specified file in YY-MM-DD HH:MM.SS format
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
procedure Clear_Source_File_Table;
-- This procedure frees memory allocated in the Source_File table (in the
-- private). It should only be used when it is guaranteed that all source
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S T A N D --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Elists; use Elists;
-with System; use System;
-with Tree_IO; use Tree_IO;
-
-package body Stand is
-
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Tree_Read_Data (Standard_Entity'Address,
- Standard_Entity_Array_Type'Size / Storage_Unit);
-
- Tree_Read_Int (Int (Standard_Package_Node));
- Tree_Read_Int (Int (Last_Standard_Node_Id));
- Tree_Read_Int (Int (Last_Standard_List_Id));
-
- Tree_Read_Int (Int (Boolean_Literals (False)));
- Tree_Read_Int (Int (Boolean_Literals (True)));
-
- Tree_Read_Int (Int (Standard_Void_Type));
- Tree_Read_Int (Int (Standard_Exception_Type));
- Tree_Read_Int (Int (Standard_A_String));
- Tree_Read_Int (Int (Standard_A_Char));
- Tree_Read_Int (Int (Standard_Debug_Renaming_Type));
-
- -- Deal with Predefined_Float_Types, which is an Elist. We wrote the
- -- entities out in sequence, terminated by an Empty entry.
-
- declare
- Elmt : Entity_Id;
- begin
- Predefined_Float_Types := New_Elmt_List;
- loop
- Tree_Read_Int (Int (Elmt));
- exit when Elmt = Empty;
- Append_Elmt (Elmt, Predefined_Float_Types);
- end loop;
- end;
-
- -- Remainder of special entities
-
- Tree_Read_Int (Int (Any_Id));
- Tree_Read_Int (Int (Any_Type));
- Tree_Read_Int (Int (Any_Access));
- Tree_Read_Int (Int (Any_Array));
- Tree_Read_Int (Int (Any_Boolean));
- Tree_Read_Int (Int (Any_Character));
- Tree_Read_Int (Int (Any_Composite));
- Tree_Read_Int (Int (Any_Discrete));
- Tree_Read_Int (Int (Any_Fixed));
- Tree_Read_Int (Int (Any_Integer));
- Tree_Read_Int (Int (Any_Modular));
- Tree_Read_Int (Int (Any_Numeric));
- Tree_Read_Int (Int (Any_Real));
- Tree_Read_Int (Int (Any_Scalar));
- Tree_Read_Int (Int (Any_String));
- Tree_Read_Int (Int (Raise_Type));
- Tree_Read_Int (Int (Universal_Integer));
- Tree_Read_Int (Int (Universal_Real));
- Tree_Read_Int (Int (Universal_Fixed));
- Tree_Read_Int (Int (Standard_Integer_8));
- Tree_Read_Int (Int (Standard_Integer_16));
- Tree_Read_Int (Int (Standard_Integer_32));
- Tree_Read_Int (Int (Standard_Integer_64));
- Tree_Read_Int (Int (Standard_Short_Short_Unsigned));
- Tree_Read_Int (Int (Standard_Short_Unsigned));
- Tree_Read_Int (Int (Standard_Unsigned));
- Tree_Read_Int (Int (Standard_Long_Unsigned));
- Tree_Read_Int (Int (Standard_Long_Long_Unsigned));
- Tree_Read_Int (Int (Standard_Unsigned_64));
- Tree_Read_Int (Int (Abort_Signal));
- Tree_Read_Int (Int (Standard_Op_Rotate_Left));
- Tree_Read_Int (Int (Standard_Op_Rotate_Right));
- Tree_Read_Int (Int (Standard_Op_Shift_Left));
- Tree_Read_Int (Int (Standard_Op_Shift_Right));
- Tree_Read_Int (Int (Standard_Op_Shift_Right_Arithmetic));
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Tree_Write_Data (Standard_Entity'Address,
- Standard_Entity_Array_Type'Size / Storage_Unit);
-
- Tree_Write_Int (Int (Standard_Package_Node));
- Tree_Write_Int (Int (Last_Standard_Node_Id));
- Tree_Write_Int (Int (Last_Standard_List_Id));
-
- Tree_Write_Int (Int (Boolean_Literals (False)));
- Tree_Write_Int (Int (Boolean_Literals (True)));
-
- Tree_Write_Int (Int (Standard_Void_Type));
- Tree_Write_Int (Int (Standard_Exception_Type));
- Tree_Write_Int (Int (Standard_A_String));
- Tree_Write_Int (Int (Standard_A_Char));
- Tree_Write_Int (Int (Standard_Debug_Renaming_Type));
-
- -- Deal with Predefined_Float_Types, which is an Elist. Write the
- -- entities out in sequence, terminated by an Empty entry.
-
- declare
- Elmt : Elmt_Id;
-
- begin
- Elmt := First_Elmt (Predefined_Float_Types);
- while Present (Elmt) loop
- Tree_Write_Int (Int (Node (Elmt)));
- Next_Elmt (Elmt);
- end loop;
-
- Tree_Write_Int (Int (Empty));
- end;
-
- -- Remainder of special entries
-
- Tree_Write_Int (Int (Any_Id));
- Tree_Write_Int (Int (Any_Type));
- Tree_Write_Int (Int (Any_Access));
- Tree_Write_Int (Int (Any_Array));
- Tree_Write_Int (Int (Any_Boolean));
- Tree_Write_Int (Int (Any_Character));
- Tree_Write_Int (Int (Any_Composite));
- Tree_Write_Int (Int (Any_Discrete));
- Tree_Write_Int (Int (Any_Fixed));
- Tree_Write_Int (Int (Any_Integer));
- Tree_Write_Int (Int (Any_Modular));
- Tree_Write_Int (Int (Any_Numeric));
- Tree_Write_Int (Int (Any_Real));
- Tree_Write_Int (Int (Any_Scalar));
- Tree_Write_Int (Int (Any_String));
- Tree_Write_Int (Int (Raise_Type));
- Tree_Write_Int (Int (Universal_Integer));
- Tree_Write_Int (Int (Universal_Real));
- Tree_Write_Int (Int (Universal_Fixed));
- Tree_Write_Int (Int (Standard_Integer_8));
- Tree_Write_Int (Int (Standard_Integer_16));
- Tree_Write_Int (Int (Standard_Integer_32));
- Tree_Write_Int (Int (Standard_Integer_64));
- Tree_Write_Int (Int (Standard_Short_Short_Unsigned));
- Tree_Write_Int (Int (Standard_Short_Unsigned));
- Tree_Write_Int (Int (Standard_Unsigned));
- Tree_Write_Int (Int (Standard_Long_Unsigned));
- Tree_Write_Int (Int (Standard_Long_Long_Unsigned));
- Tree_Write_Int (Int (Standard_Unsigned_64));
- Tree_Write_Int (Int (Abort_Signal));
- Tree_Write_Int (Int (Standard_Op_Rotate_Left));
- Tree_Write_Int (Int (Standard_Op_Rotate_Right));
- Tree_Write_Int (Int (Standard_Op_Shift_Left));
- Tree_Write_Int (Int (Standard_Op_Shift_Right));
- Tree_Write_Int (Int (Standard_Op_Shift_Right_Arithmetic));
- end Tree_Write;
-
-end Stand;
Standard_Op_Shift_Right_Arithmetic : Entity_Id;
-- These entities are used for shift operators generated by the expander
- -----------------
- -- Subprograms --
- -----------------
-
- procedure Tree_Read;
- -- Initializes entity values in this package from the current tree file
- -- using Tree_IO. Note that Tree_Read includes all the initialization that
- -- is carried out by Create_Standard.
-
- procedure Tree_Write;
- -- Writes out the entity values in this package to the current tree file
- -- using Tree_IO.
-
end Stand;
return To_String (Buf);
end To_String;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- String_Chars.Tree_Read;
- Strings.Tree_Read;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- String_Chars.Tree_Write;
- Strings.Tree_Write;
- end Tree_Write;
-
------------
-- Unlock --
------------
--------------------------------------
procedure Initialize;
- -- Initializes the strings table for a new compilation. Note that
- -- Initialize must not be called if Tree_Read is used.
+ -- Initializes the strings table for a new compilation.
procedure Lock;
-- Lock internal tables before calling back end
function Strings_Address return System.Address;
-- Return address of Strings table (used by Back_End call to Gigi)
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
procedure Write_Char_Code (Code : Char_Code);
-- Procedure to write a character code value, used for debugging purposes
-- for writing character codes. If the character code is in the range
when 'Q' =>
Ptr := Ptr + 1;
- Force_ALI_Tree_File := True;
+ Force_ALI_File := True;
Try_Semantics := True;
-- -gnatr (restrictions as warnings)
with Opt; use Opt;
with Output; use Output;
with System; use System;
-with Tree_IO; use Tree_IO;
with System.Memory; use System.Memory;
-- in Max. Works correctly to do an initial allocation if the table
-- is currently null.
- function Tree_Get_Table_Address return Address;
- -- Return Null_Address if the table length is zero,
- -- Table (First)'Address if not.
-
pragma Warnings (Off);
-- Turn off warnings. The following unchecked conversions are only used
-- internally in this package, and cannot never result in any instances
end if;
end Set_Last;
- ----------------------------
- -- Tree_Get_Table_Address --
- ----------------------------
-
- function Tree_Get_Table_Address return Address is
- begin
- if Length = 0 then
- return Null_Address;
- else
- return Table (First)'Address;
- end if;
- end Tree_Get_Table_Address;
-
- ---------------
- -- Tree_Read --
- ---------------
-
- -- Note: we allocate only the space required to accommodate the data
- -- actually written, which means that a Tree_Write/Tree_Read sequence
- -- does an implicit Release.
-
- procedure Tree_Read is
- begin
- Tree_Read_Int (Max);
- Last_Val := Max;
- Length := Max - Min + 1;
- Reallocate;
-
- Tree_Read_Data
- (Tree_Get_Table_Address,
- (Last_Val - Int (First) + 1) *
-
- -- Note the importance of parenthesizing the following division
- -- to avoid the possibility of intermediate overflow.
-
- (Table_Type'Component_Size / Storage_Unit));
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- -- Note: we write out only the currently valid data, not the entire
- -- contents of the allocated array. See note above on Tree_Read.
-
- procedure Tree_Write is
- begin
- Tree_Write_Int (Int (Last));
- Tree_Write_Data
- (Tree_Get_Table_Address,
- (Last_Val - Int (First) + 1) *
- (Table_Type'Component_Size / Storage_Unit));
- end Tree_Write;
-
begin
Init;
end Table;
-- Given a Saved_Table value returned by a prior call to Save, restores
-- the table to the state it was in at the time of the Save call.
- procedure Tree_Write;
- -- Writes out contents of table using Tree_IO
-
- procedure Tree_Read;
- -- Initializes table by reading contents previously written with the
- -- Tree_Write call (also using Tree_IO).
-
private
Last_Val : Int;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- T R E E _ G E N --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Aspects;
-with Atree;
-with Elists;
-with Fname;
-with Lib;
-with Namet;
-with Nlists;
-with Opt;
-with Osint.C;
-with Repinfo;
-with Sem_Aux;
-with Sinput;
-with Stand;
-with Stringt;
-with Uintp;
-with Urealp;
-
-with Tree_In;
-pragma Warnings (Off, Tree_In);
--- We do not use Tree_In in the compiler, but it is small, and worth including
--- so that we get the proper license check for Tree_In when the compiler is
--- built. This will avoid adding bad dependencies to Tree_In and blowing ASIS.
-
-procedure Tree_Gen is
-begin
- if Opt.Tree_Output then
- Osint.C.Tree_Create;
-
- Opt.Tree_Write;
- Atree.Tree_Write;
- Elists.Tree_Write;
- Fname.Tree_Write;
- Lib.Tree_Write;
- Namet.Tree_Write;
- Nlists.Tree_Write;
- Sem_Aux.Tree_Write;
- Sinput.Tree_Write;
- Stand.Tree_Write;
- Stringt.Tree_Write;
- Uintp.Tree_Write;
- Urealp.Tree_Write;
- Repinfo.Tree_Write;
- Aspects.Tree_Write;
-
- Osint.C.Tree_Close;
- end if;
-end Tree_Gen;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- T R E E _ G E N --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This procedure is used to write out the tree if the option is set
-
-procedure Tree_Gen;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- T R E E _ I N --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Aspects;
-with Atree;
-with Csets;
-with Elists;
-with Fname;
-with Lib;
-with Namet;
-with Nlists;
-with Opt;
-with Repinfo;
-with Sem_Aux;
-with Sinput;
-with Stand;
-with Stringt;
-with Tree_IO;
-with Uintp;
-with Urealp;
-
-procedure Tree_In (Desc : File_Descriptor) is
-begin
- Tree_IO.Tree_Read_Initialize (Desc);
-
- Opt.Tree_Read;
- Atree.Tree_Read;
- Elists.Tree_Read;
- Fname.Tree_Read;
- Lib.Tree_Read;
- Namet.Tree_Read;
- Nlists.Tree_Read;
- Sem_Aux.Tree_Read;
- Sinput.Tree_Read;
- Stand.Tree_Read;
- Stringt.Tree_Read;
- Uintp.Tree_Read;
- Urealp.Tree_Read;
- Repinfo.Tree_Read;
- Aspects.Tree_Read;
-
- Csets.Initialize;
-end Tree_In;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- T R E E _ I N --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This procedure is used to read in a tree if the option is set. Note that
--- it is not part of the compiler proper, but rather the interface from
--- tools that need to read the tree to the tree reading routines, and is
--- thus bound as part of such tools.
-
-with System.OS_Lib; use System.OS_Lib;
-
-procedure Tree_In (Desc : File_Descriptor);
--- Desc is the file descriptor for the file containing the tree, as written
--- by the compiler in a previous compilation using Tree_Gen. On return the
--- global data structures are appropriately initialized.
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- T R E E _ I O --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Debug; use Debug;
-with Output; use Output;
-with Unchecked_Conversion;
-
-package body Tree_IO is
- Debug_Flag_Tree : Boolean := False;
- -- Debug flag for debug output from tree read/write
-
- -------------------------------------------
- -- Compression Scheme Used for Tree File --
- -------------------------------------------
-
- -- We don't just write the data directly, but instead do a mild form
- -- of compression, since we expect lots of compressible zeroes and
- -- blanks. The compression scheme is as follows:
-
- -- 00nnnnnn followed by nnnnnn bytes (non compressed data)
- -- 01nnnnnn indicates nnnnnn binary zero bytes
- -- 10nnnnnn indicates nnnnnn ASCII space bytes
- -- 11nnnnnn bbbbbbbb indicates nnnnnnnn occurrences of byte bbbbbbbb
-
- -- Since we expect many zeroes in trees, and many spaces in sources,
- -- this compression should be reasonably efficient. We can put in
- -- something better later on.
-
- -- Note that this compression applies to the Write_Tree_Data and
- -- Read_Tree_Data calls, not to the calls to read and write single
- -- scalar values, which are written in memory format without any
- -- compression.
-
- C_Noncomp : constant := 2#00_000000#;
- C_Zeros : constant := 2#01_000000#;
- C_Spaces : constant := 2#10_000000#;
- C_Repeat : constant := 2#11_000000#;
- -- Codes for compression sequences
-
- Max_Count : constant := 63;
- -- Maximum data length for one compression sequence
-
- -- The above compression scheme applies only to data written with the
- -- Tree_Write routine and read with Tree_Read. Data written using the
- -- Tree_Write_Char or Tree_Write_Int routines and read using the
- -- corresponding input routines is not compressed.
-
- type Int_Bytes is array (1 .. 4) of Byte;
- for Int_Bytes'Size use 32;
-
- function To_Int_Bytes is new Unchecked_Conversion (Int, Int_Bytes);
- function To_Int is new Unchecked_Conversion (Int_Bytes, Int);
-
- ----------------------
- -- Global Variables --
- ----------------------
-
- Tree_FD : File_Descriptor;
- -- File descriptor for tree
-
- Buflen : constant Int := 8_192;
- -- Length of buffer for read and write file data
-
- Buf : array (Pos range 1 .. Buflen) of Byte;
- -- Read/write file data buffer
-
- Bufn : Nat;
- -- Number of bytes read/written from/to buffer
-
- Buft : Nat;
- -- Total number of bytes in input buffer containing valid data. Used only
- -- for input operations. There is data left to be processed in the buffer
- -- if Buft > Bufn. A value of zero for Buft means that the buffer is empty.
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Read_Buffer;
- -- Reads data into buffer, setting Bufn appropriately
-
- function Read_Byte return Byte;
- pragma Inline (Read_Byte);
- -- Returns next byte from input file, raises Tree_Format_Error if none left
-
- procedure Write_Buffer;
- -- Writes out current buffer contents
-
- procedure Write_Byte (B : Byte);
- pragma Inline (Write_Byte);
- -- Write one byte to output buffer, checking for buffer-full condition
-
- -----------------
- -- Read_Buffer --
- -----------------
-
- procedure Read_Buffer is
- begin
- Buft := Int (Read (Tree_FD, Buf (1)'Address, Integer (Buflen)));
-
- if Buft = 0 then
- raise Tree_Format_Error;
- else
- Bufn := 0;
- end if;
- end Read_Buffer;
-
- ---------------
- -- Read_Byte --
- ---------------
-
- function Read_Byte return Byte is
- begin
- if Bufn = Buft then
- Read_Buffer;
- end if;
-
- Bufn := Bufn + 1;
- return Buf (Bufn);
- end Read_Byte;
-
- --------------------
- -- Tree_Read_Bool --
- --------------------
-
- procedure Tree_Read_Bool (B : out Boolean) is
- begin
- B := Boolean'Val (Read_Byte);
-
- if Debug_Flag_Tree then
- if B then
- Write_Str ("True");
- else
- Write_Str ("False");
- end if;
-
- Write_Eol;
- end if;
- end Tree_Read_Bool;
-
- --------------------
- -- Tree_Read_Char --
- --------------------
-
- procedure Tree_Read_Char (C : out Character) is
- begin
- C := Character'Val (Read_Byte);
-
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting Character = ");
- Write_Char (C);
- Write_Eol;
- end if;
- end Tree_Read_Char;
-
- --------------------
- -- Tree_Read_Data --
- --------------------
-
- procedure Tree_Read_Data (Addr : Address; Length : Int) is
-
- type S is array (Pos) of Byte;
- -- This is a big array, for which we have to suppress the warning
-
- type SP is access all S;
-
- function To_SP is new Unchecked_Conversion (Address, SP);
-
- Data : constant SP := To_SP (Addr);
- -- Data buffer to be read as an indexable array of bytes
-
- OP : Pos := 1;
- -- Pointer to next byte of data buffer to be read into
-
- B : Byte;
- C : Byte;
- L : Int;
-
- begin
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting ");
- Write_Int (Length);
- Write_Str (" data bytes");
- Write_Eol;
- end if;
-
- -- Verify data length
-
- Tree_Read_Int (L);
-
- if L /= Length then
- Write_Str ("==> transmitting, expected ");
- Write_Int (Length);
- Write_Str (" bytes, found length = ");
- Write_Int (L);
- Write_Eol;
- raise Tree_Format_Error;
- end if;
-
- -- Loop to read data
-
- while OP <= Length loop
-
- -- Get compression control character
-
- B := Read_Byte;
- C := B and 2#00_111111#;
- B := B and 2#11_000000#;
-
- -- Non-repeat case
-
- if B = C_Noncomp then
- if Debug_Flag_Tree then
- Write_Str ("==> uncompressed: ");
- Write_Int (Int (C));
- Write_Str (", starting at ");
- Write_Int (OP);
- Write_Eol;
- end if;
-
- for J in 1 .. C loop
- Data (OP) := Read_Byte;
- OP := OP + 1;
- end loop;
-
- -- Repeated zeroes
-
- elsif B = C_Zeros then
- if Debug_Flag_Tree then
- Write_Str ("==> zeroes: ");
- Write_Int (Int (C));
- Write_Str (", starting at ");
- Write_Int (OP);
- Write_Eol;
- end if;
-
- for J in 1 .. C loop
- Data (OP) := 0;
- OP := OP + 1;
- end loop;
-
- -- Repeated spaces
-
- elsif B = C_Spaces then
- if Debug_Flag_Tree then
- Write_Str ("==> spaces: ");
- Write_Int (Int (C));
- Write_Str (", starting at ");
- Write_Int (OP);
- Write_Eol;
- end if;
-
- for J in 1 .. C loop
- Data (OP) := Character'Pos (' ');
- OP := OP + 1;
- end loop;
-
- -- Specified repeated character
-
- else -- B = C_Repeat
- B := Read_Byte;
-
- if Debug_Flag_Tree then
- Write_Str ("==> other char: ");
- Write_Int (Int (C));
- Write_Str (" (");
- Write_Int (Int (B));
- Write_Char (')');
- Write_Str (", starting at ");
- Write_Int (OP);
- Write_Eol;
- end if;
-
- for J in 1 .. C loop
- Data (OP) := B;
- OP := OP + 1;
- end loop;
- end if;
- end loop;
-
- -- At end of loop, data item must be exactly filled
-
- if OP /= Length + 1 then
- raise Tree_Format_Error;
- end if;
-
- end Tree_Read_Data;
-
- --------------------------
- -- Tree_Read_Initialize --
- --------------------------
-
- procedure Tree_Read_Initialize (Desc : File_Descriptor) is
- begin
- Buft := 0;
- Bufn := 0;
- Tree_FD := Desc;
- Debug_Flag_Tree := Debug_Flag_5;
- end Tree_Read_Initialize;
-
- -------------------
- -- Tree_Read_Int --
- -------------------
-
- procedure Tree_Read_Int (N : out Int) is
- N_Bytes : Int_Bytes;
-
- begin
- for J in 1 .. 4 loop
- N_Bytes (J) := Read_Byte;
- end loop;
-
- N := To_Int (N_Bytes);
-
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting Int = ");
- Write_Int (N);
- Write_Eol;
- end if;
- end Tree_Read_Int;
-
- -------------------
- -- Tree_Read_Str --
- -------------------
-
- procedure Tree_Read_Str (S : out String_Ptr) is
- N : Nat;
-
- begin
- Tree_Read_Int (N);
- S := new String (1 .. Natural (N));
- Tree_Read_Data (S.all (1)'Address, N);
- end Tree_Read_Str;
-
- -------------------------
- -- Tree_Read_Terminate --
- -------------------------
-
- procedure Tree_Read_Terminate is
- begin
- -- Must be at end of input buffer, so we should get Tree_Format_Error
- -- if we try to read one more byte, if not, we have a format error.
-
- declare
- B : Byte;
- pragma Warnings (Off, B);
-
- begin
- B := Read_Byte;
-
- exception
- when Tree_Format_Error => return;
- end;
-
- raise Tree_Format_Error;
- end Tree_Read_Terminate;
-
- ---------------------
- -- Tree_Write_Bool --
- ---------------------
-
- procedure Tree_Write_Bool (B : Boolean) is
- begin
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting Boolean = ");
-
- if B then
- Write_Str ("True");
- else
- Write_Str ("False");
- end if;
-
- Write_Eol;
- end if;
-
- Write_Byte (Boolean'Pos (B));
- end Tree_Write_Bool;
-
- ---------------------
- -- Tree_Write_Char --
- ---------------------
-
- procedure Tree_Write_Char (C : Character) is
- begin
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting Character = ");
- Write_Char (C);
- Write_Eol;
- end if;
-
- Write_Byte (Character'Pos (C));
- end Tree_Write_Char;
-
- ---------------------
- -- Tree_Write_Data --
- ---------------------
-
- procedure Tree_Write_Data (Addr : Address; Length : Int) is
-
- type S is array (Pos) of Byte;
- -- This is a big array, for which we have to suppress the warning
-
- type SP is access all S;
-
- function To_SP is new Unchecked_Conversion (Address, SP);
-
- Data : constant SP := To_SP (Addr);
- -- Pointer to data to be written, converted to array type
-
- IP : Pos := 1;
- -- Input buffer pointer, next byte to be processed
-
- NC : Nat range 0 .. Max_Count := 0;
- -- Number of bytes of non-compressible sequence
-
- C : Byte;
-
- procedure Write_Non_Compressed_Sequence;
- -- Output currently collected sequence of non-compressible data
-
- -----------------------------------
- -- Write_Non_Compressed_Sequence --
- -----------------------------------
-
- procedure Write_Non_Compressed_Sequence is
- begin
- if NC > 0 then
- Write_Byte (C_Noncomp + Byte (NC));
-
- if Debug_Flag_Tree then
- Write_Str ("==> uncompressed: ");
- Write_Int (NC);
- Write_Str (", starting at ");
- Write_Int (IP - NC);
- Write_Eol;
- end if;
-
- for J in reverse 1 .. NC loop
- Write_Byte (Data (IP - J));
- end loop;
-
- NC := 0;
- end if;
- end Write_Non_Compressed_Sequence;
-
- -- Start of processing for Tree_Write_Data
-
- begin
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting ");
- Write_Int (Length);
- Write_Str (" data bytes");
- Write_Eol;
- end if;
-
- -- We write the count at the start, so that we can check it on
- -- the corresponding read to make sure that reads and writes match
-
- Tree_Write_Int (Length);
-
- -- Conversion loop
- -- IP is index of next input character
- -- NC is number of non-compressible bytes saved up
-
- loop
- -- If input is completely processed, then we are all done
-
- if IP > Length then
- Write_Non_Compressed_Sequence;
- return;
- end if;
-
- -- Test for compressible sequence, must be at least three identical
- -- bytes in a row to be worthwhile compressing.
-
- if IP + 2 <= Length
- and then Data (IP) = Data (IP + 1)
- and then Data (IP) = Data (IP + 2)
- then
- Write_Non_Compressed_Sequence;
-
- -- Count length of new compression sequence
-
- C := 3;
- IP := IP + 3;
-
- while IP < Length
- and then Data (IP) = Data (IP - 1)
- and then C < Max_Count
- loop
- C := C + 1;
- IP := IP + 1;
- end loop;
-
- -- Output compression sequence
-
- if Data (IP - 1) = 0 then
- if Debug_Flag_Tree then
- Write_Str ("==> zeroes: ");
- Write_Int (Int (C));
- Write_Str (", starting at ");
- Write_Int (IP - Int (C));
- Write_Eol;
- end if;
-
- Write_Byte (C_Zeros + C);
-
- elsif Data (IP - 1) = Character'Pos (' ') then
- if Debug_Flag_Tree then
- Write_Str ("==> spaces: ");
- Write_Int (Int (C));
- Write_Str (", starting at ");
- Write_Int (IP - Int (C));
- Write_Eol;
- end if;
-
- Write_Byte (C_Spaces + C);
-
- else
- if Debug_Flag_Tree then
- Write_Str ("==> other char: ");
- Write_Int (Int (C));
- Write_Str (" (");
- Write_Int (Int (Data (IP - 1)));
- Write_Char (')');
- Write_Str (", starting at ");
- Write_Int (IP - Int (C));
- Write_Eol;
- end if;
-
- Write_Byte (C_Repeat + C);
- Write_Byte (Data (IP - 1));
- end if;
-
- -- No compression possible here
-
- else
- -- Output non-compressed sequence if at maximum length
-
- if NC = Max_Count then
- Write_Non_Compressed_Sequence;
- end if;
-
- NC := NC + 1;
- IP := IP + 1;
- end if;
- end loop;
-
- end Tree_Write_Data;
-
- ---------------------------
- -- Tree_Write_Initialize --
- ---------------------------
-
- procedure Tree_Write_Initialize (Desc : File_Descriptor) is
- begin
- Bufn := 0;
- Tree_FD := Desc;
- Set_Standard_Error;
- Debug_Flag_Tree := Debug_Flag_5;
- end Tree_Write_Initialize;
-
- --------------------
- -- Tree_Write_Int --
- --------------------
-
- procedure Tree_Write_Int (N : Int) is
- N_Bytes : constant Int_Bytes := To_Int_Bytes (N);
-
- begin
- if Debug_Flag_Tree then
- Write_Str ("==> transmitting Int = ");
- Write_Int (N);
- Write_Eol;
- end if;
-
- for J in 1 .. 4 loop
- Write_Byte (N_Bytes (J));
- end loop;
- end Tree_Write_Int;
-
- --------------------
- -- Tree_Write_Str --
- --------------------
-
- procedure Tree_Write_Str (S : String_Ptr) is
- begin
- Tree_Write_Int (S'Length);
- Tree_Write_Data (S (1)'Address, S'Length);
- end Tree_Write_Str;
-
- --------------------------
- -- Tree_Write_Terminate --
- --------------------------
-
- procedure Tree_Write_Terminate is
- begin
- if Bufn > 0 then
- Write_Buffer;
- end if;
- end Tree_Write_Terminate;
-
- ------------------
- -- Write_Buffer --
- ------------------
-
- procedure Write_Buffer is
- begin
- if Integer (Bufn) = Write (Tree_FD, Buf'Address, Integer (Bufn)) then
- Bufn := 0;
-
- else
- Set_Standard_Error;
- Write_Str ("fatal error: disk full");
- OS_Exit (2);
- end if;
- end Write_Buffer;
-
- ----------------
- -- Write_Byte --
- ----------------
-
- procedure Write_Byte (B : Byte) is
- begin
- Bufn := Bufn + 1;
- Buf (Bufn) := B;
-
- if Bufn = Buflen then
- Write_Buffer;
- end if;
- end Write_Byte;
-
-end Tree_IO;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- T R E E _ I O --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the routines used to read and write the tree files
--- used by ASIS. Only the actual read and write routines are here. The open,
--- create and close routines are elsewhere (in Osint in the compiler, and in
--- the tree read driver for the tree read interface).
-
--- Should we remove this package altogether???
-
-with Types; use Types;
-with System; use System;
-
-pragma Warnings (Off);
--- This package is used also by gnatcoll
-with System.OS_Lib; use System.OS_Lib;
-pragma Warnings (On);
-
-package Tree_IO is
-
- Tree_Format_Error : exception;
- -- Raised if a format error is detected in the input file
-
- procedure Tree_Read_Initialize (Desc : File_Descriptor);
- -- Called to initialize reading of a tree file. This call must be made
- -- before calls to Tree_Read_xx. No calls to Tree_Write_xx are permitted
- -- after this call.
-
- procedure Tree_Read_Data (Addr : Address; Length : Int);
- -- Checks that the Length provided is the same as what has been provided
- -- to the corresponding Tree_Write_Data from the current tree file,
- -- Tree_Format_Error is raised if it is not the case. If Length is
- -- correct and non zero, reads Length bytes of information into memory
- -- starting at Addr from the current tree file.
-
- procedure Tree_Read_Bool (B : out Boolean);
- -- Reads a single boolean value. The boolean value must have been written
- -- with a call to the Tree_Write_Bool procedure.
-
- procedure Tree_Read_Char (C : out Character);
- -- Reads a single character. The character must have been written with a
- -- call to the Tree_Write_Char procedure.
-
- procedure Tree_Read_Int (N : out Int);
- -- Reads a single integer value. The integer must have been written with
- -- a call to the Tree_Write_Int procedure.
-
- procedure Tree_Read_Str (S : out String_Ptr);
- -- Read string, allocate on heap, and return pointer to allocated string
- -- which always has a lower bound of 1.
-
- procedure Tree_Read_Terminate;
- -- Called after reading all data, checks that the buffer pointers is at
- -- the end of file, raising Tree_Format_Error if not.
-
- procedure Tree_Write_Initialize (Desc : File_Descriptor);
- -- Called to initialize writing of a tree file. This call must be made
- -- before calls to Tree_Write_xx. No calls to Tree_Read_xx are permitted
- -- after this call.
-
- procedure Tree_Write_Data (Addr : Address; Length : Int);
- -- Writes Length then, if Length is not null, Length bytes of data
- -- starting at Addr to current tree file
-
- procedure Tree_Write_Bool (B : Boolean);
- -- Writes a single boolean value to the current tree file
-
- procedure Tree_Write_Char (C : Character);
- -- Writes a single character to the current tree file
-
- procedure Tree_Write_Int (N : Int);
- -- Writes a single integer value to the current tree file
-
- procedure Tree_Write_Str (S : String_Ptr);
- -- Write out string value referenced by S (low bound of S must be 1)
-
- procedure Tree_Write_Terminate;
- -- Terminates writing of the file (flushing the buffer), but does not
- -- close the file (the caller is responsible for closing the file).
-
-end Tree_IO;
-- --
------------------------------------------------------------------------------
-with Output; use Output;
-with Tree_IO; use Tree_IO;
+with Output; use Output;
with GNAT.HTable; use GNAT.HTable;
end if;
end Release_And_Save;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- Uints.Tree_Read;
- Udigits.Tree_Read;
-
- Tree_Read_Int (Int (Uint_Int_First));
- Tree_Read_Int (Int (Uint_Int_Last));
- Tree_Read_Int (UI_Power_2_Set);
- Tree_Read_Int (UI_Power_10_Set);
- Tree_Read_Int (Int (Uints_Min));
- Tree_Read_Int (Udigits_Min);
-
- for J in 0 .. UI_Power_2_Set loop
- Tree_Read_Int (Int (UI_Power_2 (J)));
- end loop;
-
- for J in 0 .. UI_Power_10_Set loop
- Tree_Read_Int (Int (UI_Power_10 (J)));
- end loop;
-
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Uints.Tree_Write;
- Udigits.Tree_Write;
-
- Tree_Write_Int (Int (Uint_Int_First));
- Tree_Write_Int (Int (Uint_Int_Last));
- Tree_Write_Int (UI_Power_2_Set);
- Tree_Write_Int (UI_Power_10_Set);
- Tree_Write_Int (Int (Uints_Min));
- Tree_Write_Int (Udigits_Min);
-
- for J in 0 .. UI_Power_2_Set loop
- Tree_Write_Int (Int (UI_Power_2 (J)));
- end loop;
-
- for J in 0 .. UI_Power_10_Set loop
- Tree_Write_Int (Int (UI_Power_10 (J)));
- end loop;
-
- end Tree_Write;
-
-------------
-- UI_Abs --
-------------
-----------------
procedure Initialize;
- -- Initialize Uint tables. Note that Initialize must not be called if
- -- Tree_Read is used. Note also that there is no lock routine in this
+ -- Initialize Uint tables. Note also that there is no lock routine in this
-- unit, these are among the few tables that can be expanded during
-- gigi processing.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
function UI_Abs (Right : Uint) return Uint;
pragma Inline (UI_Abs);
-- Returns abs function of universal integer
------------------------------------------------------------------------------
with Alloc;
-with Output; use Output;
+with Output; use Output;
with Table;
-with Tree_IO; use Tree_IO;
package body Urealp is
-- The following representation clause ensures that the above record
-- has no holes. We do this so that when instances of this record are
- -- written by Tree_Gen, we do not write uninitialized values to the file.
+ -- written, we do not write uninitialized values to the file.
for Ureal_Entry use record
Num at 0 range 0 .. 31;
UR_2_M_128 : Ureal;
UR_2_M_80 : Ureal;
- Num_Ureal_Constants : constant := 10;
- -- This is used for an assertion check in Tree_Read and Tree_Write to
- -- help remember to add values to these routines when we add to the list.
-
Normalized_Real : Ureal := No_Ureal;
-- Used to memoize Norm_Num and Norm_Den, if either of these functions
-- is called, this value is set and Normalized_Entry contains the result
return Store_Ureal (Normalize (Val));
end Store_Ureal_Normalized;
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- pragma Assert (Num_Ureal_Constants = 10);
-
- Ureals.Tree_Read;
- Tree_Read_Int (Int (UR_0));
- Tree_Read_Int (Int (UR_M_0));
- Tree_Read_Int (Int (UR_Tenth));
- Tree_Read_Int (Int (UR_Half));
- Tree_Read_Int (Int (UR_1));
- Tree_Read_Int (Int (UR_2));
- Tree_Read_Int (Int (UR_10));
- Tree_Read_Int (Int (UR_100));
- Tree_Read_Int (Int (UR_2_128));
- Tree_Read_Int (Int (UR_2_M_128));
-
- -- Clear the normalization cache
-
- Normalized_Real := No_Ureal;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- pragma Assert (Num_Ureal_Constants = 10);
-
- Ureals.Tree_Write;
- Tree_Write_Int (Int (UR_0));
- Tree_Write_Int (Int (UR_M_0));
- Tree_Write_Int (Int (UR_Tenth));
- Tree_Write_Int (Int (UR_Half));
- Tree_Write_Int (Int (UR_1));
- Tree_Write_Int (Int (UR_2));
- Tree_Write_Int (Int (UR_10));
- Tree_Write_Int (Int (UR_100));
- Tree_Write_Int (Int (UR_2_128));
- Tree_Write_Int (Int (UR_2_M_128));
- end Tree_Write;
-
------------
-- UR_Abs --
------------
-----------------
procedure Initialize;
- -- Initialize Ureal tables. Note that Initialize must not be called if
- -- Tree_Read is used. Note also that there is no Lock routine in this
+ -- Initialize Ureal tables. Note that there is no Lock routine in this
-- unit. These tables are among the few tables that can be expanded
-- during Gigi processing.
- procedure Tree_Read;
- -- Initializes internal tables from current tree file using the relevant
- -- Table.Tree_Read routines. Note that Initialize should not be called if
- -- Tree_Read is used. Tree_Read includes all necessary initialization.
-
- procedure Tree_Write;
- -- Writes out internal tables to current tree file using the relevant
- -- Table.Tree_Write routines.
-
function Rbase (Real : Ureal) return Nat;
-- Return the base of the universal real
projects / thirdparty / gcc.git / commitdiff
