parent
996ae0b0ae
commit
415dddc81c
|
@ -0,0 +1,345 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T A B L E --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.44 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Debug; use Debug;
|
||||
with Opt;
|
||||
with Output; use Output;
|
||||
with System; use System;
|
||||
with Tree_IO; use Tree_IO;
|
||||
|
||||
package body Table is
|
||||
package body Table is
|
||||
|
||||
Min : constant Int := Int (Table_Low_Bound);
|
||||
-- Subscript of the minimum entry in the currently allocated table
|
||||
|
||||
Length : Int := 0;
|
||||
-- Number of entries in currently allocated table. The value of zero
|
||||
-- ensures that we initially allocate the table.
|
||||
|
||||
procedure free (T : Table_Ptr);
|
||||
pragma Import (C, free);
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
procedure Reallocate;
|
||||
-- Reallocate the existing table according to the current value stored
|
||||
-- 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.
|
||||
|
||||
------------
|
||||
-- Append --
|
||||
------------
|
||||
|
||||
procedure Append (New_Val : Table_Component_Type) is
|
||||
begin
|
||||
Increment_Last;
|
||||
Table (Table_Index_Type (Last_Val)) := New_Val;
|
||||
end Append;
|
||||
|
||||
--------------------
|
||||
-- Decrement_Last --
|
||||
--------------------
|
||||
|
||||
procedure Decrement_Last is
|
||||
begin
|
||||
Last_Val := Last_Val - 1;
|
||||
end Decrement_Last;
|
||||
|
||||
----------
|
||||
-- Free --
|
||||
----------
|
||||
|
||||
procedure Free is
|
||||
begin
|
||||
free (Table);
|
||||
Table := null;
|
||||
Length := 0;
|
||||
end Free;
|
||||
|
||||
--------------------
|
||||
-- Increment_Last --
|
||||
--------------------
|
||||
|
||||
procedure Increment_Last is
|
||||
begin
|
||||
Last_Val := Last_Val + 1;
|
||||
|
||||
if Last_Val > Max then
|
||||
Reallocate;
|
||||
end if;
|
||||
end Increment_Last;
|
||||
|
||||
----------
|
||||
-- Init --
|
||||
----------
|
||||
|
||||
procedure Init is
|
||||
Old_Length : Int := Length;
|
||||
|
||||
begin
|
||||
Last_Val := Min - 1;
|
||||
Max := Min + (Table_Initial * Opt.Table_Factor) - 1;
|
||||
Length := Max - Min + 1;
|
||||
|
||||
-- If table is same size as before (happens when table is never
|
||||
-- expanded which is a common case), then simply reuse it. Note
|
||||
-- that this also means that an explicit Init call right after
|
||||
-- the implicit one in the package body is harmless.
|
||||
|
||||
if Old_Length = Length then
|
||||
return;
|
||||
|
||||
-- Otherwise we can use Reallocate to get a table of the right size.
|
||||
-- Note that Reallocate works fine to allocate a table of the right
|
||||
-- initial size when it is first allocated.
|
||||
|
||||
else
|
||||
Reallocate;
|
||||
end if;
|
||||
end Init;
|
||||
|
||||
----------
|
||||
-- Last --
|
||||
----------
|
||||
|
||||
function Last return Table_Index_Type is
|
||||
begin
|
||||
return Table_Index_Type (Last_Val);
|
||||
end Last;
|
||||
|
||||
----------------
|
||||
-- Reallocate --
|
||||
----------------
|
||||
|
||||
procedure Reallocate is
|
||||
|
||||
function realloc
|
||||
(memblock : Table_Ptr;
|
||||
size : size_t)
|
||||
return Table_Ptr;
|
||||
pragma Import (C, realloc);
|
||||
|
||||
function malloc
|
||||
(size : size_t)
|
||||
return Table_Ptr;
|
||||
pragma Import (C, malloc);
|
||||
|
||||
New_Size : size_t;
|
||||
|
||||
begin
|
||||
if Max < Last_Val then
|
||||
pragma Assert (not Locked);
|
||||
|
||||
-- Make sure that we have at least the initial allocation. This
|
||||
-- is needed in cases where a zero length table is written out.
|
||||
|
||||
Length := Int'Max (Length, Table_Initial);
|
||||
|
||||
-- Now increment table length until it is sufficiently large
|
||||
|
||||
while Max < Last_Val loop
|
||||
Length := Length * (100 + Table_Increment) / 100;
|
||||
Max := Min + Length - 1;
|
||||
end loop;
|
||||
|
||||
if Debug_Flag_D then
|
||||
Write_Str ("--> Allocating new ");
|
||||
Write_Str (Table_Name);
|
||||
Write_Str (" table, size = ");
|
||||
Write_Int (Max - Min + 1);
|
||||
Write_Eol;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
New_Size :=
|
||||
size_t ((Max - Min + 1) *
|
||||
(Table_Type'Component_Size / Storage_Unit));
|
||||
|
||||
if Table = null then
|
||||
Table := malloc (New_Size);
|
||||
|
||||
elsif New_Size > 0 then
|
||||
Table :=
|
||||
realloc
|
||||
(memblock => Table,
|
||||
size => New_Size);
|
||||
end if;
|
||||
|
||||
if Length /= 0 and then Table = null then
|
||||
Set_Standard_Error;
|
||||
Write_Str ("available memory exhausted");
|
||||
Write_Eol;
|
||||
Set_Standard_Output;
|
||||
raise Unrecoverable_Error;
|
||||
end if;
|
||||
|
||||
end Reallocate;
|
||||
|
||||
-------------
|
||||
-- Release --
|
||||
-------------
|
||||
|
||||
procedure Release is
|
||||
begin
|
||||
Length := Last_Val - Int (Table_Low_Bound) + 1;
|
||||
Max := Last_Val;
|
||||
Reallocate;
|
||||
end Release;
|
||||
|
||||
-------------
|
||||
-- Restore --
|
||||
-------------
|
||||
|
||||
procedure Restore (T : Saved_Table) is
|
||||
begin
|
||||
free (Table);
|
||||
Last_Val := T.Last_Val;
|
||||
Max := T.Max;
|
||||
Table := T.Table;
|
||||
Length := Max - Min + 1;
|
||||
end Restore;
|
||||
|
||||
----------
|
||||
-- Save --
|
||||
----------
|
||||
|
||||
function Save return Saved_Table is
|
||||
Res : Saved_Table;
|
||||
|
||||
begin
|
||||
Res.Last_Val := Last_Val;
|
||||
Res.Max := Max;
|
||||
Res.Table := Table;
|
||||
|
||||
Table := null;
|
||||
Length := 0;
|
||||
Init;
|
||||
return Res;
|
||||
end Save;
|
||||
|
||||
--------------
|
||||
-- Set_Item --
|
||||
--------------
|
||||
|
||||
procedure Set_Item
|
||||
(Index : Table_Index_Type;
|
||||
Item : Table_Component_Type)
|
||||
is
|
||||
begin
|
||||
if Int (Index) > Max then
|
||||
Set_Last (Index);
|
||||
end if;
|
||||
|
||||
Table (Index) := Item;
|
||||
end Set_Item;
|
||||
|
||||
--------------
|
||||
-- Set_Last --
|
||||
--------------
|
||||
|
||||
procedure Set_Last (New_Val : Table_Index_Type) is
|
||||
begin
|
||||
if Int (New_Val) < Last_Val then
|
||||
Last_Val := Int (New_Val);
|
||||
else
|
||||
Last_Val := Int (New_Val);
|
||||
|
||||
if Last_Val > Max then
|
||||
Reallocate;
|
||||
end if;
|
||||
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 accomodate 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) *
|
||||
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;
|
||||
end Table;
|
|
@ -0,0 +1,225 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T A B L E --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.38 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package provides an implementation of dynamically resizable one
|
||||
-- dimensional arrays. The idea is to mimic the normal Ada semantics for
|
||||
-- arrays as closely as possible with the one additional capability of
|
||||
-- dynamically modifying the value of the Last attribute.
|
||||
|
||||
-- Note that this interface should remain synchronized with those in
|
||||
-- GNAT.Table and GNAT.Dynamic_Tables to keep coherency between these
|
||||
-- three related units.
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Table is
|
||||
pragma Elaborate_Body (Table);
|
||||
|
||||
generic
|
||||
type Table_Component_Type is private;
|
||||
type Table_Index_Type is range <>;
|
||||
|
||||
Table_Low_Bound : Table_Index_Type;
|
||||
Table_Initial : Pos;
|
||||
Table_Increment : Nat;
|
||||
Table_Name : String;
|
||||
|
||||
package Table is
|
||||
|
||||
-- Table_Component_Type and Table_Index_Type specify the type of the
|
||||
-- array, Table_Low_Bound is the lower bound. Index_type must be an
|
||||
-- integer type. The effect is roughly to declare:
|
||||
|
||||
-- Table : array (Table_Index_Type range Table_Low_Bound .. <>)
|
||||
-- of Table_Component_Type;
|
||||
|
||||
-- Note: since the upper bound can be one less than the lower
|
||||
-- bound for an empty array, the table index type must be able
|
||||
-- to cover this range, e.g. if the lower bound is 1, then the
|
||||
-- Table_Index_Type should be Natural rather than Positive.
|
||||
|
||||
-- Table_Component_Type may be any Ada type, except that controlled
|
||||
-- types are not supported. Note however that default initialization
|
||||
-- will NOT occur for array components.
|
||||
|
||||
-- The Table_Initial values controls the allocation of the table when
|
||||
-- it is first allocated, either by default, or by an explicit Init
|
||||
-- call. The value used is Opt.Table_Factor * Table_Initial.
|
||||
|
||||
-- The Table_Increment value controls the amount of increase, if the
|
||||
-- table has to be increased in size. The value given is a percentage
|
||||
-- value (e.g. 100 = increase table size by 100%, i.e. double it).
|
||||
|
||||
-- The Table_Name parameter is simply use in debug output messages it
|
||||
-- has no other usage, and is not referenced in non-debugging mode.
|
||||
|
||||
-- The Last and Set_Last subprograms provide control over the current
|
||||
-- logical allocation. They are quite efficient, so they can be used
|
||||
-- freely (expensive reallocation occurs only at major granularity
|
||||
-- chunks controlled by the allocation parameters).
|
||||
|
||||
-- Note: we do not make the table components aliased, since this would
|
||||
-- restict the use of table for discriminated types. If it is necessary
|
||||
-- to take the access of a table element, use Unrestricted_Access.
|
||||
|
||||
type Table_Type is
|
||||
array (Table_Index_Type range <>) of Table_Component_Type;
|
||||
|
||||
subtype Big_Table_Type is
|
||||
Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
|
||||
-- We work with pointers to a bogus array type that is constrained
|
||||
-- with the maximum possible range bound. This means that the pointer
|
||||
-- is a thin pointer, which is more efficient. Since subscript checks
|
||||
-- in any case must be on the logical, rather than physical bounds,
|
||||
-- safety is not compromised by this approach.
|
||||
|
||||
type Table_Ptr is access all Big_Table_Type;
|
||||
-- The table is actually represented as a pointer to allow reallocation
|
||||
|
||||
Table : aliased Table_Ptr := null;
|
||||
-- The table itself. The lower bound is the value of Low_Bound.
|
||||
-- Logically the upper bound is the current value of Last (although
|
||||
-- the actual size of the allocated table may be larger than this).
|
||||
-- The program may only access and modify Table entries in the range
|
||||
-- First .. Last.
|
||||
|
||||
Locked : Boolean := False;
|
||||
-- Table expansion is permitted only if this switch is set to False. A
|
||||
-- client may set Locked to True, in which case any attempt to expand
|
||||
-- the table will cause an assertion failure. Note that while a table
|
||||
-- is locked, its address in memory remains fixed and unchanging. This
|
||||
-- feature is used to control table expansion during Gigi processing.
|
||||
-- Gigi assumes that tables other than the Uint and Ureal tables do
|
||||
-- not move during processing, which means that they cannot be expanded.
|
||||
-- The Locked flag is used to enforce this restriction.
|
||||
|
||||
procedure Init;
|
||||
-- This procedure allocates a new table of size Initial (freeing any
|
||||
-- previously allocated larger table). It is not necessary to call
|
||||
-- Init when a table is first instantiated (since the instantiation does
|
||||
-- the same initialization steps). However, it is harmless to do so, and
|
||||
-- Init is convenient in reestablishing a table for new use.
|
||||
|
||||
function Last return Table_Index_Type;
|
||||
pragma Inline (Last);
|
||||
-- Returns the current value of the last used entry in the table, which
|
||||
-- can then be used as a subscript for Table. Note that the only way to
|
||||
-- modify Last is to call the Set_Last procedure. Last must always be
|
||||
-- used to determine the logically last entry.
|
||||
|
||||
procedure Release;
|
||||
-- Storage is allocated in chunks according to the values given in the
|
||||
-- Initial and Increment parameters. A call to Release releases all
|
||||
-- storage that is allocated, but is not logically part of the current
|
||||
-- array value. Current array values are not affected by this call.
|
||||
|
||||
procedure Free;
|
||||
-- Free all allocated memory for the table. A call to init is required
|
||||
-- before any use of this table after calling Free.
|
||||
|
||||
First : constant Table_Index_Type := Table_Low_Bound;
|
||||
-- Export First as synonym for Low_Bound (parallel with use of Last)
|
||||
|
||||
procedure Set_Last (New_Val : Table_Index_Type);
|
||||
pragma Inline (Set_Last);
|
||||
-- This procedure sets Last to the indicated value. If necessary the
|
||||
-- table is reallocated to accomodate the new value (i.e. on return
|
||||
-- the allocated table has an upper bound of at least Last). If Set_Last
|
||||
-- reduces the size of the table, then logically entries are removed
|
||||
-- from the table. If Set_Last increases the size of the table, then
|
||||
-- new entries are logically added to the table.
|
||||
|
||||
procedure Increment_Last;
|
||||
pragma Inline (Increment_Last);
|
||||
-- Adds 1 to Last (same as Set_Last (Last + 1).
|
||||
|
||||
procedure Decrement_Last;
|
||||
pragma Inline (Decrement_Last);
|
||||
-- Subtracts 1 from Last (same as Set_Last (Last - 1).
|
||||
|
||||
procedure Append (New_Val : Table_Component_Type);
|
||||
pragma Inline (Append);
|
||||
-- Equivalent to:
|
||||
-- x.Increment_Last;
|
||||
-- x.Table (x.Last) := New_Val;
|
||||
-- i.e. the table size is increased by one, and the given new item
|
||||
-- stored in the newly created table element.
|
||||
|
||||
procedure Set_Item
|
||||
(Index : Table_Index_Type;
|
||||
Item : Table_Component_Type);
|
||||
pragma Inline (Set_Item);
|
||||
-- Put Item in the table at position Index. The table is expanded if
|
||||
-- current table length is less than Index and in that case Last is set
|
||||
-- to Index. Item will replace any value already present in the table
|
||||
-- at this position.
|
||||
|
||||
type Saved_Table is private;
|
||||
-- Type used for Save/Restore subprograms
|
||||
|
||||
function Save return Saved_Table;
|
||||
-- Resets table to empty, but saves old contents of table in returned
|
||||
-- value, for possible later restoration by a call to Restore.
|
||||
|
||||
procedure Restore (T : Saved_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;
|
||||
-- Current value of Last. Note that we declare this in the private part
|
||||
-- because we don't want the client to modify Last except through one of
|
||||
-- the official interfaces (since a modification to Last may require a
|
||||
-- reallocation of the table).
|
||||
|
||||
Max : Int;
|
||||
-- Subscript of the maximum entry in the currently allocated table
|
||||
|
||||
type Saved_Table is record
|
||||
Last_Val : Int;
|
||||
Max : Int;
|
||||
Table : Table_Ptr;
|
||||
end record;
|
||||
|
||||
end Table;
|
||||
end Table;
|
|
@ -0,0 +1,228 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- T A R G P A R M --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.15 $
|
||||
-- --
|
||||
-- Copyright (C) 1999-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Namet; use Namet;
|
||||
with Output; use Output;
|
||||
with Sinput; use Sinput;
|
||||
with Sinput.L; use Sinput.L;
|
||||
with Fname.UF; use Fname.UF;
|
||||
with Types; use Types;
|
||||
|
||||
package body Targparm is
|
||||
|
||||
type Targparm_Tags is
|
||||
(AAM, CLA, DEN, DSP, FEL, HIM, LSI, MOV,
|
||||
MRN, SCD, SCP, SNZ, UAM, VMS, ZCD, ZCG, ZCF);
|
||||
|
||||
Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
|
||||
-- Flag is set True if corresponding parameter is scanned
|
||||
|
||||
AAM_Str : aliased constant Source_Buffer := "AAMP";
|
||||
CLA_Str : aliased constant Source_Buffer := "Command_Line_Args";
|
||||
DEN_Str : aliased constant Source_Buffer := "Denorm";
|
||||
DSP_Str : aliased constant Source_Buffer := "Functions_Return_By_DSP";
|
||||
FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
|
||||
HIM_Str : aliased constant Source_Buffer := "High_Integrity_Mode";
|
||||
LSI_Str : aliased constant Source_Buffer := "Long_Shifts_Inlined";
|
||||
MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";
|
||||
MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";
|
||||
SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default";
|
||||
SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes";
|
||||
SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";
|
||||
UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";
|
||||
VMS_Str : aliased constant Source_Buffer := "OpenVMS";
|
||||
ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
|
||||
ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support";
|
||||
ZCF_Str : aliased constant Source_Buffer := "Front_End_ZCX_Support";
|
||||
|
||||
type Buffer_Ptr is access constant Source_Buffer;
|
||||
Targparm_Str : array (Targparm_Tags) of Buffer_Ptr :=
|
||||
(AAM_Str'Access,
|
||||
CLA_Str'Access,
|
||||
DEN_Str'Access,
|
||||
DSP_Str'Access,
|
||||
FEL_Str'Access,
|
||||
HIM_Str'Access,
|
||||
LSI_Str'Access,
|
||||
MOV_Str'Access,
|
||||
MRN_Str'Access,
|
||||
SCD_Str'Access,
|
||||
SCP_Str'Access,
|
||||
SNZ_Str'Access,
|
||||
UAM_Str'Access,
|
||||
VMS_Str'Access,
|
||||
ZCD_Str'Access,
|
||||
ZCG_Str'Access,
|
||||
ZCF_Str'Access);
|
||||
|
||||
---------------------------
|
||||
-- Get_Target_Parameters --
|
||||
---------------------------
|
||||
|
||||
procedure Get_Target_Parameters is
|
||||
use ASCII;
|
||||
|
||||
S : Source_File_Index;
|
||||
N : Name_Id;
|
||||
T : Source_Buffer_Ptr;
|
||||
P : Source_Ptr;
|
||||
Z : Source_Ptr;
|
||||
|
||||
Fatal : Boolean := False;
|
||||
-- Set True if a fatal error is detected
|
||||
|
||||
Result : Boolean;
|
||||
-- Records boolean from system line
|
||||
|
||||
begin
|
||||
Name_Buffer (1 .. 6) := "system";
|
||||
Name_Len := 6;
|
||||
N := File_Name_Of_Spec (Name_Find);
|
||||
S := Load_Source_File (N);
|
||||
|
||||
if S = No_Source_File then
|
||||
Write_Line ("fatal error, run-time library not installed correctly");
|
||||
Write_Str ("cannot locate file ");
|
||||
Write_Line (Name_Buffer (1 .. Name_Len));
|
||||
raise Unrecoverable_Error;
|
||||
|
||||
-- This must always be the first source file read, and we have defined
|
||||
-- a constant Types.System_Source_File_Index as 1 to reflect this.
|
||||
|
||||
else
|
||||
pragma Assert (S = System_Source_File_Index);
|
||||
null;
|
||||
end if;
|
||||
|
||||
P := Source_First (S);
|
||||
Z := Source_Last (S);
|
||||
T := Source_Text (S);
|
||||
|
||||
while T (P .. P + 10) /= "end System;" loop
|
||||
|
||||
for K in Targparm_Tags loop
|
||||
if T (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
|
||||
Targparm_Str (K).all
|
||||
then
|
||||
P := P + 3 + Targparm_Str (K)'Length;
|
||||
|
||||
if Targparm_Flags (K) then
|
||||
Set_Standard_Error;
|
||||
Write_Line
|
||||
("fatal error: system.ads is incorrectly formatted");
|
||||
Write_Str ("duplicate line for parameter: ");
|
||||
|
||||
for J in Targparm_Str (K)'Range loop
|
||||
Write_Char (Targparm_Str (K).all (J));
|
||||
end loop;
|
||||
|
||||
Write_Eol;
|
||||
Set_Standard_Output;
|
||||
Fatal := True;
|
||||
|
||||
else
|
||||
Targparm_Flags (K) := True;
|
||||
end if;
|
||||
|
||||
while T (P) /= ':' or else T (P + 1) /= '=' loop
|
||||
P := P + 1;
|
||||
end loop;
|
||||
|
||||
P := P + 2;
|
||||
|
||||
while T (P) = ' ' loop
|
||||
P := P + 1;
|
||||
end loop;
|
||||
|
||||
Result := (T (P) = 'T');
|
||||
|
||||
case K is
|
||||
when AAM => AAMP_On_Target := Result;
|
||||
when CLA => Command_Line_Args_On_Target := Result;
|
||||
when DEN => Denorm_On_Target := Result;
|
||||
when DSP => Functions_Return_By_DSP_On_Target := Result;
|
||||
when FEL => Frontend_Layout_On_Target := Result;
|
||||
when HIM => High_Integrity_Mode_On_Target := Result;
|
||||
when LSI => Long_Shifts_Inlined_On_Target := Result;
|
||||
when MOV => Machine_Overflows_On_Target := Result;
|
||||
when MRN => Machine_Rounds_On_Target := Result;
|
||||
when SCD => Stack_Check_Default_On_Target := Result;
|
||||
when SCP => Stack_Check_Probes_On_Target := Result;
|
||||
when SNZ => Signed_Zeros_On_Target := Result;
|
||||
when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
|
||||
when VMS => OpenVMS_On_Target := Result;
|
||||
when ZCD => ZCX_By_Default_On_Target := Result;
|
||||
when ZCG => GCC_ZCX_Support_On_Target := Result;
|
||||
when ZCF => Front_End_ZCX_Support_On_Target := Result;
|
||||
end case;
|
||||
|
||||
exit;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
while T (P) /= CR and then T (P) /= LF loop
|
||||
P := P + 1;
|
||||
exit when P >= Z;
|
||||
end loop;
|
||||
|
||||
while T (P) = CR or else T (P) = LF loop
|
||||
P := P + 1;
|
||||
exit when P >= Z;
|
||||
end loop;
|
||||
|
||||
if P >= Z then
|
||||
Set_Standard_Error;
|
||||
Write_Line ("fatal error, system.ads not formatted correctly");
|
||||
Set_Standard_Output;
|
||||
raise Unrecoverable_Error;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
for K in Targparm_Tags loop
|
||||
if not Targparm_Flags (K) then
|
||||
Set_Standard_Error;
|
||||
Write_Line
|
||||
("fatal error: system.ads is incorrectly formatted");
|
||||
Write_Str ("missing line for parameter: ");
|
||||
|
||||
for J in Targparm_Str (K)'Range loop
|
||||
Write_Char (Targparm_Str (K).all (J));
|
||||
end loop;
|
||||
|
||||
Write_Eol;
|
||||
Set_Standard_Output;
|
||||
Fatal := True;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
if Fatal then
|
||||
raise Unrecoverable_Error;
|
||||
end if;
|
||||
end Get_Target_Parameters;
|
||||
|
||||
end Targparm;
|
|
@ -0,0 +1,288 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- T A R G P A R M --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.13 $
|
||||
-- --
|
||||
-- Copyright (C) 1999-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package obtains parameters from the target runtime version of
|
||||
-- System, to indicate parameters relevant to the target environment.
|
||||
|
||||
-- Conceptually, these parameters could be obtained using rtsfind, but
|
||||
-- we do not do this for three reasons:
|
||||
|
||||
-- 1. Compiling System for every compilation wastes time
|
||||
-- 2. This compilation impedes debugging by adding extra compile steps
|
||||
-- 3. There are recursion problems coming from compiling System itself
|
||||
-- or any of its children.
|
||||
|
||||
-- For all these reasons, we read in the source of System, and then scan
|
||||
-- it at the text level to extract the parameter values.
|
||||
|
||||
-- Note however, that later on, when the ali file is written, we make sure
|
||||
-- that the System file is at least parsed, so that the checksum is properly
|
||||
-- computed and set in the ali file. This partially negates points 1 and 2
|
||||
-- above although just parsing is quick and does not impact debugging much.
|
||||
|
||||
package Targparm is
|
||||
|
||||
-- The following parameters correspond to the variables defined in the
|
||||
-- private part of System (without the terminating _On_Target). Note
|
||||
-- that it is required that all parameters be specified in system.ads.
|
||||
|
||||
-----------------------------------
|
||||
-- Control of Exception Handling --
|
||||
-----------------------------------
|
||||
|
||||
-- GNAT provides two methods of implementing exceptions:
|
||||
|
||||
-- Longjmp/Setjmp (-gnatL)
|
||||
|
||||
-- This approach uses longjmp/setjmp to handle exceptions. It
|
||||
-- uses less storage, and can often propagate exceptions faster,
|
||||
-- at the expense of (sometimes considerable) overhead in setting
|
||||
-- up an exception handler. This approach is available on all
|
||||
-- targets, and is the default where it is the only approach.
|
||||
|
||||
-- Zero Cost (-gnatZ)
|
||||
|
||||
-- This approach uses separate exception tables. These use extra
|
||||
-- storage, and exception propagation can be quite slow, but there
|
||||
-- is no overhead in setting up an exception handler (it is to this
|
||||
-- latter operation that the phrase zero-cost refers). This approach
|
||||
-- is only available on some targets, and is the default where it is
|
||||
-- available.
|
||||
|
||||
ZCX_By_Default_On_Target : Boolean;
|
||||
-- Indicates if zero cost exceptions are active by default. Can be modified
|
||||
-- by the use of -gnatZ and -gnatL switches.
|
||||
|
||||
GCC_ZCX_Support_On_Target : Boolean;
|
||||
-- Indicates that when ZCX is active the mechanism to be used is the
|
||||
-- standard GCC ZCX mechanism (introduced in GCC 3.1)
|
||||
|
||||
Front_End_ZCX_Support_On_Target : Boolean;
|
||||
-- Indicates that when ZCX is active (and GCC_ZCX_Support is not set)
|
||||
-- the mechanism to be used is the GNAT front end specific ZCX mechanism
|
||||
|
||||
---------------------------------------
|
||||
-- High_Integrity (No Run Time) Mode --
|
||||
---------------------------------------
|
||||
|
||||
-- In High_Integrity mode, there is no system run-time, and the flag
|
||||
-- Opt.No_Run_Time is set so that the language is appropriately
|
||||
-- restricted to forbid construct that would generate run-time calls.
|
||||
|
||||
High_Integrity_Mode_On_Target : Boolean;
|
||||
-- Indicates that this build is for a high integrity mode version of
|
||||
-- GNAT, so that no run time is permitted.
|
||||
|
||||
-------------------------------
|
||||
-- Control of Stack Checking --
|
||||
-------------------------------
|
||||
|
||||
-- GNAT provides two methods of implementing exceptions:
|
||||
|
||||
-- GCC Probing Mechanism
|
||||
|
||||
-- This approach uses the standard GCC mechanism for
|
||||
-- stack checking. The method assumes that accessing
|
||||
-- storage immediately beyond the end of the stack
|
||||
-- will result in a trap that is converted to a storage
|
||||
-- error by the runtime system. This mechanism has
|
||||
-- minimal overhead, but requires complex hardware,
|
||||
-- operating system and run-time support. Probing is
|
||||
-- the default method where it is available. The stack
|
||||
-- size for the environment task depends on the operating
|
||||
-- system and cannot be set in a system-independent way.
|
||||
|
||||
-- GNAT Stack-limit Checking
|
||||
|
||||
-- This method relies on comparing the stack pointer
|
||||
-- with per-task stack limits. If the check fails, an
|
||||
-- exception is explicitly raised. The advantage is
|
||||
-- that the method requires no extra system dependent
|
||||
-- runtime support and can be used on systems without
|
||||
-- memory protection as well, but at the cost of more
|
||||
-- overhead for doing the check. This method is the
|
||||
-- default on systems that lack complete support for
|
||||
-- probing.
|
||||
|
||||
Stack_Check_Probes_On_Target : Boolean;
|
||||
-- Indicates if stack check probes are used, as opposed to the standard
|
||||
-- target independent comparison method.
|
||||
|
||||
Stack_Check_Default_On_Target : Boolean;
|
||||
-- Indicates if stack checking is on by default
|
||||
|
||||
----------------------------
|
||||
-- Command Line Arguments --
|
||||
----------------------------
|
||||
|
||||
-- For most ports of GNAT, command line arguments are supported. The
|
||||
-- following flag is set to False for targets that do not support
|
||||
-- command line arguments (notably VxWorks).
|
||||
|
||||
Command_Line_Args_On_Target : Boolean;
|
||||
-- Set False if no command line arguments on target
|
||||
|
||||
-- Note: this is prepared for future use, but not yet used, since we
|
||||
-- do not yet have a way of propagating Targparm params to the binder
|
||||
|
||||
-----------------------
|
||||
-- Main Program Name --
|
||||
-----------------------
|
||||
|
||||
-- When the binder generates the main program to be used to create the
|
||||
-- executable, the main program name is main by default (to match the
|
||||
-- usual Unix practice). If this parameter is set to True, then the
|
||||
-- name is instead by default taken from the actual Ada main program
|
||||
-- name (just the name of the child if the main program is a child unit).
|
||||
-- In either case, this value can be overridden using -M name.
|
||||
|
||||
Use_Ada_Main_Program_Name_On_Target : Boolean;
|
||||
-- Set True to use the Ada main program name as the main name
|
||||
|
||||
-- Note: this is prepared for future use, but not yet used, since we
|
||||
-- do not yet have a way of propagating Targparm params to the binder
|
||||
|
||||
----------------------------
|
||||
-- Support of Long Shifts --
|
||||
----------------------------
|
||||
|
||||
-- In GNORT mode, we cannot call library routines, and in particular
|
||||
-- we cannot call routines for long (64-bit) shifts if such routines
|
||||
-- are required on the target. This comes up in the context of support
|
||||
-- of packed arrays. We can only represent packed arrays whose length
|
||||
-- is in the range 33- to 64-bits as modular types if long shifts are
|
||||
-- done with inline code.
|
||||
|
||||
-- For the default version, for now we set long shifts inlined as True
|
||||
-- This may not be quite accurate, but until we get proper separate
|
||||
-- System's for each target, it is a safer choice.
|
||||
|
||||
Long_Shifts_Inlined_On_Target : Boolean;
|
||||
-- Indicates if long (double word) shifts are generated using inlined
|
||||
-- code (and thus are permissible in No_Run_Time mode).
|
||||
|
||||
----------------------------------------------
|
||||
-- Boolean-Valued Floating-Point Attributes --
|
||||
----------------------------------------------
|
||||
|
||||
-- The constants below give the values for representation oriented
|
||||
-- floating-point attributes that are the same for all float types
|
||||
-- on the target. These are all boolean values.
|
||||
|
||||
-- A value is only True if the target reliably supports the corresponding
|
||||
-- feature. Reliably here means that support is guaranteed for all
|
||||
-- possible settings of the relevant compiler switches (like -mieee),
|
||||
-- since we cannot control the user setting of those switches.
|
||||
|
||||
-- The attributes cannot dependent on the current setting of compiler
|
||||
-- switches, since the values must be static and consistent throughout
|
||||
-- the partition. We probably should add such consistency checks in future,
|
||||
-- but for now we don't do this.
|
||||
|
||||
AAMP_On_Target : Boolean;
|
||||
-- Set to True if target is AAMP.
|
||||
|
||||
Denorm_On_Target : Boolean;
|
||||
-- Set to False on targets that do not reliably support denormals.
|
||||
-- Reliably here means for all settings of the relevant -m flag, so
|
||||
-- for example, this is False on the Alpha where denormals are not
|
||||
-- supported unless -mieee is used.
|
||||
|
||||
Machine_Rounds_On_Target : Boolean;
|
||||
-- Set to False for targets where S'Machine_Rounds is False
|
||||
|
||||
Machine_Overflows_On_Target : Boolean;
|
||||
-- Set to True for targets where S'Machine_Overflows is True
|
||||
|
||||
Signed_Zeros_On_Target : Boolean;
|
||||
-- Set to False on targets that do not reliably support signed zeros.
|
||||
|
||||
OpenVMS_On_Target : Boolean;
|
||||
-- Set to True if target is OpenVMS.
|
||||
|
||||
--------------------------------------------------------------
|
||||
-- Handling of Unconstrained Values Returned from Functions --
|
||||
--------------------------------------------------------------
|
||||
|
||||
-- Functions that return variable length objects, notably unconstrained
|
||||
-- arrays are a special case, because there is no simple obvious way of
|
||||
-- implementing this feature. Furthermore, this capability is not present
|
||||
-- in C++ or C, so typically the system ABI does not handle this case.
|
||||
|
||||
-- GNAT uses two different approaches
|
||||
|
||||
-- The Secondary Stack
|
||||
|
||||
-- The secondary stack is a special storage pool that is used for
|
||||
-- this purpose. The called function places the result on the
|
||||
-- secondary stack, and the caller uses or copies the value from
|
||||
-- the secondary stack, and pops the secondary stack after the
|
||||
-- value is consumed. The secondary stack is outside the system
|
||||
-- ABI, and the important point is that although generally it is
|
||||
-- handled in a stack like manner corresponding to the subprogram
|
||||
-- call structure, a return from a function does NOT pop the stack.
|
||||
|
||||
-- DSP (Depressed Stack Pointer)
|
||||
|
||||
-- Some targets permit the implementation of a function call/return
|
||||
-- protocol in which the function does not pop the main stack pointer
|
||||
-- on return, but rather returns with the stack pointer depressed.
|
||||
-- This is not generally permitted by any ABI, but for at least some
|
||||
-- targets, the implementation of alloca provides a model for this
|
||||
-- approach. If return-with-DSP is implemented, then functions that
|
||||
-- return variable length objects do it by returning with the stack
|
||||
-- pointer depressed, and the returned object is a pointer to the
|
||||
-- area within the stack frame of the called procedure that contains
|
||||
-- the returned value. The caller must then pop the main stack when
|
||||
-- this value is consumed.
|
||||
|
||||
Functions_Return_By_DSP_On_Target : Boolean;
|
||||
-- Set to True if target permits functions to return with using the
|
||||
-- DSP (depressed stack pointer) approach.
|
||||
|
||||
-----------------
|
||||
-- Data Layout --
|
||||
-----------------
|
||||
|
||||
-- Normally when using the GCC backend, Gigi and GCC perform much of the
|
||||
-- data layout using the standard layout capabilities of GCC. If the
|
||||
-- parameter Backend_Layout is set to False, then the front end must
|
||||
-- perform all data layout. For further details see the package Layout.
|
||||
|
||||
Frontend_Layout_On_Target : Boolean;
|
||||
-- Set True if front end does layout
|
||||
|
||||
-----------------
|
||||
-- Subprograms --
|
||||
-----------------
|
||||
|
||||
procedure Get_Target_Parameters;
|
||||
-- Called at the start of execution to read the source of System and
|
||||
-- obtain and set the values of the above parameters.
|
||||
|
||||
end Targparm;
|
|
@ -0,0 +1,226 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNAT COMPILER COMPONENTS *
|
||||
* *
|
||||
* T A R G T Y P S *
|
||||
* *
|
||||
* Body *
|
||||
* *
|
||||
* $Revision: 1.1 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write *
|
||||
* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
|
||||
* MA 02111-1307, USA. *
|
||||
* *
|
||||
* As a special exception, if you link this file with other files to *
|
||||
* produce an executable, this file does not by itself cause the resulting *
|
||||
* executable to be covered by the GNU General Public License. This except- *
|
||||
* ion does not however invalidate any other reasons why the executable *
|
||||
* file might be covered by the GNU Public License. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
/* Functions for retrieving target types. See Ada package Get_Targ */
|
||||
|
||||
#include "config.h"
|
||||
#include "system.h"
|
||||
#include "tree.h"
|
||||
#include "real.h"
|
||||
#include "rtl.h"
|
||||
#include "ada.h"
|
||||
#include "types.h"
|
||||
#include "atree.h"
|
||||
#include "elists.h"
|
||||
#include "namet.h"
|
||||
#include "nlists.h"
|
||||
#include "snames.h"
|
||||
#include "stringt.h"
|
||||
#include "uintp.h"
|
||||
#include "urealp.h"
|
||||
#include "fe.h"
|
||||
#include "sinfo.h"
|
||||
#include "einfo.h"
|
||||
#include "ada-tree.h"
|
||||
#include "gigi.h"
|
||||
|
||||
#define MIN(X,Y) ((X) < (Y) ? (X) : (Y))
|
||||
|
||||
/* Standard data type sizes. Most of these are not used. */
|
||||
|
||||
#ifndef CHAR_TYPE_SIZE
|
||||
#define CHAR_TYPE_SIZE BITS_PER_UNIT
|
||||
#endif
|
||||
|
||||
#ifndef SHORT_TYPE_SIZE
|
||||
#define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2))
|
||||
#endif
|
||||
|
||||
#ifndef INT_TYPE_SIZE
|
||||
#define INT_TYPE_SIZE BITS_PER_WORD
|
||||
#endif
|
||||
|
||||
#ifdef OPEN_VMS /* A target macro defined in vms.h */
|
||||
#define LONG_TYPE_SIZE 64
|
||||
#else
|
||||
#ifndef LONG_TYPE_SIZE
|
||||
#define LONG_TYPE_SIZE BITS_PER_WORD
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifndef LONG_LONG_TYPE_SIZE
|
||||
#define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2)
|
||||
#endif
|
||||
|
||||
#ifndef FLOAT_TYPE_SIZE
|
||||
#define FLOAT_TYPE_SIZE BITS_PER_WORD
|
||||
#endif
|
||||
|
||||
#ifndef DOUBLE_TYPE_SIZE
|
||||
#define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
|
||||
#endif
|
||||
|
||||
#ifndef LONG_DOUBLE_TYPE_SIZE
|
||||
#define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
|
||||
#endif
|
||||
|
||||
#ifndef WIDEST_HARDWARE_FP_SIZE
|
||||
#define WIDEST_HARDWARE_FP_SIZE LONG_DOUBLE_TYPE_SIZE
|
||||
#endif
|
||||
|
||||
/* The following provide a functional interface for the front end Ada code
|
||||
to determine the sizes that are used for various C types. */
|
||||
|
||||
Pos
|
||||
get_target_bits_per_unit ()
|
||||
{
|
||||
return BITS_PER_UNIT;
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_bits_per_word ()
|
||||
{
|
||||
return BITS_PER_WORD;
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_char_size ()
|
||||
{
|
||||
return CHAR_TYPE_SIZE;
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_wchar_t_size ()
|
||||
{
|
||||
/* We never want wide chacters less than "short" in Ada. */
|
||||
return MAX (SHORT_TYPE_SIZE, WCHAR_TYPE_SIZE);
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_short_size ()
|
||||
{
|
||||
return SHORT_TYPE_SIZE;
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_int_size ()
|
||||
{
|
||||
return INT_TYPE_SIZE;
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_long_size ()
|
||||
{
|
||||
return LONG_TYPE_SIZE;
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_long_long_size ()
|
||||
{
|
||||
return LONG_LONG_TYPE_SIZE;
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_float_size ()
|
||||
{
|
||||
return FLOAT_TYPE_SIZE;
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_double_size ()
|
||||
{
|
||||
return DOUBLE_TYPE_SIZE;
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_long_double_size ()
|
||||
{
|
||||
return WIDEST_HARDWARE_FP_SIZE;
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_pointer_size ()
|
||||
{
|
||||
return POINTER_SIZE;
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_maximum_alignment ()
|
||||
{
|
||||
return BIGGEST_ALIGNMENT / BITS_PER_UNIT;
|
||||
}
|
||||
|
||||
Boolean
|
||||
get_target_no_dollar_in_label ()
|
||||
{
|
||||
#ifdef NO_DOLLAR_IN_LABEL
|
||||
return 1;
|
||||
#else
|
||||
return 0;
|
||||
#endif
|
||||
}
|
||||
|
||||
#ifndef FLOAT_WORDS_BIG_ENDIAN
|
||||
#define FLOAT_WORDS_BIG_ENDIAN WORDS_BIG_ENDIAN
|
||||
#endif
|
||||
|
||||
Nat
|
||||
get_float_words_be ()
|
||||
{
|
||||
return FLOAT_WORDS_BIG_ENDIAN;
|
||||
}
|
||||
|
||||
Nat
|
||||
get_words_be ()
|
||||
{
|
||||
return WORDS_BIG_ENDIAN;
|
||||
}
|
||||
|
||||
Nat
|
||||
get_bytes_be ()
|
||||
{
|
||||
return BYTES_BIG_ENDIAN;
|
||||
}
|
||||
|
||||
Nat
|
||||
get_bits_be ()
|
||||
{
|
||||
return BITS_BIG_ENDIAN;
|
||||
}
|
||||
|
||||
Nat
|
||||
get_strict_alignment ()
|
||||
{
|
||||
return STRICT_ALIGNMENT;
|
||||
}
|
|
@ -0,0 +1,522 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T B U I L D --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.98 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001, 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Einfo; use Einfo;
|
||||
with Lib; use Lib;
|
||||
with Namet; use Namet;
|
||||
with Nlists; use Nlists;
|
||||
with Nmake; use Nmake;
|
||||
with Restrict; use Restrict;
|
||||
with Sinfo; use Sinfo;
|
||||
with Snames; use Snames;
|
||||
with Stand; use Stand;
|
||||
with Uintp; use Uintp;
|
||||
|
||||
package body Tbuild is
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
procedure Add_Unique_Serial_Number;
|
||||
-- Add a unique serialization to the string in the Name_Buffer. This
|
||||
-- consists of a unit specific serial number, and b/s for body/spec.
|
||||
|
||||
------------------------------
|
||||
-- Add_Unique_Serial_Number --
|
||||
------------------------------
|
||||
|
||||
procedure Add_Unique_Serial_Number is
|
||||
Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
|
||||
|
||||
begin
|
||||
Add_Nat_To_Name_Buffer (Increment_Serial_Number);
|
||||
|
||||
-- Add either b or s, depending on whether current unit is a spec
|
||||
-- or a body. This is needed because we may generate the same name
|
||||
-- in a spec and a body otherwise.
|
||||
|
||||
Name_Len := Name_Len + 1;
|
||||
|
||||
if Nkind (Unit_Node) = N_Package_Declaration
|
||||
or else Nkind (Unit_Node) = N_Subprogram_Declaration
|
||||
or else Nkind (Unit_Node) in N_Generic_Declaration
|
||||
then
|
||||
Name_Buffer (Name_Len) := 's';
|
||||
else
|
||||
Name_Buffer (Name_Len) := 'b';
|
||||
end if;
|
||||
end Add_Unique_Serial_Number;
|
||||
|
||||
----------------
|
||||
-- Checks_Off --
|
||||
----------------
|
||||
|
||||
function Checks_Off (N : Node_Id) return Node_Id is
|
||||
begin
|
||||
return
|
||||
Make_Unchecked_Expression (Sloc (N),
|
||||
Expression => N);
|
||||
end Checks_Off;
|
||||
|
||||
----------------
|
||||
-- Convert_To --
|
||||
----------------
|
||||
|
||||
function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
|
||||
Result : Node_Id;
|
||||
|
||||
begin
|
||||
if Present (Etype (Expr))
|
||||
and then (Etype (Expr)) = Typ
|
||||
then
|
||||
return Relocate_Node (Expr);
|
||||
else
|
||||
Result :=
|
||||
Make_Type_Conversion (Sloc (Expr),
|
||||
Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
|
||||
Expression => Relocate_Node (Expr));
|
||||
|
||||
Set_Etype (Result, Typ);
|
||||
return Result;
|
||||
end if;
|
||||
end Convert_To;
|
||||
|
||||
--------------------
|
||||
-- Make_DT_Access --
|
||||
--------------------
|
||||
|
||||
function Make_DT_Access
|
||||
(Loc : Source_Ptr;
|
||||
Rec : Node_Id;
|
||||
Typ : Entity_Id)
|
||||
return Node_Id
|
||||
is
|
||||
Full_Type : Entity_Id := Typ;
|
||||
|
||||
begin
|
||||
if Is_Private_Type (Typ) then
|
||||
Full_Type := Underlying_Type (Typ);
|
||||
end if;
|
||||
|
||||
return
|
||||
Unchecked_Convert_To (
|
||||
New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc),
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => New_Copy (Rec),
|
||||
Selector_Name =>
|
||||
New_Reference_To (Tag_Component (Full_Type), Loc)));
|
||||
end Make_DT_Access;
|
||||
|
||||
-----------------------
|
||||
-- Make_DT_Component --
|
||||
-----------------------
|
||||
|
||||
function Make_DT_Component
|
||||
(Loc : Source_Ptr;
|
||||
Typ : Entity_Id;
|
||||
I : Positive)
|
||||
return Node_Id
|
||||
is
|
||||
X : Node_Id;
|
||||
Full_Type : Entity_Id := Typ;
|
||||
|
||||
begin
|
||||
if Is_Private_Type (Typ) then
|
||||
Full_Type := Underlying_Type (Typ);
|
||||
end if;
|
||||
|
||||
X := First_Component (
|
||||
Designated_Type (Etype (Access_Disp_Table (Full_Type))));
|
||||
|
||||
for J in 2 .. I loop
|
||||
X := Next_Component (X);
|
||||
end loop;
|
||||
|
||||
return New_Reference_To (X, Loc);
|
||||
end Make_DT_Component;
|
||||
|
||||
--------------------------------
|
||||
-- Make_Implicit_If_Statement --
|
||||
--------------------------------
|
||||
|
||||
function Make_Implicit_If_Statement
|
||||
(Node : Node_Id;
|
||||
Condition : Node_Id;
|
||||
Then_Statements : List_Id;
|
||||
Elsif_Parts : List_Id := No_List;
|
||||
Else_Statements : List_Id := No_List)
|
||||
return Node_Id
|
||||
is
|
||||
begin
|
||||
Check_Restriction (No_Implicit_Conditionals, Node);
|
||||
return Make_If_Statement (Sloc (Node),
|
||||
Condition,
|
||||
Then_Statements,
|
||||
Elsif_Parts,
|
||||
Else_Statements);
|
||||
end Make_Implicit_If_Statement;
|
||||
|
||||
-------------------------------------
|
||||
-- Make_Implicit_Label_Declaration --
|
||||
-------------------------------------
|
||||
|
||||
function Make_Implicit_Label_Declaration
|
||||
(Loc : Source_Ptr;
|
||||
Defining_Identifier : Node_Id;
|
||||
Label_Construct : Node_Id)
|
||||
return Node_Id
|
||||
is
|
||||
N : constant Node_Id :=
|
||||
Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
|
||||
|
||||
begin
|
||||
Set_Label_Construct (N, Label_Construct);
|
||||
return N;
|
||||
end Make_Implicit_Label_Declaration;
|
||||
|
||||
----------------------------------
|
||||
-- Make_Implicit_Loop_Statement --
|
||||
----------------------------------
|
||||
|
||||
function Make_Implicit_Loop_Statement
|
||||
(Node : Node_Id;
|
||||
Statements : List_Id;
|
||||
Identifier : Node_Id := Empty;
|
||||
Iteration_Scheme : Node_Id := Empty;
|
||||
Has_Created_Identifier : Boolean := False;
|
||||
End_Label : Node_Id := Empty)
|
||||
return Node_Id
|
||||
is
|
||||
begin
|
||||
Check_Restriction (No_Implicit_Loops, Node);
|
||||
|
||||
if Present (Iteration_Scheme)
|
||||
and then Present (Condition (Iteration_Scheme))
|
||||
then
|
||||
Check_Restriction (No_Implicit_Conditionals, Node);
|
||||
end if;
|
||||
|
||||
return Make_Loop_Statement (Sloc (Node),
|
||||
Identifier => Identifier,
|
||||
Iteration_Scheme => Iteration_Scheme,
|
||||
Statements => Statements,
|
||||
Has_Created_Identifier => Has_Created_Identifier,
|
||||
End_Label => End_Label);
|
||||
end Make_Implicit_Loop_Statement;
|
||||
|
||||
--------------------------
|
||||
-- Make_Integer_Literal --
|
||||
---------------------------
|
||||
|
||||
function Make_Integer_Literal
|
||||
(Loc : Source_Ptr;
|
||||
Intval : Int)
|
||||
return Node_Id
|
||||
is
|
||||
begin
|
||||
return Make_Integer_Literal (Loc, UI_From_Int (Intval));
|
||||
end Make_Integer_Literal;
|
||||
|
||||
---------------------------
|
||||
-- Make_Unsuppress_Block --
|
||||
---------------------------
|
||||
|
||||
-- Generates the following expansion:
|
||||
|
||||
-- declare
|
||||
-- pragma Suppress (<check>);
|
||||
-- begin
|
||||
-- <stmts>
|
||||
-- end;
|
||||
|
||||
function Make_Unsuppress_Block
|
||||
(Loc : Source_Ptr;
|
||||
Check : Name_Id;
|
||||
Stmts : List_Id)
|
||||
return Node_Id
|
||||
is
|
||||
begin
|
||||
return
|
||||
Make_Block_Statement (Loc,
|
||||
Declarations => New_List (
|
||||
Make_Pragma (Loc,
|
||||
Chars => Name_Suppress,
|
||||
Pragma_Argument_Associations => New_List (
|
||||
Make_Pragma_Argument_Association (Loc,
|
||||
Expression => Make_Identifier (Loc, Check))))),
|
||||
|
||||
Handled_Statement_Sequence =>
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
Statements => Stmts));
|
||||
end Make_Unsuppress_Block;
|
||||
|
||||
--------------------------
|
||||
-- New_Constraint_Error --
|
||||
--------------------------
|
||||
|
||||
function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
|
||||
Ident_Node : Node_Id;
|
||||
Raise_Node : Node_Id;
|
||||
|
||||
begin
|
||||
Ident_Node := New_Node (N_Identifier, Loc);
|
||||
Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
|
||||
Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
|
||||
Raise_Node := New_Node (N_Raise_Statement, Loc);
|
||||
Set_Name (Raise_Node, Ident_Node);
|
||||
return Raise_Node;
|
||||
end New_Constraint_Error;
|
||||
|
||||
-----------------------
|
||||
-- New_External_Name --
|
||||
-----------------------
|
||||
|
||||
function New_External_Name
|
||||
(Related_Id : Name_Id;
|
||||
Suffix : Character := ' ';
|
||||
Suffix_Index : Int := 0;
|
||||
Prefix : Character := ' ')
|
||||
return Name_Id
|
||||
is
|
||||
begin
|
||||
Get_Name_String (Related_Id);
|
||||
|
||||
if Prefix /= ' ' then
|
||||
pragma Assert (Is_OK_Internal_Letter (Prefix));
|
||||
|
||||
for J in reverse 1 .. Name_Len loop
|
||||
Name_Buffer (J + 1) := Name_Buffer (J);
|
||||
end loop;
|
||||
|
||||
Name_Len := Name_Len + 1;
|
||||
Name_Buffer (1) := Prefix;
|
||||
end if;
|
||||
|
||||
if Suffix /= ' ' then
|
||||
pragma Assert (Is_OK_Internal_Letter (Suffix));
|
||||
Name_Len := Name_Len + 1;
|
||||
Name_Buffer (Name_Len) := Suffix;
|
||||
end if;
|
||||
|
||||
if Suffix_Index /= 0 then
|
||||
if Suffix_Index < 0 then
|
||||
Add_Unique_Serial_Number;
|
||||
else
|
||||
Add_Nat_To_Name_Buffer (Suffix_Index);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return Name_Find;
|
||||
end New_External_Name;
|
||||
|
||||
function New_External_Name
|
||||
(Related_Id : Name_Id;
|
||||
Suffix : String;
|
||||
Suffix_Index : Int := 0;
|
||||
Prefix : Character := ' ')
|
||||
return Name_Id
|
||||
is
|
||||
begin
|
||||
Get_Name_String (Related_Id);
|
||||
|
||||
if Prefix /= ' ' then
|
||||
pragma Assert (Is_OK_Internal_Letter (Prefix));
|
||||
|
||||
for J in reverse 1 .. Name_Len loop
|
||||
Name_Buffer (J + 1) := Name_Buffer (J);
|
||||
end loop;
|
||||
|
||||
Name_Len := Name_Len + 1;
|
||||
Name_Buffer (1) := Prefix;
|
||||
end if;
|
||||
|
||||
if Suffix /= "" then
|
||||
Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
|
||||
Name_Len := Name_Len + Suffix'Length;
|
||||
end if;
|
||||
|
||||
if Suffix_Index /= 0 then
|
||||
if Suffix_Index < 0 then
|
||||
Add_Unique_Serial_Number;
|
||||
else
|
||||
Add_Nat_To_Name_Buffer (Suffix_Index);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return Name_Find;
|
||||
end New_External_Name;
|
||||
|
||||
function New_External_Name
|
||||
(Suffix : Character;
|
||||
Suffix_Index : Nat)
|
||||
return Name_Id
|
||||
is
|
||||
begin
|
||||
Name_Buffer (1) := Suffix;
|
||||
Name_Len := 1;
|
||||
Add_Nat_To_Name_Buffer (Suffix_Index);
|
||||
return Name_Find;
|
||||
end New_External_Name;
|
||||
|
||||
-----------------------
|
||||
-- New_Internal_Name --
|
||||
-----------------------
|
||||
|
||||
function New_Internal_Name (Id_Char : Character) return Name_Id is
|
||||
begin
|
||||
pragma Assert (Is_OK_Internal_Letter (Id_Char));
|
||||
Name_Buffer (1) := Id_Char;
|
||||
Name_Len := 1;
|
||||
Add_Unique_Serial_Number;
|
||||
return Name_Enter;
|
||||
end New_Internal_Name;
|
||||
|
||||
-----------------------
|
||||
-- New_Occurrence_Of --
|
||||
-----------------------
|
||||
|
||||
function New_Occurrence_Of
|
||||
(Def_Id : Entity_Id;
|
||||
Loc : Source_Ptr)
|
||||
return Node_Id
|
||||
is
|
||||
Occurrence : Node_Id;
|
||||
|
||||
begin
|
||||
Occurrence := New_Node (N_Identifier, Loc);
|
||||
Set_Chars (Occurrence, Chars (Def_Id));
|
||||
Set_Entity (Occurrence, Def_Id);
|
||||
|
||||
if Is_Type (Def_Id) then
|
||||
Set_Etype (Occurrence, Def_Id);
|
||||
else
|
||||
Set_Etype (Occurrence, Etype (Def_Id));
|
||||
end if;
|
||||
|
||||
return Occurrence;
|
||||
end New_Occurrence_Of;
|
||||
|
||||
----------------------
|
||||
-- New_Reference_To --
|
||||
----------------------
|
||||
|
||||
function New_Reference_To
|
||||
(Def_Id : Entity_Id;
|
||||
Loc : Source_Ptr)
|
||||
return Node_Id
|
||||
is
|
||||
Occurrence : Node_Id;
|
||||
|
||||
begin
|
||||
Occurrence := New_Node (N_Identifier, Loc);
|
||||
Set_Chars (Occurrence, Chars (Def_Id));
|
||||
Set_Entity (Occurrence, Def_Id);
|
||||
return Occurrence;
|
||||
end New_Reference_To;
|
||||
|
||||
-----------------------
|
||||
-- New_Suffixed_Name --
|
||||
-----------------------
|
||||
|
||||
function New_Suffixed_Name
|
||||
(Related_Id : Name_Id;
|
||||
Suffix : String)
|
||||
return Name_Id
|
||||
is
|
||||
begin
|
||||
Get_Name_String (Related_Id);
|
||||
Name_Len := Name_Len + 1;
|
||||
Name_Buffer (Name_Len) := '_';
|
||||
Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
|
||||
Name_Len := Name_Len + Suffix'Length;
|
||||
return Name_Find;
|
||||
end New_Suffixed_Name;
|
||||
|
||||
-------------------
|
||||
-- OK_Convert_To --
|
||||
-------------------
|
||||
|
||||
function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
|
||||
Result : Node_Id;
|
||||
|
||||
begin
|
||||
Result :=
|
||||
Make_Type_Conversion (Sloc (Expr),
|
||||
Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
|
||||
Expression => Relocate_Node (Expr));
|
||||
Set_Conversion_OK (Result, True);
|
||||
Set_Etype (Result, Typ);
|
||||
return Result;
|
||||
end OK_Convert_To;
|
||||
|
||||
--------------------------
|
||||
-- Unchecked_Convert_To --
|
||||
--------------------------
|
||||
|
||||
function Unchecked_Convert_To
|
||||
(Typ : Entity_Id;
|
||||
Expr : Node_Id)
|
||||
return Node_Id
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (Expr);
|
||||
Result : Node_Id;
|
||||
|
||||
begin
|
||||
-- If the expression is already of the correct type, then nothing
|
||||
-- to do, except for relocating the node in case this is required.
|
||||
|
||||
if Present (Etype (Expr))
|
||||
and then (Base_Type (Etype (Expr)) = Typ
|
||||
or else Etype (Expr) = Typ)
|
||||
then
|
||||
return Relocate_Node (Expr);
|
||||
|
||||
-- Cases where the inner expression is itself an unchecked conversion
|
||||
-- to the same type, and we can thus eliminate the outer conversion.
|
||||
|
||||
elsif Nkind (Expr) = N_Unchecked_Type_Conversion
|
||||
and then Entity (Subtype_Mark (Expr)) = Typ
|
||||
then
|
||||
Result := Relocate_Node (Expr);
|
||||
|
||||
-- All other cases
|
||||
|
||||
else
|
||||
Result :=
|
||||
Make_Unchecked_Type_Conversion (Loc,
|
||||
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
|
||||
Expression => Relocate_Node (Expr));
|
||||
end if;
|
||||
|
||||
Set_Etype (Result, Typ);
|
||||
return Result;
|
||||
end Unchecked_Convert_To;
|
||||
|
||||
end Tbuild;
|
|
@ -0,0 +1,241 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T B U I L D --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.69 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000, 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains various utility procedures to assist in
|
||||
-- building specific types of tree nodes.
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Tbuild is
|
||||
|
||||
function Make_DT_Component
|
||||
(Loc : Source_Ptr;
|
||||
Typ : Entity_Id;
|
||||
I : Positive)
|
||||
return Node_Id;
|
||||
-- Gives a reference to the Ith component of the Dispatch Table of
|
||||
-- a given Tagged Type.
|
||||
--
|
||||
-- I = 1 --> Inheritance_Depth
|
||||
-- I = 2 --> Tags (array of ancestors)
|
||||
-- I = 3, 4 --> predefined primitive
|
||||
-- function _Size (X : Typ) return Long_Long_Integer;
|
||||
-- function _Equality (X : Typ; Y : Typ'Class) return Boolean;
|
||||
-- I >= 5 --> User-Defined Primitive Operations
|
||||
|
||||
function Make_DT_Access
|
||||
(Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id;
|
||||
-- Create an access to the Dispatch Table by using the Tag field
|
||||
-- of a tagged record : Acc_Dt (Rec.tag).all
|
||||
|
||||
function Make_Implicit_If_Statement
|
||||
(Node : Node_Id;
|
||||
Condition : Node_Id;
|
||||
Then_Statements : List_Id;
|
||||
Elsif_Parts : List_Id := No_List;
|
||||
Else_Statements : List_Id := No_List)
|
||||
return Node_Id;
|
||||
pragma Inline (Make_Implicit_If_Statement);
|
||||
-- This function makes an N_If_Statement node whose fields are filled
|
||||
-- in with the indicated values (see Sinfo), and whose Sloc field is
|
||||
-- is set to Sloc (Node). The effect is identical to calling function
|
||||
-- Nmake.Make_If_Statement except that there is a check for restriction
|
||||
-- No_Implicit_Conditionals, and if this restriction is being violated,
|
||||
-- an error message is posted on Node.
|
||||
|
||||
function Make_Implicit_Label_Declaration
|
||||
(Loc : Source_Ptr;
|
||||
Defining_Identifier : Node_Id;
|
||||
Label_Construct : Node_Id)
|
||||
return Node_Id;
|
||||
-- Used to contruct an implicit label declaration node, including setting
|
||||
-- the proper Label_Construct field (since Label_Construct is a semantic
|
||||
-- field, the normal call to Make_Implicit_Label_Declaration does not
|
||||
-- set this field).
|
||||
|
||||
function Make_Implicit_Loop_Statement
|
||||
(Node : Node_Id;
|
||||
Statements : List_Id;
|
||||
Identifier : Node_Id := Empty;
|
||||
Iteration_Scheme : Node_Id := Empty;
|
||||
Has_Created_Identifier : Boolean := False;
|
||||
End_Label : Node_Id := Empty)
|
||||
return Node_Id;
|
||||
-- This function makes an N_Loop_Statement node whose fields are filled
|
||||
-- in with the indicated values (see Sinfo), and whose Sloc field is
|
||||
-- is set to Sloc (Node). The effect is identical to calling function
|
||||
-- Nmake.Make_Loop_Statement except that there is a check for restrictions
|
||||
-- No_Implicit_Loops and No_Implicit_Conditionals (the first applying in
|
||||
-- all cases, and the second only for while loops), and if one of these
|
||||
-- restrictions is being violated, an error message is posted on Node.
|
||||
|
||||
function Make_Integer_Literal
|
||||
(Loc : Source_Ptr;
|
||||
Intval : Int)
|
||||
return Node_Id;
|
||||
pragma Inline (Make_Integer_Literal);
|
||||
-- A convenient form of Make_Integer_Literal taking Int instead of Uint
|
||||
|
||||
function Make_Unsuppress_Block
|
||||
(Loc : Source_Ptr;
|
||||
Check : Name_Id;
|
||||
Stmts : List_Id)
|
||||
return Node_Id;
|
||||
-- Build a block with a pragma Suppress on 'Check'. Stmts is the
|
||||
-- statements list that needs protection against the check
|
||||
|
||||
function New_Constraint_Error (Loc : Source_Ptr) return Node_Id;
|
||||
-- This function builds a tree corresponding to the Ada statement
|
||||
-- "raise Constraint_Error" and returns the root of this tree,
|
||||
-- the N_Raise_Statement node.
|
||||
|
||||
function New_External_Name
|
||||
(Related_Id : Name_Id;
|
||||
Suffix : Character := ' ';
|
||||
Suffix_Index : Int := 0;
|
||||
Prefix : Character := ' ')
|
||||
return Name_Id;
|
||||
function New_External_Name
|
||||
(Related_Id : Name_Id;
|
||||
Suffix : String;
|
||||
Suffix_Index : Int := 0;
|
||||
Prefix : Character := ' ')
|
||||
return Name_Id;
|
||||
-- Builds a new entry in the names table of the form:
|
||||
--
|
||||
-- [Prefix &] Related_Id [& Suffix] [& Suffix_Index]
|
||||
--
|
||||
-- Prefix is prepended only if Prefix is non-blank (in which case it
|
||||
-- must be an upper case letter other than O,Q,U,W (which are used for
|
||||
-- identifier encoding, see Namet), and T is reserved for use by implicit
|
||||
-- types. and X is reserved for use by debug type encoding (see package
|
||||
-- Exp_Dbug). Note: the reason that Prefix is last is that it is almost
|
||||
-- always omitted. The notable case of Prefix being non-null is when
|
||||
-- it is 'T' for an implicit type.
|
||||
|
||||
-- Suffix_Index'Image is appended only if the value of Suffix_Index is
|
||||
-- positive, or if Suffix_Index is negative 1, then a unique serialized
|
||||
-- suffix is added. If Suffix_Index is zero, then no index is appended.
|
||||
|
||||
-- Suffix is also a single upper case letter other than O,Q,U,W,X and is a
|
||||
-- required parameter (T is permitted). The constructed name is stored
|
||||
-- using Find_Name so that it can be located using a subsequent Find_Name
|
||||
-- operation (i.e. it is properly hashed into the names table). The upper
|
||||
-- case letter given as the Suffix argument ensures that the name does
|
||||
-- not clash with any Ada identifier name. These generated names are
|
||||
-- permitted, but not required, to be made public by setting the flag
|
||||
-- Is_Public in the associated entity.
|
||||
|
||||
function New_External_Name
|
||||
(Suffix : Character;
|
||||
Suffix_Index : Nat)
|
||||
return Name_Id;
|
||||
-- Builds a new entry in the names table of the form
|
||||
-- Suffix & Suffix_Index'Image
|
||||
-- where Suffix is a single upper case letter other than O,Q,U,W,X and is
|
||||
-- a required parameter (T is permitted). The constructed name is stored
|
||||
-- using Find_Name so that it can be located using a subsequent Find_Name
|
||||
-- operation (i.e. it is properly hashed into the names table). The upper
|
||||
-- case letter given as the Suffix argument ensures that the name does
|
||||
-- not clash with any Ada identifier name. These generated names are
|
||||
-- permitted, but not required, to be made public by setting the flag
|
||||
-- Is_Public in the associated entity.
|
||||
|
||||
function New_Internal_Name (Id_Char : Character) return Name_Id;
|
||||
-- Id_Char is an upper case letter other than O,Q,U,W (which are reserved
|
||||
-- for identifier encoding (see Namet package for details) and X which is
|
||||
-- used for debug encoding (see Exp_Dbug). The letter T is permitted, but
|
||||
-- is reserved by convention for the case of internally generated types.
|
||||
-- The result of the call is a new generated unique name of the form XyyyU
|
||||
-- where X is Id_Char, yyy is a unique serial number, and U is either a
|
||||
-- lower case s or b indicating if the current unit is a spec or a body.
|
||||
--
|
||||
-- The name is entered into the names table using Name_Enter rather than
|
||||
-- Name_Find, because there can never be a need to locate the entry using
|
||||
-- the Name_Find procedure later on. Names created by New_Internal_Name
|
||||
-- are guaranteed to be consistent from one compilation to another (i.e.
|
||||
-- if the identical unit is compiled with a semantically consistent set
|
||||
-- of sources, the numbers will be consistent. This means that it is fine
|
||||
-- to use these as public symbols.
|
||||
|
||||
function New_Suffixed_Name
|
||||
(Related_Id : Name_Id;
|
||||
Suffix : String)
|
||||
return Name_Id;
|
||||
-- This function is used to create special suffixed names used by the
|
||||
-- debugger. Suffix is a string of upper case letters, used to construct
|
||||
-- the required name. For instance, the special type used to record the
|
||||
-- fixed-point small is called typ_SMALL where typ is the name of the
|
||||
-- fixed-point type (as passed in Related_Id), and Suffix is "SMALL".
|
||||
|
||||
function New_Occurrence_Of
|
||||
(Def_Id : Entity_Id;
|
||||
Loc : Source_Ptr)
|
||||
return Node_Id;
|
||||
-- New_Occurrence_Of creates an N_Identifier node which is an
|
||||
-- occurrence of the defining identifier which is passed as its
|
||||
-- argument. The Entity and Etype of the result are set from
|
||||
-- the given defining identifier as follows: Entity is simply
|
||||
-- a copy of Def_Id. Etype is a copy of Def_Id for types, and
|
||||
-- a copy of the Etype of Def_Id for other entities.
|
||||
|
||||
function New_Reference_To
|
||||
(Def_Id : Entity_Id;
|
||||
Loc : Source_Ptr)
|
||||
return Node_Id;
|
||||
-- This is like New_Occurrence_Of, but it does not set the Etype field.
|
||||
-- It is used from the expander, where Etype fields are generally not set,
|
||||
-- since they are set when the expanded tree is reanalyzed.
|
||||
|
||||
function Checks_Off (N : Node_Id) return Node_Id;
|
||||
pragma Inline (Checks_Off);
|
||||
-- Returns an N_Unchecked_Expression node whose expression is the given
|
||||
-- argument. The results is a subexpression identical to the argument,
|
||||
-- except that it will be analyzed and resolved with checks off.
|
||||
|
||||
function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id;
|
||||
-- Returns an expression that represents the result of a checked convert
|
||||
-- of expression Exp to type T. If the base type of Exp is T, then no
|
||||
-- conversion is required, and Exp is returned unchanged. Otherwise an
|
||||
-- N_Type_Conversion node is constructed to convert the expression.
|
||||
-- If an N_Type_Conversion node is required, Relocate_Node is used on
|
||||
-- Exp. This means that it is safe to replace a node by a Convert_To
|
||||
-- of itself to some other type.
|
||||
|
||||
function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id;
|
||||
-- Like Convert_To, except that a conversion node is always generated,
|
||||
-- and the Conversion_OK flag is set on this conversion node.
|
||||
|
||||
function Unchecked_Convert_To
|
||||
(Typ : Entity_Id;
|
||||
Expr : Node_Id)
|
||||
return Node_Id;
|
||||
-- Like Convert_To, but if a conversion is actually needed, constructs
|
||||
-- an N_Unchecked_Type_Conversion node to do the required conversion.
|
||||
|
||||
end Tbuild;
|
|
@ -0,0 +1,21 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUNTIME COMPONENTS --
|
||||
-- --
|
||||
-- T E X T _ I O --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.8 $ --
|
||||
-- --
|
||||
-- This specification is adapted 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. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
pragma Ada_95;
|
||||
with Ada.Text_IO;
|
||||
|
||||
package Text_IO renames Ada.Text_IO;
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,63 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T R E E _ G E N --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.8 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-1999, 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree;
|
||||
with Elists;
|
||||
with Fname;
|
||||
with Lib;
|
||||
with Namet;
|
||||
with Nlists;
|
||||
with Opt;
|
||||
with Osint;
|
||||
with Repinfo;
|
||||
with Sinput;
|
||||
with Stand;
|
||||
with Stringt;
|
||||
with Uintp;
|
||||
with Urealp;
|
||||
|
||||
procedure Tree_Gen is
|
||||
begin
|
||||
if Opt.Tree_Output then
|
||||
Osint.Tree_Create;
|
||||
Opt.Tree_Write;
|
||||
Atree.Tree_Write;
|
||||
Elists.Tree_Write;
|
||||
Fname.Tree_Write;
|
||||
Lib.Tree_Write;
|
||||
Namet.Tree_Write;
|
||||
Nlists.Tree_Write;
|
||||
Sinput.Tree_Write;
|
||||
Stand.Tree_Write;
|
||||
Stringt.Tree_Write;
|
||||
Uintp.Tree_Write;
|
||||
Urealp.Tree_Write;
|
||||
Repinfo.Tree_Write;
|
||||
Osint.Tree_Close;
|
||||
end if;
|
||||
end Tree_Gen;
|
|
@ -0,0 +1,31 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T R E E _ G E N --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.2 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994,1995 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This procedure is used to write out the tree if the option is set
|
||||
|
||||
procedure Tree_Gen;
|
|
@ -0,0 +1,69 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T R E E _ I N --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.10 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-1999, 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree;
|
||||
with Csets;
|
||||
with Elists;
|
||||
with Fname;
|
||||
with Lib;
|
||||
with Namet;
|
||||
with Nlists;
|
||||
with Opt;
|
||||
with Repinfo;
|
||||
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;
|
||||
Sinput.Tree_Read;
|
||||
Stand.Tree_Read;
|
||||
Stringt.Tree_Read;
|
||||
Uintp.Tree_Read;
|
||||
Urealp.Tree_Read;
|
||||
Repinfo.Tree_Read;
|
||||
Csets.Initialize;
|
||||
end Tree_In;
|
|
@ -0,0 +1,46 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T R E E _ I N --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.3 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994,1995 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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 GNAT.OS_Lib; use GNAT.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.
|
|
@ -0,0 +1,661 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T R E E _ I O --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.13 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
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
|
||||
|
||||
Max_Comp : constant := Max_Count + 1;
|
||||
-- Maximum length of 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 Bufe 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;
|
||||
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
|
||||
|
||||
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;
|
|
@ -0,0 +1,107 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T R E E _ I O --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.5 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1999 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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).
|
||||
|
||||
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
||||
with System; use System;
|
||||
with Types; use Types;
|
||||
|
||||
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 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;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,79 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T R E E P R --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.14 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994,1995 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Types; use Types;
|
||||
package Treepr is
|
||||
|
||||
-- This package provides printing routines for the abstract syntax tree
|
||||
-- These routines are intended only for debugging use.
|
||||
|
||||
procedure Tree_Dump;
|
||||
-- This routine is called from the GNAT main program to dump trees as
|
||||
-- requested by debug options (including tree of Standard if requested).
|
||||
|
||||
procedure Print_Tree_Node (N : Node_Id; Label : String := "");
|
||||
-- Prints a single tree node, without printing descendants. The Label
|
||||
-- string is used to preface each line of the printed output.
|
||||
|
||||
procedure Print_Tree_List (L : List_Id);
|
||||
-- Prints a single node list, without printing the descendants of any
|
||||
-- of the nodes in the list
|
||||
|
||||
procedure Print_Tree_Elist (E : Elist_Id);
|
||||
-- Prints a single node list, without printing the descendants of any
|
||||
-- of the nodes in the list
|
||||
|
||||
procedure Print_Node_Subtree (N : Node_Id);
|
||||
-- Prints the subtree routed at a specified tree node, including all
|
||||
-- referenced descendants.
|
||||
|
||||
procedure Print_List_Subtree (L : List_Id);
|
||||
-- Prints the subtree consisting of the given node list and all its
|
||||
-- referenced descendants.
|
||||
|
||||
procedure Print_Elist_Subtree (E : Elist_Id);
|
||||
-- Prints the subtree consisting of the given element list and all its
|
||||
-- referenced descendants.
|
||||
|
||||
procedure PE (E : Elist_Id);
|
||||
-- Debugging procedure (to be called within gdb)
|
||||
-- same as Print_Tree_Elist
|
||||
|
||||
procedure PL (L : List_Id);
|
||||
-- Debugging procedure (to be called within gdb)
|
||||
-- same as Print_Tree_List
|
||||
|
||||
procedure PN (N : Node_Id);
|
||||
-- Debugging procedure (to be called within gdb)
|
||||
-- same as Print_Tree_Node with Label = ""
|
||||
|
||||
procedure PT (N : Node_Id);
|
||||
-- Debugging procedure (to be called within gdb)
|
||||
-- same as Print_Node_Subtree
|
||||
|
||||
end Treepr;
|
|
@ -0,0 +1,795 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T R E E P R S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Generated by xtreeprs revision 1.31 using --
|
||||
-- sinfo.ads revision 1.430 --
|
||||
-- treeprs.adt revision 1.17 --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1997 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
|
||||
-- This package contains the declaration of the string used by the Tree_Print
|
||||
-- package. It must be updated whenever the arrangements of the field names
|
||||
-- in package Sinfo is changed. The utility program XTREEPRS is used to
|
||||
-- do this update correctly using the template treeprs.adt as input.
|
||||
|
||||
with Sinfo; use Sinfo;
|
||||
|
||||
package Treeprs is
|
||||
|
||||
--------------------------------
|
||||
-- String Data for Node Print --
|
||||
--------------------------------
|
||||
|
||||
-- String data for print out. The Pchars array is a long string with the
|
||||
-- the entry for each node type consisting of a single blank, followed by
|
||||
-- a series of entries, one for each Op or Flag field used for the node.
|
||||
-- Each entry has a single character which identifies the field, followed
|
||||
-- by the synonym name. The starting location for a given node type is
|
||||
-- found from the corresponding entry in the Pchars_Pos_Array.
|
||||
|
||||
-- The following characters identify the field. These are characters
|
||||
-- which could never occur in a field name, so they also mark the
|
||||
-- end of the previous name.
|
||||
|
||||
subtype Fchar is Character range '#' .. '9';
|
||||
|
||||
F_Field1 : constant Fchar := '#'; -- Character'Val (16#23#)
|
||||
F_Field2 : constant Fchar := '$'; -- Character'Val (16#24#)
|
||||
F_Field3 : constant Fchar := '%'; -- Character'Val (16#25#)
|
||||
F_Field4 : constant Fchar := '&'; -- Character'Val (16#26#)
|
||||
F_Field5 : constant Fchar := '''; -- Character'Val (16#27#)
|
||||
F_Flag1 : constant Fchar := '('; -- Character'Val (16#28#)
|
||||
F_Flag2 : constant Fchar := ')'; -- Character'Val (16#29#)
|
||||
F_Flag3 : constant Fchar := '*'; -- Character'Val (16#2A#)
|
||||
F_Flag4 : constant Fchar := '+'; -- Character'Val (16#2B#)
|
||||
F_Flag5 : constant Fchar := ','; -- Character'Val (16#2C#)
|
||||
F_Flag6 : constant Fchar := '-'; -- Character'Val (16#2D#)
|
||||
F_Flag7 : constant Fchar := '.'; -- Character'Val (16#2E#)
|
||||
F_Flag8 : constant Fchar := '/'; -- Character'Val (16#2F#)
|
||||
F_Flag9 : constant Fchar := '0'; -- Character'Val (16#30#)
|
||||
F_Flag10 : constant Fchar := '1'; -- Character'Val (16#31#)
|
||||
F_Flag11 : constant Fchar := '2'; -- Character'Val (16#32#)
|
||||
F_Flag12 : constant Fchar := '3'; -- Character'Val (16#33#)
|
||||
F_Flag13 : constant Fchar := '4'; -- Character'Val (16#34#)
|
||||
F_Flag14 : constant Fchar := '5'; -- Character'Val (16#35#)
|
||||
F_Flag15 : constant Fchar := '6'; -- Character'Val (16#36#)
|
||||
F_Flag16 : constant Fchar := '7'; -- Character'Val (16#37#)
|
||||
F_Flag17 : constant Fchar := '8'; -- Character'Val (16#38#)
|
||||
F_Flag18 : constant Fchar := '9'; -- Character'Val (16#39#)
|
||||
|
||||
-- Note this table does not include entity field and flags whose access
|
||||
-- functions are in Einfo (these are handled by the Print_Entity_Info
|
||||
-- procedure in Treepr, which uses the routines in Einfo to get the
|
||||
-- proper symbolic information). In addition, the following fields are
|
||||
-- handled by Treepr, and do not appear in the Pchars array:
|
||||
|
||||
-- Analyzed
|
||||
-- Cannot_Be_Constant
|
||||
-- Chars
|
||||
-- Comes_From_Source
|
||||
-- Error_Posted
|
||||
-- Etype
|
||||
-- Is_Controlling_Actual
|
||||
-- Is_Overloaded
|
||||
-- Is_Static_Expression
|
||||
-- Left_Opnd
|
||||
-- Must_Check_Expr
|
||||
-- Must_Not_Freeze
|
||||
-- No_Overflow_Expr
|
||||
-- Paren_Count
|
||||
-- Raises_Constraint_Error
|
||||
-- Right_Opnd
|
||||
|
||||
Pchars : constant String :=
|
||||
-- Unused_At_Start
|
||||
"" &
|
||||
-- At_Clause
|
||||
"#Identifier%Expression" &
|
||||
-- Component_Clause
|
||||
"#Component_Name$Position%First_Bit&Last_Bit" &
|
||||
-- Enumeration_Representation_Clause
|
||||
"#Identifier%Array_Aggregate&Next_Rep_Item" &
|
||||
-- Mod_Clause
|
||||
"%Expression&Pragmas_Before" &
|
||||
-- Record_Representation_Clause
|
||||
"#Identifier$Mod_Clause%Component_Clauses&Next_Rep_Item" &
|
||||
-- Attribute_Definition_Clause
|
||||
"$Name%Expression&Next_Rep_Item+From_At_Mod" &
|
||||
-- Empty
|
||||
"" &
|
||||
-- Error
|
||||
"" &
|
||||
-- Pragma
|
||||
"$Pragma_Argument_Associations%Debug_Statement&Next_Rep_Item" &
|
||||
-- Pragma_Argument_Association
|
||||
"%Expression" &
|
||||
-- Defining_Character_Literal
|
||||
"$Next_Entity%Scope" &
|
||||
-- Defining_Identifier
|
||||
"$Next_Entity%Scope" &
|
||||
-- Defining_Operator_Symbol
|
||||
"$Next_Entity%Scope" &
|
||||
-- Expanded_Name
|
||||
"%Prefix$Selector_Name&Entity4Redundant_Use2Has_Private_View" &
|
||||
-- Identifier
|
||||
"&Entity$Original_Discriminant4Redundant_Use2Has_Private_View" &
|
||||
-- Operator_Symbol
|
||||
"%Strval&Entity2Has_Private_View" &
|
||||
-- Character_Literal
|
||||
"$Char_Literal_Value&Entity2Has_Private_View" &
|
||||
-- Op_Add
|
||||
"" &
|
||||
-- Op_Concat
|
||||
"4Is_Component_Left_Opnd5Is_Component_Right_Opnd" &
|
||||
-- Op_Divide
|
||||
"5Treat_Fixed_As_Integer4Do_Division_Check9Rounded_Result" &
|
||||
-- Op_Expon
|
||||
"4Is_Power_Of_2_For_Shift" &
|
||||
-- Op_Mod
|
||||
"5Treat_Fixed_As_Integer4Do_Division_Check" &
|
||||
-- Op_Multiply
|
||||
"5Treat_Fixed_As_Integer9Rounded_Result" &
|
||||
-- Op_Rem
|
||||
"5Treat_Fixed_As_Integer4Do_Division_Check" &
|
||||
-- Op_Subtract
|
||||
"" &
|
||||
-- Op_And
|
||||
"+Do_Length_Check" &
|
||||
-- Op_Eq
|
||||
"" &
|
||||
-- Op_Ge
|
||||
"" &
|
||||
-- Op_Gt
|
||||
"" &
|
||||
-- Op_Le
|
||||
"" &
|
||||
-- Op_Lt
|
||||
"" &
|
||||
-- Op_Ne
|
||||
"" &
|
||||
-- Op_Or
|
||||
"+Do_Length_Check" &
|
||||
-- Op_Xor
|
||||
"+Do_Length_Check" &
|
||||
-- Op_Rotate_Left
|
||||
"+Shift_Count_OK" &
|
||||
-- Op_Rotate_Right
|
||||
"+Shift_Count_OK" &
|
||||
-- Op_Shift_Left
|
||||
"+Shift_Count_OK" &
|
||||
-- Op_Shift_Right
|
||||
"+Shift_Count_OK" &
|
||||
-- Op_Shift_Right_Arithmetic
|
||||
"+Shift_Count_OK" &
|
||||
-- Op_Abs
|
||||
"" &
|
||||
-- Op_Minus
|
||||
"" &
|
||||
-- Op_Not
|
||||
"" &
|
||||
-- Op_Plus
|
||||
"" &
|
||||
-- Attribute_Reference
|
||||
"%Prefix$Attribute_Name#Expressions&Entity2Do_Access_Check8Do_Overflow" &
|
||||
"_Check4Redundant_Use+OK_For_Stream" &
|
||||
-- And_Then
|
||||
"#Actions" &
|
||||
-- Conditional_Expression
|
||||
"#Expressions$Then_Actions%Else_Actions" &
|
||||
-- Explicit_Dereference
|
||||
"%Prefix2Do_Access_Check" &
|
||||
-- Function_Call
|
||||
"$Name%Parameter_Associations&First_Named_Actual#Controlling_Argument4" &
|
||||
"Do_Tag_Check8Parameter_List_Truncated9ABE_Is_Certain" &
|
||||
-- In
|
||||
"" &
|
||||
-- Indexed_Component
|
||||
"%Prefix#Expressions2Do_Access_Check" &
|
||||
-- Integer_Literal
|
||||
"%Intval4Print_In_Hex" &
|
||||
-- Not_In
|
||||
"" &
|
||||
-- Null
|
||||
"" &
|
||||
-- Or_Else
|
||||
"#Actions" &
|
||||
-- Procedure_Call_Statement
|
||||
"$Name%Parameter_Associations&First_Named_Actual#Controlling_Argument4" &
|
||||
"Do_Tag_Check8Parameter_List_Truncated9ABE_Is_Certain" &
|
||||
-- Qualified_Expression
|
||||
"&Subtype_Mark%Expression" &
|
||||
-- Raise_Constraint_Error
|
||||
"#Condition" &
|
||||
-- Raise_Program_Error
|
||||
"#Condition" &
|
||||
-- Raise_Storage_Error
|
||||
"#Condition" &
|
||||
-- Aggregate
|
||||
"#Expressions$Component_Associations8Null_Record_Present%Aggregate_Bou" &
|
||||
"nds+Static_Processing_OK9Compile_Time_Known_Aggregate2Expansion_De" &
|
||||
"layed" &
|
||||
-- Allocator
|
||||
"%Expression#Storage_Pool&Procedure_To_Call4No_Initialization8Do_Stora" &
|
||||
"ge_Check" &
|
||||
-- Extension_Aggregate
|
||||
"%Ancestor_Part#Expressions$Component_Associations8Null_Record_Present" &
|
||||
"2Expansion_Delayed" &
|
||||
-- Range
|
||||
"#Low_Bound$High_Bound2Includes_Infinities" &
|
||||
-- Real_Literal
|
||||
"%Realval&Corresponding_Integer_Value2Is_Machine_Number" &
|
||||
-- Reference
|
||||
"%Prefix" &
|
||||
-- Selected_Component
|
||||
"%Prefix$Selector_Name2Do_Access_Check4Do_Discriminant_Check" &
|
||||
-- Slice
|
||||
"%Prefix&Discrete_Range2Do_Access_Check" &
|
||||
-- String_Literal
|
||||
"%Strval2Has_Wide_Character" &
|
||||
-- Subprogram_Info
|
||||
"#Identifier" &
|
||||
-- Type_Conversion
|
||||
"&Subtype_Mark%Expression8Do_Overflow_Check4Do_Tag_Check+Do_Length_Che" &
|
||||
"ck2Float_Truncate9Rounded_Result5Conversion_OK" &
|
||||
-- Unchecked_Expression
|
||||
"%Expression" &
|
||||
-- Unchecked_Type_Conversion
|
||||
"&Subtype_Mark%Expression2Kill_Range_Check" &
|
||||
-- Subtype_Indication
|
||||
"&Subtype_Mark%Constraint/Must_Not_Freeze" &
|
||||
-- Component_Declaration
|
||||
"#Defining_Identifier+Aliased_Present'Subtype_Indication%Expression,Mo" &
|
||||
"re_Ids-Prev_Ids" &
|
||||
-- Entry_Declaration
|
||||
"#Defining_Identifier&Discrete_Subtype_Definition%Parameter_Specificat" &
|
||||
"ions" &
|
||||
-- Formal_Object_Declaration
|
||||
"#Defining_Identifier6In_Present8Out_Present&Subtype_Mark%Expression,M" &
|
||||
"ore_Ids-Prev_Ids" &
|
||||
-- Formal_Type_Declaration
|
||||
"#Defining_Identifier%Formal_Type_Definition&Discriminant_Specificatio" &
|
||||
"ns4Unknown_Discriminants_Present" &
|
||||
-- Full_Type_Declaration
|
||||
"#Defining_Identifier&Discriminant_Specifications%Type_Definition2Disc" &
|
||||
"r_Check_Funcs_Built" &
|
||||
-- Incomplete_Type_Declaration
|
||||
"#Defining_Identifier&Discriminant_Specifications4Unknown_Discriminant" &
|
||||
"s_Present" &
|
||||
-- Loop_Parameter_Specification
|
||||
"#Defining_Identifier6Reverse_Present&Discrete_Subtype_Definition" &
|
||||
-- Object_Declaration
|
||||
"#Defining_Identifier+Aliased_Present8Constant_Present&Object_Definiti" &
|
||||
"on%Expression$Handler_List_Entry'Corresponding_Generic_Association" &
|
||||
",More_Ids-Prev_Ids4No_Initialization6Assignment_OK2Exception_Junk5" &
|
||||
"Delay_Finalize_Attach7Is_Subprogram_Descriptor" &
|
||||
-- Protected_Type_Declaration
|
||||
"#Defining_Identifier&Discriminant_Specifications%Protected_Definition" &
|
||||
"'Corresponding_Body" &
|
||||
-- Private_Extension_Declaration
|
||||
"#Defining_Identifier&Discriminant_Specifications4Unknown_Discriminant" &
|
||||
"s_Present+Abstract_Present'Subtype_Indication" &
|
||||
-- Private_Type_Declaration
|
||||
"#Defining_Identifier&Discriminant_Specifications4Unknown_Discriminant" &
|
||||
"s_Present+Abstract_Present6Tagged_Present8Limited_Present" &
|
||||
-- Subtype_Declaration
|
||||
"#Defining_Identifier'Subtype_Indication&Generic_Parent_Type2Exception" &
|
||||
"_Junk" &
|
||||
-- Function_Specification
|
||||
"#Defining_Unit_Name$Elaboration_Boolean%Parameter_Specifications&Subt" &
|
||||
"ype_Mark'Generic_Parent" &
|
||||
-- Procedure_Specification
|
||||
"#Defining_Unit_Name$Elaboration_Boolean%Parameter_Specifications'Gene" &
|
||||
"ric_Parent" &
|
||||
-- Entry_Index_Specification
|
||||
"#Defining_Identifier&Discrete_Subtype_Definition" &
|
||||
-- Freeze_Entity
|
||||
"&Entity$Access_Types_To_Process%TSS_Elist#Actions'First_Subtype_Link" &
|
||||
-- Access_Function_Definition
|
||||
"6Protected_Present%Parameter_Specifications&Subtype_Mark" &
|
||||
-- Access_Procedure_Definition
|
||||
"6Protected_Present%Parameter_Specifications" &
|
||||
-- Task_Type_Declaration
|
||||
"#Defining_Identifier$Task_Body_Procedure&Discriminant_Specifications%" &
|
||||
"Task_Definition'Corresponding_Body" &
|
||||
-- Package_Body_Stub
|
||||
"#Defining_Identifier&Library_Unit'Corresponding_Body" &
|
||||
-- Protected_Body_Stub
|
||||
"#Defining_Identifier&Library_Unit'Corresponding_Body" &
|
||||
-- Subprogram_Body_Stub
|
||||
"#Specification&Library_Unit'Corresponding_Body" &
|
||||
-- Task_Body_Stub
|
||||
"#Defining_Identifier&Library_Unit'Corresponding_Body" &
|
||||
-- Function_Instantiation
|
||||
"#Defining_Unit_Name$Name%Generic_Associations&Parent_Spec'Instance_Sp" &
|
||||
"ec9ABE_Is_Certain" &
|
||||
-- Package_Instantiation
|
||||
"#Defining_Unit_Name$Name%Generic_Associations&Parent_Spec'Instance_Sp" &
|
||||
"ec9ABE_Is_Certain" &
|
||||
-- Procedure_Instantiation
|
||||
"#Defining_Unit_Name$Name&Parent_Spec%Generic_Associations'Instance_Sp" &
|
||||
"ec9ABE_Is_Certain" &
|
||||
-- Package_Body
|
||||
"#Defining_Unit_Name$Declarations&Handled_Statement_Sequence'Correspon" &
|
||||
"ding_Spec4Was_Originally_Stub" &
|
||||
-- Subprogram_Body
|
||||
"#Specification$Declarations&Handled_Statement_Sequence%Activation_Cha" &
|
||||
"in_Entity'Corresponding_Spec+Acts_As_Spec6Bad_Is_Detected8Do_Stora" &
|
||||
"ge_Check-Has_Priority_Pragma.Is_Protected_Subprogram_Body,Is_Task_" &
|
||||
"Master4Was_Originally_Stub" &
|
||||
-- Protected_Body
|
||||
"#Defining_Identifier$Declarations&End_Label'Corresponding_Spec4Was_Or" &
|
||||
"iginally_Stub" &
|
||||
-- Task_Body
|
||||
"#Defining_Identifier$Declarations&Handled_Statement_Sequence,Is_Task_" &
|
||||
"Master%Activation_Chain_Entity'Corresponding_Spec4Was_Originally_S" &
|
||||
"tub" &
|
||||
-- Implicit_Label_Declaration
|
||||
"#Defining_Identifier$Label_Construct" &
|
||||
-- Package_Declaration
|
||||
"#Specification'Corresponding_Body&Parent_Spec%Activation_Chain_Entity" &
|
||||
-- Single_Task_Declaration
|
||||
"#Defining_Identifier%Task_Definition" &
|
||||
-- Subprogram_Declaration
|
||||
"#Specification%Body_To_Inline'Corresponding_Body&Parent_Spec" &
|
||||
-- Use_Package_Clause
|
||||
"$Names%Next_Use_Clause&Hidden_By_Use_Clause" &
|
||||
-- Generic_Package_Declaration
|
||||
"#Specification'Corresponding_Body$Generic_Formal_Declarations&Parent_" &
|
||||
"Spec%Activation_Chain_Entity" &
|
||||
-- Generic_Subprogram_Declaration
|
||||
"#Specification'Corresponding_Body$Generic_Formal_Declarations&Parent_" &
|
||||
"Spec" &
|
||||
-- Constrained_Array_Definition
|
||||
"$Discrete_Subtype_Definitions+Aliased_Present'Subtype_Indication" &
|
||||
-- Unconstrained_Array_Definition
|
||||
"$Subtype_Marks+Aliased_Present'Subtype_Indication" &
|
||||
-- Exception_Renaming_Declaration
|
||||
"#Defining_Identifier$Name" &
|
||||
-- Object_Renaming_Declaration
|
||||
"#Defining_Identifier&Subtype_Mark$Name'Corresponding_Generic_Associat" &
|
||||
"ion" &
|
||||
-- Package_Renaming_Declaration
|
||||
"#Defining_Unit_Name$Name&Parent_Spec" &
|
||||
-- Subprogram_Renaming_Declaration
|
||||
"#Specification$Name&Parent_Spec'Corresponding_Spec" &
|
||||
-- Generic_Function_Renaming_Declaration
|
||||
"#Defining_Unit_Name$Name&Parent_Spec" &
|
||||
-- Generic_Package_Renaming_Declaration
|
||||
"#Defining_Unit_Name$Name&Parent_Spec" &
|
||||
-- Generic_Procedure_Renaming_Declaration
|
||||
"#Defining_Unit_Name$Name&Parent_Spec" &
|
||||
-- Abort_Statement
|
||||
"$Names" &
|
||||
-- Accept_Statement
|
||||
"#Entry_Direct_Name'Entry_Index%Parameter_Specifications&Handled_State" &
|
||||
"ment_Sequence$Declarations" &
|
||||
-- Assignment_Statement
|
||||
"$Name%Expression4Do_Tag_Check+Do_Length_Check,Forwards_OK-Backwards_O" &
|
||||
"K.No_Ctrl_Actions" &
|
||||
-- Asynchronous_Select
|
||||
"#Triggering_Alternative$Abortable_Part" &
|
||||
-- Block_Statement
|
||||
"#Identifier$Declarations&Handled_Statement_Sequence,Is_Task_Master%Ac" &
|
||||
"tivation_Chain_Entity6Has_Created_Identifier-Is_Task_Allocation_Bl" &
|
||||
"ock.Is_Asynchronous_Call_Block" &
|
||||
-- Case_Statement
|
||||
"%Expression&Alternatives'End_Span" &
|
||||
-- Code_Statement
|
||||
"%Expression" &
|
||||
-- Conditional_Entry_Call
|
||||
"#Entry_Call_Alternative&Else_Statements" &
|
||||
-- Delay_Relative_Statement
|
||||
"%Expression" &
|
||||
-- Delay_Until_Statement
|
||||
"%Expression" &
|
||||
-- Entry_Call_Statement
|
||||
"$Name%Parameter_Associations&First_Named_Actual" &
|
||||
-- Free_Statement
|
||||
"%Expression#Storage_Pool&Procedure_To_Call" &
|
||||
-- Goto_Statement
|
||||
"$Name2Exception_Junk" &
|
||||
-- Loop_Statement
|
||||
"#Identifier$Iteration_Scheme%Statements&End_Label6Has_Created_Identif" &
|
||||
"ier" &
|
||||
-- Null_Statement
|
||||
"" &
|
||||
-- Raise_Statement
|
||||
"$Name" &
|
||||
-- Requeue_Statement
|
||||
"$Name6Abort_Present" &
|
||||
-- Return_Statement
|
||||
"%Expression#Storage_Pool&Procedure_To_Call4Do_Tag_Check$Return_Type,B" &
|
||||
"y_Ref" &
|
||||
-- Selective_Accept
|
||||
"#Select_Alternatives&Else_Statements" &
|
||||
-- Timed_Entry_Call
|
||||
"#Entry_Call_Alternative&Delay_Alternative" &
|
||||
-- Exit_Statement
|
||||
"$Name#Condition" &
|
||||
-- If_Statement
|
||||
"#Condition$Then_Statements%Elsif_Parts&Else_Statements'End_Span" &
|
||||
-- Accept_Alternative
|
||||
"$Accept_Statement#Condition%Statements&Pragmas_Before'Accept_Handler_" &
|
||||
"Records" &
|
||||
-- Delay_Alternative
|
||||
"$Delay_Statement#Condition%Statements&Pragmas_Before" &
|
||||
-- Elsif_Part
|
||||
"#Condition$Then_Statements%Condition_Actions" &
|
||||
-- Entry_Body_Formal_Part
|
||||
"&Entry_Index_Specification%Parameter_Specifications#Condition" &
|
||||
-- Iteration_Scheme
|
||||
"#Condition%Condition_Actions&Loop_Parameter_Specification" &
|
||||
-- Terminate_Alternative
|
||||
"#Condition&Pragmas_Before'Pragmas_After" &
|
||||
-- Abortable_Part
|
||||
"%Statements" &
|
||||
-- Abstract_Subprogram_Declaration
|
||||
"#Specification" &
|
||||
-- Access_Definition
|
||||
"&Subtype_Mark" &
|
||||
-- Access_To_Object_Definition
|
||||
"6All_Present'Subtype_Indication8Constant_Present" &
|
||||
-- Case_Statement_Alternative
|
||||
"&Discrete_Choices%Statements" &
|
||||
-- Compilation_Unit
|
||||
"&Library_Unit#Context_Items6Private_Present$Unit'Aux_Decls_Node8Has_N" &
|
||||
"o_Elaboration_Code4Body_Required+Acts_As_Spec%First_Inlined_Subpro" &
|
||||
"gram" &
|
||||
-- Compilation_Unit_Aux
|
||||
"$Declarations#Actions'Pragmas_After" &
|
||||
-- Component_Association
|
||||
"#Choices$Loop_Actions%Expression" &
|
||||
-- Component_List
|
||||
"%Component_Items&Variant_Part4Null_Present" &
|
||||
-- Derived_Type_Definition
|
||||
"+Abstract_Present'Subtype_Indication%Record_Extension_Part" &
|
||||
-- Decimal_Fixed_Point_Definition
|
||||
"%Delta_Expression$Digits_Expression&Real_Range_Specification" &
|
||||
-- Defining_Program_Unit_Name
|
||||
"$Name#Defining_Identifier" &
|
||||
-- Delta_Constraint
|
||||
"%Delta_Expression&Range_Constraint" &
|
||||
-- Designator
|
||||
"$Name#Identifier" &
|
||||
-- Digits_Constraint
|
||||
"$Digits_Expression&Range_Constraint" &
|
||||
-- Discriminant_Association
|
||||
"#Selector_Names%Expression" &
|
||||
-- Discriminant_Specification
|
||||
"#Defining_Identifier'Discriminant_Type%Expression,More_Ids-Prev_Ids" &
|
||||
-- Enumeration_Type_Definition
|
||||
"#Literals" &
|
||||
-- Entry_Body
|
||||
"#Defining_Identifier'Entry_Body_Formal_Part$Declarations&Handled_Stat" &
|
||||
"ement_Sequence%Activation_Chain_Entity" &
|
||||
-- Entry_Call_Alternative
|
||||
"#Entry_Call_Statement%Statements&Pragmas_Before" &
|
||||
-- Exception_Declaration
|
||||
"#Defining_Identifier%Expression,More_Ids-Prev_Ids" &
|
||||
-- Exception_Handler
|
||||
"$Choice_Parameter&Exception_Choices%Statements,Zero_Cost_Handling" &
|
||||
-- Floating_Point_Definition
|
||||
"$Digits_Expression&Real_Range_Specification" &
|
||||
-- Formal_Decimal_Fixed_Point_Definition
|
||||
"" &
|
||||
-- Formal_Derived_Type_Definition
|
||||
"&Subtype_Mark6Private_Present+Abstract_Present" &
|
||||
-- Formal_Discrete_Type_Definition
|
||||
"" &
|
||||
-- Formal_Floating_Point_Definition
|
||||
"" &
|
||||
-- Formal_Modular_Type_Definition
|
||||
"" &
|
||||
-- Formal_Ordinary_Fixed_Point_Definition
|
||||
"" &
|
||||
-- Formal_Package_Declaration
|
||||
"#Defining_Identifier$Name%Generic_Associations6Box_Present'Instance_S" &
|
||||
"pec9ABE_Is_Certain" &
|
||||
-- Formal_Private_Type_Definition
|
||||
"+Abstract_Present6Tagged_Present8Limited_Present" &
|
||||
-- Formal_Signed_Integer_Type_Definition
|
||||
"" &
|
||||
-- Formal_Subprogram_Declaration
|
||||
"#Specification$Default_Name6Box_Present" &
|
||||
-- Generic_Association
|
||||
"$Selector_Name#Explicit_Generic_Actual_Parameter" &
|
||||
-- Handled_Sequence_Of_Statements
|
||||
"%Statements&End_Label'Exception_Handlers#At_End_Proc$First_Real_State" &
|
||||
"ment,Zero_Cost_Handling" &
|
||||
-- Index_Or_Discriminant_Constraint
|
||||
"#Constraints" &
|
||||
-- Itype_Reference
|
||||
"#Itype" &
|
||||
-- Label
|
||||
"#Identifier2Exception_Junk" &
|
||||
-- Modular_Type_Definition
|
||||
"%Expression" &
|
||||
-- Number_Declaration
|
||||
"#Defining_Identifier%Expression,More_Ids-Prev_Ids" &
|
||||
-- Ordinary_Fixed_Point_Definition
|
||||
"%Delta_Expression&Real_Range_Specification" &
|
||||
-- Others_Choice
|
||||
"#Others_Discrete_Choices2All_Others" &
|
||||
-- Package_Specification
|
||||
"#Defining_Unit_Name$Visible_Declarations%Private_Declarations&End_Lab" &
|
||||
"el'Generic_Parent" &
|
||||
-- Parameter_Association
|
||||
"$Selector_Name%Explicit_Actual_Parameter&Next_Named_Actual" &
|
||||
-- Parameter_Specification
|
||||
"#Defining_Identifier6In_Present8Out_Present$Parameter_Type%Expression" &
|
||||
"4Do_Accessibility_Check,More_Ids-Prev_Ids'Default_Expression" &
|
||||
-- Protected_Definition
|
||||
"$Visible_Declarations%Private_Declarations&End_Label-Has_Priority_Pra" &
|
||||
"gma" &
|
||||
-- Range_Constraint
|
||||
"&Range_Expression" &
|
||||
-- Real_Range_Specification
|
||||
"#Low_Bound$High_Bound" &
|
||||
-- Record_Definition
|
||||
"&End_Label+Abstract_Present6Tagged_Present8Limited_Present#Component_" &
|
||||
"List4Null_Present" &
|
||||
-- Signed_Integer_Type_Definition
|
||||
"#Low_Bound$High_Bound" &
|
||||
-- Single_Protected_Declaration
|
||||
"#Defining_Identifier%Protected_Definition" &
|
||||
-- Subunit
|
||||
"$Name#Proper_Body%Corresponding_Stub" &
|
||||
-- Task_Definition
|
||||
"$Visible_Declarations%Private_Declarations&End_Label-Has_Priority_Pra" &
|
||||
"gma,Has_Storage_Size_Pragma.Has_Task_Info_Pragma/Has_Task_Name_Pra" &
|
||||
"gma" &
|
||||
-- Triggering_Alternative
|
||||
"#Triggering_Statement%Statements&Pragmas_Before" &
|
||||
-- Use_Type_Clause
|
||||
"$Subtype_Marks%Next_Use_Clause&Hidden_By_Use_Clause" &
|
||||
-- Validate_Unchecked_Conversion
|
||||
"#Source_Type$Target_Type" &
|
||||
-- Variant
|
||||
"&Discrete_Choices#Component_List$Enclosing_Variant%Present_Expr'Dchec" &
|
||||
"k_Function" &
|
||||
-- Variant_Part
|
||||
"$Name#Variants" &
|
||||
-- With_Clause
|
||||
"$Name&Library_Unit'Corresponding_Spec,First_Name-Last_Name4Context_In" &
|
||||
"stalled+Elaborate_Present6Elaborate_All_Present8Implicit_With.Unre" &
|
||||
"ferenced_In_Spec/No_Entities_Ref_In_Spec" &
|
||||
-- With_Type_Clause
|
||||
"$Name6Tagged_Present" &
|
||||
-- Unused_At_End
|
||||
"";
|
||||
|
||||
type Pchar_Pos_Array is array (Node_Kind) of Positive;
|
||||
Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(
|
||||
N_Unused_At_Start => 1,
|
||||
N_At_Clause => 1,
|
||||
N_Component_Clause => 23,
|
||||
N_Enumeration_Representation_Clause => 66,
|
||||
N_Mod_Clause => 107,
|
||||
N_Record_Representation_Clause => 133,
|
||||
N_Attribute_Definition_Clause => 187,
|
||||
N_Empty => 229,
|
||||
N_Error => 229,
|
||||
N_Pragma => 229,
|
||||
N_Pragma_Argument_Association => 288,
|
||||
N_Defining_Character_Literal => 299,
|
||||
N_Defining_Identifier => 317,
|
||||
N_Defining_Operator_Symbol => 335,
|
||||
N_Expanded_Name => 353,
|
||||
N_Identifier => 412,
|
||||
N_Operator_Symbol => 472,
|
||||
N_Character_Literal => 503,
|
||||
N_Op_Add => 546,
|
||||
N_Op_Concat => 546,
|
||||
N_Op_Divide => 593,
|
||||
N_Op_Expon => 649,
|
||||
N_Op_Mod => 673,
|
||||
N_Op_Multiply => 714,
|
||||
N_Op_Rem => 752,
|
||||
N_Op_Subtract => 793,
|
||||
N_Op_And => 793,
|
||||
N_Op_Eq => 809,
|
||||
N_Op_Ge => 809,
|
||||
N_Op_Gt => 809,
|
||||
N_Op_Le => 809,
|
||||
N_Op_Lt => 809,
|
||||
N_Op_Ne => 809,
|
||||
N_Op_Or => 809,
|
||||
N_Op_Xor => 825,
|
||||
N_Op_Rotate_Left => 841,
|
||||
N_Op_Rotate_Right => 856,
|
||||
N_Op_Shift_Left => 871,
|
||||
N_Op_Shift_Right => 886,
|
||||
N_Op_Shift_Right_Arithmetic => 901,
|
||||
N_Op_Abs => 916,
|
||||
N_Op_Minus => 916,
|
||||
N_Op_Not => 916,
|
||||
N_Op_Plus => 916,
|
||||
N_Attribute_Reference => 916,
|
||||
N_And_Then => 1019,
|
||||
N_Conditional_Expression => 1027,
|
||||
N_Explicit_Dereference => 1065,
|
||||
N_Function_Call => 1088,
|
||||
N_In => 1209,
|
||||
N_Indexed_Component => 1209,
|
||||
N_Integer_Literal => 1244,
|
||||
N_Not_In => 1264,
|
||||
N_Null => 1264,
|
||||
N_Or_Else => 1264,
|
||||
N_Procedure_Call_Statement => 1272,
|
||||
N_Qualified_Expression => 1393,
|
||||
N_Raise_Constraint_Error => 1417,
|
||||
N_Raise_Program_Error => 1427,
|
||||
N_Raise_Storage_Error => 1437,
|
||||
N_Aggregate => 1447,
|
||||
N_Allocator => 1587,
|
||||
N_Extension_Aggregate => 1664,
|
||||
N_Range => 1751,
|
||||
N_Real_Literal => 1792,
|
||||
N_Reference => 1846,
|
||||
N_Selected_Component => 1853,
|
||||
N_Slice => 1912,
|
||||
N_String_Literal => 1950,
|
||||
N_Subprogram_Info => 1976,
|
||||
N_Type_Conversion => 1987,
|
||||
N_Unchecked_Expression => 2102,
|
||||
N_Unchecked_Type_Conversion => 2113,
|
||||
N_Subtype_Indication => 2154,
|
||||
N_Component_Declaration => 2194,
|
||||
N_Entry_Declaration => 2278,
|
||||
N_Formal_Object_Declaration => 2351,
|
||||
N_Formal_Type_Declaration => 2436,
|
||||
N_Full_Type_Declaration => 2537,
|
||||
N_Incomplete_Type_Declaration => 2625,
|
||||
N_Loop_Parameter_Specification => 2703,
|
||||
N_Object_Declaration => 2767,
|
||||
N_Protected_Type_Declaration => 3014,
|
||||
N_Private_Extension_Declaration => 3102,
|
||||
N_Private_Type_Declaration => 3216,
|
||||
N_Subtype_Declaration => 3342,
|
||||
N_Function_Specification => 3416,
|
||||
N_Procedure_Specification => 3508,
|
||||
N_Entry_Index_Specification => 3587,
|
||||
N_Freeze_Entity => 3635,
|
||||
N_Access_Function_Definition => 3703,
|
||||
N_Access_Procedure_Definition => 3759,
|
||||
N_Task_Type_Declaration => 3802,
|
||||
N_Package_Body_Stub => 3905,
|
||||
N_Protected_Body_Stub => 3957,
|
||||
N_Subprogram_Body_Stub => 4009,
|
||||
N_Task_Body_Stub => 4055,
|
||||
N_Function_Instantiation => 4107,
|
||||
N_Package_Instantiation => 4193,
|
||||
N_Procedure_Instantiation => 4279,
|
||||
N_Package_Body => 4365,
|
||||
N_Subprogram_Body => 4463,
|
||||
N_Protected_Body => 4690,
|
||||
N_Task_Body => 4772,
|
||||
N_Implicit_Label_Declaration => 4910,
|
||||
N_Package_Declaration => 4946,
|
||||
N_Single_Task_Declaration => 5015,
|
||||
N_Subprogram_Declaration => 5051,
|
||||
N_Use_Package_Clause => 5111,
|
||||
N_Generic_Package_Declaration => 5154,
|
||||
N_Generic_Subprogram_Declaration => 5251,
|
||||
N_Constrained_Array_Definition => 5324,
|
||||
N_Unconstrained_Array_Definition => 5388,
|
||||
N_Exception_Renaming_Declaration => 5437,
|
||||
N_Object_Renaming_Declaration => 5462,
|
||||
N_Package_Renaming_Declaration => 5534,
|
||||
N_Subprogram_Renaming_Declaration => 5570,
|
||||
N_Generic_Function_Renaming_Declaration => 5620,
|
||||
N_Generic_Package_Renaming_Declaration => 5656,
|
||||
N_Generic_Procedure_Renaming_Declaration => 5692,
|
||||
N_Abort_Statement => 5728,
|
||||
N_Accept_Statement => 5734,
|
||||
N_Assignment_Statement => 5829,
|
||||
N_Asynchronous_Select => 5915,
|
||||
N_Block_Statement => 5953,
|
||||
N_Case_Statement => 6118,
|
||||
N_Code_Statement => 6151,
|
||||
N_Conditional_Entry_Call => 6162,
|
||||
N_Delay_Relative_Statement => 6201,
|
||||
N_Delay_Until_Statement => 6212,
|
||||
N_Entry_Call_Statement => 6223,
|
||||
N_Free_Statement => 6270,
|
||||
N_Goto_Statement => 6312,
|
||||
N_Loop_Statement => 6332,
|
||||
N_Null_Statement => 6404,
|
||||
N_Raise_Statement => 6404,
|
||||
N_Requeue_Statement => 6409,
|
||||
N_Return_Statement => 6428,
|
||||
N_Selective_Accept => 6502,
|
||||
N_Timed_Entry_Call => 6538,
|
||||
N_Exit_Statement => 6579,
|
||||
N_If_Statement => 6594,
|
||||
N_Accept_Alternative => 6657,
|
||||
N_Delay_Alternative => 6733,
|
||||
N_Elsif_Part => 6785,
|
||||
N_Entry_Body_Formal_Part => 6829,
|
||||
N_Iteration_Scheme => 6890,
|
||||
N_Terminate_Alternative => 6947,
|
||||
N_Abortable_Part => 6986,
|
||||
N_Abstract_Subprogram_Declaration => 6997,
|
||||
N_Access_Definition => 7011,
|
||||
N_Access_To_Object_Definition => 7024,
|
||||
N_Case_Statement_Alternative => 7072,
|
||||
N_Compilation_Unit => 7100,
|
||||
N_Compilation_Unit_Aux => 7239,
|
||||
N_Component_Association => 7274,
|
||||
N_Component_List => 7306,
|
||||
N_Derived_Type_Definition => 7348,
|
||||
N_Decimal_Fixed_Point_Definition => 7406,
|
||||
N_Defining_Program_Unit_Name => 7466,
|
||||
N_Delta_Constraint => 7491,
|
||||
N_Designator => 7525,
|
||||
N_Digits_Constraint => 7541,
|
||||
N_Discriminant_Association => 7576,
|
||||
N_Discriminant_Specification => 7602,
|
||||
N_Enumeration_Type_Definition => 7669,
|
||||
N_Entry_Body => 7678,
|
||||
N_Entry_Call_Alternative => 7785,
|
||||
N_Exception_Declaration => 7832,
|
||||
N_Exception_Handler => 7881,
|
||||
N_Floating_Point_Definition => 7946,
|
||||
N_Formal_Decimal_Fixed_Point_Definition => 7989,
|
||||
N_Formal_Derived_Type_Definition => 7989,
|
||||
N_Formal_Discrete_Type_Definition => 8035,
|
||||
N_Formal_Floating_Point_Definition => 8035,
|
||||
N_Formal_Modular_Type_Definition => 8035,
|
||||
N_Formal_Ordinary_Fixed_Point_Definition => 8035,
|
||||
N_Formal_Package_Declaration => 8035,
|
||||
N_Formal_Private_Type_Definition => 8122,
|
||||
N_Formal_Signed_Integer_Type_Definition => 8170,
|
||||
N_Formal_Subprogram_Declaration => 8170,
|
||||
N_Generic_Association => 8209,
|
||||
N_Handled_Sequence_Of_Statements => 8257,
|
||||
N_Index_Or_Discriminant_Constraint => 8349,
|
||||
N_Itype_Reference => 8361,
|
||||
N_Label => 8367,
|
||||
N_Modular_Type_Definition => 8393,
|
||||
N_Number_Declaration => 8404,
|
||||
N_Ordinary_Fixed_Point_Definition => 8453,
|
||||
N_Others_Choice => 8495,
|
||||
N_Package_Specification => 8530,
|
||||
N_Parameter_Association => 8616,
|
||||
N_Parameter_Specification => 8674,
|
||||
N_Protected_Definition => 8803,
|
||||
N_Range_Constraint => 8875,
|
||||
N_Real_Range_Specification => 8892,
|
||||
N_Record_Definition => 8913,
|
||||
N_Signed_Integer_Type_Definition => 8999,
|
||||
N_Single_Protected_Declaration => 9020,
|
||||
N_Subunit => 9061,
|
||||
N_Task_Definition => 9097,
|
||||
N_Triggering_Alternative => 9235,
|
||||
N_Use_Type_Clause => 9282,
|
||||
N_Validate_Unchecked_Conversion => 9333,
|
||||
N_Variant => 9357,
|
||||
N_Variant_Part => 9436,
|
||||
N_With_Clause => 9450,
|
||||
N_With_Type_Clause => 9625,
|
||||
N_Unused_At_End => 9645);
|
||||
|
||||
end Treeprs;
|
|
@ -0,0 +1,108 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T R E E P R S --
|
||||
-- --
|
||||
-- T e m p l a t e --
|
||||
-- --
|
||||
-- $Revision: 1.17 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1997 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This file is a template used as input to the utility program XTreeprs,
|
||||
-- which reads this template, and the spec of Sinfo (sinfo.ads) and generates
|
||||
-- the spec for the Treeprs package (file treeprs.ads)
|
||||
|
||||
-- This package contains the declaration of the string used by the Tree_Print
|
||||
-- package. It must be updated whenever the arrangements of the field names
|
||||
-- in package Sinfo is changed. The utility program XTREEPRS is used to
|
||||
-- do this update correctly using the template treeprs.adt as input.
|
||||
|
||||
with Sinfo; use Sinfo;
|
||||
|
||||
package Treeprs is
|
||||
|
||||
--------------------------------
|
||||
-- String Data for Node Print --
|
||||
--------------------------------
|
||||
|
||||
-- String data for print out. The Pchars array is a long string with the
|
||||
-- the entry for each node type consisting of a single blank, followed by
|
||||
-- a series of entries, one for each Op or Flag field used for the node.
|
||||
-- Each entry has a single character which identifies the field, followed
|
||||
-- by the synonym name. The starting location for a given node type is
|
||||
-- found from the corresponding entry in the Pchars_Pos_Array.
|
||||
|
||||
-- The following characters identify the field. These are characters
|
||||
-- which could never occur in a field name, so they also mark the
|
||||
-- end of the previous name.
|
||||
|
||||
subtype Fchar is Character range '#' .. '9';
|
||||
|
||||
F_Field1 : constant Fchar := '#'; -- Character'Val (16#23#)
|
||||
F_Field2 : constant Fchar := '$'; -- Character'Val (16#24#)
|
||||
F_Field3 : constant Fchar := '%'; -- Character'Val (16#25#)
|
||||
F_Field4 : constant Fchar := '&'; -- Character'Val (16#26#)
|
||||
F_Field5 : constant Fchar := '''; -- Character'Val (16#27#)
|
||||
F_Flag1 : constant Fchar := '('; -- Character'Val (16#28#)
|
||||
F_Flag2 : constant Fchar := ')'; -- Character'Val (16#29#)
|
||||
F_Flag3 : constant Fchar := '*'; -- Character'Val (16#2A#)
|
||||
F_Flag4 : constant Fchar := '+'; -- Character'Val (16#2B#)
|
||||
F_Flag5 : constant Fchar := ','; -- Character'Val (16#2C#)
|
||||
F_Flag6 : constant Fchar := '-'; -- Character'Val (16#2D#)
|
||||
F_Flag7 : constant Fchar := '.'; -- Character'Val (16#2E#)
|
||||
F_Flag8 : constant Fchar := '/'; -- Character'Val (16#2F#)
|
||||
F_Flag9 : constant Fchar := '0'; -- Character'Val (16#30#)
|
||||
F_Flag10 : constant Fchar := '1'; -- Character'Val (16#31#)
|
||||
F_Flag11 : constant Fchar := '2'; -- Character'Val (16#32#)
|
||||
F_Flag12 : constant Fchar := '3'; -- Character'Val (16#33#)
|
||||
F_Flag13 : constant Fchar := '4'; -- Character'Val (16#34#)
|
||||
F_Flag14 : constant Fchar := '5'; -- Character'Val (16#35#)
|
||||
F_Flag15 : constant Fchar := '6'; -- Character'Val (16#36#)
|
||||
F_Flag16 : constant Fchar := '7'; -- Character'Val (16#37#)
|
||||
F_Flag17 : constant Fchar := '8'; -- Character'Val (16#38#)
|
||||
F_Flag18 : constant Fchar := '9'; -- Character'Val (16#39#)
|
||||
|
||||
-- Note this table does not include entity field and flags whose access
|
||||
-- functions are in Einfo (these are handled by the Print_Entity_Info
|
||||
-- procedure in Treepr, which uses the routines in Einfo to get the
|
||||
-- proper symbolic information). In addition, the following fields are
|
||||
-- handled by Treepr, and do not appear in the Pchars array:
|
||||
|
||||
-- Analyzed
|
||||
-- Cannot_Be_Constant
|
||||
-- Chars
|
||||
-- Comes_From_Source
|
||||
-- Error_Posted
|
||||
-- Etype
|
||||
-- Is_Controlling_Actual
|
||||
-- Is_Overloaded
|
||||
-- Is_Static_Expression
|
||||
-- Left_Opnd
|
||||
-- Must_Check_Expr
|
||||
-- Must_Not_Freeze
|
||||
-- No_Overflow_Expr
|
||||
-- Paren_Count
|
||||
-- Raises_Constraint_Error
|
||||
-- Right_Opnd
|
||||
|
||||
!!TEMPLATE INSERTION POINT
|
||||
|
||||
end Treeprs;
|
|
@ -0,0 +1,207 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T T Y P E F --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.21 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This module contains values for the predefined floating-point attributes.
|
||||
-- All references to these attribute values in a program being compiled must
|
||||
-- use the values in this package, not the values returned by referencing
|
||||
-- the corresponding attributes (since that would give host machine values).
|
||||
-- Boolean-valued attributes are defined in System.Parameters, because they
|
||||
-- need a finer control than what is provided by the formats described below.
|
||||
|
||||
-- The codes for the eight floating-point formats supported are:
|
||||
|
||||
-- IEEES - IEEE Single Float
|
||||
-- IEEEL - IEEE Double Float
|
||||
-- IEEEX - IEEE Double Extended Float
|
||||
-- VAXFF - VAX F Float
|
||||
-- VAXDF - VAX D Float
|
||||
-- VAXGF - VAX G Float
|
||||
-- AAMPS - AAMP 32-bit Float
|
||||
-- AAMPL - AAMP 48-bit Float
|
||||
|
||||
package Ttypef is
|
||||
|
||||
----------------------------------
|
||||
-- Universal Integer Attributes --
|
||||
----------------------------------
|
||||
|
||||
-- Note that the constant declarations below specify values
|
||||
-- using the Ada model, so IEEES_Machine_Emax does not specify
|
||||
-- the IEEE definition of the single precision float type,
|
||||
-- but the value of the Ada attribute which is one higher
|
||||
-- as the binary point is at a different location.
|
||||
|
||||
IEEES_Digits : constant := 6;
|
||||
IEEEL_Digits : constant := 15;
|
||||
IEEEX_Digits : constant := 18;
|
||||
VAXFF_Digits : constant := 6;
|
||||
VAXDF_Digits : constant := 9;
|
||||
VAXGF_Digits : constant := 15;
|
||||
AAMPS_Digits : constant := 6;
|
||||
AAMPL_Digits : constant := 9;
|
||||
|
||||
IEEES_Machine_Emax : constant := 128;
|
||||
IEEEL_Machine_Emax : constant := 1024;
|
||||
IEEEX_Machine_Emax : constant := 16384;
|
||||
VAXFF_Machine_Emax : constant := 127;
|
||||
VAXDF_Machine_Emax : constant := 127;
|
||||
VAXGF_Machine_Emax : constant := 1023;
|
||||
AAMPS_Machine_Emax : constant := 127;
|
||||
AAMPL_Machine_Emax : constant := 127;
|
||||
|
||||
IEEES_Machine_Emin : constant := -125;
|
||||
IEEEL_Machine_Emin : constant := -1021;
|
||||
IEEEX_Machine_Emin : constant := -16381;
|
||||
VAXFF_Machine_Emin : constant := -127;
|
||||
VAXDF_Machine_Emin : constant := -127;
|
||||
VAXGF_Machine_Emin : constant := -1023;
|
||||
AAMPS_Machine_Emin : constant := -127;
|
||||
AAMPL_Machine_Emin : constant := -127;
|
||||
|
||||
IEEES_Machine_Mantissa : constant := 24;
|
||||
IEEEL_Machine_Mantissa : constant := 53;
|
||||
IEEEX_Machine_Mantissa : constant := 64;
|
||||
VAXFF_Machine_Mantissa : constant := 24;
|
||||
VAXDF_Machine_Mantissa : constant := 56;
|
||||
VAXGF_Machine_Mantissa : constant := 53;
|
||||
AAMPS_Machine_Mantissa : constant := 24;
|
||||
AAMPL_Machine_Mantissa : constant := 40;
|
||||
|
||||
IEEES_Model_Emin : constant := -125;
|
||||
IEEEL_Model_Emin : constant := -1021;
|
||||
IEEEX_Model_Emin : constant := -16381;
|
||||
VAXFF_Model_Emin : constant := -127;
|
||||
VAXDF_Model_Emin : constant := -127;
|
||||
VAXGF_Model_Emin : constant := -1023;
|
||||
AAMPS_Model_Emin : constant := -127;
|
||||
AAMPL_Model_Emin : constant := -127;
|
||||
|
||||
IEEES_Model_Mantissa : constant := 24;
|
||||
IEEEL_Model_Mantissa : constant := 53;
|
||||
IEEEX_Model_Mantissa : constant := 64;
|
||||
VAXFF_Model_Mantissa : constant := 24;
|
||||
VAXDF_Model_Mantissa : constant := 56;
|
||||
VAXGF_Model_Mantissa : constant := 53;
|
||||
AAMPS_Model_Mantissa : constant := 24;
|
||||
AAMPL_Model_Mantissa : constant := 40;
|
||||
|
||||
IEEES_Safe_Emax : constant := 128;
|
||||
IEEEL_Safe_Emax : constant := 1024;
|
||||
IEEEX_Safe_Emax : constant := 16384;
|
||||
VAXFF_Safe_Emax : constant := 127;
|
||||
VAXDF_Safe_Emax : constant := 127;
|
||||
VAXGF_Safe_Emax : constant := 1023;
|
||||
AAMPS_Safe_Emax : constant := 127;
|
||||
AAMPL_Safe_Emax : constant := 127;
|
||||
|
||||
-------------------------------
|
||||
-- Universal Real Attributes --
|
||||
-------------------------------
|
||||
|
||||
IEEES_Model_Epsilon : constant := 2#1.0#E-23;
|
||||
IEEEL_Model_Epsilon : constant := 2#1.0#E-52;
|
||||
IEEEX_Model_Epsilon : constant := 2#1.0#E-63;
|
||||
VAXFF_Model_Epsilon : constant := 16#0.1000_000#E-4;
|
||||
VAXDF_Model_Epsilon : constant := 16#0.4000_0000_0000_000#E-7;
|
||||
VAXGF_Model_Epsilon : constant := 16#0.4000_0000_0000_00#E-12;
|
||||
AAMPS_Model_Epsilon : constant := 2#1.0#E-23;
|
||||
AAMPL_Model_Epsilon : constant := 2#1.0#E-39;
|
||||
|
||||
IEEES_Model_Small : constant := 2#1.0#E-126;
|
||||
IEEEL_Model_Small : constant := 2#1.0#E-1022;
|
||||
IEEEX_Model_Small : constant := 2#1.0#E-16381;
|
||||
VAXFF_Model_Small : constant := 16#0.8000_000#E-21;
|
||||
VAXDF_Model_Small : constant := 16#0.8000_0000_0000_000#E-31;
|
||||
VAXGF_Model_Small : constant := 16#0.8000_0000_0000_00#E-51;
|
||||
AAMPS_Model_Small : constant := 16#0.8000_000#E-21;
|
||||
AAMPL_Model_Small : constant := 16#0.8000_0000_000#E-31;
|
||||
|
||||
IEEES_Safe_First : constant := -16#0.FFFF_FF#E+32;
|
||||
IEEEL_Safe_First : constant := -16#0.FFFF_FFFF_FFFF_F8#E+256;
|
||||
IEEEX_Safe_First : constant := -16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
|
||||
VAXFF_Safe_First : constant := -16#0.7FFF_FF8#E+32;
|
||||
VAXDF_Safe_First : constant := -16#0.7FFF_FFFF_FFFF_FF8#E-38;
|
||||
VAXGF_Safe_First : constant := -16#0.7FFF_FFFF_FFFF_FC#E-256;
|
||||
AAMPS_Safe_First : constant := -16#0.7FFF_FF8#E+32;
|
||||
AAMPL_Safe_First : constant := -16#0.7FFF_FFFF_FF8#E+32;
|
||||
|
||||
IEEES_Safe_Large : constant := 16#0.FFFF_FF#E+32;
|
||||
IEEEL_Safe_Large : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256;
|
||||
IEEEX_Safe_Large : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
|
||||
VAXFF_Safe_Large : constant := 16#0.7FFF_FC0#E+32;
|
||||
VAXDF_Safe_Large : constant := 16#0.7FFF_FFFF_0000_000#E+32;
|
||||
VAXGF_Safe_Large : constant := 16#0.7FFF_FFFF_FFFF_F0#E+256;
|
||||
AAMPS_Safe_Large : constant := 16#0.7FFF_FC0#E+32;
|
||||
AAMPL_Safe_Large : constant := 16#0.7FFF_FFFF#E+32;
|
||||
|
||||
IEEES_Safe_Last : constant := 16#0.FFFF_FF#E+32;
|
||||
IEEEL_Safe_Last : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256;
|
||||
IEEEX_Safe_Last : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
|
||||
VAXFF_Safe_Last : constant := 16#0.7FFF_FF8#E+32;
|
||||
VAXDF_Safe_Last : constant := 16#0.7FFF_FFFF_FFFF_FC0#E+32;
|
||||
VAXGF_Safe_Last : constant := 16#0.7FFF_FFFF_FFFF_FC#E+256;
|
||||
AAMPS_Safe_Last : constant := 16#0.7FFF_FF8#E+32;
|
||||
AAMPL_Safe_Last : constant := 16#0.7FFF_FFFF_FF8#E+32;
|
||||
|
||||
IEEES_Safe_Small : constant := 2#1.0#E-126;
|
||||
IEEEL_Safe_Small : constant := 2#1.0#E-1022;
|
||||
IEEEX_Safe_Small : constant := 2#1.0#E-16381;
|
||||
VAXFF_Safe_Small : constant := 16#0.1000_000#E-31;
|
||||
VAXDF_Safe_Small : constant := 16#0.1000_0000_0000_000#E-31;
|
||||
VAXGF_Safe_Small : constant := 16#0.1000_0000_0000_00#E-255;
|
||||
AAMPS_Safe_Small : constant := 16#0.1000_000#E-31;
|
||||
AAMPL_Safe_Small : constant := 16#0.1000_0000_000#E-31;
|
||||
|
||||
----------------------
|
||||
-- Typed Attributes --
|
||||
----------------------
|
||||
|
||||
-- The attributes First and Last are typed attributes in Ada, and yield
|
||||
-- values of the appropriate float type. However we still describe them
|
||||
-- as universal real values in this file, since we are talking about the
|
||||
-- target floating-point types, not the host floating-point types.
|
||||
|
||||
IEEES_First : constant := -16#0.FFFF_FF#E+32;
|
||||
IEEEL_First : constant := -16#0.FFFF_FFFF_FFFF_F8#E+256;
|
||||
IEEEX_First : constant := -16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
|
||||
VAXFF_First : constant := -16#0.7FFF_FF8#E+32;
|
||||
VAXDF_First : constant := -16#0.7FFF_FFFF_FFFF_FF8#E+32;
|
||||
VAXGF_First : constant := -16#0.7FFF_FFFF_FFFF_FC#E+256;
|
||||
AAMPS_First : constant := -16#0.7FFF_FF8#E+32;
|
||||
AAMPL_First : constant := -16#0.7FFF_FFFF_FF8#E+32;
|
||||
|
||||
IEEES_Last : constant := 16#0.FFFF_FF#E+32;
|
||||
IEEEL_Last : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256;
|
||||
IEEEX_Last : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
|
||||
VAXFF_Last : constant := 16#0.7FFF_FF8#E+32;
|
||||
VAXDF_Last : constant := 16#0.7FFF_FFFF_FFFF_FC0#E+32;
|
||||
VAXGF_Last : constant := 16#0.7FFF_FFFF_FFFF_FC#E+256;
|
||||
AAMPS_Last : constant := 16#0.7FFF_FF8#E+32;
|
||||
AAMPL_Last : constant := 16#0.7FFF_FFFF_FF8#E+32;
|
||||
|
||||
end Ttypef;
|
|
@ -0,0 +1,211 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T T Y P E S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.25 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains constants describing target properties
|
||||
|
||||
with Types; use Types;
|
||||
with Get_Targ; use Get_Targ;
|
||||
|
||||
package Ttypes is
|
||||
|
||||
------------------------------
|
||||
-- Host/Target Dependencies --
|
||||
------------------------------
|
||||
|
||||
-- It is vital to maintain a clear distinction between properties of
|
||||
-- types on the host and types on the target, since in the general
|
||||
-- case of a cross-compiler these will be different.
|
||||
|
||||
-- This package and its companion Ttypef provide definitions of values
|
||||
-- that describe the properties of the target types. All instances of
|
||||
-- target dependencies, including the definitions of such packages as
|
||||
-- Standard and System depend directly or indirectly on the definitions
|
||||
-- in the Ttypes and Ttypef packages.
|
||||
|
||||
-- In the source of the compiler, references to attributes such as
|
||||
-- Integer'Size will give information regarding the host types (i.e.
|
||||
-- the types within the compiler itself). Such references are therefore
|
||||
-- almost always suspicious (it is hard for example to see that the
|
||||
-- code in the compiler should even be using type Integer very much,
|
||||
-- and certainly this code should not depend on the size of Integer).
|
||||
|
||||
-- On the other hand, it is perfectly reasonable for the compiler to
|
||||
-- require access to the size of type Integer for the target machine,
|
||||
-- e.g. in constructing the internal representation of package Standard.
|
||||
-- For this purpose, instead of referencing the attribute Integer'Size,
|
||||
-- a reference to Ttypes.Standard_Integer_Size will provide the needed
|
||||
-- value for the target type.
|
||||
|
||||
-- Two approaches are used for handling target dependent values in the
|
||||
-- standard library packages. Package Standard is handled specially,
|
||||
-- being constructed internally (by package Stand). Target dependent
|
||||
-- values needed in Stand are obtained by direct reference to Ttypes
|
||||
-- and Ttypef.
|
||||
|
||||
-- For package System, the required constant values are obtained by
|
||||
-- referencing appropriate attributes. Ada 95 already defines most of
|
||||
-- the required attributes, and GNAT specific attributes have been
|
||||
-- defined to cover the remaining cases (such as Storage_Unit). The
|
||||
-- evaluation of these attributes obtains the required target dependent
|
||||
-- values from Ttypes and Ttypef. The additional attributes that have
|
||||
-- been added to GNAT (Address_Size, Storage_Unit, Word_Size, Max_Priority,
|
||||
-- and Max_Interrupt_Priority) are for almost all purposes redundant with
|
||||
-- respect to the corresponding references to System constants. For example
|
||||
-- in a program, System.Address_Size and Standard'Address_Size yield the
|
||||
-- same value. The critical use of the attribute is in writing the System
|
||||
-- declaration of Address_Size which of course cannot refer to itself. By
|
||||
-- this means we achieve complete target independence in the source code
|
||||
-- of package System, i.e. there is only one copy of the source of System
|
||||
-- for all targets.
|
||||
|
||||
-- Note that during compilation there are two versions of package System
|
||||
-- around. The version that is directly WITH'ed by compiler packages
|
||||
-- contains host-dependent definitions, which is what is needed in that
|
||||
-- case (for example, System.Storage_Unit referenced in the source of the
|
||||
-- compiler refers to the storage unit of the host, not the target. This
|
||||
-- means that, like attribute references, any references to constants in
|
||||
-- package System in the compiler code are suspicious, since it is strange
|
||||
-- for the compiler to have such host dependencies. If the compiler needs
|
||||
-- to access the target dependent values of such quantities as Storage_Unit
|
||||
-- then it should reference the constants in this package (Ttypes), rather
|
||||
-- than referencing System.Storage_Unit, or Standard'Storage_Unit, both of
|
||||
-- which would yield the host value.
|
||||
|
||||
---------------------------------------------------
|
||||
-- Target-Dependent Values for Types in Standard --
|
||||
---------------------------------------------------
|
||||
|
||||
-- Note: GNAT always supplies all the following integer and float types,
|
||||
-- but depending on the machine, some of the types may be identical. For
|
||||
-- example, on some machines, Short_Float may be the same as Float, and
|
||||
-- Long_Long_Float may be the same as Long_Float.
|
||||
|
||||
Standard_Short_Short_Integer_Size : constant Pos := Get_Char_Size;
|
||||
Standard_Short_Short_Integer_Width : constant Pos :=
|
||||
Width_From_Size (Standard_Short_Short_Integer_Size);
|
||||
|
||||
Standard_Short_Integer_Size : constant Pos := Get_Short_Size;
|
||||
Standard_Short_Integer_Width : constant Pos :=
|
||||
Width_From_Size (Standard_Short_Integer_Size);
|
||||
|
||||
Standard_Integer_Size : constant Pos := Get_Int_Size;
|
||||
Standard_Integer_Width : constant Pos :=
|
||||
Width_From_Size (Standard_Integer_Size);
|
||||
|
||||
Standard_Long_Integer_Size : constant Pos := Get_Long_Size;
|
||||
Standard_Long_Integer_Width : constant Pos :=
|
||||
Width_From_Size (Standard_Long_Integer_Size);
|
||||
|
||||
Standard_Long_Long_Integer_Size : constant Pos := Get_Long_Long_Size;
|
||||
Standard_Long_Long_Integer_Width : constant Pos :=
|
||||
Width_From_Size (Standard_Long_Long_Integer_Size);
|
||||
|
||||
Standard_Short_Float_Size : constant Pos := Get_Float_Size;
|
||||
Standard_Short_Float_Digits : constant Pos :=
|
||||
Digits_From_Size (Standard_Short_Float_Size);
|
||||
|
||||
Standard_Float_Size : constant Pos := Get_Float_Size;
|
||||
Standard_Float_Digits : constant Pos :=
|
||||
Digits_From_Size (Standard_Float_Size);
|
||||
|
||||
Standard_Long_Float_Size : constant Pos := Get_Double_Size;
|
||||
Standard_Long_Float_Digits : constant Pos :=
|
||||
Digits_From_Size (Standard_Long_Float_Size);
|
||||
|
||||
Standard_Long_Long_Float_Size : constant Pos := Get_Long_Double_Size;
|
||||
Standard_Long_Long_Float_Digits : constant Pos :=
|
||||
Digits_From_Size (Standard_Long_Long_Float_Size);
|
||||
|
||||
Standard_Character_Size : constant Pos := Get_Char_Size;
|
||||
|
||||
Standard_Wide_Character_Size : constant Pos := 2 * Get_Char_Size;
|
||||
-- The Standard.Wide_Character type is special in the sense that
|
||||
-- it is not defined in terms of its corresponding C type (wchar_t).
|
||||
-- Unfortunately this makes the representation of Wide_Character
|
||||
-- incompatible with the C wchar_t type.
|
||||
-- ??? This is required by the RM or backward compatibility
|
||||
|
||||
-- Note: there is no specific control over the representation of
|
||||
-- enumeration types. The convention used is that if an enumeration
|
||||
-- type has fewer than 2**(Character'Size) elements, then the size
|
||||
-- used is Character'Size, otherwise Integer'Size is used.
|
||||
|
||||
-- Similarly, the size of fixed-point types depends on the size of the
|
||||
-- corresponding integer type, which is the smallest predefined integer
|
||||
-- type capable of representing the required range of values.
|
||||
|
||||
-------------------------------------------------
|
||||
-- Target-Dependent Values for Types in System --
|
||||
-------------------------------------------------
|
||||
|
||||
System_Address_Size : constant Pos := Get_Pointer_Size;
|
||||
-- System.Address'Size (also size of all thin pointers)
|
||||
|
||||
System_Max_Binary_Modulus_Power : constant Pos :=
|
||||
Standard_Long_Long_Integer_Size;
|
||||
|
||||
System_Max_Nonbinary_Modulus_Power : constant Pos :=
|
||||
Standard_Integer_Size - 1;
|
||||
|
||||
System_Storage_Unit : constant Pos := Get_Bits_Per_Unit;
|
||||
System_Word_Size : constant Pos := Get_Bits_Per_Word;
|
||||
|
||||
System_Tick_Nanoseconds : constant Pos := 1_000_000_000;
|
||||
-- Value of System.Tick in nanoseconds. At the moment, this is a fixed
|
||||
-- constant (with value of 1.0 seconds), but later we should add this
|
||||
-- value to the GCC configuration file so that its value can be made
|
||||
-- configuration dependent.
|
||||
|
||||
-----------------------------------------------------
|
||||
-- Target-Dependent Values for Types in Interfaces --
|
||||
-----------------------------------------------------
|
||||
|
||||
Interfaces_Wchar_T_Size : constant Pos := Get_Wchar_T_Size;
|
||||
|
||||
----------------------------------------
|
||||
-- Other Target-Dependent Definitions --
|
||||
----------------------------------------
|
||||
|
||||
Maximum_Alignment : constant Pos := Get_Maximum_Alignment;
|
||||
-- The maximum alignment, in storage units, that an object or
|
||||
-- type may require on the target machine.
|
||||
|
||||
Bytes_Big_Endian : Boolean := Get_Bytes_BE /= 0;
|
||||
-- Important note: for Ada purposes, the important setting is the bytes
|
||||
-- endianness (Bytes_Big_Endian), not the bits value (Bits_Big_Endian).
|
||||
-- This is because Ada bit addressing must be compatible with the byte
|
||||
-- ordering (otherwise we would end up with non-contiguous fields). It
|
||||
-- is rare for the two to be different, but if they are, Bits_Big_Endian
|
||||
-- is relevant only for the generation of instructions with bit numbers,
|
||||
-- and thus relevant only to the back end. Note that this is a variable
|
||||
-- rather than a constant, since it can be modified (flipped) by -gnatd8.
|
||||
|
||||
Target_Strict_Alignment : Boolean := Get_Strict_Alignment /= 0;
|
||||
-- True if instructions will fail if data is misaligned
|
||||
|
||||
end Ttypes;
|
|
@ -0,0 +1,235 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T Y P E S --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.20 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
package body Types is
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat;
|
||||
-- Extract two decimal digit value from time stamp
|
||||
|
||||
---------
|
||||
-- "<" --
|
||||
---------
|
||||
|
||||
function "<" (Left, Right : Time_Stamp_Type) return Boolean is
|
||||
begin
|
||||
return not (Left = Right) and then String (Left) < String (Right);
|
||||
end "<";
|
||||
|
||||
----------
|
||||
-- "<=" --
|
||||
----------
|
||||
|
||||
function "<=" (Left, Right : Time_Stamp_Type) return Boolean is
|
||||
begin
|
||||
return not (Left > Right);
|
||||
end "<=";
|
||||
|
||||
---------
|
||||
-- "=" --
|
||||
---------
|
||||
|
||||
function "=" (Left, Right : Time_Stamp_Type) return Boolean is
|
||||
Sleft : Nat;
|
||||
Sright : Nat;
|
||||
|
||||
begin
|
||||
if String (Left) = String (Right) then
|
||||
return True;
|
||||
|
||||
elsif Left (1) = ' ' or else Right (1) = ' ' then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
-- In the following code we check for a difference of 2 seconds or less
|
||||
|
||||
-- Recall that the time stamp format is:
|
||||
|
||||
-- Y Y Y Y M M D D H H M M S S
|
||||
-- 01 02 03 04 05 06 07 08 09 10 11 12 13 14
|
||||
|
||||
-- Note that we do not bother to worry about shifts in the day.
|
||||
-- It seems unlikely that such shifts could ever occur in practice
|
||||
-- and even if they do we err on the safe side, ie we say that the time
|
||||
-- stamps are different.
|
||||
|
||||
Sright := V (Right, 13) + 60 * (V (Right, 11) + 60 * V (Right, 09));
|
||||
Sleft := V (Left, 13) + 60 * (V (Left, 11) + 60 * V (Left, 09));
|
||||
|
||||
-- So the check is: dates must be the same, times differ 2 sec at most
|
||||
|
||||
return abs (Sleft - Sright) <= 2
|
||||
and then String (Left (1 .. 8)) = String (Right (1 .. 8));
|
||||
end "=";
|
||||
|
||||
---------
|
||||
-- ">" --
|
||||
---------
|
||||
|
||||
function ">" (Left, Right : Time_Stamp_Type) return Boolean is
|
||||
begin
|
||||
return not (Left = Right) and then String (Left) > String (Right);
|
||||
end ">";
|
||||
|
||||
----------
|
||||
-- ">=" --
|
||||
----------
|
||||
|
||||
function ">=" (Left, Right : Time_Stamp_Type) return Boolean is
|
||||
begin
|
||||
return not (Left < Right);
|
||||
end ">=";
|
||||
|
||||
-------------------
|
||||
-- Get_Char_Code --
|
||||
-------------------
|
||||
|
||||
function Get_Char_Code (C : Character) return Char_Code is
|
||||
begin
|
||||
return Char_Code'Val (Character'Pos (C));
|
||||
end Get_Char_Code;
|
||||
|
||||
-------------------
|
||||
-- Get_Character --
|
||||
-------------------
|
||||
|
||||
-- Note: raises Constraint_Error if checks on and C out of range
|
||||
|
||||
function Get_Character (C : Char_Code) return Character is
|
||||
begin
|
||||
return Character'Val (C);
|
||||
end Get_Character;
|
||||
|
||||
--------------------
|
||||
-- Get_Hex_String --
|
||||
--------------------
|
||||
|
||||
subtype Wordh is Word range 0 .. 15;
|
||||
Hex : constant array (Wordh) of Character := "0123456789ABCDEF";
|
||||
|
||||
function Get_Hex_String (W : Word) return Word_Hex_String is
|
||||
X : Word := W;
|
||||
WS : Word_Hex_String;
|
||||
|
||||
begin
|
||||
for J in reverse 1 .. 8 loop
|
||||
WS (J) := Hex (X mod 16);
|
||||
X := X / 16;
|
||||
end loop;
|
||||
|
||||
return WS;
|
||||
end Get_Hex_String;
|
||||
|
||||
------------------------
|
||||
-- In_Character_Range --
|
||||
------------------------
|
||||
|
||||
function In_Character_Range (C : Char_Code) return Boolean is
|
||||
begin
|
||||
return (C <= 255);
|
||||
end In_Character_Range;
|
||||
|
||||
---------------------
|
||||
-- Make_Time_Stamp --
|
||||
---------------------
|
||||
|
||||
procedure Make_Time_Stamp
|
||||
(Year : Nat;
|
||||
Month : Nat;
|
||||
Day : Nat;
|
||||
Hour : Nat;
|
||||
Minutes : Nat;
|
||||
Seconds : Nat;
|
||||
TS : out Time_Stamp_Type)
|
||||
is
|
||||
Z : constant := Character'Pos ('0');
|
||||
|
||||
begin
|
||||
TS (01) := Character'Val (Z + Year / 1000);
|
||||
TS (02) := Character'Val (Z + (Year / 100) mod 10);
|
||||
TS (03) := Character'Val (Z + (Year / 10) mod 10);
|
||||
TS (04) := Character'Val (Z + Year mod 10);
|
||||
TS (05) := Character'Val (Z + Month / 10);
|
||||
TS (06) := Character'Val (Z + Month mod 10);
|
||||
TS (07) := Character'Val (Z + Day / 10);
|
||||
TS (08) := Character'Val (Z + Day mod 10);
|
||||
TS (09) := Character'Val (Z + Hour / 10);
|
||||
TS (10) := Character'Val (Z + Hour mod 10);
|
||||
TS (11) := Character'Val (Z + Minutes / 10);
|
||||
TS (12) := Character'Val (Z + Minutes mod 10);
|
||||
TS (13) := Character'Val (Z + Seconds / 10);
|
||||
TS (14) := Character'Val (Z + Seconds mod 10);
|
||||
end Make_Time_Stamp;
|
||||
|
||||
----------------------
|
||||
-- Split_Time_Stamp --
|
||||
----------------------
|
||||
|
||||
procedure Split_Time_Stamp
|
||||
(TS : Time_Stamp_Type;
|
||||
Year : out Nat;
|
||||
Month : out Nat;
|
||||
Day : out Nat;
|
||||
Hour : out Nat;
|
||||
Minutes : out Nat;
|
||||
Seconds : out Nat)
|
||||
is
|
||||
|
||||
begin
|
||||
-- Y Y Y Y M M D D H H M M S S
|
||||
-- 01 02 03 04 05 06 07 08 09 10 11 12 13 14
|
||||
|
||||
Year := 100 * V (TS, 01) + V (TS, 03);
|
||||
Month := V (TS, 05);
|
||||
Day := V (TS, 07);
|
||||
Hour := V (TS, 09);
|
||||
Minutes := V (TS, 11);
|
||||
Seconds := V (TS, 13);
|
||||
end Split_Time_Stamp;
|
||||
|
||||
-------
|
||||
-- V --
|
||||
-------
|
||||
|
||||
function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat is
|
||||
begin
|
||||
return 10 * (Character'Pos (T (X)) - Character'Pos ('0')) +
|
||||
Character'Pos (T (X + 1)) - Character'Pos ('0');
|
||||
end V;
|
||||
|
||||
end Types;
|
|
@ -0,0 +1,720 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- T Y P E S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.87 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Unchecked_Deallocation;
|
||||
|
||||
package Types is
|
||||
pragma Preelaborate (Types);
|
||||
|
||||
-- This package contains host independent type definitions which are used
|
||||
-- in more than one unit in the compiler. They are gathered here for easy
|
||||
-- reference, though in some cases the full description is found in the
|
||||
-- relevant module which implements the definition. The main reason that
|
||||
-- they are not in their "natural" specs is that this would cause a lot of
|
||||
-- inter-spec dependencies, and in particular some awkward circular
|
||||
-- dependencies would have to be dealt with.
|
||||
|
||||
-- WARNING: There is a C version of this package. Any changes to this
|
||||
-- source file must be properly reflected in the C header file a-types.h
|
||||
|
||||
-- Note: the declarations in this package reflect an expectation that the
|
||||
-- host machine has an efficient integer base type with a range at least
|
||||
-- 32 bits 2s-complement. If there are any machines for which this is not
|
||||
-- a correct assumption, a significant number of changes will be required!
|
||||
|
||||
-------------------------------
|
||||
-- General Use Integer Types --
|
||||
-------------------------------
|
||||
|
||||
type Int is range -2 ** 31 .. +2 ** 31 - 1;
|
||||
-- Signed 32-bit integer
|
||||
|
||||
type Dint is range -2 ** 63 .. +2 ** 63 - 1;
|
||||
-- Double length (64-bit) integer
|
||||
|
||||
subtype Nat is Int range 0 .. Int'Last;
|
||||
-- Non-negative Int values
|
||||
|
||||
subtype Pos is Int range 1 .. Int'Last;
|
||||
-- Positive Int values
|
||||
|
||||
type Word is mod 2 ** 32;
|
||||
-- Unsigned 32-bit integer
|
||||
|
||||
type Short is range -32768 .. +32767;
|
||||
for Short'Size use 16;
|
||||
-- 16-bit signed integer
|
||||
|
||||
type Byte is mod 2 ** 8;
|
||||
for Byte'Size use 8;
|
||||
-- 8-bit unsigned integer
|
||||
|
||||
type size_t is mod 2 ** Standard'Address_Size;
|
||||
-- Memory size value, for use in calls to C routines
|
||||
|
||||
--------------------------------------
|
||||
-- 8-Bit Character and String Types --
|
||||
--------------------------------------
|
||||
|
||||
-- We use Standard.Character and Standard.String freely, since we are
|
||||
-- compiling ourselves, and we properly implement the required 8-bit
|
||||
-- character code as required in Ada 95. This section defines a few
|
||||
-- general use constants and subtypes.
|
||||
|
||||
EOF : constant Character := ASCII.SUB;
|
||||
-- The character SUB (16#1A#) is used in DOS and other systems derived
|
||||
-- from DOS (OS/2, NT etc) to signal the end of a text file. Internally
|
||||
-- all source files are ended by an EOF character, even on Unix systems.
|
||||
-- An EOF character acts as the end of file only as the last character
|
||||
-- of a source buffer, in any other position, it is treated as a blank
|
||||
-- if it appears between tokens, and as an illegal character otherwise.
|
||||
-- This makes life easier dealing with files that originated from DOS,
|
||||
-- including concatenated files with interspersed EOF characters.
|
||||
|
||||
subtype Graphic_Character is Character range ' ' .. '~';
|
||||
-- Graphic characters, as defined in ARM
|
||||
|
||||
subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR;
|
||||
-- Line terminator characters (LF, VT, FF, CR)
|
||||
|
||||
subtype Upper_Half_Character is
|
||||
Character range Character'Val (16#80#) .. Character'Val (16#FF#);
|
||||
-- Characters with the upper bit set
|
||||
|
||||
type Character_Ptr is access all Character;
|
||||
type String_Ptr is access all String;
|
||||
-- Standard character and string pointers
|
||||
|
||||
procedure Free is new Unchecked_Deallocation (String, String_Ptr);
|
||||
-- Procedure for freeing dynamically allocated String values
|
||||
|
||||
subtype Word_Hex_String is String (1 .. 8);
|
||||
-- Type used to represent Word value as 8 hex digits, with upper case
|
||||
-- letters for the alphabetic cases.
|
||||
|
||||
function Get_Hex_String (W : Word) return Word_Hex_String;
|
||||
-- Convert word value to 8-character hex string
|
||||
|
||||
-----------------------------------------
|
||||
-- Types Used for Text Buffer Handling --
|
||||
-----------------------------------------
|
||||
|
||||
-- We can't use type String for text buffers, since we must use the
|
||||
-- standard 32-bit integer as an index value, since we count on all
|
||||
-- index values being the same size.
|
||||
|
||||
type Text_Ptr is new Int;
|
||||
-- Type used for subscripts in text buffer
|
||||
|
||||
type Text_Buffer is array (Text_Ptr range <>) of Character;
|
||||
-- Text buffer used to hold source file or library information file
|
||||
|
||||
type Text_Buffer_Ptr is access all Text_Buffer;
|
||||
-- Text buffers for input files are allocated dynamically and this type
|
||||
-- is used to reference these text buffers.
|
||||
|
||||
procedure Free is new Unchecked_Deallocation (Text_Buffer, Text_Buffer_Ptr);
|
||||
-- Procedure for freeing dynamically allocated text buffers
|
||||
|
||||
------------------------------------------
|
||||
-- Types Used for Source Input Handling --
|
||||
------------------------------------------
|
||||
|
||||
type Logical_Line_Number is range 0 .. Int'Last;
|
||||
for Logical_Line_Number'Size use 32;
|
||||
-- Line number type, used for storing logical line numbers (i.e. line
|
||||
-- numbers that include effects of any Source_Reference pragmas in the
|
||||
-- source file). The value zero indicates a line containing a source
|
||||
-- reference pragma.
|
||||
|
||||
No_Line_Number : constant Logical_Line_Number := 0;
|
||||
-- Special value used to indicate no line number
|
||||
|
||||
type Physical_Line_Number is range 1 .. Int'Last;
|
||||
for Physical_Line_Number'Size use 32;
|
||||
-- Line number type, used for storing physical line numbers (i.e.
|
||||
-- line numbers in the physical file being compiled, unaffected by
|
||||
-- the presence of source reference pragmas.
|
||||
|
||||
type Column_Number is range 0 .. 32767;
|
||||
for Column_Number'Size use 16;
|
||||
-- Column number (assume that 2**15 is large enough, see declaration
|
||||
-- of Hostparm.Max_Line_Length)
|
||||
|
||||
No_Column_Number : constant Column_Number := 0;
|
||||
-- Special value used to indicate no column number
|
||||
|
||||
subtype Source_Buffer is Text_Buffer;
|
||||
-- Type used to store text of a source file . The buffer for the main
|
||||
-- source (the source specified on the command line) has a lower bound
|
||||
-- starting at zero. Subsequent subsidiary sources have lower bounds
|
||||
-- which are one greater than the previous upper bound.
|
||||
|
||||
subtype Big_Source_Buffer is Text_Buffer (0 .. Text_Ptr'Last);
|
||||
-- This is a virtual type used as the designated type of the access
|
||||
-- type Source_Buffer_Ptr, see Osint.Read_Source_File for details.
|
||||
|
||||
type Source_Buffer_Ptr is access all Big_Source_Buffer;
|
||||
-- Pointer to source buffer. We use virtual origin addressing for
|
||||
-- source buffers, with thin pointers. The pointer points to a virtual
|
||||
-- instance of type Big_Source_Buffer, where the actual type is in fact
|
||||
-- of type Source_Buffer. The address is adjusted so that the virtual
|
||||
-- origin addressing works correctly. See Osint.Read_Source_Buffer for
|
||||
-- further details.
|
||||
|
||||
subtype Source_Ptr is Text_Ptr;
|
||||
-- Type used to represent a source location, which is a subscript of a
|
||||
-- character in the source buffer. As noted above, diffferent source
|
||||
-- buffers have different ranges, so it is possible to tell from a
|
||||
-- Source_Ptr value which source it refers to. Note that negative numbers
|
||||
-- are allowed to accomodate the following special values.
|
||||
|
||||
No_Location : constant Source_Ptr := -1;
|
||||
-- Value used to indicate no source position set in a node
|
||||
|
||||
Standard_Location : constant Source_Ptr := -2;
|
||||
-- Used for all nodes in the representation of package Standard other
|
||||
-- than nodes representing the contents of Standard.ASCII. Note that
|
||||
-- testing for <= Standard_Location tests for both Standard_Location
|
||||
-- and for Standard_ASCII_Location.
|
||||
|
||||
Standard_ASCII_Location : constant Source_Ptr := -3;
|
||||
-- Used for all nodes in the presentation of package Standard.ASCII
|
||||
|
||||
First_Source_Ptr : constant Source_Ptr := 0;
|
||||
-- Starting source pointer index value for first source program
|
||||
|
||||
-------------------------------------
|
||||
-- Range Definitions for Tree Data --
|
||||
-------------------------------------
|
||||
|
||||
-- The tree has fields that can hold any of the following types:
|
||||
|
||||
-- Pointers to other tree nodes (type Node_Id)
|
||||
-- List pointers (type List_Id)
|
||||
-- Element list pointers (type Elist_Id)
|
||||
-- Names (type Name_Id)
|
||||
-- Strings (type String_Id)
|
||||
-- Universal integers (type Uint)
|
||||
-- Universal reals (type Ureal)
|
||||
-- Character codes (type Char_Code stored with a bias)
|
||||
|
||||
-- In most contexts, the strongly typed interface determines which of
|
||||
-- these types is present. However, there are some situations (involving
|
||||
-- untyped traversals of the tree), where it is convenient to be easily
|
||||
-- able to distinguish these values. The underlying representation in all
|
||||
-- cases is an integer type Union_Id, and we ensure that the range of
|
||||
-- the various possible values for each of the above types is disjoint
|
||||
-- so that this distinction is possible.
|
||||
|
||||
type Union_Id is new Int;
|
||||
-- The type in the tree for a union of possible ID values
|
||||
|
||||
-- Note: it is also helpful for debugging purposes to make these ranges
|
||||
-- distinct. If a bug leads to misidentification of a value, then it will
|
||||
-- typically result in an out of range value and a Constraint_Error.
|
||||
|
||||
List_Low_Bound : constant := -100_000_000;
|
||||
-- The List_Id values are subscripts into an array of list headers which
|
||||
-- has List_Low_Bound as its lower bound. This value is chosen so that all
|
||||
-- List_Id values are negative, and the value zero is in the range of both
|
||||
-- List_Id and Node_Id values (see further description below).
|
||||
|
||||
List_High_Bound : constant := 0;
|
||||
-- Maximum List_Id subscript value. This allows up to 100 million list
|
||||
-- Id values, which is in practice infinite, and there is no need to
|
||||
-- check the range. The range overlaps the node range by one element
|
||||
-- (with value zero), which is used both for the Empty node, and for
|
||||
-- indicating no list. The fact that the same value is used is convenient
|
||||
-- because it means that the default value of Empty applies to both nodes
|
||||
-- and lists, and also is more efficient to test for.
|
||||
|
||||
Node_Low_Bound : constant := 0;
|
||||
-- The tree Id values start at zero, because we use zero for Empty (to
|
||||
-- allow a zero test for Empty). Actual tree node subscripts start at 0
|
||||
-- since Empty is a legitimate node value.
|
||||
|
||||
Node_High_Bound : constant := 099_999_999;
|
||||
-- Maximum number of nodes that can be allocated is 100 million, which
|
||||
-- is in practice infinite, and there is no need to check the range.
|
||||
|
||||
Elist_Low_Bound : constant := 100_000_000;
|
||||
-- The Elist_Id values are subscripts into an array of elist headers which
|
||||
-- has Elist_Low_Bound as its lower bound.
|
||||
|
||||
Elist_High_Bound : constant := 199_999_999;
|
||||
-- Maximum Elist_Id subscript value. This allows up to 100 million Elists,
|
||||
-- which is in practice infinite and there is no need to check the range.
|
||||
|
||||
Elmt_Low_Bound : constant := 200_000_000;
|
||||
-- Low bound of element Id values. The use of these values is internal to
|
||||
-- the Elists package, but the definition of the range is included here
|
||||
-- since it must be disjoint from other Id values. The Elmt_Id values are
|
||||
-- subscripts into an array of list elements which has this as lower bound.
|
||||
|
||||
Elmt_High_Bound : constant := 299_999_999;
|
||||
-- Upper bound of Elmt_Id values. This allows up to 100 million element
|
||||
-- list members, which is in practice infinite (no range check needed).
|
||||
|
||||
Names_Low_Bound : constant := 300_000_000;
|
||||
-- Low bound for name Id values
|
||||
|
||||
Names_High_Bound : constant := 399_999_999;
|
||||
-- Maximum number of names that can be allocated is 100 million, which is
|
||||
-- in practice infinite and there is no need to check the range.
|
||||
|
||||
Strings_Low_Bound : constant := 400_000_000;
|
||||
-- Low bound for string Id values
|
||||
|
||||
Strings_High_Bound : constant := 499_999_999;
|
||||
-- Maximum number of strings that can be allocated is 100 million, which
|
||||
-- is in practice infinite and there is no need to check the range.
|
||||
|
||||
Ureal_Low_Bound : constant := 500_000_000;
|
||||
-- Low bound for Ureal values.
|
||||
|
||||
Ureal_High_Bound : constant := 599_999_999;
|
||||
-- Maximum number of Ureal values stored is 100_000_000 which is in
|
||||
-- practice infinite so that no check is required.
|
||||
|
||||
Uint_Low_Bound : constant := 600_000_000;
|
||||
-- Low bound for Uint values.
|
||||
|
||||
Uint_Table_Start : constant := 2_000_000_000;
|
||||
-- Location where table entries for universal integers start (see
|
||||
-- Uintp spec for details of the representation of Uint values).
|
||||
|
||||
Uint_High_Bound : constant := 2_099_999_999;
|
||||
-- The range of Uint values is very large, since a substantial part
|
||||
-- of this range is used to store direct values, see Uintp for details.
|
||||
|
||||
Char_Code_Bias : constant := 2_100_000_000;
|
||||
-- A bias value added to character code values stored in the tree which
|
||||
-- ensures that they have different values from any of the above types.
|
||||
|
||||
-- The following subtype definitions are used to provide convenient names
|
||||
-- for membership tests on Int values to see what data type range they
|
||||
-- lie in. Such tests appear only in the lowest level packages.
|
||||
|
||||
subtype List_Range is Union_Id
|
||||
range List_Low_Bound .. List_High_Bound;
|
||||
|
||||
subtype Node_Range is Union_Id
|
||||
range Node_Low_Bound .. Node_High_Bound;
|
||||
|
||||
subtype Elist_Range is Union_Id
|
||||
range Elist_Low_Bound .. Elist_High_Bound;
|
||||
|
||||
subtype Elmt_Range is Union_Id
|
||||
range Elmt_Low_Bound .. Elmt_High_Bound;
|
||||
|
||||
subtype Names_Range is Union_Id
|
||||
range Names_Low_Bound .. Names_High_Bound;
|
||||
|
||||
subtype Strings_Range is Union_Id
|
||||
range Strings_Low_Bound .. Strings_High_Bound;
|
||||
|
||||
subtype Uint_Range is Union_Id
|
||||
range Uint_Low_Bound .. Uint_High_Bound;
|
||||
|
||||
subtype Ureal_Range is Union_Id
|
||||
range Ureal_Low_Bound .. Ureal_High_Bound;
|
||||
|
||||
subtype Char_Code_Range is Union_Id
|
||||
range Char_Code_Bias .. Char_Code_Bias + 2**16 - 1;
|
||||
|
||||
-----------------------------
|
||||
-- Types for Namet Package --
|
||||
-----------------------------
|
||||
|
||||
-- Name_Id values are used to identify entries in the names table. Except
|
||||
-- for the special values No_Name, and Error_Name, they are subscript
|
||||
-- values for the Names table defined in package Namet.
|
||||
|
||||
-- Note that with only a few exceptions, which are clearly documented, the
|
||||
-- type Name_Id should be regarded as a private type. In particular it is
|
||||
-- never appropriate to perform arithmetic operations using this type.
|
||||
|
||||
type Name_Id is range Names_Low_Bound .. Names_High_Bound;
|
||||
for Name_Id'Size use 32;
|
||||
-- Type used to identify entries in the names table
|
||||
|
||||
No_Name : constant Name_Id := Names_Low_Bound;
|
||||
-- The special Name_Id value No_Name is used in the parser to indicate
|
||||
-- a situation where no name is present (e.g. on a loop or block).
|
||||
|
||||
Error_Name : constant Name_Id := Names_Low_Bound + 1;
|
||||
-- The special Name_Id value Error_Name is used in the parser to
|
||||
-- indicate that some kind of error was encountered in scanning out
|
||||
-- the relevant name, so it does not have a representable label.
|
||||
|
||||
First_Name_Id : constant Name_Id := Names_Low_Bound + 2;
|
||||
-- Subscript of first entry in names table
|
||||
|
||||
----------------------------
|
||||
-- Types for Atree Package --
|
||||
----------------------------
|
||||
|
||||
-- Node_Id values are used to identify nodes in the tree. They are
|
||||
-- subscripts into the Node table declared in package Tree. Note that
|
||||
-- the special values Empty and Error are subscripts into this table,
|
||||
-- See package Atree for further details.
|
||||
|
||||
type Node_Id is range Node_Low_Bound .. Node_High_Bound;
|
||||
-- Type used to identify nodes in the tree
|
||||
|
||||
subtype Entity_Id is Node_Id;
|
||||
-- A synonym for node types, used in the entity package to refer to
|
||||
-- nodes that are entities (i.e. nodes with an Nkind of N_Defining_xxx)
|
||||
-- All such nodes are extended nodes and these are the only extended
|
||||
-- nodes, so that in practice entity and extended nodes are synonymous.
|
||||
|
||||
subtype Node_Or_Entity_Id is Node_Id;
|
||||
-- A synonym for node types, used in cases where a given value may be used
|
||||
-- to represent either a node or an entity. We like to minimize such uses
|
||||
-- for obvious reasons of logical type consistency, but where such uses
|
||||
-- occur, they should be documented by use of this type.
|
||||
|
||||
Empty : constant Node_Id := Node_Low_Bound;
|
||||
-- Used to indicate null node. A node is actually allocated with this
|
||||
-- Id value, so that Nkind (Empty) = N_Empty. Note that Node_Low_Bound
|
||||
-- is zero, so Empty = No_List = zero.
|
||||
|
||||
Empty_List_Or_Node : constant := 0;
|
||||
-- This constant is used in situations (e.g. initializing empty fields)
|
||||
-- where the value set will be used to represent either an empty node
|
||||
-- or a non-existent list, depending on the context.
|
||||
|
||||
Error : constant Node_Id := Node_Low_Bound + 1;
|
||||
-- Used to indicate that there was an error in the source program. A node
|
||||
-- is actually allocated at this address, so that Nkind (Error) = N_Error.
|
||||
|
||||
Empty_Or_Error : constant Node_Id := Error;
|
||||
-- Since Empty and Error are the first two Node_Id values, the test for
|
||||
-- N <= Empty_Or_Error tests to see if N is Empty or Error. This definition
|
||||
-- provides convenient self-documentation for such tests.
|
||||
|
||||
First_Node_Id : constant Node_Id := Node_Low_Bound;
|
||||
-- Subscript of first allocated node. Note that Empty and Error are both
|
||||
-- allocated nodes, whose Nkind fields can be accessed without error.
|
||||
|
||||
------------------------------
|
||||
-- Types for Nlists Package --
|
||||
------------------------------
|
||||
|
||||
-- List_Id values are used to identify node lists in the tree. They are
|
||||
-- subscripts into the Lists table declared in package Tree. Note that
|
||||
-- the special value Error_List is a subscript in this table, but the
|
||||
-- value No_List is *not* a valid subscript, and any attempt to apply
|
||||
-- list operations to No_List will cause a (detected) error.
|
||||
|
||||
type List_Id is range List_Low_Bound .. List_High_Bound;
|
||||
-- Type used to identify a node list
|
||||
|
||||
No_List : constant List_Id := List_High_Bound;
|
||||
-- Used to indicate absence of a list. Note that the value is zero, which
|
||||
-- is the same as Empty, which is helpful in intializing nodes where a
|
||||
-- value of zero can represent either an empty node or an empty list.
|
||||
|
||||
Error_List : constant List_Id := List_Low_Bound;
|
||||
-- Used to indicate that there was an error in the source program in a
|
||||
-- context which would normally require a list. This node appears to be
|
||||
-- an empty list to the list operations (a null list is actually allocated
|
||||
-- which has this Id value).
|
||||
|
||||
First_List_Id : constant List_Id := Error_List;
|
||||
-- Subscript of first allocated list header
|
||||
|
||||
------------------------------
|
||||
-- Types for Elists Package --
|
||||
------------------------------
|
||||
|
||||
-- Element list Id values are used to identify element lists stored in
|
||||
-- the tree (see package Tree for further details). They are formed by
|
||||
-- adding a bias (Element_List_Bias) to subscript values in the same
|
||||
-- array that is used for node list headers.
|
||||
|
||||
type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound;
|
||||
-- Type used to identify an element list (Elist header table subscript)
|
||||
|
||||
No_Elist : constant Elist_Id := Elist_Low_Bound;
|
||||
-- Used to indicate absense of an element list. Note that this is not
|
||||
-- an actual Elist header, so element list operations on this value
|
||||
-- are not valid.
|
||||
|
||||
First_Elist_Id : constant Elist_Id := No_Elist + 1;
|
||||
-- Subscript of first allocated Elist header.
|
||||
|
||||
-- Element Id values are used to identify individual elements of an
|
||||
-- element list (see package Elists for further details).
|
||||
|
||||
type Elmt_Id is range Elmt_Low_Bound .. Elmt_High_Bound;
|
||||
-- Type used to identify an element list
|
||||
|
||||
No_Elmt : constant Elmt_Id := Elmt_Low_Bound;
|
||||
-- Used to represent empty element
|
||||
|
||||
First_Elmt_Id : constant Elmt_Id := No_Elmt + 1;
|
||||
-- Subscript of first allocated Elmt table entry
|
||||
|
||||
-------------------------------
|
||||
-- Types for Stringt Package --
|
||||
-------------------------------
|
||||
|
||||
-- String_Id values are used to identify entries in the strings table.
|
||||
-- They are subscripts into the strings table defined in package Strings.
|
||||
|
||||
-- Note that with only a few exceptions, which are clearly documented, the
|
||||
-- type String_Id should be regarded as a private type. In particular it is
|
||||
-- never appropriate to perform arithmetic operations using this type.
|
||||
|
||||
type String_Id is range Strings_Low_Bound .. Strings_High_Bound;
|
||||
-- Type used to identify entries in the strings table
|
||||
|
||||
No_String : constant String_Id := Strings_Low_Bound;
|
||||
-- Used to indicate missing string Id. Note that the value zero is used
|
||||
-- to indicate a missing data value for all the Int types in this section.
|
||||
|
||||
First_String_Id : constant String_Id := No_String + 1;
|
||||
-- First subscript allocated in string table
|
||||
|
||||
-------------------------
|
||||
-- Character Code Type --
|
||||
-------------------------
|
||||
|
||||
-- The type Char is used for character data internally in the compiler,
|
||||
-- but character codes in the source are represented by the Char_Code
|
||||
-- type. Each character literal in the source is interpreted as being one
|
||||
-- of the 2**16 possible Wide_Character codes, and a unique integer value
|
||||
-- is assigned, corresponding to the POS value in the Wide_Character type.
|
||||
-- String literals are similarly interpreted as a sequence of such codes.
|
||||
|
||||
-- Note: when character code values are stored in the tree, they are stored
|
||||
-- by adding a bias value (Char_Code_Bias) that results in values that can
|
||||
-- be distinguished from other types of values stored in the tree.
|
||||
|
||||
type Char_Code is mod 2 ** 16;
|
||||
for Char_Code'Size use 16;
|
||||
|
||||
function Get_Char_Code (C : Character) return Char_Code;
|
||||
pragma Inline (Get_Char_Code);
|
||||
-- Function to obtain internal character code from source character. For
|
||||
-- the moment, the internal character code is simply the Pos value of the
|
||||
-- input source character, but we provide this interface for possible
|
||||
-- later support of alternative character sets.
|
||||
|
||||
function In_Character_Range (C : Char_Code) return Boolean;
|
||||
pragma Inline (In_Character_Range);
|
||||
-- Determines if the given character code is in range of type Character,
|
||||
-- and if so, returns True. If not, returns False.
|
||||
|
||||
function Get_Character (C : Char_Code) return Character;
|
||||
pragma Inline (Get_Character);
|
||||
-- For a character C that is in character range (see above function), this
|
||||
-- function returns the corresponding Character value. It is an error to
|
||||
-- call Get_Character if C is not in character range
|
||||
|
||||
---------------------------------------
|
||||
-- Types used for Library Management --
|
||||
---------------------------------------
|
||||
|
||||
type Unit_Number_Type is new Int;
|
||||
-- Unit number. The main source is unit 0, and subsidiary sources have
|
||||
-- non-zero numbers starting with 1. Unit numbers are used to index the
|
||||
-- file table in Lib.
|
||||
|
||||
Main_Unit : constant Unit_Number_Type := 0;
|
||||
-- Unit number value for main unit
|
||||
|
||||
No_Unit : constant Unit_Number_Type := -1;
|
||||
-- Special value used to signal no unit
|
||||
|
||||
type Source_File_Index is new Nat;
|
||||
-- Type used to index the source file table (see package Sinput)
|
||||
|
||||
No_Source_File : constant Source_File_Index := 0;
|
||||
-- Value used to indicate no source file present
|
||||
|
||||
System_Source_File_Index : constant Source_File_Index := 1;
|
||||
-- Value used for source file table entry for system.ads, which is
|
||||
-- always the first source file read (see unit Targparm for details).
|
||||
|
||||
subtype File_Name_Type is Name_Id;
|
||||
-- File names are stored in the names table and this synonym is used to
|
||||
-- indicate that a Name_Id value is being used to hold a simple file
|
||||
-- name (which does not include any directory information).
|
||||
|
||||
No_File : constant File_Name_Type := File_Name_Type (No_Name);
|
||||
-- Constant used to indicate no file found
|
||||
|
||||
subtype Unit_Name_Type is Name_Id;
|
||||
-- Unit names are stored in the names table and this synonym is used to
|
||||
-- indicate that a Name_Id value is being used to hold a unit name.
|
||||
|
||||
-----------------------------------
|
||||
-- Representation of Time Stamps --
|
||||
-----------------------------------
|
||||
|
||||
-- All compiled units are marked with a time stamp which is derived from
|
||||
-- the source file (we assume that the host system has the concept of a
|
||||
-- file time stamp which is modified when a file is modified). These
|
||||
-- time stamps are used to ensure consistency of the set of units that
|
||||
-- constitutes a library. Time stamps are 12 character strings with
|
||||
-- with the following format:
|
||||
|
||||
-- YYYYMMDDHHMMSS
|
||||
|
||||
-- YYYY year
|
||||
-- MM month (2 digits 01-12)
|
||||
-- DD day (2 digits 01-31)
|
||||
-- HH hour (2 digits 00-23)
|
||||
-- MM minutes (2 digits 00-59)
|
||||
-- SS seconds (2 digits 00-59)
|
||||
|
||||
-- In the case of Unix systems (and other systems which keep the time in
|
||||
-- GMT), the time stamp is the GMT time of the file, not the local time.
|
||||
-- This solves problems in using libraries across networks with clients
|
||||
-- spread across multiple time-zones.
|
||||
|
||||
Time_Stamp_Length : constant := 14;
|
||||
-- Length of time stamp value
|
||||
|
||||
subtype Time_Stamp_Index is Natural range 1 .. Time_Stamp_Length;
|
||||
type Time_Stamp_Type is new String (Time_Stamp_Index);
|
||||
-- Type used to represent time stamp
|
||||
|
||||
Empty_Time_Stamp : constant Time_Stamp_Type := (others => ' ');
|
||||
-- Type used to represent an empty or missing time stamp. Looks less
|
||||
-- than any real time stamp if two time stamps are compared. Note that
|
||||
-- although this is not a private type, clients should not rely on the
|
||||
-- exact way in which this string is represented, and instead should
|
||||
-- use the subprograms below.
|
||||
|
||||
function "=" (Left, Right : Time_Stamp_Type) return Boolean;
|
||||
function "<=" (Left, Right : Time_Stamp_Type) return Boolean;
|
||||
function ">=" (Left, Right : Time_Stamp_Type) return Boolean;
|
||||
function "<" (Left, Right : Time_Stamp_Type) return Boolean;
|
||||
function ">" (Left, Right : Time_Stamp_Type) return Boolean;
|
||||
-- Comparison functions on time stamps. Note that two time stamps
|
||||
-- are defined as being equal if they have the same day/month/year
|
||||
-- and the hour/minutes/seconds values are within 2 seconds of one
|
||||
-- another. This deals with rounding effects in library file time
|
||||
-- stamps caused by copying operations during installation. We have
|
||||
-- particularly noticed that WinNT seems susceptible to such changes.
|
||||
-- Note: the Empty_Time_Stamp value looks equal to itself, and less
|
||||
-- than any non-empty time stamp value.
|
||||
|
||||
procedure Split_Time_Stamp
|
||||
(TS : Time_Stamp_Type;
|
||||
Year : out Nat;
|
||||
Month : out Nat;
|
||||
Day : out Nat;
|
||||
Hour : out Nat;
|
||||
Minutes : out Nat;
|
||||
Seconds : out Nat);
|
||||
-- Given a time stamp, decompose it into its components
|
||||
|
||||
procedure Make_Time_Stamp
|
||||
(Year : Nat;
|
||||
Month : Nat;
|
||||
Day : Nat;
|
||||
Hour : Nat;
|
||||
Minutes : Nat;
|
||||
Seconds : Nat;
|
||||
TS : out Time_Stamp_Type);
|
||||
-- Given the components of a time stamp, initialize the value
|
||||
|
||||
-----------------------------------------------
|
||||
-- Types used for Pragma Suppress Management --
|
||||
-----------------------------------------------
|
||||
|
||||
-- The following record contains an entry for each recognized check name
|
||||
-- for pragma Suppress. It is used to represent current settings of scope
|
||||
-- based suppress actions from pragma Suppress or command line settings.
|
||||
|
||||
type Suppress_Record is record
|
||||
Access_Checks : Boolean;
|
||||
Accessibility_Checks : Boolean;
|
||||
Discriminant_Checks : Boolean;
|
||||
Division_Checks : Boolean;
|
||||
Elaboration_Checks : Boolean;
|
||||
Index_Checks : Boolean;
|
||||
Length_Checks : Boolean;
|
||||
Overflow_Checks : Boolean;
|
||||
Range_Checks : Boolean;
|
||||
Storage_Checks : Boolean;
|
||||
Tag_Checks : Boolean;
|
||||
end record;
|
||||
|
||||
-- To add a new check type to GNAT, the following steps are required:
|
||||
|
||||
-- 1. Add an appropriate entry to the above record type
|
||||
-- 2. Add an entry to Snames spec and body for the new name
|
||||
-- 3. Add an entry to the definition of Check_Id in the Snames spec
|
||||
-- 4. Add a new entity flag definition in Einfo for the check
|
||||
-- 5. Add a new function to Sem.Util to handle the new check test
|
||||
-- 6. Add appropriate processing for pragma Suppress in Sem.Prag
|
||||
-- 7. Add a branch to the case statement in Sem.Ch8.Pop_Scope
|
||||
-- 8. Add a new Do_xxx_Check flag to Sinfo (if required)
|
||||
-- 9. Add appropriate checks for the new test
|
||||
|
||||
-----------------------------------
|
||||
-- Global Exception Declarations --
|
||||
-----------------------------------
|
||||
|
||||
-- This section contains declarations of exceptions that are used
|
||||
-- throughout the compiler.
|
||||
|
||||
Unrecoverable_Error : exception;
|
||||
-- This exception is raised to immediately terminate the compilation
|
||||
-- of the current source program. Used in situations where things are
|
||||
-- bad enough that it doesn't seem worth continuing (e.g. max errors
|
||||
-- reached, or a required file is not found). Also raised when the
|
||||
-- compiler finds itself in trouble after an error (see Comperr).
|
||||
|
||||
---------------------------------
|
||||
-- Parameter Mechanism Control --
|
||||
---------------------------------
|
||||
|
||||
-- Function and parameter entities have a field that records the
|
||||
-- passing mechanism. See specification of Sem_Mech for full details.
|
||||
-- The following subtype is used to represent values of this type:
|
||||
|
||||
subtype Mechanism_Type is Int range -10 .. Int'Last;
|
||||
-- Type used to represent a mechanism value. This is a subtype rather
|
||||
-- than a type to avoid some annoying processing problems with certain
|
||||
-- routines in Einfo (processing them to create the corresponding C).
|
||||
|
||||
end Types;
|
|
@ -0,0 +1,335 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNAT COMPILER COMPONENTS *
|
||||
* *
|
||||
* T Y P E S *
|
||||
* *
|
||||
* C Header File *
|
||||
* *
|
||||
* $Revision: 1.1 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001, 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 2, 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 COPYING. If not, write *
|
||||
* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
|
||||
* MA 02111-1307, USA. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
/* This is the C file that corresponds to the Ada package spec Types. It was
|
||||
created manually from the files types.ads and types.adb.
|
||||
|
||||
This package contains host independent type definitions which are used
|
||||
throughout the compiler modules. The comments in the C version are brief
|
||||
reminders of the purpose of each declaration. For complete documentation,
|
||||
see the Ada version of these definitions. */
|
||||
|
||||
/* Boolean Types: */
|
||||
|
||||
/* Boolean type (cannot use enum, because of bit field restriction on some
|
||||
compilers). */
|
||||
typedef unsigned char Boolean;
|
||||
#define False 0
|
||||
#define True 1
|
||||
|
||||
/* General Use Integer Types */
|
||||
|
||||
/* Signed 32/bit integer */
|
||||
typedef int Int;
|
||||
|
||||
/* Signed 16 bit integer */
|
||||
typedef short Short;
|
||||
|
||||
/* Non/negative Int values */
|
||||
typedef Int Nat;
|
||||
|
||||
/* Positive Int values */
|
||||
typedef Int Pos;
|
||||
|
||||
/* 8/bit unsigned integer */
|
||||
typedef char Byte;
|
||||
|
||||
/* 8/Bit Character and String Types: */
|
||||
|
||||
/* 8/bit character type */
|
||||
typedef char Char;
|
||||
|
||||
/* Graphic characters, as defined in ARM */
|
||||
typedef Char Graphic_Character;
|
||||
|
||||
/* Line terminator characters (LF, VT, FF, CR) */
|
||||
typedef Char Line_Terminator;
|
||||
|
||||
/* Characters with the upper bit set */
|
||||
typedef Char Upper_Half_Character;
|
||||
|
||||
/* String type built on Char (note that zero is an OK index) */
|
||||
typedef Char *Str;
|
||||
|
||||
/* Pointer to string of Chars */
|
||||
typedef Char *Str_Ptr;
|
||||
|
||||
/* Types for the fat pointer used for strings and the template it
|
||||
points to. */
|
||||
typedef struct {int Low_Bound, High_Bound; } String_Template;
|
||||
typedef struct {const char *Array; String_Template *Bounds; }
|
||||
__attribute ((aligned (sizeof (char *) * 2))) Fat_Pointer;
|
||||
|
||||
/* Types for Node/Entity Kinds: */
|
||||
|
||||
/* The reason that these are defined here in the C version, rather than in the
|
||||
corresponding packages is that the requirement for putting bodies of
|
||||
inlined stuff IN the C header changes the dependencies. Both a-sinfo.h
|
||||
and a-einfo.h now reference routines defined in tree.h.
|
||||
|
||||
Note: these types would more naturally be defined as unsigned char, but
|
||||
once again, the annoying restriction on bit fields for some compilers
|
||||
bites us! */
|
||||
|
||||
typedef unsigned int Node_Kind;
|
||||
typedef unsigned int Entity_Kind;
|
||||
|
||||
/* Types used for Text Buffer Handling: */
|
||||
|
||||
/* Type used for subscripts in text buffer. */
|
||||
typedef Int Text_Ptr;
|
||||
|
||||
/* Text buffer used to hold source file or library information file. */
|
||||
typedef Char *Text_Buffer;
|
||||
|
||||
/* Pointer to text buffer. */
|
||||
typedef Char *Text_Buffer_Ptr;
|
||||
|
||||
/* Types used for Source Input Handling: */
|
||||
|
||||
/* Line number type, used for storing all line numbers. */
|
||||
typedef Int Line_Number_Type;
|
||||
|
||||
/* Column number type, used for storing all column numbers. */
|
||||
typedef Int Column_Number_Type;
|
||||
|
||||
/* Type used to store text of a source file. */
|
||||
typedef Text_Buffer Source_Buffer;
|
||||
|
||||
/* Pointer to source buffer. */
|
||||
typedef Text_Buffer_Ptr Source_Buffer_Ptr;
|
||||
|
||||
/* Type used for source location. */
|
||||
typedef Text_Ptr Source_Ptr;
|
||||
|
||||
/* Value used to indicate no source position set. */
|
||||
#define No_Location -1
|
||||
|
||||
/* Used for Sloc in all nodes in the representation of package Standard. */
|
||||
#define Standard_Location -2
|
||||
|
||||
/* Type used for union of all possible ID values covering all ranges */
|
||||
typedef int Union_Id;
|
||||
|
||||
/* Range definitions for Tree Data: */
|
||||
|
||||
#define List_Low_Bound -100000000
|
||||
#define List_High_Bound 0
|
||||
|
||||
#define Node_Low_Bound 0
|
||||
#define Node_High_Bound 99999999
|
||||
|
||||
#define Elist_Low_Bound 100000000
|
||||
#define Elist_High_Bound 199999999
|
||||
|
||||
#define Elmt_Low_Bound 200000000
|
||||
#define Elmt_High_Bound 299999999
|
||||
|
||||
#define Names_Low_Bound 300000000
|
||||
#define Names_High_Bound 399999999
|
||||
|
||||
#define Strings_Low_Bound 400000000
|
||||
#define Strings_High_Bound 499999999
|
||||
|
||||
#define Ureal_Low_Bound 500000000
|
||||
#define Ureal_High_Bound 599999999
|
||||
|
||||
#define Uint_Low_Bound 600000000
|
||||
#define Uint_Table_Start 2000000000
|
||||
#define Uint_High_Bound 2099999999
|
||||
|
||||
#define Char_Code_Bias 2100000000
|
||||
|
||||
SUBTYPE (List_Range, Int, List_Low_Bound, List_High_Bound)
|
||||
SUBTYPE (Node_Range, Int, Node_Low_Bound, Node_High_Bound)
|
||||
SUBTYPE (Elist_Range, Int, Elist_Low_Bound, Elist_High_Bound)
|
||||
SUBTYPE (Elmt_Range, Int, Elmt_Low_Bound, Elmt_High_Bound)
|
||||
SUBTYPE (Names_Range, Int, Names_Low_Bound, Names_High_Bound)
|
||||
SUBTYPE (Strings_Range, Int, Strings_Low_Bound, Strings_High_Bound)
|
||||
SUBTYPE (Uint_Range, Int, Uint_Low_Bound, Uint_High_Bound)
|
||||
SUBTYPE (Ureal_Range, Int, Ureal_Low_Bound, Ureal_High_Bound)
|
||||
SUBTYPE (Char_Code_Range, Int, Char_Code_Bias, (Char_Code_Bias + 65535))
|
||||
|
||||
/* Types for Names_Table Package: */
|
||||
|
||||
typedef Int Name_Id;
|
||||
|
||||
/* Name_Id value for no name present. */
|
||||
#define No_Name Names_Low_Bound
|
||||
|
||||
/* Name_Id value for bad name. */
|
||||
#define Error_Name (Names_Low_Bound + 1)
|
||||
|
||||
/* First subscript of names table. */
|
||||
#define First_Name_Id (Names_Low_Bound + 2)
|
||||
|
||||
/* Types for Tree Package: */
|
||||
|
||||
/* Subscript of nodes table entry. */
|
||||
typedef Int Node_Id;
|
||||
|
||||
/* Used in semantics for Node_Id value referencing an entity. */
|
||||
typedef Node_Id Entity_Id;
|
||||
|
||||
/* Null node. */
|
||||
#define Empty 0
|
||||
|
||||
/* Error node. */
|
||||
#define Error 1
|
||||
|
||||
/* Subscript of first allocated node. */
|
||||
#define First_Node_Id Empty
|
||||
|
||||
/* Subscript of entry in lists table. */
|
||||
typedef Int List_Id;
|
||||
|
||||
/* Indicates absence of a list. */
|
||||
#define No_List 0
|
||||
|
||||
/* Error list. */
|
||||
#define Error_List List_Low_Bound
|
||||
|
||||
/* Subscript of first allocated list header. */
|
||||
#define First_List_Id Error_List
|
||||
|
||||
/* Element list Id, subscript value of entry in lists table. */
|
||||
typedef Int Elist_Id;
|
||||
|
||||
/* Used to indicate absence of an element list. */
|
||||
#define No_Elist Elist_Low_Bound
|
||||
|
||||
/* Subscript of first allocated elist header */
|
||||
#define First_Elist_Id (No_Elist + 1)
|
||||
|
||||
/* Element Id, subscript value of entry in elements table. */
|
||||
typedef Int Elmt_Id;
|
||||
|
||||
/* Used to indicate absence of a list element. */
|
||||
#define No_Elmt Elmt_Low_Bound
|
||||
|
||||
/* Subscript of first allocated element */
|
||||
#define First_Elmt_Id (No_Elmt + 1)
|
||||
|
||||
/* Types for String_Table Package: */
|
||||
|
||||
/* Subscript of strings table entry. */
|
||||
typedef Int String_Id;
|
||||
|
||||
/* Used to indicate missing string Id. */
|
||||
#define No_String Strings_Low_Bound
|
||||
|
||||
/* Subscript of first entry in strings table. */
|
||||
#define First_String_Id (No_String + 1)
|
||||
|
||||
/* Types for Uint_Support Package: */
|
||||
|
||||
/* Type used for representation of universal integers. */
|
||||
typedef Int Uint;
|
||||
|
||||
/* Used to indicate missing Uint value. */
|
||||
#define No_Uint Uint_Low_Bound
|
||||
|
||||
/* Base value used to represent Uint values. */
|
||||
#define Base 32768
|
||||
|
||||
/* Minimum and maximum integers directly representable as Uint values */
|
||||
#define Min_Direct (-(Base - 1))
|
||||
#define Max_Direct ((Base - 1) * (Base - 1))
|
||||
|
||||
#define Uint_Direct_Bias (Uint_Low_Bound + Base)
|
||||
#define Uint_Direct_First (Uint_Direct_Bias + Min_Direct)
|
||||
#define Uint_Direct_Last (Uint_Direct_Bias + Max_Direct)
|
||||
|
||||
/* Define range of direct biased values */
|
||||
SUBTYPE (Uint_Direct, Uint, Uint_Direct_First, Uint_Direct_Last)
|
||||
|
||||
/* Constants in Uint format. */
|
||||
#define Uint_0 (Uint_Direct_Bias + 0)
|
||||
#define Uint_1 (Uint_Direct_Bias + 1)
|
||||
#define Uint_2 (Uint_Direct_Bias + 2)
|
||||
#define Uint_10 (Uint_Direct_Bias + 10)
|
||||
#define Uint_16 (Uint_Direct_Bias + 16)
|
||||
|
||||
/* Types for Ureal_Support Package: */
|
||||
|
||||
/* Type used for representation of universal reals. */
|
||||
typedef Int Ureal;
|
||||
|
||||
/* Used to indicate missing Uint value. */
|
||||
#define No_Ureal Ureal_Low_Bound
|
||||
|
||||
/* Subscript of first entry in Ureal table. */
|
||||
#define Ureal_First_Entry (No_Ureal + 1)
|
||||
|
||||
/* Character Code Type: */
|
||||
|
||||
/* Character code value, intended to be 16 bits. */
|
||||
typedef short Char_Code;
|
||||
|
||||
/* Types Used for Library Management: */
|
||||
|
||||
/* Unit number. */
|
||||
typedef Int Unit_Number_Type;
|
||||
|
||||
/* Unit number value for main unit. */
|
||||
#define Main_Unit 0
|
||||
|
||||
/* Type used for lines table. */
|
||||
typedef Source_Ptr *Lines_Table_Type;
|
||||
|
||||
/* Type used for pointer to lines table. */
|
||||
typedef Source_Ptr *Lines_Table_Ptr;
|
||||
|
||||
/* Length of time stamp value. */
|
||||
#define Time_Stamp_Length 22
|
||||
|
||||
/* Type used to represent time stamp. */
|
||||
typedef Char *Time_Stamp_Type;
|
||||
|
||||
/* Name_Id synonym used for file names. */
|
||||
typedef Name_Id File_Name_Type;
|
||||
|
||||
/* Constant used to indicate no file found. */
|
||||
#define No_File No_Name
|
||||
|
||||
/* Name_Id synonym used for unit names. */
|
||||
typedef Name_Id Unit_Name_Type;
|
||||
|
||||
/* Definitions for mechanism type and values */
|
||||
typedef Int Mechanism_Type;
|
||||
#define Default 0
|
||||
#define By_Copy (-1)
|
||||
#define By_Reference (-2)
|
||||
#define By_Descriptor (-3)
|
||||
#define By_Descriptor_UBS (-4)
|
||||
#define By_Descriptor_UBSB (-5)
|
||||
#define By_Descriptor_UBA (-6)
|
||||
#define By_Descriptor_S (-7)
|
||||
#define By_Descriptor_SB (-8)
|
||||
#define By_Descriptor_A (-9)
|
||||
#define By_Descriptor_NCA (-10)
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,505 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- U I N T P --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.58 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001, 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Support for universal integer arithmetic
|
||||
|
||||
-- WARNING: There is a C version of this package. Any changes to this
|
||||
-- source file must be properly reflected in the C header file sinfo.h
|
||||
|
||||
with Alloc;
|
||||
with Table;
|
||||
with Types; use Types;
|
||||
|
||||
package Uintp is
|
||||
|
||||
-------------------------------------------------
|
||||
-- Basic Types and Constants for Uintp Package --
|
||||
-------------------------------------------------
|
||||
|
||||
type Uint is private;
|
||||
-- The basic universal integer type
|
||||
|
||||
No_Uint : constant Uint;
|
||||
-- A constant value indicating a missing or unset Uint value
|
||||
|
||||
Uint_0 : constant Uint;
|
||||
Uint_1 : constant Uint;
|
||||
Uint_2 : constant Uint;
|
||||
Uint_3 : constant Uint;
|
||||
Uint_4 : constant Uint;
|
||||
Uint_5 : constant Uint;
|
||||
Uint_6 : constant Uint;
|
||||
Uint_7 : constant Uint;
|
||||
Uint_8 : constant Uint;
|
||||
Uint_9 : constant Uint;
|
||||
Uint_10 : constant Uint;
|
||||
Uint_12 : constant Uint;
|
||||
Uint_15 : constant Uint;
|
||||
Uint_16 : constant Uint;
|
||||
Uint_24 : constant Uint;
|
||||
Uint_32 : constant Uint;
|
||||
Uint_63 : constant Uint;
|
||||
Uint_64 : constant Uint;
|
||||
Uint_128 : constant Uint;
|
||||
|
||||
Uint_Minus_1 : constant Uint;
|
||||
Uint_Minus_2 : constant Uint;
|
||||
Uint_Minus_3 : constant Uint;
|
||||
Uint_Minus_4 : constant Uint;
|
||||
Uint_Minus_5 : constant Uint;
|
||||
Uint_Minus_6 : constant Uint;
|
||||
Uint_Minus_7 : constant Uint;
|
||||
Uint_Minus_8 : constant Uint;
|
||||
Uint_Minus_9 : constant Uint;
|
||||
Uint_Minus_12 : constant Uint;
|
||||
Uint_Minus_128 : constant Uint;
|
||||
|
||||
-----------------
|
||||
-- Subprograms --
|
||||
-----------------
|
||||
|
||||
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
|
||||
-- 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 Tree_Read.
|
||||
-- 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 Tree_Write.
|
||||
|
||||
function UI_Abs (Right : Uint) return Uint;
|
||||
pragma Inline (UI_Abs);
|
||||
-- Returns abs function of universal integer.
|
||||
|
||||
function UI_Add (Left : Uint; Right : Uint) return Uint;
|
||||
function UI_Add (Left : Int; Right : Uint) return Uint;
|
||||
function UI_Add (Left : Uint; Right : Int) return Uint;
|
||||
-- Returns sum of two integer values.
|
||||
|
||||
function UI_Decimal_Digits_Hi (U : Uint) return Nat;
|
||||
-- Returns an estimate of the number of decimal digits required to
|
||||
-- represent the absolute value of U. This estimate is correct or high,
|
||||
-- i.e. it never returns a value that is too low. The accuracy of the
|
||||
-- estimate affects only the effectiveness of comparison optimizations
|
||||
-- in Urealp.
|
||||
|
||||
function UI_Decimal_Digits_Lo (U : Uint) return Nat;
|
||||
-- Returns an estimate of the number of decimal digits required to
|
||||
-- represent the absolute value of U. This estimate is correct or low,
|
||||
-- i.e. it never returns a value that is too high. The accuracy of the
|
||||
-- estimate affects only the effectiveness of comparison optimizations
|
||||
-- in Urealp.
|
||||
|
||||
function UI_Div (Left : Uint; Right : Uint) return Uint;
|
||||
function UI_Div (Left : Int; Right : Uint) return Uint;
|
||||
function UI_Div (Left : Uint; Right : Int) return Uint;
|
||||
-- Returns quotient of two integer values. Fatal error if Right = 0
|
||||
|
||||
function UI_Eq (Left : Uint; Right : Uint) return Boolean;
|
||||
function UI_Eq (Left : Int; Right : Uint) return Boolean;
|
||||
function UI_Eq (Left : Uint; Right : Int) return Boolean;
|
||||
pragma Inline (UI_Eq);
|
||||
-- Compares integer values for equality.
|
||||
|
||||
function UI_Expon (Left : Uint; Right : Uint) return Uint;
|
||||
function UI_Expon (Left : Int; Right : Uint) return Uint;
|
||||
function UI_Expon (Left : Uint; Right : Int) return Uint;
|
||||
function UI_Expon (Left : Int; Right : Int) return Uint;
|
||||
-- Returns result of exponentiating two integer values
|
||||
-- Fatal error if Right is negative.
|
||||
|
||||
function UI_GCD (Uin, Vin : Uint) return Uint;
|
||||
-- Computes GCD of input values. Assumes Uin >= Vin >= 0.
|
||||
|
||||
function UI_Ge (Left : Uint; Right : Uint) return Boolean;
|
||||
function UI_Ge (Left : Int; Right : Uint) return Boolean;
|
||||
function UI_Ge (Left : Uint; Right : Int) return Boolean;
|
||||
pragma Inline (UI_Ge);
|
||||
-- Compares integer values for greater than or equal.
|
||||
|
||||
function UI_Gt (Left : Uint; Right : Uint) return Boolean;
|
||||
function UI_Gt (Left : Int; Right : Uint) return Boolean;
|
||||
function UI_Gt (Left : Uint; Right : Int) return Boolean;
|
||||
pragma Inline (UI_Gt);
|
||||
-- Compares integer values for greater than.
|
||||
|
||||
function UI_Is_In_Int_Range (Input : Uint) return Boolean;
|
||||
pragma Inline (UI_Is_In_Int_Range);
|
||||
-- Determines if universal integer is in Int range.
|
||||
|
||||
function UI_Le (Left : Uint; Right : Uint) return Boolean;
|
||||
function UI_Le (Left : Int; Right : Uint) return Boolean;
|
||||
function UI_Le (Left : Uint; Right : Int) return Boolean;
|
||||
pragma Inline (UI_Le);
|
||||
-- Compares integer values for less than or equal.
|
||||
|
||||
function UI_Lt (Left : Uint; Right : Uint) return Boolean;
|
||||
function UI_Lt (Left : Int; Right : Uint) return Boolean;
|
||||
function UI_Lt (Left : Uint; Right : Int) return Boolean;
|
||||
-- Compares integer values for less than.
|
||||
|
||||
function UI_Max (Left : Uint; Right : Uint) return Uint;
|
||||
function UI_Max (Left : Int; Right : Uint) return Uint;
|
||||
function UI_Max (Left : Uint; Right : Int) return Uint;
|
||||
-- Returns maximum of two integer values
|
||||
|
||||
function UI_Min (Left : Uint; Right : Uint) return Uint;
|
||||
function UI_Min (Left : Int; Right : Uint) return Uint;
|
||||
function UI_Min (Left : Uint; Right : Int) return Uint;
|
||||
-- Returns minimum of two integer values.
|
||||
|
||||
function UI_Mod (Left : Uint; Right : Uint) return Uint;
|
||||
function UI_Mod (Left : Int; Right : Uint) return Uint;
|
||||
function UI_Mod (Left : Uint; Right : Int) return Uint;
|
||||
pragma Inline (UI_Mod);
|
||||
-- Returns mod function of two integer values.
|
||||
|
||||
function UI_Mul (Left : Uint; Right : Uint) return Uint;
|
||||
function UI_Mul (Left : Int; Right : Uint) return Uint;
|
||||
function UI_Mul (Left : Uint; Right : Int) return Uint;
|
||||
-- Returns product of two integer values
|
||||
|
||||
function UI_Ne (Left : Uint; Right : Uint) return Boolean;
|
||||
function UI_Ne (Left : Int; Right : Uint) return Boolean;
|
||||
function UI_Ne (Left : Uint; Right : Int) return Boolean;
|
||||
pragma Inline (UI_Ne);
|
||||
-- Compares integer values for inequality.
|
||||
|
||||
function UI_Negate (Right : Uint) return Uint;
|
||||
pragma Inline (UI_Negate);
|
||||
-- Returns negative of universal integer.
|
||||
|
||||
function UI_Rem (Left : Uint; Right : Uint) return Uint;
|
||||
function UI_Rem (Left : Int; Right : Uint) return Uint;
|
||||
function UI_Rem (Left : Uint; Right : Int) return Uint;
|
||||
-- Returns rem of two integer values.
|
||||
|
||||
function UI_Sub (Left : Uint; Right : Uint) return Uint;
|
||||
function UI_Sub (Left : Int; Right : Uint) return Uint;
|
||||
function UI_Sub (Left : Uint; Right : Int) return Uint;
|
||||
pragma Inline (UI_Sub);
|
||||
-- Returns difference of two integer values
|
||||
|
||||
function UI_From_Dint (Input : Dint) return Uint;
|
||||
-- Converts Dint value to universal integer form.
|
||||
|
||||
function UI_From_Int (Input : Int) return Uint;
|
||||
-- Converts Int value to universal integer form.
|
||||
|
||||
function UI_To_Int (Input : Uint) return Int;
|
||||
-- Converts universal integer value to Int. Fatal error
|
||||
-- if value is not in appropriate range.
|
||||
|
||||
function Num_Bits (Input : Uint) return Nat;
|
||||
-- Approximate number of binary bits in given universal integer.
|
||||
-- This function is used for capacity checks, and it can be one
|
||||
-- bit off without affecting its usage.
|
||||
|
||||
---------------------
|
||||
-- Output Routines --
|
||||
---------------------
|
||||
|
||||
type UI_Format is (Hex, Decimal, Auto);
|
||||
-- Used to determine whether UI_Image/UI_Write output is in hexadecimal
|
||||
-- or decimal format. Auto, the default setting, lets the routine make
|
||||
-- a decision based on the value.
|
||||
|
||||
UI_Image_Max : constant := 32;
|
||||
UI_Image_Buffer : String (1 .. UI_Image_Max);
|
||||
UI_Image_Length : Natural;
|
||||
-- Buffer used for UI_Image as described below
|
||||
|
||||
procedure UI_Image (Input : Uint; Format : UI_Format := Auto);
|
||||
-- Places a representation of Uint, consisting of a possible minus sign,
|
||||
-- followed by the value in UI_Image_Buffer. The form of the value is an
|
||||
-- integer literal in either decimal (no base) or hexadecimal (base 16)
|
||||
-- format. If Hex is True on entry, then hex mode is forced, otherwise
|
||||
-- UI_Image makes a guess at which output format is more convenient. The
|
||||
-- value must fit in UI_Image_Buffer. If necessary, the result is an
|
||||
-- approximation of the proper value, using an exponential format. The
|
||||
-- image of No_Uint is output as a single question mark.
|
||||
|
||||
procedure UI_Write (Input : Uint; Format : UI_Format := Auto);
|
||||
-- Writes a representation of Uint, consisting of a possible minus sign,
|
||||
-- followed by the value to the output file. The form of the value is an
|
||||
-- integer literal in either decimal (no base) or hexadecimal (base 16)
|
||||
-- format as appropriate. UI_Format shows which format to use. Auto,
|
||||
-- the default, asks UI_Write to make a guess at which output format
|
||||
-- will be more convenient to read.
|
||||
|
||||
procedure pid (Input : Uint);
|
||||
-- Writes representation of Uint in decimal with a terminating line
|
||||
-- return. This is intended for use from the debugger.
|
||||
|
||||
procedure pih (Input : Uint);
|
||||
-- Writes representation of Uint in hex with a terminating line return.
|
||||
-- This is intended for use from the debugger.
|
||||
|
||||
------------------------
|
||||
-- Operator Renamings --
|
||||
------------------------
|
||||
|
||||
function "+" (Left : Uint; Right : Uint) return Uint renames UI_Add;
|
||||
function "+" (Left : Int; Right : Uint) return Uint renames UI_Add;
|
||||
function "+" (Left : Uint; Right : Int) return Uint renames UI_Add;
|
||||
|
||||
function "/" (Left : Uint; Right : Uint) return Uint renames UI_Div;
|
||||
function "/" (Left : Int; Right : Uint) return Uint renames UI_Div;
|
||||
function "/" (Left : Uint; Right : Int) return Uint renames UI_Div;
|
||||
|
||||
function "*" (Left : Uint; Right : Uint) return Uint renames UI_Mul;
|
||||
function "*" (Left : Int; Right : Uint) return Uint renames UI_Mul;
|
||||
function "*" (Left : Uint; Right : Int) return Uint renames UI_Mul;
|
||||
|
||||
function "-" (Left : Uint; Right : Uint) return Uint renames UI_Sub;
|
||||
function "-" (Left : Int; Right : Uint) return Uint renames UI_Sub;
|
||||
function "-" (Left : Uint; Right : Int) return Uint renames UI_Sub;
|
||||
|
||||
function "**" (Left : Uint; Right : Uint) return Uint renames UI_Expon;
|
||||
function "**" (Left : Uint; Right : Int) return Uint renames UI_Expon;
|
||||
function "**" (Left : Int; Right : Uint) return Uint renames UI_Expon;
|
||||
function "**" (Left : Int; Right : Int) return Uint renames UI_Expon;
|
||||
|
||||
function "abs" (Real : Uint) return Uint renames UI_Abs;
|
||||
|
||||
function "mod" (Left : Uint; Right : Uint) return Uint renames UI_Mod;
|
||||
function "mod" (Left : Int; Right : Uint) return Uint renames UI_Mod;
|
||||
function "mod" (Left : Uint; Right : Int) return Uint renames UI_Mod;
|
||||
|
||||
function "rem" (Left : Uint; Right : Uint) return Uint renames UI_Rem;
|
||||
function "rem" (Left : Int; Right : Uint) return Uint renames UI_Rem;
|
||||
function "rem" (Left : Uint; Right : Int) return Uint renames UI_Rem;
|
||||
|
||||
function "-" (Real : Uint) return Uint renames UI_Negate;
|
||||
|
||||
function "=" (Left : Uint; Right : Uint) return Boolean renames UI_Eq;
|
||||
function "=" (Left : Int; Right : Uint) return Boolean renames UI_Eq;
|
||||
function "=" (Left : Uint; Right : Int) return Boolean renames UI_Eq;
|
||||
|
||||
function ">=" (Left : Uint; Right : Uint) return Boolean renames UI_Ge;
|
||||
function ">=" (Left : Int; Right : Uint) return Boolean renames UI_Ge;
|
||||
function ">=" (Left : Uint; Right : Int) return Boolean renames UI_Ge;
|
||||
|
||||
function ">" (Left : Uint; Right : Uint) return Boolean renames UI_Gt;
|
||||
function ">" (Left : Int; Right : Uint) return Boolean renames UI_Gt;
|
||||
function ">" (Left : Uint; Right : Int) return Boolean renames UI_Gt;
|
||||
|
||||
function "<=" (Left : Uint; Right : Uint) return Boolean renames UI_Le;
|
||||
function "<=" (Left : Int; Right : Uint) return Boolean renames UI_Le;
|
||||
function "<=" (Left : Uint; Right : Int) return Boolean renames UI_Le;
|
||||
|
||||
function "<" (Left : Uint; Right : Uint) return Boolean renames UI_Lt;
|
||||
function "<" (Left : Int; Right : Uint) return Boolean renames UI_Lt;
|
||||
function "<" (Left : Uint; Right : Int) return Boolean renames UI_Lt;
|
||||
|
||||
-----------------------------
|
||||
-- Mark/Release Processing --
|
||||
-----------------------------
|
||||
|
||||
-- The space used by Uint data is not automatically reclaimed. However,
|
||||
-- a mark-release regime is implemented which allows storage to be
|
||||
-- released back to a previously noted mark. This is used for example
|
||||
-- when doing comparisons, where only intermediate results get stored
|
||||
-- that do not need to be saved for future use.
|
||||
|
||||
type Save_Mark is private;
|
||||
|
||||
function Mark return Save_Mark;
|
||||
-- Note mark point for future release
|
||||
|
||||
procedure Release (M : Save_Mark);
|
||||
-- Release storage allocated since mark was noted
|
||||
|
||||
procedure Release_And_Save (M : Save_Mark; UI : in out Uint);
|
||||
-- Like Release, except that the given Uint value (which is typically
|
||||
-- among the data being released) is recopied after the release, so
|
||||
-- that it is the most recent item, and UI is updated to point to
|
||||
-- its copied location.
|
||||
|
||||
procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Uint);
|
||||
-- Like Release, except that the given Uint values (which are typically
|
||||
-- among the data being released) are recopied after the release, so
|
||||
-- that they are the most recent items, and UI1 and UI2 are updated if
|
||||
-- necessary to point to the copied locations. This routine is careful
|
||||
-- to do things in the right order, so that the values do not clobber
|
||||
-- one another.
|
||||
|
||||
-----------------------------------
|
||||
-- Representation of Uint Values --
|
||||
-----------------------------------
|
||||
|
||||
private
|
||||
|
||||
type Uint is new Int range Uint_Low_Bound .. Uint_High_Bound;
|
||||
for Uint'Size use 32;
|
||||
|
||||
No_Uint : constant Uint := Uint (Uint_Low_Bound);
|
||||
|
||||
-- Uint values are represented as multiple precision integers stored in
|
||||
-- a multi-digit format using Base as the base. This value is chosen so
|
||||
-- that the product Base*Base is within the range of allowed Int values.
|
||||
|
||||
-- Base is defined to allow efficient execution of the primitive
|
||||
-- operations (a0, b0, c0) defined in the section "The Classical
|
||||
-- Algorithms" (sec. 4.3.1) of Donald Knuth's "The Art of Computer
|
||||
-- Programming", Vol. 2. These algorithms are used in this package.
|
||||
|
||||
Base_Bits : constant := 15;
|
||||
-- Number of bits in base value
|
||||
|
||||
Base : constant Int := 2 ** Base_Bits;
|
||||
|
||||
-- Values in the range -(Base+1) .. maxdirect are encoded directly as
|
||||
-- Uint values by adding a bias value. The value of maxdirect is chosen
|
||||
-- so that a directly represented number always fits in two digits when
|
||||
-- represented in base format.
|
||||
|
||||
Min_Direct : constant Int := -(Base - 1);
|
||||
Max_Direct : constant Int := (Base - 1) * (Base - 1);
|
||||
|
||||
-- The following values define the bias used to store Uint values which
|
||||
-- are in this range, as well as the biased values for the first and
|
||||
-- last values in this range. We use a new derived type for these
|
||||
-- constants to avoid accidental use of Uint arithmetic on these
|
||||
-- values, which is never correct.
|
||||
|
||||
type Ctrl is range Int'First .. Int'Last;
|
||||
|
||||
Uint_Direct_Bias : constant Ctrl := Ctrl (Uint_Low_Bound) + Ctrl (Base);
|
||||
Uint_Direct_First : constant Ctrl := Uint_Direct_Bias + Ctrl (Min_Direct);
|
||||
Uint_Direct_Last : constant Ctrl := Uint_Direct_Bias + Ctrl (Max_Direct);
|
||||
|
||||
Uint_0 : constant Uint := Uint (Uint_Direct_Bias);
|
||||
Uint_1 : constant Uint := Uint (Uint_Direct_Bias + 1);
|
||||
Uint_2 : constant Uint := Uint (Uint_Direct_Bias + 2);
|
||||
Uint_3 : constant Uint := Uint (Uint_Direct_Bias + 3);
|
||||
Uint_4 : constant Uint := Uint (Uint_Direct_Bias + 4);
|
||||
Uint_5 : constant Uint := Uint (Uint_Direct_Bias + 5);
|
||||
Uint_6 : constant Uint := Uint (Uint_Direct_Bias + 6);
|
||||
Uint_7 : constant Uint := Uint (Uint_Direct_Bias + 7);
|
||||
Uint_8 : constant Uint := Uint (Uint_Direct_Bias + 8);
|
||||
Uint_9 : constant Uint := Uint (Uint_Direct_Bias + 9);
|
||||
Uint_10 : constant Uint := Uint (Uint_Direct_Bias + 10);
|
||||
Uint_12 : constant Uint := Uint (Uint_Direct_Bias + 12);
|
||||
Uint_15 : constant Uint := Uint (Uint_Direct_Bias + 15);
|
||||
Uint_16 : constant Uint := Uint (Uint_Direct_Bias + 16);
|
||||
Uint_24 : constant Uint := Uint (Uint_Direct_Bias + 24);
|
||||
Uint_32 : constant Uint := Uint (Uint_Direct_Bias + 32);
|
||||
Uint_63 : constant Uint := Uint (Uint_Direct_Bias + 63);
|
||||
Uint_64 : constant Uint := Uint (Uint_Direct_Bias + 64);
|
||||
Uint_128 : constant Uint := Uint (Uint_Direct_Bias + 128);
|
||||
|
||||
Uint_Minus_1 : constant Uint := Uint (Uint_Direct_Bias - 1);
|
||||
Uint_Minus_2 : constant Uint := Uint (Uint_Direct_Bias - 2);
|
||||
Uint_Minus_3 : constant Uint := Uint (Uint_Direct_Bias - 3);
|
||||
Uint_Minus_4 : constant Uint := Uint (Uint_Direct_Bias - 4);
|
||||
Uint_Minus_5 : constant Uint := Uint (Uint_Direct_Bias - 5);
|
||||
Uint_Minus_6 : constant Uint := Uint (Uint_Direct_Bias - 6);
|
||||
Uint_Minus_7 : constant Uint := Uint (Uint_Direct_Bias - 7);
|
||||
Uint_Minus_8 : constant Uint := Uint (Uint_Direct_Bias - 8);
|
||||
Uint_Minus_9 : constant Uint := Uint (Uint_Direct_Bias - 9);
|
||||
Uint_Minus_12 : constant Uint := Uint (Uint_Direct_Bias - 12);
|
||||
Uint_Minus_128 : constant Uint := Uint (Uint_Direct_Bias - 128);
|
||||
|
||||
type Save_Mark is record
|
||||
Save_Uint : Uint;
|
||||
Save_Udigit : Int;
|
||||
end record;
|
||||
|
||||
-- Values outside the range that is represented directly are stored
|
||||
-- using two tables. The secondary table Udigits contains sequences of
|
||||
-- Int values consisting of the digits of the number in a radix Base
|
||||
-- system. The digits are stored from most significant to least
|
||||
-- significant with the first digit only carrying the sign.
|
||||
|
||||
-- There is one entry in the primary Uints table for each distinct Uint
|
||||
-- value. This table entry contains the length (number of digits) and
|
||||
-- a starting offset of the value in the Udigits table.
|
||||
|
||||
Uint_First_Entry : constant Uint := Uint (Uint_Table_Start);
|
||||
|
||||
-- Some subprograms defined in this package manipulate the Udigits
|
||||
-- table directly, while for others it is more convenient to work with
|
||||
-- locally defined arrays of the digits of the Universal Integers.
|
||||
-- The type UI_Vector is defined for this purpose and some internal
|
||||
-- subprograms used for converting from one to the other are defined.
|
||||
|
||||
type UI_Vector is array (Pos range <>) of Int;
|
||||
-- Vector containing the integer values of a Uint value
|
||||
|
||||
-- Note: An earlier version of this package used pointers of arrays
|
||||
-- of Ints (dynamically allocated) for the Uint type. The change
|
||||
-- leads to a few less natural idioms used throughout this code, but
|
||||
-- eliminates all uses of the heap except for the table package itself.
|
||||
-- For example, Uint parameters are often converted to UI_Vectors for
|
||||
-- internal manipulation. This is done by creating the local UI_Vector
|
||||
-- using the function N_Digits on the Uint to find the size needed for
|
||||
-- the vector, and then calling Init_Operand to copy the values out
|
||||
-- of the table into the vector.
|
||||
|
||||
type Uint_Entry is record
|
||||
Length : Pos;
|
||||
-- Length of entry in Udigits table in digits (i.e. in words)
|
||||
|
||||
Loc : Int;
|
||||
-- Starting location in Udigits table of this Uint value
|
||||
end record;
|
||||
|
||||
package Uints is new Table.Table (
|
||||
Table_Component_Type => Uint_Entry,
|
||||
Table_Index_Type => Uint,
|
||||
Table_Low_Bound => Uint_First_Entry,
|
||||
Table_Initial => Alloc.Uints_Initial,
|
||||
Table_Increment => Alloc.Uints_Increment,
|
||||
Table_Name => "Uints");
|
||||
|
||||
package Udigits is new Table.Table (
|
||||
Table_Component_Type => Int,
|
||||
Table_Index_Type => Int,
|
||||
Table_Low_Bound => 0,
|
||||
Table_Initial => Alloc.Udigits_Initial,
|
||||
Table_Increment => Alloc.Udigits_Increment,
|
||||
Table_Name => "Udigits");
|
||||
|
||||
-- Note: the reason these tables are defined here in the private part of
|
||||
-- the spec, rather than in the body, is that they are refrerenced
|
||||
-- directly by gigi.
|
||||
|
||||
end Uintp;
|
|
@ -0,0 +1,75 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNAT COMPILER COMPONENTS *
|
||||
* *
|
||||
* U I N T P *
|
||||
* *
|
||||
* C Header File *
|
||||
* *
|
||||
* $Revision: 1.1 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001, 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 2, 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 COPYING. If not, write *
|
||||
* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
|
||||
* MA 02111-1307, USA. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
/* This file corresponds to the Ada package specification Uintp. It was
|
||||
created manually from the files uintp.ads and uintp.adb */
|
||||
|
||||
/* Support for universal integer arithmetic */
|
||||
|
||||
struct Uint_Entry
|
||||
{
|
||||
Pos Length;
|
||||
Int Loc;
|
||||
};
|
||||
|
||||
/* See if a Uint is within the range of an integer. */
|
||||
#define UI_Is_In_Int_Range uintp__ui_is_in_int_range
|
||||
extern Boolean UI_Is_In_Int_Range PARAMS((Uint));
|
||||
|
||||
/* Obtain Int value from Uint input. This will abort if the result is
|
||||
out of range. */
|
||||
#define UI_To_Int uintp__ui_to_int
|
||||
extern Int UI_To_Int PARAMS((Uint));
|
||||
|
||||
/* Convert an Int into a Uint. */
|
||||
#define UI_From_Int uintp__ui_from_int
|
||||
extern Uint UI_From_Int PARAMS((int));
|
||||
|
||||
/* Similarly, but return a GCC INTEGER_CST. Overflow is tested by the
|
||||
constant-folding used to build the node. TYPE is the GCC type of the
|
||||
resulting node. */
|
||||
extern tree UI_To_gnu PARAMS((Uint, tree));
|
||||
|
||||
/* Universal integers are represented by the Uint type which is an index into
|
||||
the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an
|
||||
index and length for getting the "digits" of the universal integer from the
|
||||
Udigits_Ptr table.
|
||||
|
||||
For efficiency, this method is used only for integer values larger than the
|
||||
constant Uint_Bias. If a Uint is less than this constant, then it contains
|
||||
the integer value itself. The origin of the Uints_Ptr table is adjusted so
|
||||
that a Uint value of Uint_Bias indexes the first element. */
|
||||
|
||||
#define Uints_Ptr (uintp__uints__table - Uint_Table_Start)
|
||||
extern struct Uint_Entry *uintp__uints__table;
|
||||
|
||||
#define Udigits_Ptr uintp__udigits__table
|
||||
extern int *uintp__udigits__table;
|
||||
|
||||
#define Uint_0 (Uint_Direct_Bias + 0)
|
||||
#define Uint_1 (Uint_Direct_Bias + 1)
|
|
@ -0,0 +1,653 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- U N A M E --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.56 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001, 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Casing; use Casing;
|
||||
with Einfo; use Einfo;
|
||||
with Hostparm;
|
||||
with Lib; use Lib;
|
||||
with Namet; use Namet;
|
||||
with Nlists; use Nlists;
|
||||
with Output; use Output;
|
||||
with Sinfo; use Sinfo;
|
||||
with Sinput; use Sinput;
|
||||
|
||||
package body Uname is
|
||||
|
||||
-------------------
|
||||
-- Get_Body_Name --
|
||||
-------------------
|
||||
|
||||
function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
|
||||
begin
|
||||
Get_Name_String (N);
|
||||
|
||||
pragma Assert (Name_Len > 2
|
||||
and then Name_Buffer (Name_Len - 1) = '%'
|
||||
and then Name_Buffer (Name_Len) = 's');
|
||||
|
||||
Name_Buffer (Name_Len) := 'b';
|
||||
return Name_Find;
|
||||
end Get_Body_Name;
|
||||
|
||||
-----------------------------------
|
||||
-- Get_External_Unit_Name_String --
|
||||
-----------------------------------
|
||||
|
||||
procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is
|
||||
Pcount : Natural;
|
||||
Newlen : Natural;
|
||||
|
||||
begin
|
||||
-- Get unit name and eliminate trailing %s or %b
|
||||
|
||||
Get_Name_String (N);
|
||||
Name_Len := Name_Len - 2;
|
||||
|
||||
-- Find number of components
|
||||
|
||||
Pcount := 0;
|
||||
for J in 1 .. Name_Len loop
|
||||
if Name_Buffer (J) = '.' then
|
||||
Pcount := Pcount + 1;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- If simple name, nothing to do
|
||||
|
||||
if Pcount = 0 then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- If name has multiple components, replace dots by double underscore
|
||||
|
||||
Newlen := Name_Len + Pcount;
|
||||
|
||||
for J in reverse 1 .. Name_Len loop
|
||||
if Name_Buffer (J) = '.' then
|
||||
Name_Buffer (Newlen) := '_';
|
||||
Name_Buffer (Newlen - 1) := '_';
|
||||
Newlen := Newlen - 2;
|
||||
|
||||
else
|
||||
Name_Buffer (Newlen) := Name_Buffer (J);
|
||||
Newlen := Newlen - 1;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Name_Len := Name_Len + Pcount;
|
||||
end Get_External_Unit_Name_String;
|
||||
|
||||
--------------------------
|
||||
-- Get_Parent_Body_Name --
|
||||
--------------------------
|
||||
|
||||
function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
|
||||
begin
|
||||
Get_Name_String (N);
|
||||
|
||||
while Name_Buffer (Name_Len) /= '.' loop
|
||||
pragma Assert (Name_Len > 1); -- not a child or subunit name
|
||||
Name_Len := Name_Len - 1;
|
||||
end loop;
|
||||
|
||||
Name_Buffer (Name_Len) := '%';
|
||||
Name_Len := Name_Len + 1;
|
||||
Name_Buffer (Name_Len) := 'b';
|
||||
return Name_Find;
|
||||
|
||||
end Get_Parent_Body_Name;
|
||||
|
||||
--------------------------
|
||||
-- Get_Parent_Spec_Name --
|
||||
--------------------------
|
||||
|
||||
function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
|
||||
begin
|
||||
Get_Name_String (N);
|
||||
|
||||
while Name_Buffer (Name_Len) /= '.' loop
|
||||
if Name_Len = 1 then
|
||||
return No_Name; -- not a child or subunit name
|
||||
else
|
||||
Name_Len := Name_Len - 1;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Name_Buffer (Name_Len) := '%';
|
||||
Name_Len := Name_Len + 1;
|
||||
Name_Buffer (Name_Len) := 's';
|
||||
return Name_Find;
|
||||
|
||||
end Get_Parent_Spec_Name;
|
||||
|
||||
-------------------
|
||||
-- Get_Spec_Name --
|
||||
-------------------
|
||||
|
||||
function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
|
||||
begin
|
||||
Get_Name_String (N);
|
||||
|
||||
pragma Assert (Name_Len > 2
|
||||
and then Name_Buffer (Name_Len - 1) = '%'
|
||||
and then Name_Buffer (Name_Len) = 'b');
|
||||
|
||||
Name_Buffer (Name_Len) := 's';
|
||||
return Name_Find;
|
||||
end Get_Spec_Name;
|
||||
|
||||
-------------------
|
||||
-- Get_Unit_Name --
|
||||
-------------------
|
||||
|
||||
function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is
|
||||
|
||||
Unit_Name_Buffer : String (1 .. Hostparm.Max_Name_Length);
|
||||
-- Buffer used to build name of unit. Note that we cannot use the
|
||||
-- Name_Buffer in package Name_Table because we use it to read
|
||||
-- component names.
|
||||
|
||||
Unit_Name_Length : Natural := 0;
|
||||
-- Length of name stored in Unit_Name_Buffer
|
||||
|
||||
Node : Node_Id;
|
||||
-- Program unit node
|
||||
|
||||
procedure Add_Char (C : Character);
|
||||
-- Add a single character to stored unit name
|
||||
|
||||
procedure Add_Name (Name : Name_Id);
|
||||
-- Add the characters of a names table entry to stored unit name
|
||||
|
||||
procedure Add_Node_Name (Node : Node_Id);
|
||||
-- Recursive procedure adds characters associated with Node
|
||||
|
||||
function Get_Parent (Node : Node_Id) return Node_Id;
|
||||
-- Get parent compilation unit of a stub
|
||||
|
||||
--------------
|
||||
-- Add_Char --
|
||||
--------------
|
||||
|
||||
procedure Add_Char (C : Character) is
|
||||
begin
|
||||
-- Should really check for max length exceeded here???
|
||||
Unit_Name_Length := Unit_Name_Length + 1;
|
||||
Unit_Name_Buffer (Unit_Name_Length) := C;
|
||||
end Add_Char;
|
||||
|
||||
--------------
|
||||
-- Add_Name --
|
||||
--------------
|
||||
|
||||
procedure Add_Name (Name : Name_Id) is
|
||||
begin
|
||||
Get_Name_String (Name);
|
||||
|
||||
for J in 1 .. Name_Len loop
|
||||
Add_Char (Name_Buffer (J));
|
||||
end loop;
|
||||
end Add_Name;
|
||||
|
||||
-------------------
|
||||
-- Add_Node_Name --
|
||||
-------------------
|
||||
|
||||
procedure Add_Node_Name (Node : Node_Id) is
|
||||
Kind : Node_Kind := Nkind (Node);
|
||||
|
||||
begin
|
||||
-- Just ignore an error node (someone else will give a message)
|
||||
|
||||
if Node = Error then
|
||||
return;
|
||||
|
||||
-- Otherwise see what kind of node we have
|
||||
|
||||
else
|
||||
case Kind is
|
||||
|
||||
when N_Identifier |
|
||||
N_Defining_Identifier |
|
||||
N_Defining_Operator_Symbol =>
|
||||
|
||||
-- Note: it is of course an error to have a defining
|
||||
-- operator symbol at this point, but this is not where
|
||||
-- the error is signalled, so we handle it nicely here!
|
||||
|
||||
Add_Name (Chars (Node));
|
||||
|
||||
when N_Defining_Program_Unit_Name =>
|
||||
Add_Node_Name (Name (Node));
|
||||
Add_Char ('.');
|
||||
Add_Node_Name (Defining_Identifier (Node));
|
||||
|
||||
when N_Selected_Component |
|
||||
N_Expanded_Name =>
|
||||
Add_Node_Name (Prefix (Node));
|
||||
Add_Char ('.');
|
||||
Add_Node_Name (Selector_Name (Node));
|
||||
|
||||
when N_Subprogram_Specification |
|
||||
N_Package_Specification =>
|
||||
Add_Node_Name (Defining_Unit_Name (Node));
|
||||
|
||||
when N_Subprogram_Body |
|
||||
N_Subprogram_Declaration |
|
||||
N_Package_Declaration |
|
||||
N_Generic_Declaration =>
|
||||
Add_Node_Name (Specification (Node));
|
||||
|
||||
when N_Generic_Instantiation =>
|
||||
Add_Node_Name (Defining_Unit_Name (Node));
|
||||
|
||||
when N_Package_Body =>
|
||||
Add_Node_Name (Defining_Unit_Name (Node));
|
||||
|
||||
when N_Task_Body |
|
||||
N_Protected_Body =>
|
||||
Add_Node_Name (Defining_Identifier (Node));
|
||||
|
||||
when N_Package_Renaming_Declaration =>
|
||||
Add_Node_Name (Defining_Unit_Name (Node));
|
||||
|
||||
when N_Subprogram_Renaming_Declaration =>
|
||||
Add_Node_Name (Specification (Node));
|
||||
|
||||
when N_Generic_Renaming_Declaration =>
|
||||
Add_Node_Name (Defining_Unit_Name (Node));
|
||||
|
||||
when N_Subprogram_Body_Stub =>
|
||||
Add_Node_Name (Get_Parent (Node));
|
||||
Add_Char ('.');
|
||||
Add_Node_Name (Specification (Node));
|
||||
|
||||
when N_Compilation_Unit =>
|
||||
Add_Node_Name (Unit (Node));
|
||||
|
||||
when N_Package_Body_Stub =>
|
||||
Add_Node_Name (Get_Parent (Node));
|
||||
Add_Char ('.');
|
||||
Add_Node_Name (Defining_Identifier (Node));
|
||||
|
||||
when N_Task_Body_Stub |
|
||||
N_Protected_Body_Stub =>
|
||||
Add_Node_Name (Get_Parent (Node));
|
||||
Add_Char ('.');
|
||||
Add_Node_Name (Defining_Identifier (Node));
|
||||
|
||||
when N_Subunit =>
|
||||
Add_Node_Name (Name (Node));
|
||||
Add_Char ('.');
|
||||
Add_Node_Name (Proper_Body (Node));
|
||||
|
||||
when N_With_Clause =>
|
||||
Add_Node_Name (Name (Node));
|
||||
|
||||
when N_Pragma =>
|
||||
Add_Node_Name (Expression (First
|
||||
(Pragma_Argument_Associations (Node))));
|
||||
|
||||
-- Tasks and protected stuff appear only in an error context,
|
||||
-- but the error has been posted elsewhere, so we deal nicely
|
||||
-- with these error situations here, and produce a reasonable
|
||||
-- unit name using the defining identifier.
|
||||
|
||||
when N_Task_Type_Declaration |
|
||||
N_Single_Task_Declaration |
|
||||
N_Protected_Type_Declaration |
|
||||
N_Single_Protected_Declaration =>
|
||||
Add_Node_Name (Defining_Identifier (Node));
|
||||
|
||||
when others =>
|
||||
raise Program_Error;
|
||||
|
||||
end case;
|
||||
end if;
|
||||
end Add_Node_Name;
|
||||
|
||||
----------------
|
||||
-- Get_Parent --
|
||||
----------------
|
||||
|
||||
function Get_Parent (Node : Node_Id) return Node_Id is
|
||||
N : Node_Id := Node;
|
||||
|
||||
begin
|
||||
while Nkind (N) /= N_Compilation_Unit loop
|
||||
N := Parent (N);
|
||||
end loop;
|
||||
|
||||
return N;
|
||||
end Get_Parent;
|
||||
|
||||
--------------------------------------------
|
||||
-- Start of Processing for Get_Unit_Name --
|
||||
--------------------------------------------
|
||||
|
||||
begin
|
||||
Node := N;
|
||||
|
||||
-- If we have Defining_Identifier, find the associated unit node
|
||||
|
||||
if Nkind (Node) = N_Defining_Identifier then
|
||||
Node := Declaration_Node (Node);
|
||||
|
||||
-- If an expanded name, it is an already analyzed child unit, find
|
||||
-- unit node.
|
||||
|
||||
elsif Nkind (Node) = N_Expanded_Name then
|
||||
Node := Declaration_Node (Entity (Node));
|
||||
end if;
|
||||
|
||||
if Nkind (Node) = N_Package_Specification
|
||||
or else Nkind (Node) in N_Subprogram_Specification
|
||||
then
|
||||
Node := Parent (Node);
|
||||
end if;
|
||||
|
||||
-- Node points to the unit, so get its name and add proper suffix
|
||||
|
||||
Add_Node_Name (Node);
|
||||
Add_Char ('%');
|
||||
|
||||
case Nkind (Node) is
|
||||
when N_Generic_Declaration |
|
||||
N_Subprogram_Declaration |
|
||||
N_Package_Declaration |
|
||||
N_With_Clause |
|
||||
N_Pragma |
|
||||
N_Generic_Instantiation |
|
||||
N_Package_Renaming_Declaration |
|
||||
N_Subprogram_Renaming_Declaration |
|
||||
N_Generic_Renaming_Declaration |
|
||||
N_Single_Task_Declaration |
|
||||
N_Single_Protected_Declaration |
|
||||
N_Task_Type_Declaration |
|
||||
N_Protected_Type_Declaration =>
|
||||
|
||||
Add_Char ('s');
|
||||
|
||||
when N_Subprogram_Body |
|
||||
N_Package_Body |
|
||||
N_Subunit |
|
||||
N_Body_Stub |
|
||||
N_Task_Body |
|
||||
N_Protected_Body |
|
||||
N_Identifier |
|
||||
N_Selected_Component =>
|
||||
|
||||
Add_Char ('b');
|
||||
|
||||
when others =>
|
||||
raise Program_Error;
|
||||
end case;
|
||||
|
||||
Name_Buffer (1 .. Unit_Name_Length) :=
|
||||
Unit_Name_Buffer (1 .. Unit_Name_Length);
|
||||
Name_Len := Unit_Name_Length;
|
||||
return Name_Find;
|
||||
|
||||
end Get_Unit_Name;
|
||||
|
||||
--------------------------
|
||||
-- Get_Unit_Name_String --
|
||||
--------------------------
|
||||
|
||||
procedure Get_Unit_Name_String (N : Unit_Name_Type) is
|
||||
Unit_Is_Body : Boolean;
|
||||
|
||||
begin
|
||||
Get_Decoded_Name_String (N);
|
||||
Unit_Is_Body := Name_Buffer (Name_Len) = 'b';
|
||||
Set_Casing (Identifier_Casing (Source_Index (Main_Unit)), Mixed_Case);
|
||||
|
||||
-- A special fudge, normally we don't have operator symbols present,
|
||||
-- since it is always an error to do so. However, if we do, at this
|
||||
-- stage it has the form:
|
||||
|
||||
-- "and"
|
||||
|
||||
-- and the %s or %b has already been eliminated so put 2 chars back
|
||||
|
||||
if Name_Buffer (1) = '"' then
|
||||
Name_Len := Name_Len + 2;
|
||||
end if;
|
||||
|
||||
-- Now adjust the %s or %b to (spec) or (body)
|
||||
|
||||
if Unit_Is_Body then
|
||||
Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
|
||||
else
|
||||
Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
|
||||
end if;
|
||||
|
||||
for J in 1 .. Name_Len loop
|
||||
if Name_Buffer (J) = '-' then
|
||||
Name_Buffer (J) := '.';
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Name_Len := Name_Len + (7 - 2);
|
||||
end Get_Unit_Name_String;
|
||||
|
||||
------------------
|
||||
-- Is_Body_Name --
|
||||
------------------
|
||||
|
||||
function Is_Body_Name (N : Unit_Name_Type) return Boolean is
|
||||
begin
|
||||
Get_Name_String (N);
|
||||
return Name_Len > 2
|
||||
and then Name_Buffer (Name_Len - 1) = '%'
|
||||
and then Name_Buffer (Name_Len) = 'b';
|
||||
end Is_Body_Name;
|
||||
|
||||
-------------------
|
||||
-- Is_Child_Name --
|
||||
-------------------
|
||||
|
||||
function Is_Child_Name (N : Unit_Name_Type) return Boolean is
|
||||
J : Natural;
|
||||
|
||||
begin
|
||||
Get_Name_String (N);
|
||||
J := Name_Len;
|
||||
|
||||
while Name_Buffer (J) /= '.' loop
|
||||
if J = 1 then
|
||||
return False; -- not a child or subunit name
|
||||
else
|
||||
J := J - 1;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
return True;
|
||||
end Is_Child_Name;
|
||||
|
||||
------------------
|
||||
-- Is_Spec_Name --
|
||||
------------------
|
||||
|
||||
function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
|
||||
begin
|
||||
Get_Name_String (N);
|
||||
return Name_Len > 2
|
||||
and then Name_Buffer (Name_Len - 1) = '%'
|
||||
and then Name_Buffer (Name_Len) = 's';
|
||||
end Is_Spec_Name;
|
||||
|
||||
-----------------------
|
||||
-- Name_To_Unit_Name --
|
||||
-----------------------
|
||||
|
||||
function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
|
||||
begin
|
||||
Get_Name_String (N);
|
||||
Name_Buffer (Name_Len + 1) := '%';
|
||||
Name_Buffer (Name_Len + 2) := 's';
|
||||
Name_Len := Name_Len + 2;
|
||||
return Name_Find;
|
||||
end Name_To_Unit_Name;
|
||||
|
||||
---------------
|
||||
-- New_Child --
|
||||
---------------
|
||||
|
||||
function New_Child
|
||||
(Old : Unit_Name_Type;
|
||||
Newp : Unit_Name_Type)
|
||||
return Unit_Name_Type
|
||||
is
|
||||
P : Natural;
|
||||
|
||||
begin
|
||||
Get_Name_String (Old);
|
||||
|
||||
declare
|
||||
Child : String := Name_Buffer (1 .. Name_Len);
|
||||
|
||||
begin
|
||||
Get_Name_String (Newp);
|
||||
Name_Len := Name_Len - 2;
|
||||
|
||||
P := Child'Last;
|
||||
while Child (P) /= '.' loop
|
||||
P := P - 1;
|
||||
end loop;
|
||||
|
||||
while P <= Child'Last loop
|
||||
Name_Len := Name_Len + 1;
|
||||
Name_Buffer (Name_Len) := Child (P);
|
||||
P := P + 1;
|
||||
end loop;
|
||||
|
||||
return Name_Find;
|
||||
end;
|
||||
end New_Child;
|
||||
|
||||
--------------
|
||||
-- Uname_Ge --
|
||||
--------------
|
||||
|
||||
function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is
|
||||
begin
|
||||
return Left = Right or else Uname_Gt (Left, Right);
|
||||
end Uname_Ge;
|
||||
|
||||
--------------
|
||||
-- Uname_Gt --
|
||||
--------------
|
||||
|
||||
function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is
|
||||
begin
|
||||
return Left /= Right and then not Uname_Lt (Left, Right);
|
||||
end Uname_Gt;
|
||||
|
||||
--------------
|
||||
-- Uname_Le --
|
||||
--------------
|
||||
|
||||
function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is
|
||||
begin
|
||||
return Left = Right or else Uname_Lt (Left, Right);
|
||||
end Uname_Le;
|
||||
|
||||
--------------
|
||||
-- Uname_Lt --
|
||||
--------------
|
||||
|
||||
function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is
|
||||
Left_Name : String (1 .. Hostparm.Max_Name_Length);
|
||||
Left_Length : Natural;
|
||||
Right_Name : String renames Name_Buffer;
|
||||
Right_Length : Natural renames Name_Len;
|
||||
J : Natural;
|
||||
|
||||
begin
|
||||
pragma Warnings (Off, Right_Length);
|
||||
-- Suppress warnings on Right_Length, used in pragma Assert
|
||||
|
||||
if Left = Right then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
Get_Name_String (Left);
|
||||
Left_Name (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1);
|
||||
Left_Length := Name_Len;
|
||||
Get_Name_String (Right);
|
||||
J := 1;
|
||||
|
||||
loop
|
||||
exit when Left_Name (J) = '%';
|
||||
|
||||
if Right_Name (J) = '%' then
|
||||
return False; -- left name is longer
|
||||
end if;
|
||||
|
||||
pragma Assert (J <= Left_Length and then J <= Right_Length);
|
||||
|
||||
if Left_Name (J) /= Right_Name (J) then
|
||||
return Left_Name (J) < Right_Name (J); -- parent names different
|
||||
end if;
|
||||
|
||||
J := J + 1;
|
||||
end loop;
|
||||
|
||||
-- Come here pointing to % in left name
|
||||
|
||||
if Right_Name (J) /= '%' then
|
||||
return True; -- right name is longer
|
||||
end if;
|
||||
|
||||
-- Here the parent names are the same and specs sort low. If neither is
|
||||
-- a spec, then we are comparing the same name and we want a result of
|
||||
-- False in any case.
|
||||
|
||||
return Left_Name (J + 1) = 's';
|
||||
end Uname_Lt;
|
||||
|
||||
---------------------
|
||||
-- Write_Unit_Name --
|
||||
---------------------
|
||||
|
||||
procedure Write_Unit_Name (N : Unit_Name_Type) is
|
||||
begin
|
||||
Get_Unit_Name_String (N);
|
||||
Write_Str (Name_Buffer (1 .. Name_Len));
|
||||
end Write_Unit_Name;
|
||||
|
||||
end Uname;
|
|
@ -0,0 +1,176 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- U N A M E --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.23 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1998, 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Types; use Types;
|
||||
package Uname is
|
||||
|
||||
---------------------------
|
||||
-- Unit Name Conventions --
|
||||
---------------------------
|
||||
|
||||
-- Units are associated with a unique ASCII name as follows. First we
|
||||
-- have the fully expanded name of the unit, with lower case letters
|
||||
-- (except for the use of upper case letters for encoding upper half
|
||||
-- and wide characters, as described in Namet), and periods. Following
|
||||
-- this is one of the following suffixes:
|
||||
|
||||
-- %s for package/subprogram/generic declarations (specs)
|
||||
-- %b for package/subprogram/generic bodies and subunits
|
||||
|
||||
-- Unit names are stored in the names table, and referred to by the
|
||||
-- corresponding Name_Id values. The subtype Unit_Name, which is a
|
||||
-- synonym for Name_Id, is used to indicate that a Name_Id value that
|
||||
-- holds a unit name (as defined above) is expected.
|
||||
|
||||
-- Note: as far as possible the conventions for unit names are encapsulated
|
||||
-- in this package. The one exception is that package Fname, which provides
|
||||
-- conversion routines from unit names to file names must be aware of the
|
||||
-- precise conventions that are used.
|
||||
|
||||
-------------------
|
||||
-- Display Names --
|
||||
-------------------
|
||||
|
||||
-- For display purposes, unit names are printed out with the suffix
|
||||
-- " (body)" for a body and " (spec)" for a spec. These formats are
|
||||
-- used for the Write_Unit_Name and Get_Unit_Name_String subprograms.
|
||||
|
||||
-----------------
|
||||
-- Subprograms --
|
||||
-----------------
|
||||
|
||||
function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type;
|
||||
-- Given the name of a spec, this function returns the name of the
|
||||
-- corresponding body, i.e. characters %s replaced by %b
|
||||
|
||||
function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type;
|
||||
-- Given the name of a subunit, returns the name of the parent body.
|
||||
|
||||
function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type;
|
||||
-- Given the name of a child unit spec or body, returns the unit name
|
||||
-- of the parent spec. Returns No_Name if the given name is not the name
|
||||
-- of a child unit.
|
||||
|
||||
procedure Get_External_Unit_Name_String (N : Unit_Name_Type);
|
||||
-- Given the name of a body or spec unit, this procedure places in
|
||||
-- Name_Buffer the name of the unit with periods replaced by double
|
||||
-- underscores. The spec/body indication is eliminated. The length
|
||||
-- of the stored name is placed in Name_Len. All letters are lower
|
||||
-- case, corresponding to the string used in external names.
|
||||
|
||||
function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type;
|
||||
-- Given the name of a body, this function returns the name of the
|
||||
-- corresponding spec, i.e. characters %b replaced by %s
|
||||
|
||||
function Get_Unit_Name (N : Node_Id) return Unit_Name_Type;
|
||||
-- This procedure returns the unit name that corresponds to the given node,
|
||||
-- which is one of the following:
|
||||
--
|
||||
-- N_Subprogram_Declaration (spec) cases
|
||||
-- N_Package_Declaration
|
||||
-- N_Generic_Declaration
|
||||
-- N_With_Clause
|
||||
-- N_Function_Instantiation
|
||||
-- N_Package_Instantiation
|
||||
-- N_Procedure_Instantiation
|
||||
-- N_Pragma (Elaborate case)
|
||||
--
|
||||
-- N_Package_Body (body) cases
|
||||
-- N_Subprogram_Body
|
||||
-- N_Identifier
|
||||
-- N_Selected_Component
|
||||
--
|
||||
-- N_Subprogram_Body_Stub (subunit) cases
|
||||
-- N_Package_Body_Stub
|
||||
-- N_Task_Body_Stub
|
||||
-- N_Protected_Body_Stub
|
||||
-- N_Subunit
|
||||
|
||||
procedure Get_Unit_Name_String (N : Unit_Name_Type);
|
||||
-- Places the display name of the unit in Name_Buffer and sets Name_Len
|
||||
-- to the length of the stored name, i.e. it uses the same interface as
|
||||
-- the Get_Name_String routine in the Namet package. The name contains
|
||||
-- an indication of spec or body, and is decoded.
|
||||
|
||||
function Is_Body_Name (N : Unit_Name_Type) return Boolean;
|
||||
-- Returns True iff the given name is the unit name of a body (i.e. if
|
||||
-- it ends with the characters %b).
|
||||
|
||||
function Is_Child_Name (N : Unit_Name_Type) return Boolean;
|
||||
-- Returns True iff the given name is a child unit name (of either a
|
||||
-- body or a spec).
|
||||
|
||||
function Is_Spec_Name (N : Unit_Name_Type) return Boolean;
|
||||
-- Returns True iff the given name is the unit name of a specification
|
||||
-- (i.e. if it ends with the characters %s).
|
||||
|
||||
function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type;
|
||||
-- Given the Id of the Ada name of a unit, this function returns the
|
||||
-- corresponding unit name of the spec (by appending %s to the name).
|
||||
|
||||
function New_Child
|
||||
(Old : Unit_Name_Type;
|
||||
Newp : Unit_Name_Type)
|
||||
return Unit_Name_Type;
|
||||
-- Old is a child unit name (for either a body or spec). Newp is the
|
||||
-- unit name of the actual parent (this may be different from the
|
||||
-- parent in old). The returned unit name is formed by taking the
|
||||
-- parent name from Newp and the child unit name from Old, with the
|
||||
-- result being a body or spec depending on Old. For example:
|
||||
--
|
||||
-- Old = A.B.C (body)
|
||||
-- Newp = A.R (spec)
|
||||
-- result = A.R.C (body)
|
||||
--
|
||||
-- See spec of Load_Unit for extensive discussion of why this routine
|
||||
-- needs to be used (the call in the body of Load_Unit is the only one).
|
||||
|
||||
function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean;
|
||||
function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean;
|
||||
function Uname_Le (Left, Right : Unit_Name_Type) return Boolean;
|
||||
function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean;
|
||||
-- These functions perform lexicographic ordering of unit names. The
|
||||
-- ordering is suitable for printing, and is not quite a straightforward
|
||||
-- comparison of the names, since the convention is that specs appear
|
||||
-- before bodies. Note that the standard = and /= operators work fine
|
||||
-- because all unit names are hashed into the name table, so if two names
|
||||
-- are the same, they always have the same Name_Id value.
|
||||
|
||||
procedure Write_Unit_Name (N : Unit_Name_Type);
|
||||
-- Given a unit name, this procedure writes the display name to the
|
||||
-- standard output file. Name_Buffer and Name_Len are set as described
|
||||
-- above for the Get_Unit_Name_String call on return.
|
||||
|
||||
end Uname;
|
|
@ -0,0 +1,24 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- U N C H E C K E D _ C O N V E R S I O N --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.15 $ --
|
||||
-- --
|
||||
-- This specification is adapted 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. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
generic
|
||||
type Source (<>) is limited private;
|
||||
type Target (<>) is limited private;
|
||||
|
||||
function Unchecked_Conversion (S : Source) return Target;
|
||||
pragma Import (Intrinsic, Unchecked_Conversion);
|
||||
pragma Pure (Unchecked_Conversion);
|
|
@ -0,0 +1,23 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- U N C H E C K E D _ D E A L L O C A T I O N --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.15 $ --
|
||||
-- --
|
||||
-- This specification is adapted 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. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
generic
|
||||
type Object (<>) is limited private;
|
||||
type Name is access Object;
|
||||
|
||||
procedure Unchecked_Deallocation (X : in out Name);
|
||||
pragma Import (Intrinsic, Unchecked_Deallocation);
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,355 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- U R E A L P --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.35 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1998 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Support for universal real arithmetic
|
||||
|
||||
with Types; use Types;
|
||||
with Uintp; use Uintp;
|
||||
|
||||
package Urealp is
|
||||
|
||||
---------------------------------------
|
||||
-- Representation of Universal Reals --
|
||||
---------------------------------------
|
||||
|
||||
-- A universal real value is represented by a single value (which is
|
||||
-- an index into an internal table). These values are not hashed, so
|
||||
-- the equality operator should not be used on Ureal values (instead
|
||||
-- use the UR_Eq function).
|
||||
|
||||
-- A Ureal value represents an arbitrary precision universal real value,
|
||||
-- stored internally using four components
|
||||
|
||||
-- the numerator (Uint, always non-negative)
|
||||
-- the denominator (Uint, always non-zero, always positive if base = 0)
|
||||
-- a real base (Nat, either zero, or in the range 2 .. 16)
|
||||
-- a sign flag (Boolean), set if negative
|
||||
|
||||
-- If the base is zero, then the absolute value of the Ureal is simply
|
||||
-- numerator/denominator. If the base is non-zero, then the absolute
|
||||
-- value is num / (rbase ** den).
|
||||
|
||||
-- Negative numbers are represented by the sign of the numerator being
|
||||
-- negative. The denominator is always positive.
|
||||
|
||||
-- A normalized Ureal value has base = 0, and numerator/denominator
|
||||
-- reduced to lowest terms, with zero itself being represented as 0/1.
|
||||
-- This is a canonical format, so that for normalized Ureal values it
|
||||
-- is the case that two equal values always have the same denominator
|
||||
-- and numerator values.
|
||||
|
||||
-- Note: a value of minus zero is legitimate, and the operations in
|
||||
-- Urealp preserve the handling of signed zeroes in accordance with
|
||||
-- the rules of IEEE P754 ("IEEE floating point").
|
||||
|
||||
------------------------------
|
||||
-- Types for Urealp Package --
|
||||
------------------------------
|
||||
|
||||
type Ureal is private;
|
||||
-- Type used for representation of universal reals
|
||||
|
||||
No_Ureal : constant Ureal;
|
||||
-- Constant used to indicate missing or unset Ureal value
|
||||
|
||||
---------------------
|
||||
-- Ureal Constants --
|
||||
---------------------
|
||||
|
||||
function Ureal_0 return Ureal;
|
||||
-- Returns value 0.0
|
||||
|
||||
function Ureal_M_0 return Ureal;
|
||||
-- Returns value -0.0
|
||||
|
||||
function Ureal_Tenth return Ureal;
|
||||
-- Returns value 0.1
|
||||
|
||||
function Ureal_Half return Ureal;
|
||||
-- Returns value 0.5
|
||||
|
||||
function Ureal_1 return Ureal;
|
||||
-- Returns value 1.0
|
||||
|
||||
function Ureal_2 return Ureal;
|
||||
-- Returns value 2.0
|
||||
|
||||
function Ureal_10 return Ureal;
|
||||
-- Returns value 10.0
|
||||
|
||||
function Ureal_100 return Ureal;
|
||||
-- Returns value 100.0
|
||||
|
||||
function Ureal_2_128 return Ureal;
|
||||
-- Returns value 2.0 ** 128
|
||||
|
||||
function Ureal_2_M_128 return Ureal;
|
||||
-- Returns value 2.0 ** (-128)
|
||||
|
||||
-----------------
|
||||
-- Subprograms --
|
||||
-----------------
|
||||
|
||||
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
|
||||
-- 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 Tree_Read.
|
||||
-- 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 Tree_Write
|
||||
|
||||
function Rbase (Real : Ureal) return Nat;
|
||||
-- Return the base of the universal real.
|
||||
|
||||
function Denominator (Real : Ureal) return Uint;
|
||||
-- Return the denominator of the universal real.
|
||||
|
||||
function Numerator (Real : Ureal) return Uint;
|
||||
-- Return the numerator of the universal real.
|
||||
|
||||
function Norm_Den (Real : Ureal) return Uint;
|
||||
-- Return the denominator of the universal real after a normalization.
|
||||
|
||||
function Norm_Num (Real : Ureal) return Uint;
|
||||
-- Return the numerator of the universal real after a normalization.
|
||||
|
||||
function UR_From_Uint (UI : Uint) return Ureal;
|
||||
-- Returns real corresponding to universal integer value
|
||||
|
||||
function UR_To_Uint (Real : Ureal) return Uint;
|
||||
-- Return integer value obtained by accurate rounding of real value.
|
||||
-- The rounding of values half way between two integers is away from
|
||||
-- zero, as required by normal Ada 95 rounding semantics.
|
||||
|
||||
function UR_Trunc (Real : Ureal) return Uint;
|
||||
-- Return integer value obtained by a truncation of real towards zero
|
||||
|
||||
function UR_Ceiling (Real : Ureal) return Uint;
|
||||
-- Return value of smallest integer not less than the given value
|
||||
|
||||
function UR_Floor (Real : Ureal) return Uint;
|
||||
-- Return value of smallest integer not greater than the given value
|
||||
|
||||
-- Conversion table for above four functions
|
||||
|
||||
-- Input To_Uint Trunc Ceiling Floor
|
||||
-- 1.0 1 1 1 1
|
||||
-- 1.2 1 1 2 1
|
||||
-- 1.5 2 1 2 1
|
||||
-- 1.7 2 1 2 1
|
||||
-- 2.0 2 2 2 2
|
||||
-- -1.0 -1 -1 -1 -1
|
||||
-- -1.2 -1 -1 -1 -2
|
||||
-- -1.5 -2 -1 -1 -2
|
||||
-- -1.7 -2 -1 -1 -2
|
||||
-- -2.0 -2 -2 -2 -2
|
||||
|
||||
function UR_From_Components
|
||||
(Num : Uint;
|
||||
Den : Uint;
|
||||
Rbase : Nat := 0;
|
||||
Negative : Boolean := False)
|
||||
return Ureal;
|
||||
-- Builds real value from given numerator, denominator and base. The
|
||||
-- value is negative if Negative is set to true, and otherwise is
|
||||
-- non-negative.
|
||||
|
||||
function UR_Add (Left : Ureal; Right : Ureal) return Ureal;
|
||||
function UR_Add (Left : Ureal; Right : Uint) return Ureal;
|
||||
function UR_Add (Left : Uint; Right : Ureal) return Ureal;
|
||||
-- Returns real sum of operands
|
||||
|
||||
function UR_Div (Left : Ureal; Right : Ureal) return Ureal;
|
||||
function UR_Div (Left : Uint; Right : Ureal) return Ureal;
|
||||
function UR_Div (Left : Ureal; Right : Uint) return Ureal;
|
||||
-- Returns real quotient of operands. Fatal error if Right is zero
|
||||
|
||||
function UR_Mul (Left : Ureal; Right : Ureal) return Ureal;
|
||||
function UR_Mul (Left : Uint; Right : Ureal) return Ureal;
|
||||
function UR_Mul (Left : Ureal; Right : Uint) return Ureal;
|
||||
-- Returns real product of operands
|
||||
|
||||
function UR_Sub (Left : Ureal; Right : Ureal) return Ureal;
|
||||
function UR_Sub (Left : Uint; Right : Ureal) return Ureal;
|
||||
function UR_Sub (Left : Ureal; Right : Uint) return Ureal;
|
||||
-- Returns real difference of operands
|
||||
|
||||
function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal;
|
||||
-- Returns result of raising Ureal to Uint power.
|
||||
-- Fatal error if Left is 0 and Right is negative.
|
||||
|
||||
function UR_Abs (Real : Ureal) return Ureal;
|
||||
-- Returns abs function of real
|
||||
|
||||
function UR_Negate (Real : Ureal) return Ureal;
|
||||
-- Returns negative of real
|
||||
|
||||
function UR_Eq (Left, Right : Ureal) return Boolean;
|
||||
-- Compares reals for equality.
|
||||
|
||||
function UR_Max (Left, Right : Ureal) return Ureal;
|
||||
-- Returns the maximum of two reals
|
||||
|
||||
function UR_Min (Left, Right : Ureal) return Ureal;
|
||||
-- Returns the minimum of two reals
|
||||
|
||||
function UR_Ne (Left, Right : Ureal) return Boolean;
|
||||
-- Compares reals for inequality.
|
||||
|
||||
function UR_Lt (Left, Right : Ureal) return Boolean;
|
||||
-- Compares reals for less than.
|
||||
|
||||
function UR_Le (Left, Right : Ureal) return Boolean;
|
||||
-- Compares reals for less than or equal.
|
||||
|
||||
function UR_Gt (Left, Right : Ureal) return Boolean;
|
||||
-- Compares reals for greater than.
|
||||
|
||||
function UR_Ge (Left, Right : Ureal) return Boolean;
|
||||
-- Compares reals for greater than or equal.
|
||||
|
||||
function UR_Is_Zero (Real : Ureal) return Boolean;
|
||||
-- Tests if real value is zero
|
||||
|
||||
function UR_Is_Negative (Real : Ureal) return Boolean;
|
||||
-- Tests if real value is negative, note that negative zero gives true
|
||||
|
||||
function UR_Is_Positive (Real : Ureal) return Boolean;
|
||||
-- Test if real value is greater than zero
|
||||
|
||||
procedure UR_Write (Real : Ureal);
|
||||
-- Writes value of Real to standard output. Used only for debugging and
|
||||
-- tree/source output. If the result is easily representable as a standard
|
||||
-- Ada literal, it will be given that way, but as a result of evaluation
|
||||
-- of static expressions, it is possible to generate constants (e.g. 1/13)
|
||||
-- which have no such representation. In such cases (and in cases where it
|
||||
-- is too much work to figure out the Ada literal), the string that is
|
||||
-- output is of the form [numerator/denominator].
|
||||
|
||||
procedure pr (Real : Ureal);
|
||||
-- Writes value of Real to standard output with a terminating line return,
|
||||
-- using UR_Write as described above. This is for use from the debugger.
|
||||
|
||||
------------------------
|
||||
-- Operator Renamings --
|
||||
------------------------
|
||||
|
||||
function "+" (Left : Ureal; Right : Ureal) return Ureal renames UR_Add;
|
||||
function "+" (Left : Uint; Right : Ureal) return Ureal renames UR_Add;
|
||||
function "+" (Left : Ureal; Right : Uint) return Ureal renames UR_Add;
|
||||
|
||||
function "/" (Left : Ureal; Right : Ureal) return Ureal renames UR_Div;
|
||||
function "/" (Left : Uint; Right : Ureal) return Ureal renames UR_Div;
|
||||
function "/" (Left : Ureal; Right : Uint) return Ureal renames UR_Div;
|
||||
|
||||
function "*" (Left : Ureal; Right : Ureal) return Ureal renames UR_Mul;
|
||||
function "*" (Left : Uint; Right : Ureal) return Ureal renames UR_Mul;
|
||||
function "*" (Left : Ureal; Right : Uint) return Ureal renames UR_Mul;
|
||||
|
||||
function "-" (Left : Ureal; Right : Ureal) return Ureal renames UR_Sub;
|
||||
function "-" (Left : Uint; Right : Ureal) return Ureal renames UR_Sub;
|
||||
function "-" (Left : Ureal; Right : Uint) return Ureal renames UR_Sub;
|
||||
|
||||
function "**" (Real : Ureal; N : Uint) return Ureal
|
||||
renames UR_Exponentiate;
|
||||
|
||||
function "abs" (Real : Ureal) return Ureal renames UR_Abs;
|
||||
|
||||
function "-" (Real : Ureal) return Ureal renames UR_Negate;
|
||||
|
||||
function "=" (Left, Right : Ureal) return Boolean renames UR_Eq;
|
||||
|
||||
function "<" (Left, Right : Ureal) return Boolean renames UR_Lt;
|
||||
|
||||
function "<=" (Left, Right : Ureal) return Boolean renames UR_Le;
|
||||
|
||||
function ">=" (Left, Right : Ureal) return Boolean renames UR_Ge;
|
||||
|
||||
function ">" (Left, Right : Ureal) return Boolean renames UR_Gt;
|
||||
|
||||
-----------------------------
|
||||
-- Mark/Release Processing --
|
||||
-----------------------------
|
||||
|
||||
-- The space used by Ureal data is not automatically reclaimed. However,
|
||||
-- a mark-release regime is implemented which allows storage to be
|
||||
-- released back to a previously noted mark. This is used for example
|
||||
-- when doing comparisons, where only intermediate results get stored
|
||||
-- that do not need to be saved for future use.
|
||||
|
||||
type Save_Mark is private;
|
||||
|
||||
function Mark return Save_Mark;
|
||||
-- Note mark point for future release
|
||||
|
||||
procedure Release (M : Save_Mark);
|
||||
-- Release storage allocated since mark was noted
|
||||
|
||||
------------------------------------
|
||||
-- Representation of Ureal Values --
|
||||
------------------------------------
|
||||
|
||||
private
|
||||
|
||||
type Ureal is new Int range Ureal_Low_Bound .. Ureal_High_Bound;
|
||||
for Ureal'Size use 32;
|
||||
|
||||
No_Ureal : constant Ureal := Ureal'First;
|
||||
|
||||
type Save_Mark is new Int;
|
||||
|
||||
pragma Inline (Denominator);
|
||||
pragma Inline (Mark);
|
||||
pragma Inline (Norm_Num);
|
||||
pragma Inline (Norm_Den);
|
||||
pragma Inline (Numerator);
|
||||
pragma Inline (Rbase);
|
||||
pragma Inline (Release);
|
||||
pragma Inline (Ureal_0);
|
||||
pragma Inline (Ureal_M_0);
|
||||
pragma Inline (Ureal_Tenth);
|
||||
pragma Inline (Ureal_Half);
|
||||
pragma Inline (Ureal_1);
|
||||
pragma Inline (Ureal_2);
|
||||
pragma Inline (Ureal_10);
|
||||
pragma Inline (UR_From_Components);
|
||||
|
||||
end Urealp;
|
|
@ -0,0 +1,50 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNAT COMPILER COMPONENTS *
|
||||
* *
|
||||
* U R E A L P *
|
||||
* *
|
||||
* C Header File *
|
||||
* *
|
||||
* $Revision: 1.1 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write *
|
||||
* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
|
||||
* MA 02111-1307, USA. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
/* This file corresponds to the Ada package specification Urealp. It was
|
||||
created manually from the files urealp.ads and urealp.adb */
|
||||
|
||||
/* Support for universal real arithmetic. */
|
||||
|
||||
#define Numerator urealp__numerator
|
||||
extern Uint Numerator PARAMS ((Ureal));
|
||||
|
||||
#define Denominator urealp__denominator
|
||||
extern Uint Denominator PARAMS ((Ureal));
|
||||
|
||||
#define Rbase urealp__rbase
|
||||
extern Nat Rbase PARAMS ((Ureal));
|
||||
|
||||
#define UR_Is_Negative urealp__ur_is_negative
|
||||
extern Boolean UR_Is_Negative PARAMS ((Ureal));
|
||||
|
||||
#define UR_Is_Zero urealp__ur_is_zero
|
||||
extern Boolean UR_Is_Zero PARAMS ((Ureal));
|
||||
|
||||
#define Machine eval_fat__machine
|
||||
extern Ureal Machine PARAMS ((Entity_Id, Ureal));
|
|
@ -0,0 +1,390 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- U S A G E --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.116 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001, 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Hostparm;
|
||||
with Namet; use Namet;
|
||||
with Osint; use Osint;
|
||||
with Output; use Output;
|
||||
with System.WCh_Con; use System.WCh_Con;
|
||||
|
||||
procedure Usage is
|
||||
|
||||
procedure Write_Switch_Char (Sw : String; Prefix : String := "gnat");
|
||||
-- Output two spaces followed by default switch character followed
|
||||
-- Prefix, followed by the string given as the argument, and then
|
||||
-- enough blanks to tab to column 13, i.e. assuming Sw is not longer
|
||||
-- than 5 characters, the maximum allowed, Write_Switch_Char will
|
||||
-- always output exactly 12 characters.
|
||||
|
||||
procedure Write_Switch_Char (Sw : String; Prefix : String := "gnat") is
|
||||
begin
|
||||
Write_Str (" ");
|
||||
Write_Char (Switch_Character);
|
||||
Write_Str (Prefix);
|
||||
Write_Str (Sw);
|
||||
|
||||
for J in 1 .. 12 - 3 - Prefix'Length - Sw'Length loop
|
||||
Write_Char (' ');
|
||||
end loop;
|
||||
end Write_Switch_Char;
|
||||
|
||||
-- Start of processing for Usage
|
||||
|
||||
begin
|
||||
Find_Program_Name;
|
||||
|
||||
-- For gnatmake, we are appending this information to the end of
|
||||
-- the normal gnatmake output, so generate appropriate header
|
||||
|
||||
if Name_Len >= 8
|
||||
and then (Name_Buffer (Name_Len - 7 .. Name_Len) = "gnatmake"
|
||||
or else
|
||||
Name_Buffer (Name_Len - 7 .. Name_Len) = "GNATMAKE")
|
||||
then
|
||||
Write_Eol;
|
||||
Write_Line ("Compiler switches (passed to the compiler by gnatmake):");
|
||||
|
||||
else
|
||||
-- Usage line
|
||||
|
||||
Write_Str ("Usage: ");
|
||||
Write_Program_Name;
|
||||
Write_Char (' ');
|
||||
Write_Str ("switches sfile");
|
||||
Write_Eol;
|
||||
Write_Eol;
|
||||
|
||||
-- Line for sfile
|
||||
|
||||
Write_Line (" sfile Source file name");
|
||||
end if;
|
||||
|
||||
Write_Eol;
|
||||
|
||||
-- Common GCC switches not available in JGNAT
|
||||
|
||||
if not Hostparm.Java_VM then
|
||||
Write_Switch_Char ("fstack-check ", "");
|
||||
Write_Line ("Generate stack checking code");
|
||||
|
||||
Write_Switch_Char ("fno-inline ", "");
|
||||
Write_Line ("Inhibit all inlining (makes executable smaller)");
|
||||
end if;
|
||||
|
||||
-- Common switches available to both GCC and JGNAT
|
||||
|
||||
Write_Switch_Char ("g ", "");
|
||||
Write_Line ("Generate debugging information");
|
||||
|
||||
Write_Switch_Char ("Idir ", "");
|
||||
Write_Line ("Specify source files search path");
|
||||
|
||||
Write_Switch_Char ("I- ", "");
|
||||
Write_Line ("Do not look for sources in current directory");
|
||||
|
||||
Write_Switch_Char ("O[0123] ", "");
|
||||
Write_Line ("Control the optimization level");
|
||||
|
||||
Write_Eol;
|
||||
|
||||
-- Individual lines for switches. Write_Switch_Char outputs fourteen
|
||||
-- characters, so the remaining message is allowed to be a maximum
|
||||
-- of 65 characters to be comfortable on an 80 character device.
|
||||
-- If the Write_Str fits on one line, it is short enough!
|
||||
|
||||
-- Line for -gnata switch
|
||||
|
||||
Write_Switch_Char ("a");
|
||||
Write_Line ("Assertions enabled. Pragma Assert/Debug to be activated");
|
||||
|
||||
-- Line for -gnatA switch
|
||||
|
||||
Write_Switch_Char ("A");
|
||||
Write_Line ("Avoid processing gnat.adc, if present file will be ignored");
|
||||
|
||||
-- Line for -gnatb switch
|
||||
|
||||
Write_Switch_Char ("b");
|
||||
Write_Line ("Generate brief messages to stderr even if verbose mode set");
|
||||
|
||||
-- Line for -gnatc switch
|
||||
|
||||
Write_Switch_Char ("c");
|
||||
Write_Line ("Check syntax and semantics only (no code generation)");
|
||||
|
||||
Write_Switch_Char ("C");
|
||||
Write_Line ("Compress names in external names and debug info tables");
|
||||
|
||||
-- Line for -gnatd switch
|
||||
|
||||
Write_Switch_Char ("d?");
|
||||
Write_Line ("Compiler debug option ? (a-z,A-Z,0-9), see debug.adb");
|
||||
|
||||
-- Line for -gnatD switch
|
||||
|
||||
Write_Switch_Char ("D");
|
||||
Write_Line ("Debug expanded generated code rather than source code");
|
||||
|
||||
-- Line for -gnatec switch
|
||||
|
||||
Write_Switch_Char ("ec?");
|
||||
Write_Line ("Specify configuration pragmas file, e.g. -gnatec/x/f.adc");
|
||||
|
||||
-- Line for -gnatE switch
|
||||
|
||||
Write_Switch_Char ("E");
|
||||
Write_Line ("Dynamic elaboration checking mode enabled");
|
||||
|
||||
-- Line for -gnatf switch
|
||||
|
||||
Write_Switch_Char ("f");
|
||||
Write_Line ("Full errors. Verbose details, all undefined references");
|
||||
|
||||
-- Line for -gnatF switch
|
||||
|
||||
Write_Switch_Char ("F");
|
||||
Write_Line ("Force all import/export external names to all uppercase");
|
||||
|
||||
-- Line for -gnatg switch
|
||||
|
||||
Write_Switch_Char ("g");
|
||||
Write_Line ("GNAT implementation mode (used for compiling GNAT units)");
|
||||
|
||||
-- Line for -gnatG switch
|
||||
|
||||
Write_Switch_Char ("G");
|
||||
Write_Line ("Output generated expanded code in source form");
|
||||
|
||||
-- Line for -gnath switch
|
||||
|
||||
Write_Switch_Char ("h");
|
||||
Write_Line ("Output this usage (help) information");
|
||||
|
||||
-- Line for -gnati switch
|
||||
|
||||
Write_Switch_Char ("i?");
|
||||
Write_Line ("Identifier char set (?=1/2/3/4/8/p/f/n/w)");
|
||||
|
||||
-- Line for -gnatk switch
|
||||
|
||||
Write_Switch_Char ("k");
|
||||
Write_Line ("Limit file names to nnn characters (k = krunch)");
|
||||
|
||||
-- Line for -gnatl switch
|
||||
|
||||
Write_Switch_Char ("l");
|
||||
Write_Line ("Output full source listing with embedded error messages");
|
||||
|
||||
-- Line for -gnatL switch
|
||||
|
||||
Write_Switch_Char ("L");
|
||||
Write_Line ("Use longjmp/setjmp for exception handling");
|
||||
|
||||
-- Line for -gnatm switch
|
||||
|
||||
Write_Switch_Char ("mnnn");
|
||||
Write_Line ("Limit number of detected errors to nnn (1-999)");
|
||||
|
||||
-- Line for -gnatn switch
|
||||
|
||||
Write_Switch_Char ("n");
|
||||
Write_Line ("Inlining of subprograms (apply pragma Inline across units)");
|
||||
|
||||
-- Line for -gnatN switch
|
||||
|
||||
Write_Switch_Char ("N");
|
||||
Write_Line ("Full (frontend) inlining of subprograqms");
|
||||
|
||||
-- Line for -gnato switch
|
||||
|
||||
Write_Switch_Char ("o");
|
||||
Write_Line ("Enable overflow checking (off by default)");
|
||||
|
||||
-- Line for -gnatO switch
|
||||
|
||||
Write_Switch_Char ("O nm ");
|
||||
Write_Line ("Set name of output ali file (internal switch)");
|
||||
|
||||
-- Line for -gnatp switch
|
||||
|
||||
Write_Switch_Char ("p");
|
||||
Write_Line ("Suppress all checks");
|
||||
|
||||
-- Line for -gnatP switch
|
||||
|
||||
Write_Switch_Char ("P");
|
||||
Write_Line ("Generate periodic calls to System.Polling.Poll");
|
||||
|
||||
-- Line for -gnatq switch
|
||||
|
||||
Write_Switch_Char ("q");
|
||||
Write_Line ("Don't quit, try semantics, even if parse errors");
|
||||
|
||||
-- Line for -gnatQ switch
|
||||
|
||||
Write_Switch_Char ("Q");
|
||||
Write_Line ("Don't quit, write ali/tree file even if compile errors");
|
||||
|
||||
-- Line for -gnatR switch
|
||||
|
||||
Write_Switch_Char ("R?");
|
||||
Write_Line ("List rep inf (?=0/1/2/3 for none/types/all/variable)");
|
||||
|
||||
-- Lines for -gnats switch
|
||||
|
||||
Write_Switch_Char ("s");
|
||||
Write_Line ("Syntax check only");
|
||||
|
||||
-- Lines for -gnatt switch
|
||||
|
||||
Write_Switch_Char ("t");
|
||||
Write_Line ("Tree output file to be generated");
|
||||
|
||||
-- Line for -gnatT switch
|
||||
|
||||
Write_Switch_Char ("Tnnn");
|
||||
Write_Line ("All compiler tables start at nnn times usual starting size");
|
||||
|
||||
-- Line for -gnatu switch
|
||||
|
||||
Write_Switch_Char ("u");
|
||||
Write_Line ("List units for this compilation");
|
||||
|
||||
-- Line for -gnatU switch
|
||||
|
||||
Write_Switch_Char ("U");
|
||||
Write_Line ("Enable unique tag for error messages");
|
||||
|
||||
-- Line for -gnatv switch
|
||||
|
||||
Write_Switch_Char ("v");
|
||||
Write_Line ("Verbose mode. Full error output with source lines to stdout");
|
||||
|
||||
-- Line for -gnatV switch
|
||||
|
||||
Write_Switch_Char ("V?");
|
||||
Write_Line
|
||||
("Validity checking (?=ndcte or 0-4 None/Default/Copy/Test/Exprs)");
|
||||
|
||||
-- Lines for -gnatw switch
|
||||
|
||||
Write_Switch_Char ("wxx");
|
||||
Write_Line ("Enable selected warning modes, xx = list of parameters:");
|
||||
Write_Line (" a turn on all optional warnings (except b,h)");
|
||||
Write_Line (" A turn off all optional warnings");
|
||||
Write_Line (" b turn on biased rounding warnings");
|
||||
Write_Line (" B turn off biased rounding warnings");
|
||||
Write_Line (" c turn on constant conditional warnings");
|
||||
Write_Line (" C* turn off constant conditional warnings");
|
||||
Write_Line (" e treat all warnings as errors");
|
||||
Write_Line (" h turn on warnings for hiding variables");
|
||||
Write_Line (" H* turn off warnings for hiding variables");
|
||||
Write_Line (" i* turn on warnings for implementation units");
|
||||
Write_Line (" I turn off warnings for implementation units");
|
||||
Write_Line (" l turn on elaboration warnings");
|
||||
Write_Line (" L* turn off elaboration warnings");
|
||||
Write_Line (" o* turn on address clause overlay warnings");
|
||||
Write_Line (" O turn off address clause overlay warnings");
|
||||
Write_Line (" p turn on warnings for ineffective pragma inline");
|
||||
Write_Line (" P* turn off warnings for ineffective pragma inline");
|
||||
Write_Line (" r turn on redundant construct warnings");
|
||||
Write_Line (" R* turn off redundant construct warnings");
|
||||
Write_Line (" s suppress all warnings");
|
||||
Write_Line (" u turn on warnings for unused entities");
|
||||
Write_Line (" U* turn off warnings for unused entities");
|
||||
Write_Line (" * indicates default in above list");
|
||||
|
||||
-- Line for -gnatW switch
|
||||
|
||||
Write_Switch_Char ("W");
|
||||
Write_Str ("Wide character encoding method (");
|
||||
|
||||
for J in WC_Encoding_Method loop
|
||||
Write_Char (WC_Encoding_Letters (J));
|
||||
|
||||
if J = WC_Encoding_Method'Last then
|
||||
Write_Char (')');
|
||||
else
|
||||
Write_Char ('/');
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -gnatx switch
|
||||
|
||||
Write_Switch_Char ("x");
|
||||
Write_Line ("Suppress output of cross-reference information");
|
||||
|
||||
-- Line for -gnatX switch
|
||||
|
||||
Write_Switch_Char ("X");
|
||||
Write_Line ("Language extensions permitted");
|
||||
|
||||
-- Lines for -gnaty switch
|
||||
|
||||
Write_Switch_Char ("y");
|
||||
Write_Line ("Enable all style checks");
|
||||
|
||||
Write_Switch_Char ("yxx");
|
||||
Write_Line ("Enable selected style checks xx = list of parameters:");
|
||||
Write_Line (" 1-9 check indentation");
|
||||
Write_Line (" a check attribute casing");
|
||||
Write_Line (" b check no blanks at end of lines");
|
||||
Write_Line (" c check comment format");
|
||||
Write_Line (" e check end/exit labels present");
|
||||
Write_Line (" f check no form feeds/vertical tabs in source");
|
||||
Write_Line (" h check no horizontal tabs in source");
|
||||
Write_Line (" i check if-then layout");
|
||||
Write_Line (" k check casing rules for keywords, identifiers");
|
||||
Write_Line (" l check reference manual layout");
|
||||
Write_Line (" m check line length <= 79 characters");
|
||||
Write_Line (" n check casing of package Standard identifiers");
|
||||
Write_Line (" Mnnn check line length <= nnn characters");
|
||||
Write_Line (" o check subprogram bodies in alphabetical order");
|
||||
Write_Line (" p check pragma casing");
|
||||
Write_Line (" r check RM column layout");
|
||||
Write_Line (" s check separate subprogram specs present");
|
||||
Write_Line (" t check token separation rules");
|
||||
|
||||
-- Lines for -gnatz switch
|
||||
|
||||
Write_Switch_Char ("z");
|
||||
Write_Line ("Distribution stub generation (r/s for receiver/sender stubs)");
|
||||
|
||||
-- Line for -gnatZ switch
|
||||
|
||||
Write_Switch_Char ("Z");
|
||||
Write_Line ("Use zero cost exception handling");
|
||||
|
||||
-- Line for -gnat83 switch
|
||||
|
||||
Write_Switch_Char ("83");
|
||||
Write_Line ("Enforce Ada 83 restrictions");
|
||||
|
||||
end Usage;
|
|
@ -0,0 +1,31 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- U S A G E --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.5 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Procedure to generate screen of usage information if no file name present
|
||||
|
||||
procedure Usage;
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,222 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- V A L I D S W --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.2 $
|
||||
-- --
|
||||
-- Copyright (C) 2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Opt; use Opt;
|
||||
|
||||
package body Validsw is
|
||||
|
||||
----------------------------------
|
||||
-- Reset_Validity_Check_Options --
|
||||
----------------------------------
|
||||
|
||||
procedure Reset_Validity_Check_Options is
|
||||
begin
|
||||
Validity_Check_Copies := False;
|
||||
Validity_Check_Default := True;
|
||||
Validity_Check_Floating_Point := False;
|
||||
Validity_Check_In_Out_Params := False;
|
||||
Validity_Check_In_Params := False;
|
||||
Validity_Check_Operands := False;
|
||||
Validity_Check_Returns := False;
|
||||
Validity_Check_Subscripts := False;
|
||||
Validity_Check_Tests := False;
|
||||
end Reset_Validity_Check_Options;
|
||||
|
||||
---------------------------------
|
||||
-- Save_Validity_Check_Options --
|
||||
---------------------------------
|
||||
|
||||
procedure Save_Validity_Check_Options
|
||||
(Options : out Validity_Check_Options)
|
||||
is
|
||||
P : Natural := 0;
|
||||
|
||||
procedure Add (C : Character; S : Boolean);
|
||||
-- Add given character C to string if switch S is true
|
||||
|
||||
procedure Add (C : Character; S : Boolean) is
|
||||
begin
|
||||
if S then
|
||||
P := P + 1;
|
||||
Options (P) := C;
|
||||
end if;
|
||||
end Add;
|
||||
|
||||
-- Start of processing for Save_Validity_Check_Options
|
||||
|
||||
begin
|
||||
for K in Options'Range loop
|
||||
Options (K) := ' ';
|
||||
end loop;
|
||||
|
||||
Add ('c', Validity_Check_Copies);
|
||||
Add ('d', Validity_Check_Default);
|
||||
Add ('f', Validity_Check_Floating_Point);
|
||||
Add ('i', Validity_Check_In_Params);
|
||||
Add ('m', Validity_Check_In_Out_Params);
|
||||
Add ('o', Validity_Check_Operands);
|
||||
Add ('r', Validity_Check_Returns);
|
||||
Add ('s', Validity_Check_Subscripts);
|
||||
Add ('t', Validity_Check_Tests);
|
||||
end Save_Validity_Check_Options;
|
||||
|
||||
----------------------------------------
|
||||
-- Set_Default_Validity_Check_Options --
|
||||
----------------------------------------
|
||||
|
||||
procedure Set_Default_Validity_Check_Options is
|
||||
begin
|
||||
Reset_Validity_Check_Options;
|
||||
Set_Validity_Check_Options ("d");
|
||||
end Set_Default_Validity_Check_Options;
|
||||
|
||||
--------------------------------
|
||||
-- Set_Validity_Check_Options --
|
||||
--------------------------------
|
||||
|
||||
-- Version used when no error checking is required
|
||||
|
||||
procedure Set_Validity_Check_Options (Options : String) is
|
||||
OK : Boolean;
|
||||
EC : Natural;
|
||||
|
||||
begin
|
||||
Set_Validity_Check_Options (Options, OK, EC);
|
||||
end Set_Validity_Check_Options;
|
||||
|
||||
-- Normal version with error checking
|
||||
|
||||
procedure Set_Validity_Check_Options
|
||||
(Options : String;
|
||||
OK : out Boolean;
|
||||
Err_Col : out Natural)
|
||||
is
|
||||
J : Natural;
|
||||
C : Character;
|
||||
|
||||
begin
|
||||
Reset_Validity_Check_Options;
|
||||
|
||||
J := Options'First;
|
||||
while J <= Options'Last loop
|
||||
C := Options (J);
|
||||
J := J + 1;
|
||||
|
||||
case C is
|
||||
when 'c' =>
|
||||
Validity_Check_Copies := True;
|
||||
|
||||
when 'd' =>
|
||||
Validity_Check_Default := True;
|
||||
|
||||
when 'f' =>
|
||||
Validity_Check_Floating_Point := True;
|
||||
|
||||
when 'i' =>
|
||||
Validity_Check_In_Params := True;
|
||||
|
||||
when 'm' =>
|
||||
Validity_Check_In_Out_Params := True;
|
||||
|
||||
when 'o' =>
|
||||
Validity_Check_Operands := True;
|
||||
|
||||
when 'r' =>
|
||||
Validity_Check_Returns := True;
|
||||
|
||||
when 's' =>
|
||||
Validity_Check_Subscripts := True;
|
||||
|
||||
when 't' =>
|
||||
Validity_Check_Tests := True;
|
||||
|
||||
when 'C' =>
|
||||
Validity_Check_Copies := False;
|
||||
|
||||
when 'D' =>
|
||||
Validity_Check_Default := False;
|
||||
|
||||
when 'I' =>
|
||||
Validity_Check_In_Params := False;
|
||||
|
||||
when 'F' =>
|
||||
Validity_Check_Floating_Point := False;
|
||||
|
||||
when 'M' =>
|
||||
Validity_Check_In_Out_Params := False;
|
||||
|
||||
when 'O' =>
|
||||
Validity_Check_Operands := False;
|
||||
|
||||
when 'R' =>
|
||||
Validity_Check_Returns := False;
|
||||
|
||||
when 'S' =>
|
||||
Validity_Check_Subscripts := False;
|
||||
|
||||
when 'T' =>
|
||||
Validity_Check_Tests := False;
|
||||
|
||||
when 'a' =>
|
||||
Validity_Check_Copies := True;
|
||||
Validity_Check_Default := True;
|
||||
Validity_Check_Floating_Point := True;
|
||||
Validity_Check_In_Out_Params := True;
|
||||
Validity_Check_In_Params := True;
|
||||
Validity_Check_Operands := True;
|
||||
Validity_Check_Returns := True;
|
||||
Validity_Check_Subscripts := True;
|
||||
Validity_Check_Tests := True;
|
||||
|
||||
when 'n' =>
|
||||
Validity_Check_Copies := False;
|
||||
Validity_Check_Default := False;
|
||||
Validity_Check_Floating_Point := False;
|
||||
Validity_Check_In_Out_Params := False;
|
||||
Validity_Check_In_Params := False;
|
||||
Validity_Check_Operands := False;
|
||||
Validity_Check_Returns := False;
|
||||
Validity_Check_Subscripts := False;
|
||||
Validity_Check_Tests := False;
|
||||
|
||||
when ' ' =>
|
||||
null;
|
||||
|
||||
when others =>
|
||||
OK := False;
|
||||
Err_Col := J - 1;
|
||||
return;
|
||||
end case;
|
||||
end loop;
|
||||
|
||||
Validity_Checks_On := True;
|
||||
OK := True;
|
||||
Err_Col := Options'Last + 1;
|
||||
end Set_Validity_Check_Options;
|
||||
|
||||
end Validsw;
|
|
@ -0,0 +1,146 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- V A L I D S W --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- --
|
||||
-- Copyright (C) 2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This unit contains the routines used to handle setting of validity
|
||||
-- checking options.
|
||||
|
||||
package Validsw is
|
||||
|
||||
-----------------------------
|
||||
-- Validity Check Switches --
|
||||
-----------------------------
|
||||
|
||||
-- The following flags determine the specific set of validity checks
|
||||
-- to be made if validity checking is active (Validity_Checks_On = True)
|
||||
|
||||
-- See GNAT users guide for an exact description of each option. The letter
|
||||
-- given in the comment is the letter used in the -gnatV compiler switch
|
||||
-- or in the argument of a Validity_Checks pragma to activate the option.
|
||||
-- The corresponding upper case letter deactivates the option.
|
||||
|
||||
Validity_Check_Copies : Boolean := False;
|
||||
-- Controls the validity checking of copies. If this switch is set to
|
||||
-- true using -gnatVc, or a 'c' in the argument of a Validity_Checks
|
||||
-- pragma, then the right side of assignments and also initializing
|
||||
-- expressions in object declarations are checked for validity.
|
||||
|
||||
Validity_Check_Default : Boolean := True;
|
||||
-- Controls default (reference manual) validity checking. If this switch
|
||||
-- is set to True using -gnatVd or a 'd' in the argument of a Validity_
|
||||
-- Checks pragma then left side subscripts and case statement arguments
|
||||
-- are checked for validity. This switch is also set by default if no
|
||||
-- -gnatV switch is used and no Validity_Checks pragma is processed.
|
||||
|
||||
Validity_Check_Floating_Point : Boolean := False;
|
||||
-- Normally validity checking applies only to discrete values (integer
|
||||
-- and enumeration types). If this switch is set to True using -gnatVf
|
||||
-- or an 'f' in the argument of a Validity_Checks pragma, then floating-
|
||||
-- point values are also checked. The context in which such checks
|
||||
-- occur depends on other flags, e.g. if Validity_Check_Copies is also
|
||||
-- set then floating-point values on the right side of an assignment
|
||||
-- will be validity checked.
|
||||
|
||||
Validity_Check_In_Out_Params : Boolean := False;
|
||||
-- Controls the validity checking of IN OUT parameters. If this switch
|
||||
-- is set to True using -gnatVm or a 'm' in the argument of a pragma
|
||||
-- Validity_Checks, then the initial value of all IN OUT parameters
|
||||
-- will be checked at the point of call of a procecure. Note that the
|
||||
-- character 'm' here stands for modified (parameters).
|
||||
|
||||
Validity_Check_In_Params : Boolean := False;
|
||||
-- Controls the validity checking of IN parameters. If this switch is
|
||||
-- set to True using -gnatVm or an 'i' in the argument of a pragma
|
||||
-- Validity_Checks, then the initial value of all IN parameters
|
||||
-- will be checked at the point of call of a procecure or function.
|
||||
|
||||
Validity_Check_Operands : Boolean := False;
|
||||
-- Controls validity checking of operands. If this switch is set to
|
||||
-- True using -gnatVo or an 'o' in the argument of a Validity_Checks
|
||||
-- pragma, then operands of all predefined operators and attributes
|
||||
-- will be validity checked.
|
||||
|
||||
Validity_Check_Returns : Boolean := False;
|
||||
-- Controls validity checking of returned values. If this switch is set
|
||||
-- to True using -gnatVr, or an 'r' in the argument of a Validity_Checks
|
||||
-- pragma, then the expression in a RETURN statement is validity checked.
|
||||
|
||||
Validity_Check_Subscripts : Boolean := False;
|
||||
-- Controls validity checking of subscripts. If this switch is set to
|
||||
-- True using -gnatVs, or an 's' in the argument of a Validity_Checks
|
||||
-- pragma, then all subscripts are checked for validity. Note that left
|
||||
-- side subscript checking is controlled also by Validity_Check_Default.
|
||||
-- If Validity_Check_Subscripts is True, then all subscripts are checked,
|
||||
-- otherwise if Validity_Check_Default is True, then left side subscripts
|
||||
-- are checked, otherwise no subscripts are checked.
|
||||
|
||||
Validity_Check_Tests : Boolean := False;
|
||||
-- Controls validity checking of tests that occur in conditions (i.e. the
|
||||
-- tests in IF, WHILE, and EXIT statements, and in entry guards). If this
|
||||
-- switch is set to True using -gnatVt, or a 't' in the argument of a
|
||||
-- Validity_Checks pragma, then all such conditions are validity checked.
|
||||
|
||||
-----------------
|
||||
-- Subprograms --
|
||||
-----------------
|
||||
|
||||
procedure Set_Default_Validity_Check_Options;
|
||||
-- This procedure is called to set the default validity checking options
|
||||
-- that apply if no Validity_Check switches or pragma is given.
|
||||
|
||||
procedure Set_Validity_Check_Options
|
||||
(Options : String;
|
||||
OK : out Boolean;
|
||||
Err_Col : out Natural);
|
||||
-- This procedure is called to set the validity check options that
|
||||
-- correspond to the characters in the given Options string. If
|
||||
-- all options are valid, then Set_Default_Validity_Check_Options
|
||||
-- is first called to set the defaults, and then the options in the
|
||||
-- given string are set in an additive manner. If any invalid character
|
||||
-- is found, then OK is False on exit, and Err_Col is the index in
|
||||
-- in options of the bad character. If all options are valid, then
|
||||
-- OK is True on return, and Err_Col is set to options'Last + 1.
|
||||
|
||||
procedure Set_Validity_Check_Options (Options : String);
|
||||
-- Like the above procedure, except that the call is simply ignored if
|
||||
-- there are any error conditions, this is for example appopriate for
|
||||
-- calls where the string is known to be valid, e.g. because it was
|
||||
-- obtained by Save_Validity_Check_Options.
|
||||
|
||||
procedure Reset_Validity_Check_Options;
|
||||
-- Sets all validity check options to off
|
||||
|
||||
subtype Validity_Check_Options is String (1 .. 16);
|
||||
-- Long enough string to hold all options from Save call below
|
||||
|
||||
procedure Save_Validity_Check_Options
|
||||
(Options : out Validity_Check_Options);
|
||||
-- Sets Options to represent current selection of options. This
|
||||
-- set can be restored by first calling Reset_Validity_Check_Options,
|
||||
-- and then calling Set_Validity_Check_Options with the Options string.
|
||||
|
||||
end Validsw;
|
|
@ -0,0 +1,163 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- W I D E C H A R --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.15 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Note: this package uses the generic subprograms in System.Wch_Cnv, which
|
||||
-- completely encapsulate the set of wide character encoding methods, so no
|
||||
-- modifications are required when adding new encoding methods.
|
||||
|
||||
with Opt; use Opt;
|
||||
|
||||
with System.WCh_Cnv; use System.WCh_Cnv;
|
||||
with System.WCh_Con; use System.WCh_Con;
|
||||
|
||||
package body Widechar is
|
||||
|
||||
---------------------------
|
||||
-- Is_Start_Of_Wide_Char --
|
||||
---------------------------
|
||||
|
||||
function Is_Start_Of_Wide_Char
|
||||
(S : Source_Buffer_Ptr;
|
||||
P : Source_Ptr)
|
||||
return Boolean
|
||||
is
|
||||
begin
|
||||
case Wide_Character_Encoding_Method is
|
||||
when WCEM_Hex =>
|
||||
return S (P) = ASCII.ESC;
|
||||
|
||||
when WCEM_Upper |
|
||||
WCEM_Shift_JIS |
|
||||
WCEM_EUC |
|
||||
WCEM_UTF8 =>
|
||||
return S (P) >= Character'Val (16#80#);
|
||||
|
||||
when WCEM_Brackets =>
|
||||
return P <= S'Last - 2
|
||||
and then S (P) = '['
|
||||
and then S (P + 1) = '"'
|
||||
and then S (P + 2) /= '"';
|
||||
end case;
|
||||
end Is_Start_Of_Wide_Char;
|
||||
|
||||
-----------------
|
||||
-- Length_Wide --
|
||||
-----------------
|
||||
|
||||
function Length_Wide return Nat is
|
||||
begin
|
||||
return WC_Longest_Sequence;
|
||||
end Length_Wide;
|
||||
|
||||
---------------
|
||||
-- Scan_Wide --
|
||||
---------------
|
||||
|
||||
procedure Scan_Wide
|
||||
(S : Source_Buffer_Ptr;
|
||||
P : in out Source_Ptr;
|
||||
C : out Char_Code;
|
||||
Err : out Boolean)
|
||||
is
|
||||
function In_Char return Character;
|
||||
-- Function to obtain characters of wide character escape sequence
|
||||
|
||||
function In_Char return Character is
|
||||
begin
|
||||
P := P + 1;
|
||||
return S (P - 1);
|
||||
end In_Char;
|
||||
|
||||
function WC_In is new Char_Sequence_To_Wide_Char (In_Char);
|
||||
|
||||
begin
|
||||
C := Char_Code (Wide_Character'Pos
|
||||
(WC_In (In_Char, Wide_Character_Encoding_Method)));
|
||||
Err := False;
|
||||
|
||||
exception
|
||||
when Constraint_Error =>
|
||||
C := Char_Code (0);
|
||||
P := P - 1;
|
||||
Err := True;
|
||||
end Scan_Wide;
|
||||
|
||||
--------------
|
||||
-- Set_Wide --
|
||||
--------------
|
||||
|
||||
procedure Set_Wide
|
||||
(C : Char_Code;
|
||||
S : in out String;
|
||||
P : in out Natural)
|
||||
is
|
||||
procedure Out_Char (C : Character);
|
||||
-- Procedure to store one character of wide character sequence
|
||||
|
||||
procedure Out_Char (C : Character) is
|
||||
begin
|
||||
P := P + 1;
|
||||
S (P) := C;
|
||||
end Out_Char;
|
||||
|
||||
procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char);
|
||||
|
||||
begin
|
||||
WC_Out (Wide_Character'Val (C), Wide_Character_Encoding_Method);
|
||||
end Set_Wide;
|
||||
|
||||
---------------
|
||||
-- Skip_Wide --
|
||||
---------------
|
||||
|
||||
procedure Skip_Wide (S : String; P : in out Natural) is
|
||||
function Skip_Char return Character;
|
||||
-- Function to skip one character of wide character escape sequence
|
||||
|
||||
function Skip_Char return Character is
|
||||
begin
|
||||
P := P + 1;
|
||||
return S (P - 1);
|
||||
end Skip_Char;
|
||||
|
||||
function WC_Skip is new Char_Sequence_To_Wide_Char (Skip_Char);
|
||||
|
||||
Discard : Wide_Character;
|
||||
|
||||
begin
|
||||
Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method);
|
||||
end Skip_Wide;
|
||||
|
||||
end Widechar;
|
|
@ -0,0 +1,87 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- W I D E C H A R --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.10 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1998 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Subprograms for manipulation of wide character sequences
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Widechar is
|
||||
|
||||
function Length_Wide return Nat;
|
||||
-- Returns the maximum length in characters for the escape sequence that
|
||||
-- is used to encode wide character literals outside the ASCII range. Used
|
||||
-- only in the implementation of the attribute Width for Wide_Character.
|
||||
|
||||
procedure Scan_Wide
|
||||
(S : Source_Buffer_Ptr;
|
||||
P : in out Source_Ptr;
|
||||
C : out Char_Code;
|
||||
Err : out Boolean);
|
||||
-- On entry S (P) points to the first character in the source text for
|
||||
-- a wide character (i.e. to an ESC character, a left bracket, or an
|
||||
-- upper half character, depending on the representation method). A
|
||||
-- single wide character is scanned. If no error is found, the value
|
||||
-- stored in C is the code for this wide character, P is updated past
|
||||
-- the sequence and Err is set to False. If an error is found, then
|
||||
-- P points to the improper character, C is undefined, and Err is
|
||||
-- set to True.
|
||||
|
||||
procedure Set_Wide
|
||||
(C : Char_Code;
|
||||
S : in out String;
|
||||
P : in out Natural);
|
||||
-- The escape sequence (including any leading ESC character) for the
|
||||
-- given character code is stored starting at S (P + 1), and on return
|
||||
-- P points to the last stored character (i.e. P is the count of stored
|
||||
-- characters on entry and exit, and the escape sequence is appended to
|
||||
-- the end of the stored string). The character code C represents a code
|
||||
-- originally constructed by Scan_Wide, so it is known to be in a range
|
||||
-- that is appropriate for the encoding method in use.
|
||||
|
||||
procedure Skip_Wide (S : String; P : in out Natural);
|
||||
-- On entry, S (P) points to an ESC character for a wide character escape
|
||||
-- sequence or to an upper half character if the encoding method uses the
|
||||
-- upper bit, or to a left bracket if the brackets encoding method is in
|
||||
-- use. On exit, P is bumped past the wide character sequence. No error
|
||||
-- checking is done, since this is only used on escape sequences generated
|
||||
-- by Set_Wide, which are known to be correct.
|
||||
|
||||
function Is_Start_Of_Wide_Char
|
||||
(S : Source_Buffer_Ptr;
|
||||
P : Source_Ptr)
|
||||
return Boolean;
|
||||
-- Determines if S (P) is the start of a wide character sequence
|
||||
|
||||
end Widechar;
|
|
@ -0,0 +1,539 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT SYSTEM UTILITIES --
|
||||
-- --
|
||||
-- X E I N F O --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.29 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Program to construct C header file a-einfo.h (C version of einfo.ads spec)
|
||||
-- for use by Gigi. This header file contaInF all definitions and access
|
||||
-- functions, but does not contain set procedures, since Gigi is not allowed
|
||||
-- to modify the GNAT tree)
|
||||
|
||||
-- Input files:
|
||||
|
||||
-- einfo.ads spec of Einfo package
|
||||
-- einfo.adb body of Einfo package
|
||||
|
||||
-- Output files:
|
||||
|
||||
-- a-einfo.h Corresponding c header file
|
||||
|
||||
-- Note: It is assumed that the input files have been compiled without errors
|
||||
|
||||
-- An optional argument allows the specification of an output file name to
|
||||
-- override the default a-einfo.h file name for the generated output file.
|
||||
|
||||
-- Most, but not all of the functions in Einfo can be inlined in the C header.
|
||||
-- They are the functions identified by pragma Inline in the spec. Functions
|
||||
-- that cannot be inlined are simply defined in the header.
|
||||
|
||||
with Ada.Command_Line; use Ada.Command_Line;
|
||||
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
||||
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
|
||||
with Ada.Strings.Maps; use Ada.Strings.Maps;
|
||||
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
|
||||
with Ada.Text_IO; use Ada.Text_IO;
|
||||
|
||||
with GNAT.Spitbol; use GNAT.Spitbol;
|
||||
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
||||
with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
|
||||
|
||||
procedure XEinfo is
|
||||
|
||||
package TB renames GNAT.Spitbol.Table_Boolean;
|
||||
|
||||
Err : exception;
|
||||
|
||||
A : VString := Nul;
|
||||
B : VString := Nul;
|
||||
C : VString := Nul;
|
||||
Einfobrev : VString := Nul;
|
||||
Einfosrev : VString := Nul;
|
||||
Expr : VString := Nul;
|
||||
Filler : VString := Nul;
|
||||
Fline : VString := Nul;
|
||||
Formal : VString := Nul;
|
||||
Formaltyp : VString := Nul;
|
||||
FN : VString := Nul;
|
||||
Line : VString := Nul;
|
||||
N : VString := Nul;
|
||||
N1 : VString := Nul;
|
||||
N2 : VString := Nul;
|
||||
N3 : VString := Nul;
|
||||
Nam : VString := Nul;
|
||||
Name : VString := Nul;
|
||||
NewS : VString := Nul;
|
||||
Nextlin : VString := Nul;
|
||||
OldS : VString := Nul;
|
||||
Rtn : VString := Nul;
|
||||
Term : VString := Nul;
|
||||
XEinforev : VString := Nul;
|
||||
|
||||
InB : File_Type;
|
||||
-- Used to read initial header from body
|
||||
|
||||
InF : File_Type;
|
||||
-- Used to read full text of both spec and body
|
||||
|
||||
Ofile : File_Type;
|
||||
-- Used to write output file
|
||||
|
||||
wsp : Pattern := NSpan (' ' & ASCII.HT);
|
||||
Get_BRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
|
||||
& Break (' ') * Einfobrev;
|
||||
Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
|
||||
& Break (' ') * Einfosrev;
|
||||
Comment : Pattern := wsp & "--";
|
||||
For_Rep : Pattern := wsp & "for";
|
||||
Get_Func : Pattern := wsp * A & "function" & wsp & Break (' ') * Name;
|
||||
Inline : Pattern := wsp & "pragma Inline (" & Break (')') * Name;
|
||||
Get_Pack : Pattern := wsp & "package ";
|
||||
Get_Enam : Pattern := wsp & Break (',') * N & ',';
|
||||
Find_Fun : Pattern := wsp & "function";
|
||||
F_Subtyp : Pattern := wsp * A & "subtype " & Break (' ') * N;
|
||||
G_Subtyp : Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
|
||||
& wsp & "is" & wsp & Break (" ;") * OldS
|
||||
& wsp & ';' & wsp & Rtab (0);
|
||||
F_Typ : Pattern := wsp * A & "type " & Break (' ') * N & " is (";
|
||||
Get_Nam : Pattern := wsp * A & Break (",)") * Nam & Len (1) * Term;
|
||||
Get_Styp : Pattern := wsp * A & "subtype " & Break (' ') * N;
|
||||
Get_N1 : Pattern := wsp & Break (' ') * N1;
|
||||
Get_N2 : Pattern := wsp & "-- " & Rest * N2;
|
||||
Get_N3 : Pattern := wsp & Break (';') * N3;
|
||||
Get_FN : Pattern := wsp * C & "function" & wsp & Break (" (") * FN;
|
||||
Is_Rturn : Pattern := BreakX ('r') & "return";
|
||||
Is_Begin : Pattern := wsp & "begin";
|
||||
Get_Asrt : Pattern := wsp & "pragma Assert";
|
||||
Semicoln : Pattern := BreakX (';');
|
||||
Get_Cmnt : Pattern := BreakX ('-') * A & "--";
|
||||
Get_Expr : Pattern := wsp & "return " & Break (';') * Expr;
|
||||
Chek_End : Pattern := wsp & "end" & BreakX (';') & ';';
|
||||
Get_B1 : Pattern := BreakX (' ') * A & " in " & Rest * B;
|
||||
Get_B2 : Pattern := BreakX (' ') * A & " = " & Rest * B;
|
||||
Get_B3 : Pattern := BreakX (' ') * A & " /= " & Rest * B;
|
||||
To_Paren : Pattern := wsp * Filler & '(';
|
||||
Get_Fml : Pattern := Break (" :") * Formal & wsp & ':' & wsp
|
||||
& BreakX (" );") * Formaltyp;
|
||||
Nxt_Fml : Pattern := wsp & "; ";
|
||||
Get_Rtn : Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
|
||||
Rem_Prn : Pattern := wsp & ')';
|
||||
|
||||
M : Match_Result;
|
||||
|
||||
Lineno : Natural := 0;
|
||||
-- Line number in spec
|
||||
|
||||
V : Natural;
|
||||
Ctr : Natural;
|
||||
|
||||
Inlined : TB.Table (200);
|
||||
-- Inlined<N> = True for inlined function, False otherwise
|
||||
|
||||
Lastinlined : Boolean;
|
||||
|
||||
procedure Badfunc;
|
||||
-- Signal bad function in body
|
||||
|
||||
function Getlin return VString;
|
||||
-- Get non-comment line (comment lines skipped, also skips FOR rep clauses)
|
||||
-- Fatal error (raises End_Error exception) if end of file encountered
|
||||
|
||||
procedure Must (B : Boolean);
|
||||
-- Raises Err if the argument (a Match) call, returns False
|
||||
|
||||
procedure Sethead (Line : in out VString; Term : String);
|
||||
-- Process function header into C
|
||||
|
||||
-------------
|
||||
-- Badfunc --
|
||||
-------------
|
||||
|
||||
procedure Badfunc is
|
||||
begin
|
||||
Put_Line
|
||||
(Standard_Error,
|
||||
"Body for function " & FN & " does not meet requirements");
|
||||
raise Err;
|
||||
end Badfunc;
|
||||
|
||||
-------------
|
||||
-- Getlin --
|
||||
-------------
|
||||
|
||||
function Getlin return VString is
|
||||
Lin : VString;
|
||||
|
||||
begin
|
||||
loop
|
||||
Lin := Get_Line (InF);
|
||||
Lineno := Lineno + 1;
|
||||
|
||||
if Lin /= ""
|
||||
and then not Match (Lin, Comment)
|
||||
and then not Match (Lin, For_Rep)
|
||||
then
|
||||
return Lin;
|
||||
end if;
|
||||
end loop;
|
||||
end Getlin;
|
||||
|
||||
----------
|
||||
-- Must --
|
||||
----------
|
||||
|
||||
procedure Must (B : Boolean) is
|
||||
begin
|
||||
if not B then
|
||||
raise Err;
|
||||
end if;
|
||||
end Must;
|
||||
|
||||
-------------
|
||||
-- Sethead --
|
||||
-------------
|
||||
|
||||
procedure Sethead (Line : in out VString; Term : String) is
|
||||
Args : VString;
|
||||
|
||||
begin
|
||||
Must (Match (Line, Get_Func, ""));
|
||||
Args := Nul;
|
||||
|
||||
if Match (Line, To_Paren, "") then
|
||||
Args := Filler & '(';
|
||||
|
||||
loop
|
||||
Must (Match (Line, Get_Fml, ""));
|
||||
Append (Args, Formaltyp & ' ' & Formal);
|
||||
exit when not Match (Line, Nxt_Fml);
|
||||
Append (Args, ",");
|
||||
end loop;
|
||||
|
||||
Match (Line, Rem_Prn, "");
|
||||
Append (Args, ')');
|
||||
end if;
|
||||
|
||||
Must (Match (Line, Get_Rtn));
|
||||
|
||||
if Present (Inlined, Name) then
|
||||
Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term);
|
||||
else
|
||||
Put_Line (Ofile, A & Rtn & ' ' & Name & Args & Term);
|
||||
end if;
|
||||
end Sethead;
|
||||
|
||||
-- Start of processing for XEinfo
|
||||
|
||||
begin
|
||||
Anchored_Mode := True;
|
||||
|
||||
Match ("$Revision: 1.29 $", "$Rev" & "ision: " & Break (' ') * XEinforev);
|
||||
|
||||
if Argument_Count > 0 then
|
||||
Create (Ofile, Out_File, Argument (1));
|
||||
else
|
||||
Create (Ofile, Out_File, "a-einfo.h");
|
||||
end if;
|
||||
|
||||
Open (InB, In_File, "einfo.adb");
|
||||
Open (InF, In_File, "einfo.ads");
|
||||
|
||||
Lineno := 0;
|
||||
|
||||
-- Get einfo revs and write header to output file
|
||||
|
||||
loop
|
||||
Line := Get_Line (InB);
|
||||
|
||||
if Line = "" then
|
||||
raise Err;
|
||||
end if;
|
||||
|
||||
exit when Match (Line, Get_BRev);
|
||||
end loop;
|
||||
|
||||
loop
|
||||
Line := Get_Line (InF);
|
||||
Lineno := Lineno + 1;
|
||||
exit when Line = "";
|
||||
|
||||
if Match (Line, Get_SRev) then
|
||||
Put_Line
|
||||
(Ofile,
|
||||
"/* Generated by xeinfo revision " & XEinforev &
|
||||
" using */");
|
||||
Put_Line
|
||||
(Ofile,
|
||||
"/* einfo.ads revision " & Einfosrev &
|
||||
" */");
|
||||
Put_Line
|
||||
(Ofile,
|
||||
"/* einfo.adb revision " & Einfobrev &
|
||||
" */");
|
||||
else
|
||||
Match (Line,
|
||||
"-- S p e c ",
|
||||
"-- C Header File ");
|
||||
|
||||
Match (Line, "--", "/*");
|
||||
Match (Line, Rtab (2) * A & "--", M);
|
||||
Replace (M, A & "*/");
|
||||
Put_Line (Ofile, Line);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Put_Line (Ofile, "");
|
||||
|
||||
-- Find and record pragma Inlines
|
||||
|
||||
loop
|
||||
Line := Get_Line (InF);
|
||||
exit when Match (Line, " -- END XEINFO INLINES");
|
||||
|
||||
|
||||
if Match (Line, Inline) then
|
||||
Set (Inlined, Name, True);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Skip to package line
|
||||
|
||||
Reset (InF, In_File);
|
||||
Lineno := 0;
|
||||
|
||||
loop
|
||||
Line := Getlin;
|
||||
exit when Match (Line, Get_Pack);
|
||||
end loop;
|
||||
|
||||
V := 0;
|
||||
Line := Getlin;
|
||||
Must (Match (Line, wsp & "type Entity_Kind"));
|
||||
|
||||
-- Process entity kind code definitions
|
||||
|
||||
loop
|
||||
Line := Getlin;
|
||||
exit when not Match (Line, Get_Enam);
|
||||
Put_Line (Ofile, " #define " & Rpad (N, 32) & " " & V);
|
||||
V := V + 1;
|
||||
end loop;
|
||||
|
||||
Must (Match (Line, wsp & Rest * N));
|
||||
Put_Line (Ofile, " #define " & Rpad (N, 32) & ' ' & V);
|
||||
Line := Getlin;
|
||||
|
||||
Must (Match (Line, wsp & ");"));
|
||||
Put_Line (Ofile, "");
|
||||
|
||||
-- Loop through subtype and type declarations
|
||||
|
||||
loop
|
||||
Line := Getlin;
|
||||
exit when Match (Line, Find_Fun);
|
||||
|
||||
-- Case of a subtype declaration
|
||||
|
||||
if Match (Line, F_Subtyp) then
|
||||
|
||||
-- Case of a subtype declaration that is an abbreviation of the
|
||||
-- form subtype x is y, and if so generate the appropriate typedef
|
||||
|
||||
if Match (Line, G_Subtyp) then
|
||||
Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';');
|
||||
|
||||
-- Otherwise the subtype must be declaring a subrange of Entity_Id
|
||||
|
||||
else
|
||||
Must (Match (Line, Get_Styp));
|
||||
Line := Getlin;
|
||||
Must (Match (Line, Get_N1));
|
||||
|
||||
loop
|
||||
Line := Get_Line (InF);
|
||||
Lineno := Lineno + 1;
|
||||
exit when not Match (Line, Get_N2);
|
||||
end loop;
|
||||
|
||||
Must (Match (Line, Get_N3));
|
||||
Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, ");
|
||||
Put_Line (Ofile, A & " " & N1 & ", " & N3 & ')');
|
||||
Put_Line (Ofile, "");
|
||||
end if;
|
||||
|
||||
|
||||
-- Case of type declaration
|
||||
|
||||
elsif Match (Line, F_Typ) then
|
||||
-- Process type declaration (must be enumeration type)
|
||||
|
||||
Ctr := 0;
|
||||
Put_Line (Ofile, A & "typedef int " & N & ';');
|
||||
|
||||
loop
|
||||
Line := Getlin;
|
||||
Must (Match (Line, Get_Nam));
|
||||
Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
|
||||
Ctr := Ctr + 1;
|
||||
exit when Term /= ",";
|
||||
end loop;
|
||||
|
||||
Put_Line (Ofile, "");
|
||||
|
||||
-- Neither subtype nor type declaration
|
||||
|
||||
else
|
||||
raise Err;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Process function declarations
|
||||
-- Note: Lastinlined used to control blank lines
|
||||
|
||||
Put_Line (Ofile, "");
|
||||
Lastinlined := True;
|
||||
|
||||
-- Loop through function declarations
|
||||
|
||||
while Match (Line, Get_FN) loop
|
||||
|
||||
-- Non-inlined funcion
|
||||
|
||||
if not Present (Inlined, FN) then
|
||||
Put_Line (Ofile, "");
|
||||
Put_Line
|
||||
(Ofile,
|
||||
" #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
|
||||
|
||||
-- Inlined function
|
||||
|
||||
else
|
||||
if not Lastinlined then
|
||||
Put_Line (Ofile, "");
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Merge here to output spec
|
||||
|
||||
Sethead (Line, ";");
|
||||
Lastinlined := Get (Inlined, FN);
|
||||
Line := Getlin;
|
||||
end loop;
|
||||
|
||||
Put_Line (Ofile, "");
|
||||
|
||||
-- Read body to find inlined functions
|
||||
|
||||
Close (InB);
|
||||
Close (InF);
|
||||
Open (InF, In_File, "einfo.adb");
|
||||
Lineno := 0;
|
||||
|
||||
-- Loop through input lines to find bodies of inlined functions
|
||||
|
||||
while not End_Of_File (InF) loop
|
||||
Fline := Get_Line (InF);
|
||||
|
||||
if Match (Fline, Get_FN)
|
||||
and then Get (Inlined, FN)
|
||||
then
|
||||
-- Here we have an inlined function
|
||||
|
||||
if not Match (Fline, Is_Rturn) then
|
||||
Line := Fline;
|
||||
Badfunc;
|
||||
end if;
|
||||
|
||||
Line := Getlin;
|
||||
|
||||
if not Match (Line, Is_Begin) then
|
||||
Badfunc;
|
||||
end if;
|
||||
|
||||
-- Skip past pragma Asserts
|
||||
|
||||
loop
|
||||
Line := Getlin;
|
||||
exit when not Match (Line, Get_Asrt);
|
||||
|
||||
-- Pragma asser found, get its continuation lines
|
||||
|
||||
loop
|
||||
exit when Match (Line, Semicoln);
|
||||
Line := Getlin;
|
||||
end loop;
|
||||
end loop;
|
||||
|
||||
-- Process return statement
|
||||
|
||||
Match (Line, Get_Cmnt, M);
|
||||
Replace (M, A);
|
||||
|
||||
-- Get continuations of return statemnt
|
||||
|
||||
while not Match (Line, Semicoln) loop
|
||||
Nextlin := Getlin;
|
||||
Match (Nextlin, wsp, " ");
|
||||
Append (Line, Nextlin);
|
||||
end loop;
|
||||
|
||||
if not Match (Line, Get_Expr) then
|
||||
Badfunc;
|
||||
end if;
|
||||
|
||||
Line := Getlin;
|
||||
|
||||
if not Match (Line, Chek_End) then
|
||||
Badfunc;
|
||||
end if;
|
||||
|
||||
Match (Expr, Get_B1, M);
|
||||
Replace (M, "IN (" & A & ", " & B & ')');
|
||||
Match (Expr, Get_B2, M);
|
||||
Replace (M, A & " == " & B);
|
||||
Match (Expr, Get_B3, M);
|
||||
Replace (M, A & " != " & B);
|
||||
Put_Line (Ofile, "");
|
||||
Sethead (Fline, "");
|
||||
Put_Line (Ofile, C & " { return " & Expr & "; }");
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Put_Line (Ofile, "");
|
||||
Put_Line
|
||||
(Ofile,
|
||||
"/* End of einfo.h (C version of Einfo package specification) */");
|
||||
|
||||
exception
|
||||
when Err =>
|
||||
Put_Line (Standard_Error, Lineno & ". " & Line);
|
||||
Put_Line (Standard_Error, "**** fatal error ****");
|
||||
Set_Exit_Status (1);
|
||||
|
||||
when End_Error =>
|
||||
Put_Line (Standard_Error, "unexpected end of file");
|
||||
Put_Line (Standard_Error, "**** fatal error ****");
|
||||
|
||||
end XEinfo;
|
|
@ -0,0 +1,485 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT SYSTEM UTILITIES --
|
||||
-- --
|
||||
-- X N M A K E --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.27 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Program to construct the spec and body of the Nmake package
|
||||
|
||||
-- Input files:
|
||||
|
||||
-- sinfo.ads Spec of Sinfo package
|
||||
-- nmake.adt Template for Nmake package
|
||||
|
||||
-- Output files:
|
||||
|
||||
-- nmake.ads Spec of Nmake package
|
||||
-- nmake.adb Body of Nmake package
|
||||
|
||||
-- Note: this program assumes that sinfo.ads has passed the error checks that
|
||||
-- are carried out by the csinfo utility, so it does not duplicate these
|
||||
-- checks and assumes that sinfo.ads has the correct form.
|
||||
|
||||
-- In the absence of any switches, both the ads and adb files are output.
|
||||
-- The switch -s or /s indicates that only the ads file is to be output.
|
||||
-- The switch -b or /b indicates that only the adb file is to be output.
|
||||
|
||||
-- If a file name argument is given, then the output is written to this file
|
||||
-- rather than to nmake.ads or nmake.adb. A file name can only be given if
|
||||
-- exactly one of the -s or -b options is present.
|
||||
|
||||
with Ada.Command_Line; use Ada.Command_Line;
|
||||
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
||||
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
|
||||
with Ada.Strings.Maps; use Ada.Strings.Maps;
|
||||
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
|
||||
with Ada.Text_IO; use Ada.Text_IO;
|
||||
|
||||
with GNAT.Spitbol; use GNAT.Spitbol;
|
||||
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
||||
|
||||
procedure XNmake is
|
||||
|
||||
Err : exception;
|
||||
-- Raised to terminate execution
|
||||
|
||||
A : VString := Nul;
|
||||
Arg : VString := Nul;
|
||||
Arg_List : VString := Nul;
|
||||
Comment : VString := Nul;
|
||||
Default : VString := Nul;
|
||||
Field : VString := Nul;
|
||||
Line : VString := Nul;
|
||||
Node : VString := Nul;
|
||||
Op_Name : VString := Nul;
|
||||
Prevl : VString := Nul;
|
||||
Sinfo_Rev : VString := Nul;
|
||||
Synonym : VString := Nul;
|
||||
Temp_Rev : VString := Nul;
|
||||
X : VString := Nul;
|
||||
XNmake_Rev : VString := Nul;
|
||||
|
||||
Lineno : Natural;
|
||||
NWidth : Natural;
|
||||
|
||||
FileS : VString := V ("nmake.ads");
|
||||
FileB : VString := V ("nmake.adb");
|
||||
-- Set to null if corresponding file not to be generated
|
||||
|
||||
Given_File : VString := Nul;
|
||||
-- File name given by command line argument
|
||||
|
||||
InS, InT : File_Type;
|
||||
OutS, OutB : File_Type;
|
||||
|
||||
wsp : Pattern := Span (' ' & ASCII.HT);
|
||||
|
||||
-- Note: in following patterns, we break up the word revision to
|
||||
-- avoid RCS getting enthusiastic about updating the reference!
|
||||
|
||||
Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: " &
|
||||
Break (' ') * Sinfo_Rev;
|
||||
|
||||
GetT_Rev : Pattern := BreakX ('$') & "$Rev" & "ision: " &
|
||||
Break (' ') * Temp_Rev;
|
||||
|
||||
|
||||
Body_Only : Pattern := BreakX (' ') * X & Span (' ') & "-- body only";
|
||||
Spec_Only : Pattern := BreakX (' ') * X & Span (' ') & "-- spec only";
|
||||
|
||||
Node_Hdr : Pattern := wsp & "-- N_" & Rest * Node;
|
||||
Punc : Pattern := BreakX (" .,");
|
||||
|
||||
Binop : Pattern := wsp & "-- plus fields for binary operator";
|
||||
Unop : Pattern := wsp & "-- plus fields for unary operator";
|
||||
Syn : Pattern := wsp & "-- " & Break (' ') * Synonym
|
||||
& " (" & Break (')') * Field & Rest * Comment;
|
||||
|
||||
Templ : Pattern := BreakX ('T') * A & "T e m p l a t e";
|
||||
Spec : Pattern := BreakX ('S') * A & "S p e c";
|
||||
|
||||
Sem_Field : Pattern := BreakX ('-') & "-Sem";
|
||||
Lib_Field : Pattern := BreakX ('-') & "-Lib";
|
||||
|
||||
Get_Field : Pattern := BreakX (Decimal_Digit_Set) * Field;
|
||||
|
||||
Get_Dflt : Pattern := BreakX ('(') & "(set to "
|
||||
& Break (" ") * Default & " if";
|
||||
|
||||
Next_Arg : Pattern := Break (',') * Arg & ',';
|
||||
|
||||
Op_Node : Pattern := "Op_" & Rest * Op_Name;
|
||||
|
||||
Shft_Rot : Pattern := "Shift_" or "Rotate_";
|
||||
|
||||
No_Ent : Pattern := "Or_Else" or "And_Then" or "In" or "Not_In";
|
||||
|
||||
M : Match_Result;
|
||||
|
||||
V_String_Id : constant VString := V ("String_Id");
|
||||
V_Node_Id : constant VString := V ("Node_Id");
|
||||
V_Name_Id : constant VString := V ("Name_Id");
|
||||
V_List_Id : constant VString := V ("List_Id");
|
||||
V_Elist_Id : constant VString := V ("Elist_Id");
|
||||
V_Boolean : constant VString := V ("Boolean");
|
||||
|
||||
procedure WriteS (S : String);
|
||||
procedure WriteB (S : String);
|
||||
procedure WriteBS (S : String);
|
||||
procedure WriteS (S : VString);
|
||||
procedure WriteB (S : VString);
|
||||
procedure WriteBS (S : VString);
|
||||
-- Write given line to spec or body file or both if active
|
||||
|
||||
procedure WriteB (S : String) is
|
||||
begin
|
||||
if FileB /= Nul then
|
||||
Put_Line (OutB, S);
|
||||
end if;
|
||||
end WriteB;
|
||||
|
||||
procedure WriteB (S : VString) is
|
||||
begin
|
||||
if FileB /= Nul then
|
||||
Put_Line (OutB, S);
|
||||
end if;
|
||||
end WriteB;
|
||||
|
||||
procedure WriteBS (S : String) is
|
||||
begin
|
||||
if FileB /= Nul then
|
||||
Put_Line (OutB, S);
|
||||
end if;
|
||||
|
||||
if FileS /= Nul then
|
||||
Put_Line (OutS, S);
|
||||
end if;
|
||||
end WriteBS;
|
||||
|
||||
procedure WriteBS (S : VString) is
|
||||
begin
|
||||
if FileB /= Nul then
|
||||
Put_Line (OutB, S);
|
||||
end if;
|
||||
|
||||
if FileS /= Nul then
|
||||
Put_Line (OutS, S);
|
||||
end if;
|
||||
end WriteBS;
|
||||
|
||||
procedure WriteS (S : String) is
|
||||
begin
|
||||
if FileS /= Nul then
|
||||
Put_Line (OutS, S);
|
||||
end if;
|
||||
end WriteS;
|
||||
|
||||
procedure WriteS (S : VString) is
|
||||
begin
|
||||
if FileS /= Nul then
|
||||
Put_Line (OutS, S);
|
||||
end if;
|
||||
end WriteS;
|
||||
|
||||
-- Start of processing for XNmake
|
||||
|
||||
begin
|
||||
-- Capture our revision (following line updated by RCS)
|
||||
|
||||
Match ("$Revision: 1.27 $", "$Rev" & "ision: " & Break (' ') * XNmake_Rev);
|
||||
|
||||
Lineno := 0;
|
||||
NWidth := 28;
|
||||
Anchored_Mode := True;
|
||||
|
||||
for ArgN in 1 .. Argument_Count loop
|
||||
declare
|
||||
Arg : constant String := Argument (ArgN);
|
||||
|
||||
begin
|
||||
if Arg (1) = '/' or else Arg (1) = '-' then
|
||||
if Arg'Length = 2
|
||||
and then (Arg (2) = 'b' or else Arg (2) = 'B')
|
||||
then
|
||||
FileS := Nul;
|
||||
|
||||
elsif Arg'Length = 2
|
||||
and then (Arg (2) = 's' or else Arg (2) = 'S')
|
||||
then
|
||||
FileB := Nul;
|
||||
|
||||
else
|
||||
raise Err;
|
||||
end if;
|
||||
|
||||
else
|
||||
if Given_File /= Nul then
|
||||
raise Err;
|
||||
else
|
||||
Given_File := V (Arg);
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
if FileS = Nul and then FileB = Nul then
|
||||
raise Err;
|
||||
|
||||
elsif Given_File /= Nul then
|
||||
if FileS = Nul then
|
||||
FileS := Given_File;
|
||||
|
||||
elsif FileB = Nul then
|
||||
FileB := Given_File;
|
||||
|
||||
else
|
||||
raise Err;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Open (InS, In_File, "sinfo.ads");
|
||||
Open (InT, In_File, "nmake.adt");
|
||||
|
||||
if FileS /= Nul then
|
||||
Create (OutS, Out_File, S (FileS));
|
||||
end if;
|
||||
|
||||
if FileB /= Nul then
|
||||
Create (OutB, Out_File, S (FileB));
|
||||
end if;
|
||||
|
||||
Anchored_Mode := True;
|
||||
|
||||
-- Get Sinfo revision number
|
||||
|
||||
loop
|
||||
Line := Get_Line (InS);
|
||||
exit when Match (Line, Get_SRev);
|
||||
end loop;
|
||||
|
||||
-- Copy initial part of template to spec and body
|
||||
|
||||
loop
|
||||
Line := Get_Line (InT);
|
||||
|
||||
if Match (Line, GetT_Rev) then
|
||||
WriteBS
|
||||
("-- Generated by xnmake revision " &
|
||||
XNmake_Rev & " using" &
|
||||
" --");
|
||||
|
||||
WriteBS
|
||||
("-- sinfo.ads revision " &
|
||||
Sinfo_Rev &
|
||||
" --");
|
||||
|
||||
WriteBS
|
||||
("-- nmake.adt revision " &
|
||||
Temp_Rev &
|
||||
" --");
|
||||
|
||||
else
|
||||
-- Skip lines describing the template
|
||||
|
||||
if Match (Line, "-- This file is a template") then
|
||||
loop
|
||||
Line := Get_Line (InT);
|
||||
exit when Line = "";
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
exit when Match (Line, "package");
|
||||
|
||||
if Match (Line, Body_Only, M) then
|
||||
Replace (M, X);
|
||||
WriteB (Line);
|
||||
|
||||
elsif Match (Line, Spec_Only, M) then
|
||||
Replace (M, X);
|
||||
WriteS (Line);
|
||||
|
||||
else
|
||||
if Match (Line, Templ, M) then
|
||||
Replace (M, A & " S p e c ");
|
||||
end if;
|
||||
|
||||
WriteS (Line);
|
||||
|
||||
if Match (Line, Spec, M) then
|
||||
Replace (M, A & "B o d y");
|
||||
end if;
|
||||
|
||||
WriteB (Line);
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Package line reached
|
||||
|
||||
WriteS ("package Nmake is");
|
||||
WriteB ("package body Nmake is");
|
||||
WriteB ("");
|
||||
|
||||
-- Copy rest of lines up to template insert point to spec only
|
||||
|
||||
loop
|
||||
Line := Get_Line (InT);
|
||||
exit when Match (Line, "!!TEMPLATE INSERTION POINT");
|
||||
WriteS (Line);
|
||||
end loop;
|
||||
|
||||
-- Here we are doing the actual insertions, loop through node types
|
||||
|
||||
loop
|
||||
Line := Get_Line (InS);
|
||||
|
||||
if Match (Line, Node_Hdr)
|
||||
and then not Match (Node, Punc)
|
||||
and then Node /= "Unused"
|
||||
then
|
||||
exit when Node = "Empty";
|
||||
Prevl := " function Make_" & Node & " (Sloc : Source_Ptr";
|
||||
Arg_List := Nul;
|
||||
|
||||
-- Loop through fields of one node
|
||||
|
||||
loop
|
||||
Line := Get_Line (InS);
|
||||
exit when Line = "";
|
||||
|
||||
if Match (Line, Binop) then
|
||||
WriteBS (Prevl & ';');
|
||||
Append (Arg_List, "Left_Opnd,Right_Opnd,");
|
||||
WriteBS (
|
||||
" " & Rpad ("Left_Opnd", NWidth) & " : Node_Id;");
|
||||
Prevl :=
|
||||
" " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";
|
||||
|
||||
elsif Match (Line, Unop) then
|
||||
WriteBS (Prevl & ';');
|
||||
Append (Arg_List, "Right_Opnd,");
|
||||
Prevl := " " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";
|
||||
|
||||
elsif Match (Line, Syn) then
|
||||
if Synonym /= "Prev_Ids"
|
||||
and then Synonym /= "More_Ids"
|
||||
and then Synonym /= "Comes_From_Source"
|
||||
and then Synonym /= "Paren_Count"
|
||||
and then not Match (Field, Sem_Field)
|
||||
and then not Match (Field, Lib_Field)
|
||||
then
|
||||
Match (Field, Get_Field);
|
||||
|
||||
if Field = "Str" then Field := V_String_Id;
|
||||
elsif Field = "Node" then Field := V_Node_Id;
|
||||
elsif Field = "Name" then Field := V_Name_Id;
|
||||
elsif Field = "List" then Field := V_List_Id;
|
||||
elsif Field = "Elist" then Field := V_Elist_Id;
|
||||
elsif Field = "Flag" then Field := V_Boolean;
|
||||
end if;
|
||||
|
||||
if Field = "Boolean" then
|
||||
Default := V ("False");
|
||||
else
|
||||
Default := Nul;
|
||||
end if;
|
||||
|
||||
Match (Comment, Get_Dflt);
|
||||
|
||||
WriteBS (Prevl & ';');
|
||||
Append (Arg_List, Synonym & ',');
|
||||
Rpad (Synonym, NWidth);
|
||||
|
||||
if Default = "" then
|
||||
Prevl := " " & Synonym & " : " & Field;
|
||||
else
|
||||
Prevl :=
|
||||
" " & Synonym & " : " & Field & " := " & Default;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
WriteBS (Prevl & ')');
|
||||
WriteS (" return Node_Id;");
|
||||
WriteS (" pragma Inline (Make_" & Node & ");");
|
||||
WriteB (" return Node_Id");
|
||||
WriteB (" is");
|
||||
WriteB (" N : constant Node_Id :=");
|
||||
|
||||
if Match (Node, "Defining_Identifier") or else
|
||||
Match (Node, "Defining_Character") or else
|
||||
Match (Node, "Defining_Operator")
|
||||
then
|
||||
WriteB (" New_Entity (N_" & Node & ", Sloc);");
|
||||
else
|
||||
WriteB (" New_Node (N_" & Node & ", Sloc);");
|
||||
end if;
|
||||
|
||||
WriteB (" begin");
|
||||
|
||||
while Match (Arg_List, Next_Arg, "") loop
|
||||
if Length (Arg) < NWidth then
|
||||
WriteB (" Set_" & Arg & " (N, " & Arg & ");");
|
||||
else
|
||||
WriteB (" Set_" & Arg);
|
||||
WriteB (" (N, " & Arg & ");");
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
if Match (Node, Op_Node) then
|
||||
if Node = "Op_Plus" then
|
||||
WriteB (" Set_Chars (N, Name_Op_Add);");
|
||||
|
||||
elsif Node = "Op_Minus" then
|
||||
WriteB (" Set_Chars (N, Name_Op_Subtract);");
|
||||
|
||||
elsif Match (Op_Name, Shft_Rot) then
|
||||
WriteB (" Set_Chars (N, Name_" & Op_Name & ");");
|
||||
|
||||
else
|
||||
WriteB (" Set_Chars (N, Name_" & Node & ");");
|
||||
end if;
|
||||
|
||||
if not Match (Op_Name, No_Ent) then
|
||||
WriteB (" Set_Entity (N, Standard_" & Node & ");");
|
||||
end if;
|
||||
end if;
|
||||
|
||||
WriteB (" return N;");
|
||||
WriteB (" end Make_" & Node & ';');
|
||||
WriteBS ("");
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
WriteBS ("end Nmake;");
|
||||
|
||||
exception
|
||||
|
||||
when Err =>
|
||||
Put_Line (Standard_Error, "usage: xnmake [-b] [-s] [filename]");
|
||||
Set_Exit_Status (1);
|
||||
|
||||
end XNmake;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,384 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- X R _ T A B L S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.18 $
|
||||
-- --
|
||||
-- Copyright (C) 1998-2000 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Strings.Unbounded;
|
||||
|
||||
package Xr_Tabls is
|
||||
|
||||
-------------------
|
||||
-- Project files --
|
||||
-------------------
|
||||
|
||||
function ALI_File_Name (Ada_File_Name : String) return String;
|
||||
-- Returns the ali file name corresponding to Ada_File_Name, using the
|
||||
-- information provided in gnat.adc if it exists
|
||||
|
||||
procedure Create_Project_File
|
||||
(Name : String);
|
||||
-- Open and parse a new project file
|
||||
-- If the file Name could not be open or is not a valid project file
|
||||
-- then a project file associated with the standard default directories
|
||||
-- is returned
|
||||
|
||||
function Find_ALI_File (Short_Name : String) return String;
|
||||
-- Returns the directory name for the file Short_Name
|
||||
-- takes into account the obj_dir lines in the project file,
|
||||
-- and the default paths for Gnat
|
||||
|
||||
function Find_Source_File (Short_Name : String) return String;
|
||||
-- Returns the directory name for the file Short_Name
|
||||
-- takes into account the src_dir lines in the project file,
|
||||
-- and the default paths for Gnat
|
||||
|
||||
function Next_Src_Dir return String;
|
||||
-- Returns the next directory to visit to find related source files
|
||||
-- If there are no more such directory, Length = 0
|
||||
|
||||
function Next_Obj_Dir return String;
|
||||
-- Returns the next directory to visit to find related ali files
|
||||
-- If there are no more such directory, Length = 0
|
||||
|
||||
function Current_Obj_Dir return String;
|
||||
-- Returns the obj_dir which was returned by the last Next_Obj_Dir call
|
||||
|
||||
procedure Parse_Gnatls
|
||||
(Gnatls_Src_Cache : out Ada.Strings.Unbounded.Unbounded_String;
|
||||
Gnatls_Obj_Cache : out Ada.Strings.Unbounded.Unbounded_String);
|
||||
-- Parse the output of Gnatls, to find the standard
|
||||
-- directories for source files
|
||||
|
||||
procedure Reset_Src_Dir;
|
||||
-- Reset the iterator for Src_Dir
|
||||
|
||||
procedure Reset_Obj_Dir;
|
||||
-- Reset the iterator for Obj_Dir
|
||||
|
||||
------------
|
||||
-- Tables --
|
||||
------------
|
||||
|
||||
type Declaration_Reference is private;
|
||||
Empty_Declaration : constant Declaration_Reference;
|
||||
|
||||
type File_Reference is private;
|
||||
Empty_File : constant File_Reference;
|
||||
|
||||
type Reference is private;
|
||||
Empty_Reference : constant Reference;
|
||||
|
||||
type File_Table is limited private;
|
||||
type Entity_Table is limited private;
|
||||
|
||||
function Add_Declaration
|
||||
(File_Ref : File_Reference;
|
||||
Symbol : String;
|
||||
Line : Natural;
|
||||
Column : Natural;
|
||||
Decl_Type : Character)
|
||||
return Declaration_Reference;
|
||||
-- Add a new declaration in the table and return the index to it.
|
||||
-- Decl_Type is the type of the entity
|
||||
|
||||
procedure Add_Parent
|
||||
(Declaration : in out Declaration_Reference;
|
||||
Symbol : String;
|
||||
Line : Natural;
|
||||
Column : Natural;
|
||||
File_Ref : File_Reference);
|
||||
-- The parent declaration (Symbol in file File_Ref at position Line and
|
||||
-- Column) information is added to Declaration.
|
||||
|
||||
procedure Add_File
|
||||
(File_Name : String;
|
||||
File_Existed : out Boolean;
|
||||
Ref : out File_Reference;
|
||||
Visited : Boolean := True;
|
||||
Emit_Warning : Boolean := False;
|
||||
Gnatchop_File : String := "";
|
||||
Gnatchop_Offset : Integer := 0);
|
||||
-- Add a new reference to a file in the table. Ref is used to return
|
||||
-- the index in the table where this file is stored On exit,
|
||||
-- File_Existed is True if the file was already in the table Visited is
|
||||
-- the value which will be used in the table (if True, the file will
|
||||
-- not be returned by Next_Unvisited_File). If Emit_Warning is True and
|
||||
-- the ali file does not exist or does not have cross-referencing
|
||||
-- informations, then a warning will be emitted.
|
||||
-- Gnatchop_File is the name of the file that File_Name was extracted from
|
||||
-- through a call to "gnatchop -r" (with pragma Source_Reference).
|
||||
-- Gnatchop_Offset should be the index of the first line of File_Name
|
||||
-- withing Gnatchop_File.
|
||||
|
||||
procedure Add_Line
|
||||
(File : File_Reference;
|
||||
Line : Natural;
|
||||
Column : Natural);
|
||||
-- Add a new reference in a file, which the user has provided
|
||||
-- on the command line. This is used for a optimized matching
|
||||
-- algorithm.
|
||||
|
||||
procedure Add_Reference
|
||||
(Declaration : Declaration_Reference;
|
||||
File_Ref : File_Reference;
|
||||
Line : Natural;
|
||||
Column : Natural;
|
||||
Ref_Type : Character);
|
||||
-- Add a new reference (Ref_Type = 'r'), body (Ref_Type = 'b') or
|
||||
-- modification (Ref_Type = 'm') to an entity
|
||||
|
||||
type Compare_Result is (LessThan, Equal, GreaterThan);
|
||||
function Compare (Ref1, Ref2 : Reference) return Compare_Result;
|
||||
function Compare
|
||||
(Decl1 : Declaration_Reference;
|
||||
File2 : File_Reference;
|
||||
Line2 : Integer;
|
||||
Col2 : Integer;
|
||||
Symb2 : String)
|
||||
return Compare_Result;
|
||||
-- Compare two references
|
||||
|
||||
function First_Body (Decl : Declaration_Reference) return Reference;
|
||||
function First_Declaration return Declaration_Reference;
|
||||
function First_Modif (Decl : Declaration_Reference) return Reference;
|
||||
function First_Reference (Decl : Declaration_Reference) return Reference;
|
||||
-- Initialize the iterators
|
||||
|
||||
function Get_Column (Decl : Declaration_Reference) return String;
|
||||
function Get_Column (Ref : Reference) return String;
|
||||
|
||||
function Get_Declaration
|
||||
(File_Ref : File_Reference;
|
||||
Line : Natural;
|
||||
Column : Natural)
|
||||
return Declaration_Reference;
|
||||
-- Returns reference to the declaration found in file File_Ref at the
|
||||
-- given Line and Column
|
||||
|
||||
function Get_Parent
|
||||
(Decl : Declaration_Reference)
|
||||
return Declaration_Reference;
|
||||
-- Returns reference to Decl's parent declaration
|
||||
|
||||
function Get_Emit_Warning (File : File_Reference) return Boolean;
|
||||
-- Returns the Emit_Warning field of the structure
|
||||
|
||||
function Get_Gnatchop_File
|
||||
(File : File_Reference; With_Dir : Boolean := False) return String;
|
||||
function Get_Gnatchop_File
|
||||
(Ref : Reference; With_Dir : Boolean := False) return String;
|
||||
function Get_Gnatchop_File
|
||||
(Decl : Declaration_Reference; With_Dir : Boolean := False) return String;
|
||||
-- Return the name of the file that File was extracted from through a
|
||||
-- call to "gnatchop -r".
|
||||
-- The file name for File is returned if File wasn't extracted from such a
|
||||
-- file. The directory will be given only if With_Dir is True.
|
||||
|
||||
|
||||
function Get_File
|
||||
(Decl : Declaration_Reference;
|
||||
With_Dir : Boolean := False)
|
||||
return String;
|
||||
-- Extract column number or file name from reference
|
||||
|
||||
function Get_File
|
||||
(Ref : Reference;
|
||||
With_Dir : Boolean := False)
|
||||
return String;
|
||||
pragma Inline (Get_File);
|
||||
|
||||
function Get_File
|
||||
(File : File_Reference;
|
||||
With_Dir : Boolean := False;
|
||||
Strip : Natural := 0)
|
||||
return String;
|
||||
-- Returns the file name (and its directory if With_Dir is True or
|
||||
-- the user as used the -f switch on the command line.
|
||||
-- If Strip is not 0, then the last Strip-th "-..." substrings are
|
||||
-- removed first. For instance, with Strip=2, a file name
|
||||
-- "parent-child1-child2-child3.ali" would be returned as
|
||||
-- "parent-child1.ali". This is used when looking for the ALI file to use
|
||||
-- for a package, since for separates with have to use the parent's ALI.
|
||||
--
|
||||
-- "" is returned if there is no such parent unit
|
||||
|
||||
function Get_File_Ref (Ref : Reference) return File_Reference;
|
||||
function Get_Line (Decl : Declaration_Reference) return String;
|
||||
function Get_Line (Ref : Reference) return String;
|
||||
function Get_Symbol (Decl : Declaration_Reference) return String;
|
||||
function Get_Type (Decl : Declaration_Reference) return Character;
|
||||
-- Functions that return the content of a declaration
|
||||
|
||||
function Get_Source_Line (Ref : Reference) return String;
|
||||
function Get_Source_Line (Decl : Declaration_Reference) return String;
|
||||
-- Return the source line associated with the reference
|
||||
|
||||
procedure Grep_Source_Files;
|
||||
-- Parse all the source files which have at least one reference, and
|
||||
-- grep the appropriate lines so that we'll be able to display them.
|
||||
-- This function should be called once all the .ali files have been
|
||||
-- parsed, and only if the appropriate user switch has been used.
|
||||
|
||||
function Longest_File_Name return Natural;
|
||||
-- Returns the longest file name found
|
||||
|
||||
function Match (Decl : Declaration_Reference) return Boolean;
|
||||
-- Return True if the declaration matches
|
||||
|
||||
function Match
|
||||
(File : File_Reference;
|
||||
Line : Natural;
|
||||
Column : Natural)
|
||||
return Boolean;
|
||||
-- Returns True if File:Line:Column was given on the command line
|
||||
-- by the user
|
||||
|
||||
function Next (Decl : Declaration_Reference) return Declaration_Reference;
|
||||
function Next (Ref : Reference) return Reference;
|
||||
-- Returns the next declaration, or Empty_Declaration
|
||||
|
||||
function Next_Unvisited_File return File_Reference;
|
||||
-- Returns the next unvisited library file in the list
|
||||
-- If there is no more unvisited file, return Empty_File
|
||||
|
||||
procedure Set_Default_Match (Value : Boolean);
|
||||
-- Set the default value for match in declarations.
|
||||
-- This is used so that if no file was provided in the
|
||||
-- command line, then every file match
|
||||
|
||||
procedure Set_Directory
|
||||
(File : File_Reference;
|
||||
Dir : String);
|
||||
-- Set the directory for a file
|
||||
|
||||
procedure Set_Unvisited (File_Ref : in File_Reference);
|
||||
-- Set File_Ref as unvisited. So Next_Unvisited_File will return it.
|
||||
|
||||
|
||||
private
|
||||
type Project_File (Src_Dir_Length, Obj_Dir_Length : Natural) is record
|
||||
Src_Dir : String (1 .. Src_Dir_Length);
|
||||
Src_Dir_Index : Integer;
|
||||
|
||||
Obj_Dir : String (1 .. Obj_Dir_Length);
|
||||
Obj_Dir_Index : Integer;
|
||||
Last_Obj_Dir_Start : Natural;
|
||||
end record;
|
||||
|
||||
type Project_File_Ptr is access all Project_File;
|
||||
-- This is actually a list of all the directories to be searched,
|
||||
-- either for source files or for library files
|
||||
|
||||
type String_Access is access all String;
|
||||
|
||||
type Ref_In_File;
|
||||
type Ref_In_File_Ptr is access all Ref_In_File;
|
||||
|
||||
type Ref_In_File is record
|
||||
Line : Natural;
|
||||
Column : Natural;
|
||||
Next : Ref_In_File_Ptr := null;
|
||||
end record;
|
||||
|
||||
type File_Record;
|
||||
type File_Reference is access all File_Record;
|
||||
|
||||
Empty_File : constant File_Reference := null;
|
||||
|
||||
type File_Record (File_Length : Natural) is record
|
||||
File : String (1 .. File_Length);
|
||||
Dir : String_Access := null;
|
||||
Lines : Ref_In_File_Ptr := null;
|
||||
Visited : Boolean := False;
|
||||
Emit_Warning : Boolean := False;
|
||||
Gnatchop_File : String_Access := null;
|
||||
Gnatchop_Offset : Integer := 0;
|
||||
Next : File_Reference := null;
|
||||
end record;
|
||||
-- Holds a reference to a source file, that was referenced in at least one
|
||||
-- ALI file.
|
||||
-- Gnatchop_File will contain the name of the file that File was extracted
|
||||
-- From. Gnatchop_Offset contains the index of the first line of File
|
||||
-- within Gnatchop_File. These two fields are used to properly support
|
||||
-- gnatchop files and pragma Source_Reference.
|
||||
|
||||
|
||||
type Reference_Record;
|
||||
type Reference is access all Reference_Record;
|
||||
|
||||
Empty_Reference : constant Reference := null;
|
||||
|
||||
type Reference_Record is record
|
||||
File : File_Reference;
|
||||
Line : Natural;
|
||||
Column : Natural;
|
||||
Source_Line : Ada.Strings.Unbounded.Unbounded_String;
|
||||
Next : Reference := null;
|
||||
end record;
|
||||
-- File is a reference to the Ada source file
|
||||
-- Source_Line is the Line as it appears in the source file. This
|
||||
-- field is only used when the switch is set on the command line
|
||||
|
||||
type Declaration_Record;
|
||||
type Declaration_Reference is access all Declaration_Record;
|
||||
|
||||
Empty_Declaration : constant Declaration_Reference := null;
|
||||
|
||||
type Declaration_Record (Symbol_Length : Natural) is record
|
||||
Symbol : String (1 .. Symbol_Length);
|
||||
Decl : aliased Reference_Record;
|
||||
Decl_Type : Character;
|
||||
Body_Ref : Reference := null;
|
||||
Ref_Ref : Reference := null;
|
||||
Modif_Ref : Reference := null;
|
||||
Match : Boolean := False;
|
||||
Par_Symbol : Declaration_Reference := null;
|
||||
Next : Declaration_Reference := null;
|
||||
end record;
|
||||
|
||||
type File_Table is record
|
||||
Table : File_Reference := null;
|
||||
Longest_Name : Natural := 0;
|
||||
end record;
|
||||
|
||||
type Entity_Table is record
|
||||
Table : Declaration_Reference := null;
|
||||
end record;
|
||||
|
||||
pragma Inline (First_Body);
|
||||
pragma Inline (First_Declaration);
|
||||
pragma Inline (First_Modif);
|
||||
pragma Inline (First_Reference);
|
||||
pragma Inline (Get_Column);
|
||||
pragma Inline (Get_Emit_Warning);
|
||||
pragma Inline (Get_File);
|
||||
pragma Inline (Get_File_Ref);
|
||||
pragma Inline (Get_Line);
|
||||
pragma Inline (Get_Symbol);
|
||||
pragma Inline (Get_Type);
|
||||
pragma Inline (Longest_File_Name);
|
||||
pragma Inline (Next);
|
||||
|
||||
end Xr_Tabls;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,205 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- X R E F _ L I B --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.20 $
|
||||
-- --
|
||||
-- Copyright (C) 1998-1999 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Hostparm;
|
||||
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
|
||||
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
||||
with GNAT.Dynamic_Tables;
|
||||
|
||||
with Xr_Tabls; use Xr_Tabls;
|
||||
with GNAT.Regexp; use GNAT.Regexp;
|
||||
|
||||
-- Misc. utilities for the cross-referencing tool
|
||||
|
||||
package Xref_Lib is
|
||||
|
||||
subtype File_Name_String is String (1 .. Hostparm.Max_Name_Length);
|
||||
subtype Line_String is String (1 .. Hostparm.Max_Line_Length);
|
||||
|
||||
type ALI_File is limited private;
|
||||
|
||||
---------------------
|
||||
-- Directory Input --
|
||||
---------------------
|
||||
type Rec_DIR is limited private;
|
||||
-- This one is used for recursive search of .ali files
|
||||
|
||||
procedure Find_ALI_Files;
|
||||
-- Find all the ali files that we will have to parse, and have them to
|
||||
-- the file list
|
||||
|
||||
---------------------
|
||||
-- Search patterns --
|
||||
---------------------
|
||||
|
||||
type Search_Pattern is private;
|
||||
type Search_Pattern_Ptr is access all Search_Pattern;
|
||||
|
||||
procedure Add_Entity
|
||||
(Pattern : in out Search_Pattern;
|
||||
Entity : String;
|
||||
Glob : Boolean := False);
|
||||
-- Add a new entity to the search pattern (the entity should have the
|
||||
-- form pattern[:file[:line[:column]]], and it is parsed entirely in
|
||||
-- this procedure. Glob indicates if we should use the 'globbing
|
||||
-- patterns' (True) or the full regular expressions (False)
|
||||
|
||||
procedure Add_File (File : String);
|
||||
-- Add a new file in the list of files to search for references.
|
||||
-- File is considered to be a globbing regular expression, which is thus
|
||||
-- expanded
|
||||
|
||||
Invalid_Argument : exception;
|
||||
-- Exception raised when there is a syntax error in the command line
|
||||
|
||||
function Match
|
||||
(Pattern : Search_Pattern;
|
||||
Symbol : String)
|
||||
return Boolean;
|
||||
-- Returns true if Symbol matches one of the entities in the command line
|
||||
|
||||
-----------------------
|
||||
-- Output Algorithms --
|
||||
-----------------------
|
||||
|
||||
procedure Print_Gnatfind
|
||||
(References : in Boolean;
|
||||
Full_Path_Name : in Boolean);
|
||||
procedure Print_Unused (Full_Path_Name : in Boolean);
|
||||
procedure Print_Vi (Full_Path_Name : in Boolean);
|
||||
procedure Print_Xref (Full_Path_Name : in Boolean);
|
||||
-- The actual print procedures. These functions step through the symbol
|
||||
-- table and print all the symbols if they match the files given on the
|
||||
-- command line (they already match the entities if they are in the
|
||||
-- symbol table)
|
||||
|
||||
------------------------
|
||||
-- General Algorithms --
|
||||
------------------------
|
||||
function Default_Project_File (Dir_Name : in String) return String;
|
||||
-- Returns the default Project file name
|
||||
|
||||
procedure Search
|
||||
(Pattern : Search_Pattern;
|
||||
Local_Symbols : Boolean;
|
||||
Wide_Search : Boolean;
|
||||
Read_Only : Boolean;
|
||||
Der_Info : Boolean;
|
||||
Type_Tree : Boolean);
|
||||
-- Search every ali file (following the Readdir rule above), for
|
||||
-- each line matching Pattern, and executes Process on these
|
||||
-- lines. If World is True, Search will look into every .ali file
|
||||
-- in the object search path. If Read_Only is True, we parse the
|
||||
-- read-only ali files too. If Der_Mode is true then the derived type
|
||||
-- information will be processed. If Type_Tree is true then the type
|
||||
-- hierarchy will be search going from pattern to the parent type
|
||||
|
||||
procedure Search_Xref
|
||||
(Local_Symbols : Boolean;
|
||||
Read_Only : Boolean;
|
||||
Der_Info : Boolean);
|
||||
-- Search every ali file given in the command line and all their
|
||||
-- dependencies. If Read_Only is True, we parse the read-only ali
|
||||
-- files too. If Der_Mode is true then the derived type information will
|
||||
-- be processed
|
||||
|
||||
---------------
|
||||
-- ALI files --
|
||||
---------------
|
||||
|
||||
function Current_Xref_File
|
||||
(File : ALI_File)
|
||||
return Xr_Tabls.File_Reference;
|
||||
-- Returns the name of the file in which the last identifier
|
||||
-- is declared
|
||||
|
||||
function File_Name
|
||||
(File : ALI_File;
|
||||
Num : Positive)
|
||||
return Xr_Tabls.File_Reference;
|
||||
-- Returns the dependency file name number Num
|
||||
|
||||
function Get_Full_Type (Abbrev : Character) return String;
|
||||
-- Returns the full type corresponding to a type letter as found in
|
||||
-- the .ali files.
|
||||
|
||||
procedure Open
|
||||
(Name : in String;
|
||||
File : out ALI_File;
|
||||
Dependencies : in Boolean := False);
|
||||
-- Open a new ALI file
|
||||
-- if Dependencies is True, the insert every library file 'with'ed in
|
||||
-- the files database (used for gnatxref)
|
||||
|
||||
|
||||
private
|
||||
type Rec_DIR is limited record
|
||||
Dir : GNAT.Directory_Operations.Dir_Type;
|
||||
end record;
|
||||
|
||||
package Dependencies_Tables is new GNAT.Dynamic_Tables
|
||||
(Table_Component_Type => Xr_Tabls.File_Reference,
|
||||
Table_Index_Type => Positive,
|
||||
Table_Low_Bound => 1,
|
||||
Table_Initial => 400,
|
||||
Table_Increment => 100);
|
||||
use Dependencies_Tables;
|
||||
|
||||
type Dependencies is new Dependencies_Tables.Instance;
|
||||
|
||||
type ALI_File is limited record
|
||||
Buffer : String_Access := null;
|
||||
-- Buffer used to read the whole file at once
|
||||
|
||||
Current_Line : Positive;
|
||||
-- Start of the current line in Buffer
|
||||
|
||||
Xref_Line : Positive;
|
||||
-- Start of the xref lines in Buffer
|
||||
|
||||
X_File : Xr_Tabls.File_Reference;
|
||||
-- Stores the cross-referencing file-name ("X..." lines), as an
|
||||
-- index into the dependencies table
|
||||
|
||||
Dep : Dependencies;
|
||||
-- Store file name associated with each number ("D..." lines)
|
||||
end record;
|
||||
|
||||
-- The following record type stores all the patterns that are searched for
|
||||
|
||||
type Search_Pattern is record
|
||||
Entity : GNAT.Regexp.Regexp;
|
||||
-- A regular expression matching the entities we are looking for.
|
||||
-- File is a list of the places where the declaration of the entities
|
||||
-- has to be. When the user enters a file:line:column on the command
|
||||
-- line, it is stored as "Entity_Name Declaration_File:line:column"
|
||||
|
||||
Initialized : Boolean := False;
|
||||
-- Set to True when Entity has been initialized.
|
||||
end record;
|
||||
-- Stores all the pattern that are search for.
|
||||
end Xref_Lib;
|
|
@ -0,0 +1,261 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT SYSTEM UTILITIES --
|
||||
-- --
|
||||
-- X S I N F O --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.19 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Program to construct C header file a-sinfo.h (C version of sinfo.ads spec,
|
||||
-- for use by Gigi, contains all definitions and access functions, but does
|
||||
-- not contain set procedures, since Gigi never modifies the GNAT tree)
|
||||
|
||||
-- Input files:
|
||||
|
||||
-- sinfo.ads Spec of Sinfo package
|
||||
|
||||
-- Output files:
|
||||
|
||||
-- a-sinfo.h Corresponding c header file
|
||||
|
||||
-- Note: this program assumes that sinfo.ads has passed the error checks
|
||||
-- which are carried out by the CSinfo utility, so it does not duplicate
|
||||
-- these checks and assumes the soruce is correct.
|
||||
|
||||
-- An optional argument allows the specification of an output file name to
|
||||
-- override the default a-sinfo.h file name for the generated output file.
|
||||
|
||||
with Ada.Command_Line; use Ada.Command_Line;
|
||||
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
||||
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
|
||||
with Ada.Text_IO; use Ada.Text_IO;
|
||||
|
||||
with GNAT.Spitbol; use GNAT.Spitbol;
|
||||
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
||||
|
||||
procedure XSinfo is
|
||||
|
||||
Done : exception;
|
||||
Err : exception;
|
||||
|
||||
A : VString := Nul;
|
||||
Arg : VString := Nul;
|
||||
Comment : VString := Nul;
|
||||
Line : VString := Nul;
|
||||
N : VString := Nul;
|
||||
N1, N2 : VString := Nul;
|
||||
Nam : VString := Nul;
|
||||
Rtn : VString := Nul;
|
||||
Sinforev : VString := Nul;
|
||||
Term : VString := Nul;
|
||||
XSinforev : VString := Nul;
|
||||
|
||||
InS : File_Type;
|
||||
Ofile : File_Type;
|
||||
|
||||
wsp : Pattern := Span (' ' & ASCII.HT);
|
||||
Get_Vsn : Pattern := BreakX ('$') & "$Rev" & "ision: "
|
||||
& Break (' ') * Sinforev;
|
||||
Wsp_For : Pattern := wsp & "for";
|
||||
Is_Cmnt : Pattern := wsp & "--";
|
||||
Typ_Nod : Pattern := wsp * A & "type Node_Kind is";
|
||||
Get_Nam : Pattern := wsp * A & "N_" & Break (",)") * Nam
|
||||
& Len (1) * Term;
|
||||
Sub_Typ : Pattern := wsp * A & "subtype " & Break (' ') * N;
|
||||
No_Cont : Pattern := wsp & Break (' ') * N1 & " .. " & Break (';') * N2;
|
||||
Cont_N1 : Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0);
|
||||
Cont_N2 : Pattern := Span (' ') & Break (';') * N2;
|
||||
Is_Func : Pattern := wsp * A & "function " & Rest * Nam;
|
||||
Get_Arg : Pattern := wsp & "(N : " & Break (')') * Arg
|
||||
& ") return " & Break (';') * Rtn
|
||||
& ';' & wsp & "--" & wsp & Rest * Comment;
|
||||
|
||||
NKV : Natural;
|
||||
|
||||
M : Match_Result;
|
||||
|
||||
|
||||
procedure Getline;
|
||||
-- Get non-comment, non-blank line. Also skips "for " rep clauses.
|
||||
|
||||
procedure Getline is
|
||||
begin
|
||||
loop
|
||||
Line := Get_Line (InS);
|
||||
|
||||
if Line /= ""
|
||||
and then not Match (Line, Wsp_For)
|
||||
and then not Match (Line, Is_Cmnt)
|
||||
then
|
||||
return;
|
||||
|
||||
elsif Match (Line, " -- End functions (note") then
|
||||
raise Done;
|
||||
end if;
|
||||
end loop;
|
||||
end Getline;
|
||||
|
||||
-- Start of processing for XSinfo
|
||||
|
||||
begin
|
||||
Set_Exit_Status (1);
|
||||
Anchored_Mode := True;
|
||||
Match ("$Revision: 1.19 $", "$Rev" & "ision: " & Break (' ') * XSinforev);
|
||||
|
||||
if Argument_Count > 0 then
|
||||
Create (Ofile, Out_File, Argument (1));
|
||||
else
|
||||
Create (Ofile, Out_File, "a-sinfo.h");
|
||||
end if;
|
||||
|
||||
Open (InS, In_File, "sinfo.ads");
|
||||
|
||||
-- Get Sinfo rev and write header to output file
|
||||
|
||||
loop
|
||||
Line := Get_Line (InS);
|
||||
exit when Line = "";
|
||||
|
||||
if Match (Line, Get_Vsn) then
|
||||
Put_Line
|
||||
(Ofile, "/* Generated by xsinfo revision "
|
||||
& XSinforev & " using */");
|
||||
Put_Line
|
||||
(Ofile, "/* sinfo.ads revision "
|
||||
& Sinforev & " */");
|
||||
|
||||
else
|
||||
Match
|
||||
(Line,
|
||||
"-- S p e c ",
|
||||
"-- C Header File ");
|
||||
|
||||
Match (Line, "--", "/*");
|
||||
Match (Line, Rtab (2) * A & "--", M);
|
||||
Replace (M, A & "*/");
|
||||
Put_Line (Ofile, Line);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Skip to package line
|
||||
|
||||
loop
|
||||
Getline;
|
||||
exit when Match (Line, "package");
|
||||
end loop;
|
||||
|
||||
-- Skip to first node kind line
|
||||
|
||||
loop
|
||||
Getline;
|
||||
exit when Match (Line, Typ_Nod);
|
||||
Put_Line (Ofile, Line);
|
||||
end loop;
|
||||
|
||||
Put_Line (Ofile, "");
|
||||
NKV := 0;
|
||||
|
||||
-- Loop through node kind codes
|
||||
|
||||
loop
|
||||
Getline;
|
||||
|
||||
if Match (Line, Get_Nam) then
|
||||
Put_Line (Ofile, A & "#define N_" & Nam & ' ' & NKV);
|
||||
NKV := NKV + 1;
|
||||
exit when not Match (Term, ",");
|
||||
|
||||
else
|
||||
Put_Line (Ofile, Line);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Put_Line (Ofile, "");
|
||||
Put_Line (Ofile, A & "#define Number_Node_Kinds " & NKV);
|
||||
|
||||
-- Loop through subtype declarations
|
||||
|
||||
loop
|
||||
Getline;
|
||||
|
||||
if not Match (Line, Sub_Typ) then
|
||||
exit when Match (Line, " function");
|
||||
Put_Line (Ofile, Line);
|
||||
|
||||
else
|
||||
Put_Line (Ofile, A & "SUBTYPE (" & N & ", Node_Kind, ");
|
||||
Getline;
|
||||
|
||||
-- Normal case
|
||||
|
||||
if Match (Line, No_Cont) then
|
||||
Put_Line (Ofile, A & " " & N1 & ", " & N2 & ')');
|
||||
|
||||
-- Continuation case
|
||||
|
||||
else
|
||||
if not Match (Line, Cont_N1) then
|
||||
raise Err;
|
||||
end if;
|
||||
|
||||
Getline;
|
||||
|
||||
if not Match (Line, Cont_N2) then
|
||||
raise Err;
|
||||
end if;
|
||||
|
||||
Put_Line (Ofile, A & " " & N1 & ',');
|
||||
Put_Line (Ofile, A & " " & N2 & ')');
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Loop through functions. Note that this loop is terminated by
|
||||
-- the call to Getfile encountering the end of functions sentinel
|
||||
|
||||
loop
|
||||
if Match (Line, Is_Func) then
|
||||
Getline;
|
||||
if not Match (Line, Get_Arg) then
|
||||
raise Err;
|
||||
end if;
|
||||
Put_Line
|
||||
(Ofile,
|
||||
A & "INLINE " & Rpad (Rtn, 9)
|
||||
& ' ' & Rpad (Nam, 30) & " (" & Arg & " N)");
|
||||
|
||||
Put_Line (Ofile, A & " { return " & Comment & " (N); }");
|
||||
|
||||
else
|
||||
Put_Line (Ofile, Line);
|
||||
end if;
|
||||
|
||||
Getline;
|
||||
end loop;
|
||||
|
||||
exception
|
||||
when Done =>
|
||||
Put_Line (Ofile, "");
|
||||
Set_Exit_Status (0);
|
||||
|
||||
end XSinfo;
|
|
@ -0,0 +1,383 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT SYSTEM UTILITIES --
|
||||
-- --
|
||||
-- X T R E E P R S --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.33 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Program to construct the spec of the Treeprs package
|
||||
|
||||
-- Input files:
|
||||
|
||||
-- sinfo.ads Spec of Sinfo package
|
||||
-- treeprs.adt Template for Treeprs package
|
||||
|
||||
-- Output files:
|
||||
|
||||
-- treeprs.ads Spec of Treeprs package
|
||||
|
||||
-- Note: this program assumes that sinfo.ads has passed the error checks which
|
||||
-- are carried out by the CSinfo utility so it does not duplicate these checks
|
||||
|
||||
-- An optional argument allows the specification of an output file name to
|
||||
-- override the default treeprs.ads file name for the generated output file.
|
||||
|
||||
with Ada.Command_Line; use Ada.Command_Line;
|
||||
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
||||
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
|
||||
with Ada.Text_IO; use Ada.Text_IO;
|
||||
|
||||
with GNAT.Spitbol; use GNAT.Spitbol;
|
||||
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
||||
with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
|
||||
with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString;
|
||||
|
||||
procedure XTreeprs is
|
||||
|
||||
package TB renames GNAT.Spitbol.Table_Boolean;
|
||||
package TV renames GNAT.Spitbol.Table_VString;
|
||||
|
||||
Err : exception;
|
||||
-- Raised on fatal error
|
||||
|
||||
A : VString := Nul;
|
||||
Ffield : VString := Nul;
|
||||
Field : VString := Nul;
|
||||
Fieldno : VString := Nul;
|
||||
Flagno : VString := Nul;
|
||||
Line : VString := Nul;
|
||||
Name : VString := Nul;
|
||||
Node : VString := Nul;
|
||||
Outstring : VString := Nul;
|
||||
Prefix : VString := Nul;
|
||||
S : VString := Nul;
|
||||
S1 : VString := Nul;
|
||||
Sinforev : VString := Nul;
|
||||
Syn : VString := Nul;
|
||||
Synonym : VString := Nul;
|
||||
Temprev : VString := Nul;
|
||||
Term : VString := Nul;
|
||||
Treeprsrev : VString := Nul;
|
||||
|
||||
OutS : File_Type;
|
||||
-- Output file
|
||||
|
||||
InS : File_Type;
|
||||
-- Read sinfo.ads
|
||||
|
||||
InT : File_Type;
|
||||
-- Read treeprs.adt
|
||||
|
||||
Special : TB.Table (20);
|
||||
-- Table of special fields. These fields are not included in the table
|
||||
-- constructed by Xtreeprs, since they are specially handled in treeprs.
|
||||
-- This means these field definitions are completely ignored.
|
||||
|
||||
Names : array (1 .. 500) of VString;
|
||||
-- Table of names of synonyms
|
||||
|
||||
Positions : array (1 .. 500) of Natural;
|
||||
-- Table of starting positions in Pchars string for synonyms
|
||||
|
||||
Strings : TV.Table (300);
|
||||
-- Contribution of each synonym to Pchars string, indexed by name
|
||||
|
||||
Count : Natural := 0;
|
||||
-- Number of synonyms processed so far
|
||||
|
||||
Curpos : Natural := 1;
|
||||
-- Number of characters generated in Pchars string so far
|
||||
|
||||
Lineno : Natural := 0;
|
||||
-- Line number in sinfo.ads
|
||||
|
||||
Field_Base : constant := Character'Pos ('#');
|
||||
-- Fields 1-5 are represented by the characters #$%&' (i.e. by five
|
||||
-- contiguous characters starting at # (16#23#)).
|
||||
|
||||
Flag_Base : constant := Character'Pos ('(');
|
||||
-- Flags 1-18 are represented by the characters ()*+,-./0123456789
|
||||
-- (i.e. by 18 contiguous characters starting at (16#28#)).
|
||||
|
||||
Fieldch : Character;
|
||||
-- Field character, as per above tables
|
||||
|
||||
Sp : aliased Natural;
|
||||
-- Space left on line for Pchars output
|
||||
|
||||
wsp : Pattern := Span (' ' & ASCII.HT);
|
||||
|
||||
Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
|
||||
& Break (' ') * Sinforev;
|
||||
Get_TRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
|
||||
& Break (' ') * Temprev;
|
||||
Is_Temp : Pattern := BreakX ('T') * A & "T e m p l a t e";
|
||||
Get_Node : Pattern := wsp & "-- N_" & Rest * Node;
|
||||
Tst_Punc : Pattern := Break (" ,.");
|
||||
Get_Syn : Pattern := Span (' ') & "-- " & Break (' ') * Synonym
|
||||
& " (" & Break (')') * Field;
|
||||
Brk_Min : Pattern := Break ('-') * Ffield;
|
||||
Is_Flag : Pattern := "Flag" & Rest * Flagno;
|
||||
Is_Field : Pattern := Rtab (1) & Len (1) * Fieldno;
|
||||
Is_Syn : Pattern := wsp & "N_" & Break (",)") * Syn & Len (1) * Term;
|
||||
Brk_Node : Pattern := Break (' ') * Node & ' ';
|
||||
Chop_SP : Pattern := Len (Sp'Unrestricted_Access) * S1;
|
||||
|
||||
M : Match_Result;
|
||||
|
||||
begin
|
||||
Anchored_Mode := True;
|
||||
|
||||
Match ("$Revision: 1.33 $", "$Rev" & "ision: " & Break (' ') * Treeprsrev);
|
||||
|
||||
if Argument_Count > 0 then
|
||||
Create (OutS, Out_File, Argument (1));
|
||||
else
|
||||
Create (OutS, Out_File, "treeprs.ads");
|
||||
end if;
|
||||
|
||||
Open (InS, In_File, "sinfo.ads");
|
||||
Open (InT, In_File, "treeprs.adt");
|
||||
|
||||
-- Initialize special fields table
|
||||
|
||||
Set (Special, "Analyzed", True);
|
||||
Set (Special, "Cannot_Be_Constant", True);
|
||||
Set (Special, "Chars", True);
|
||||
Set (Special, "Comes_From_Source", True);
|
||||
Set (Special, "Error_Posted", True);
|
||||
Set (Special, "Etype", True);
|
||||
Set (Special, "Has_No_Side_Effects", True);
|
||||
Set (Special, "Is_Controlling_Actual", True);
|
||||
Set (Special, "Is_Overloaded", True);
|
||||
Set (Special, "Is_Static_Expression", True);
|
||||
Set (Special, "Left_Opnd", True);
|
||||
Set (Special, "Must_Check_Expr", True);
|
||||
Set (Special, "No_Overflow_Expr", True);
|
||||
Set (Special, "Paren_Count", True);
|
||||
Set (Special, "Raises_Constraint_Error", True);
|
||||
Set (Special, "Right_Opnd", True);
|
||||
|
||||
-- Get sinfo revs and write header to output file
|
||||
|
||||
loop
|
||||
Line := Get_Line (InS);
|
||||
Lineno := Lineno + 1;
|
||||
|
||||
if Line = "" then
|
||||
raise Err;
|
||||
end if;
|
||||
|
||||
exit when Match (Line, Get_SRev);
|
||||
end loop;
|
||||
|
||||
-- Read template header and generate new header
|
||||
|
||||
loop
|
||||
Line := Get_Line (InT);
|
||||
|
||||
if Match (Line, Get_TRev) then
|
||||
Put_Line
|
||||
(OutS,
|
||||
"-- Generated by xtreeprs revision " &
|
||||
Treeprsrev & " using --");
|
||||
|
||||
Put_Line
|
||||
(OutS,
|
||||
"-- sinfo.ads revision " &
|
||||
Sinforev & " --");
|
||||
|
||||
Put_Line
|
||||
(OutS,
|
||||
"-- treeprs.adt revision "
|
||||
& Temprev & " --");
|
||||
|
||||
else
|
||||
-- Skip lines describing the template
|
||||
|
||||
if Match (Line, "-- This file is a template") then
|
||||
loop
|
||||
Line := Get_Line (InT);
|
||||
exit when Line = "";
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
exit when Match (Line, "package");
|
||||
|
||||
if Match (Line, Is_Temp, M) then
|
||||
Replace (M, A & " S p e c ");
|
||||
end if;
|
||||
|
||||
Put_Line (OutS, Line);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Put_Line (OutS, Line);
|
||||
|
||||
-- Copy rest of comments up to template insert point to spec
|
||||
|
||||
loop
|
||||
Line := Get_Line (InT);
|
||||
exit when Match (Line, "!!TEMPLATE INSERTION POINT");
|
||||
Put_Line (OutS, Line);
|
||||
end loop;
|
||||
|
||||
-- Here we are doing the actual insertions
|
||||
|
||||
Put_Line (OutS, " Pchars : constant String :=");
|
||||
|
||||
-- Loop through comments describing nodes, picking up fields
|
||||
|
||||
loop
|
||||
Line := Get_Line (InS);
|
||||
Lineno := Lineno + 1;
|
||||
exit when Match (Line, " type Node_Kind");
|
||||
|
||||
if Match (Line, Get_Node)
|
||||
and then not Match (Node, Tst_Punc)
|
||||
then
|
||||
Outstring := Node & ' ';
|
||||
|
||||
loop
|
||||
Line := Get_Line (InS);
|
||||
exit when Line = "";
|
||||
|
||||
if Match (Line, Get_Syn)
|
||||
and then not Match (Synonym, "plus")
|
||||
and then not Present (Special, Synonym)
|
||||
then
|
||||
-- Convert this field into the character used to
|
||||
-- represent the field according to the table:
|
||||
|
||||
-- Field1 '#'
|
||||
-- Field2 '$'
|
||||
-- Field3 '%'
|
||||
-- Field4 '&'
|
||||
-- Field5 "'"
|
||||
-- Flag1 "("
|
||||
-- Flag2 ")"
|
||||
-- Flag3 '*'
|
||||
-- Flag4 '+'
|
||||
-- Flag5 ','
|
||||
-- Flag6 '-'
|
||||
-- Flag7 '.'
|
||||
-- Flag8 '/'
|
||||
-- Flag9 '0'
|
||||
-- Flag10 '1'
|
||||
-- Flag11 '2'
|
||||
-- Flag12 '3'
|
||||
-- Flag13 '4'
|
||||
-- Flag14 '5'
|
||||
-- Flag15 '6'
|
||||
-- Flag16 '7'
|
||||
-- Flag17 '8'
|
||||
-- Flag18 '9'
|
||||
|
||||
if Match (Field, Brk_Min) then
|
||||
Field := Ffield;
|
||||
end if;
|
||||
|
||||
if Match (Field, Is_Flag) then
|
||||
Fieldch := Char (Flag_Base - 1 + N (Flagno));
|
||||
|
||||
elsif Match (Field, Is_Field) then
|
||||
Fieldch := Char (Field_Base - 1 + N (Fieldno));
|
||||
|
||||
else
|
||||
Put_Line
|
||||
(Standard_Error,
|
||||
"*** Line " &
|
||||
Lineno &
|
||||
" has unrecognized field name " &
|
||||
Field);
|
||||
raise Err;
|
||||
end if;
|
||||
|
||||
Append (Outstring, Fieldch & Synonym);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Set (Strings, Node, Outstring);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Loop through actual definitions of node kind enumeration literals
|
||||
|
||||
loop
|
||||
loop
|
||||
Line := Get_Line (InS);
|
||||
Lineno := Lineno + 1;
|
||||
exit when Match (Line, Is_Syn);
|
||||
end loop;
|
||||
|
||||
S := Get (Strings, Syn);
|
||||
Match (S, Brk_Node, "");
|
||||
Count := Count + 1;
|
||||
Names (Count) := Syn;
|
||||
Positions (Count) := Curpos;
|
||||
Curpos := Curpos + Length (S);
|
||||
Put_Line (OutS, " -- " & Node);
|
||||
Prefix := V (" ");
|
||||
exit when Term = ")";
|
||||
|
||||
-- Loop to output the string literal for Pchars
|
||||
|
||||
loop
|
||||
Sp := 79 - 4 - Length (Prefix);
|
||||
exit when (Size (S) <= Sp);
|
||||
Match (S, Chop_SP, "");
|
||||
Put_Line (OutS, Prefix & '"' & S1 & """ &");
|
||||
Prefix := V (" ");
|
||||
end loop;
|
||||
|
||||
Put_Line (OutS, Prefix & '"' & S & """ &");
|
||||
end loop;
|
||||
|
||||
Put_Line (OutS, " """";");
|
||||
Put_Line (OutS, "");
|
||||
Put_Line
|
||||
(OutS, " type Pchar_Pos_Array is array (Node_Kind) of Positive;");
|
||||
Put_Line
|
||||
(OutS,
|
||||
" Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(");
|
||||
|
||||
-- Output lines for Pchar_Pos_Array values
|
||||
|
||||
for M in 1 .. Count - 1 loop
|
||||
Name := Rpad ("N_" & Names (M), 40);
|
||||
Put_Line (OutS, " " & Name & " => " & Positions (M) & ',');
|
||||
end loop;
|
||||
|
||||
Name := Rpad ("N_" & Names (Count), 40);
|
||||
Put_Line (OutS, " " & Name & " => " & Positions (Count) & ");");
|
||||
|
||||
Put_Line (OutS, "");
|
||||
Put_Line (OutS, "end Treeprs;");
|
||||
|
||||
exception
|
||||
when Err =>
|
||||
Put_Line (Standard_Error, "*** fatal error");
|
||||
Set_Exit_Status (1);
|
||||
|
||||
end XTreeprs;
|
Loading…
Reference in New Issue