--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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;
+}
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * T R A C E B A C K *
+ * *
+ * C Implementation File *
+ * *
+ * $Revision: 1.1 $
+ * *
+ * Copyright (C) 2000-2001 Ada Core Technologies, 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). *
+ * *
+ ****************************************************************************/
+
+/* This file contains low level support for stack unwinding using GCC intrinsic
+ functions.
+ It has been tested on the following configurations:
+ HPPA/HP-UX
+ PowerPC/AiX
+ PowerPC/VxWorks
+ Sparc/Solaris
+ i386/Linux
+ i386/Solaris
+ i386/NT
+ i386/OS2
+ i386/LynxOS
+ Alpha/VxWorks
+*/
+
+#ifdef __alpha_vxworks
+#include "vxWorks.h"
+#endif
+
+#ifdef IN_RTS
+#define POSIX
+#include "tconfig.h"
+#include "tsystem.h"
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+#define Lock_Task system__soft_links__lock_task
+extern void (*Lock_Task) (void);
+
+#define Unlock_Task system__soft_links__unlock_task
+extern void (*Unlock_Task) (void);
+
+#ifndef CURRENT_STACK_FRAME
+# define CURRENT_STACK_FRAME ({ char __csf; &__csf; })
+#endif
+
+extern int __gnat_backtrace PARAMS ((void **, int, void *, void *));
+
+#if defined (__hppa)
+struct layout
+{
+ void *return_address;
+ void *pad[4];
+ struct layout *next;
+};
+
+#define FRAME_LEVEL 1
+#define FRAME_OFFSET -20
+#define SKIP_FRAME 1
+#define PC_ADJUST -4
+
+/* If CURRENT is unaligned, it means that CURRENT is not a valid frame
+ pointer and we should stop popping frames. */
+
+#define STOP_FRAME(CURRENT, TOP_STACK) \
+ (((int) (CURRENT) & 0x3) != 0 && (CURRENT)->return_address == 0)
+
+/* Current implementation need to be protected against invalid memory
+ accesses */
+#define PROTECT_SEGV
+
+#elif defined (_AIX)
+struct layout
+{
+ struct layout *next;
+ void *pad;
+ void *return_address;
+};
+
+#define FRAME_LEVEL 1
+#define FRAME_OFFSET 0
+#define SKIP_FRAME 2
+#define PC_ADJUST -4
+#define STOP_FRAME(CURRENT, TOP_STACK) ((void *) (CURRENT) < (TOP_STACK))
+
+#elif defined (_ARCH_PPC) && defined (__vxworks)
+struct layout
+{
+ struct layout *next;
+ void *return_address;
+};
+
+#define FRAME_LEVEL 1
+#define FRAME_OFFSET 0
+#define SKIP_FRAME 2
+#define PC_ADJUST 0
+#define STOP_FRAME(CURRENT, TOP_STACK) ((CURRENT)->return_address == 0)
+
+#elif defined (sun) && defined (sparc)
+struct layout
+{
+ struct layout *next;
+ void *return_address;
+};
+
+#define FRAME_LEVEL 1
+#define FRAME_OFFSET (14*4)
+#define SKIP_FRAME 1
+#define PC_ADJUST 0
+#define STOP_FRAME(CURRENT, TOP_STACK) \
+ ((CURRENT)->return_address == 0|| (CURRENT)->next == 0 \
+ || (void *) (CURRENT) < (TOP_STACK))
+
+#elif defined (i386)
+struct layout
+{
+ struct layout *next;
+ void *return_address;
+};
+
+#define FRAME_LEVEL 0
+#define FRAME_OFFSET 0
+#define SKIP_FRAME 1
+#define PC_ADJUST -2
+#define STOP_FRAME(CURRENT, TOP_STACK) \
+ ((CURRENT)->return_address == 0|| (CURRENT)->next == 0 \
+ || (void *) (CURRENT) < (TOP_STACK))
+
+#elif defined (__alpha_vxworks)
+
+#define SKIP_FRAME 1
+#define PC_ADJUST -4
+
+extern void kerTaskEntry();
+
+#define STOP_FRAME \
+ (current == NULL \
+ || ((CORE_ADDR) &kerTaskEntry >= PROC_LOW_ADDR (current->proc_desc) \
+ && current->pc >= (CORE_ADDR) &kerTaskEntry))
+#endif
+
+#if !defined (PC_ADJUST)
+int
+__gnat_backtrace (array, size, exclude_min, exclude_max)
+ void **array ATTRIBUTE_UNUSED;
+ int size ATTRIBUTE_UNUSED;
+ void *exclude_min ATTRIBUTE_UNUSED;
+ void *exclude_max ATTRIBUTE_UNUSED;
+{
+ return 0;
+}
+
+#elif !defined (__alpha_vxworks)
+
+#ifdef PROTECT_SEGV
+#include <setjmp.h>
+#include <signal.h>
+
+static jmp_buf sigsegv_excp;
+
+static void
+segv_handler (ignored)
+ int ignored;
+{
+ longjmp (sigsegv_excp, 1);
+}
+#endif
+
+int
+__gnat_backtrace (array, size, exclude_min, exclude_max)
+ void **array;
+ int size;
+ void *exclude_min;
+ void *exclude_max;
+{
+ struct layout *current;
+ void *top_frame;
+ void *top_stack;
+ void *ret;
+ int cnt = 0;
+
+#ifdef PROTECT_SEGV
+ struct sigaction this_act, old_act;
+
+ /* This function is not thread safe if PROTECT_SEGV is defined, so
+ protect it */
+ (*Lock_Task) ();
+#endif
+
+ top_frame = __builtin_frame_address (FRAME_LEVEL);
+ top_stack = CURRENT_STACK_FRAME;
+ current = (struct layout *) ((size_t) top_frame + FRAME_OFFSET);
+
+#ifdef PROTECT_SEGV
+ this_act.sa_handler = segv_handler;
+ sigemptyset (&this_act.sa_mask);
+ this_act.sa_flags = 0;
+ sigaction (SIGSEGV, &this_act, &old_act);
+
+ if (setjmp (sigsegv_excp))
+ goto Done;
+#endif
+
+ /* We skip the call to this function, it makes no sense to record it. */
+ while (cnt < SKIP_FRAME)
+ {
+ current = (struct layout *) ((size_t) current->next + FRAME_OFFSET);
+ cnt++;
+ }
+
+ cnt = 0;
+ while (cnt < size)
+ {
+ if (STOP_FRAME (current, top_stack))
+ break;
+
+ if (current->return_address < exclude_min
+ || current->return_address > exclude_max)
+ array[cnt++] = current->return_address + PC_ADJUST;
+
+ current = (struct layout *) ((size_t) current->next + FRAME_OFFSET);
+ }
+
+#ifdef PROTECT_SEGV
+ Done:
+ sigaction (SIGSEGV, &old_act, NULL);
+ (*Unlock_Task) ();
+#endif
+ return cnt;
+}
+
+#else
+/* Alpha vxWorks requires a special, complex treatment that is extracted
+ from GDB */
+
+#include <string.h>
+
+/* Register numbers of various important registers.
+ Note that most of these values are "real" register numbers,
+ and correspond to the general registers of the machine,
+ and FP_REGNUM is a "phony" register number which is too large
+ to be an actual register number as far as the user is concerned
+ but serves to get the desired value when passed to read_register. */
+
+#define T7_REGNUM 8 /* Return address register for OSF/1 __add* */
+#define GCC_FP_REGNUM 15 /* Used by gcc as frame register */
+#define T9_REGNUM 23 /* Return address register for OSF/1 __div* */
+#define SP_REGNUM 30 /* Contains address of top of stack */
+#define RA_REGNUM 26 /* Contains return address value */
+#define FP0_REGNUM 32 /* Floating point register 0 */
+#define PC_REGNUM 64 /* Contains program counter */
+#define NUM_REGS 66
+
+#define VM_MIN_ADDRESS (CORE_ADDR)0x120000000
+
+#define SIZEOF_FRAME_SAVED_REGS (sizeof (CORE_ADDR) * (NUM_REGS))
+#define INIT_EXTRA_FRAME_INFO(fromleaf, fci) init_extra_frame_info(fci)
+
+#define FRAME_CHAIN(thisframe) (CORE_ADDR) alpha_frame_chain (thisframe)
+
+#define FRAME_CHAIN_VALID(CHAIN, THISFRAME) \
+ ((CHAIN) != 0 \
+ && !inside_entry_file (FRAME_SAVED_PC (THISFRAME)))
+
+#define FRAME_SAVED_PC(FRAME) (alpha_frame_saved_pc (FRAME))
+
+#define FRAME_CHAIN_COMBINE(CHAIN, THISFRAME) (CHAIN)
+
+#define INIT_FRAME_PC(FROMLEAF, PREV)
+
+#define INIT_FRAME_PC_FIRST(FROMLEAF, PREV) \
+ (PREV)->pc = ((FROMLEAF) ? SAVED_PC_AFTER_CALL ((PREV)->next) \
+ : (PREV)->next ? FRAME_SAVED_PC ((prev)->NEXT) : read_pc ());
+
+#define SAVED_PC_AFTER_CALL(FRAME) alpha_saved_pc_after_call (FRAME)
+
+typedef unsigned long long int bfd_vma;
+
+typedef bfd_vma CORE_ADDR;
+
+typedef struct pdr
+{
+ bfd_vma adr; /* memory address of start of procedure */
+ long isym; /* start of local symbol entries */
+ long iline; /* start of line number entries*/
+ long regmask; /* save register mask */
+ long regoffset; /* save register offset */
+ long iopt; /* start of optimization symbol entries*/
+ long fregmask; /* save floating point register mask */
+ long fregoffset; /* save floating point register offset */
+ long frameoffset; /* frame size */
+ short framereg; /* frame pointer register */
+ short pcreg; /* offset or reg of return pc */
+ long lnLow; /* lowest line in the procedure */
+ long lnHigh; /* highest line in the procedure */
+ bfd_vma cbLineOffset; /* byte offset for this procedure from the fd base */
+ /* These fields are new for 64 bit ECOFF. */
+ unsigned gp_prologue : 8; /* byte size of GP prologue */
+ unsigned gp_used : 1; /* true if the procedure uses GP */
+ unsigned reg_frame : 1; /* true if register frame procedure */
+ unsigned prof : 1; /* true if compiled with -pg */
+ unsigned reserved : 13; /* reserved: must be zero */
+ unsigned localoff : 8; /* offset of local variables from vfp */
+} PDR;
+
+typedef struct alpha_extra_func_info
+{
+ long numargs; /* number of args to procedure (was iopt) */
+ PDR pdr; /* Procedure descriptor record */
+}
+*alpha_extra_func_info_t;
+
+struct frame_info
+{
+ /* Nominal address of the frame described. See comments at FRAME_FP
+ about what this means outside the *FRAME* macros; in the *FRAME*
+ macros, it can mean whatever makes most sense for this machine. */
+ CORE_ADDR frame;
+
+ /* Address at which execution is occurring in this frame. For the
+ innermost frame, it's the current pc. For other frames, it is a
+ pc saved in the next frame. */
+ CORE_ADDR pc;
+
+ /* For each register, address of where it was saved on entry to the
+ frame, or zero if it was not saved on entry to this frame. This
+ includes special registers such as pc and fp saved in special
+ ways in the stack frame. The SP_REGNUM is even more special, the
+ address here is the sp for the next frame, not the address where
+ the sp was saved. Allocated by frame_saved_regs_zalloc () which
+ is called and initialized by FRAME_INIT_SAVED_REGS. */
+ CORE_ADDR *saved_regs; /*NUM_REGS */
+
+ int localoff;
+ int pc_reg;
+ alpha_extra_func_info_t proc_desc;
+
+ /* Pointers to the next and previous frame_info's in the frame cache. */
+ struct frame_info *next, *prev;
+};
+
+struct frame_saved_regs
+{
+ /* For each register R (except the SP), regs[R] is the address at
+ which it was saved on entry to the frame, or zero if it was not
+ saved on entry to this frame. This includes special registers
+ such as pc and fp saved in special ways in the stack frame.
+
+ regs[SP_REGNUM] is different. It holds the actual SP, not the
+ address at which it was saved. */
+
+ CORE_ADDR regs[NUM_REGS];
+};
+
+static CORE_ADDR theRegisters[32];
+
+/* Prototypes for local functions. */
+
+static CORE_ADDR read_next_frame_reg PARAMS ((struct frame_info *, int));
+static CORE_ADDR heuristic_proc_start PARAMS ((CORE_ADDR));
+static int alpha_about_to_return PARAMS ((CORE_ADDR pc));
+static void init_extra_frame_info PARAMS ((struct frame_info *));
+static CORE_ADDR alpha_frame_chain PARAMS ((struct frame_info *));
+static CORE_ADDR alpha_frame_saved_pc PARAMS ((struct frame_info *frame))
+static void *trace_alloc PARAMS ((unsigned int));
+static struct frame_info *create_new_frame PARAMS ((CORE_ADDR, CORE_ADDR));
+
+static alpha_extra_func_info_t
+heuristic_proc_desc PARAMS ((CORE_ADDR, CORE_ADDR, struct frame_info *,
+ struct frame_saved_regs *));
+
+static alpha_extra_func_info_t
+find_proc_desc PARAMS ((CORE_ADDR, struct frame_info *,
+ struct frame_saved_regs *));
+
+/* Heuristic_proc_start may hunt through the text section for a long
+ time across a 2400 baud serial line. Allows the user to limit this
+ search. */
+static unsigned int heuristic_fence_post = 1<<16;
+
+/* Layout of a stack frame on the alpha:
+
+ | |
+ pdr members: | 7th ... nth arg, |
+ | `pushed' by caller. |
+ | |
+----------------|-------------------------------|<-- old_sp == vfp
+ ^ ^ ^ ^ | |
+ | | | | | |
+ | |localoff | Copies of 1st .. 6th |
+ | | | | | argument if necessary. |
+ | | | v | |
+ | | | --- |-------------------------------|<-- FRAME_LOCALS_ADDRESS
+ | | | | |
+ | | | | Locals and temporaries. |
+ | | | | |
+ | | | |-------------------------------|
+ | | | | |
+ |-fregoffset | Saved float registers. |
+ | | | | F9 |
+ | | | | . |
+ | | | | . |
+ | | | | F2 |
+ | | v | |
+ | | -------|-------------------------------|
+ | | | |
+ | | | Saved registers. |
+ | | | S6 |
+ |-regoffset | . |
+ | | | . |
+ | | | S0 |
+ | | | pdr.pcreg |
+ | v | |
+ | ----------|-------------------------------|
+ | | |
+ frameoffset | Argument build area, gets |
+ | | 7th ... nth arg for any |
+ | | called procedure. |
+ v | |
+ -------------|-------------------------------|<-- sp
+ | | */
+
+#define PROC_LOW_ADDR(PROC) ((PROC)->pdr.adr) /* least address */
+#define PROC_HIGH_ADDR(PROC) ((PROC)->pdr.iline) /* upper address bound */
+#define PROC_DUMMY_FRAME(PROC) ((PROC)->pdr.cbLineOffset) /*CALL_DUMMY frame */
+#define PROC_FRAME_OFFSET(PROC) ((PROC)->pdr.frameoffset)
+#define PROC_FRAME_REG(PROC) ((PROC)->pdr.framereg)
+#define PROC_REG_MASK(PROC) ((PROC)->pdr.regmask)
+#define PROC_FREG_MASK(PROC) ((PROC)->pdr.fregmask)
+#define PROC_REG_OFFSET(PROC) ((PROC)->pdr.regoffset)
+#define PROC_FREG_OFFSET(PROC) ((PROC)->pdr.fregoffset)
+#define PROC_PC_REG(PROC) ((PROC)->pdr.pcreg)
+#define PROC_LOCALOFF(PROC) ((PROC)->pdr.localoff)
+
+/* Local storage allocation/deallocation functions. trace_alloc does
+ a malloc, but also chains allocated blocks on trace_alloc_chain, so
+ they may all be freed on exit from __gnat_backtrace. */
+
+struct alloc_chain
+{
+ struct alloc_chain *next;
+ double x[0];
+};
+struct alloc_chain *trace_alloc_chain;
+
+static void *
+trace_alloc (n)
+ unsigned int n;
+{
+ struct alloc_chain * result = malloc (n + sizeof(struct alloc_chain));
+
+ result->next = trace_alloc_chain;
+ trace_alloc_chain = result;
+ return (void*) result->x;
+}
+
+static void
+free_trace_alloc ()
+{
+ while (trace_alloc_chain != 0)
+ {
+ struct alloc_chain *old = trace_alloc_chain;
+
+ trace_alloc_chain = trace_alloc_chain->next;
+ free (old);
+ }
+}
+
+/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0
+ otherwise. */
+
+static int
+read_memory_safe4 (addr, dest)
+ CORE_ADDR addr;
+ unsigned int *dest;
+{
+ *dest = *((unsigned int*) addr);
+ return 0;
+}
+
+/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0
+ otherwise. */
+
+static int
+read_memory_safe8 (addr, dest)
+ CORE_ADDR addr;
+ CORE_ADDR *dest;
+{
+ *dest = *((CORE_ADDR*) addr);
+ return 0;
+}
+
+static CORE_ADDR
+read_register (regno)
+ int regno;
+{
+ if (regno >= 0 && regno < 31)
+ return theRegisters[regno];
+
+ return (CORE_ADDR) 0;
+}
+
+static void
+frame_saved_regs_zalloc (fi)
+ struct frame_info *fi;
+{
+ fi->saved_regs = (CORE_ADDR *) trace_alloc (SIZEOF_FRAME_SAVED_REGS);
+ memset (fi->saved_regs, 0, SIZEOF_FRAME_SAVED_REGS);
+}
+
+static void *
+frame_obstack_alloc (size)
+ unsigned long size;
+{
+ return (void *) trace_alloc (size);
+}
+
+static int
+inside_entry_file (addr)
+ CORE_ADDR addr;
+{
+ if (addr == 0)
+ return 1;
+ else
+ return 0;
+}
+
+static CORE_ADDR
+alpha_saved_pc_after_call (frame)
+ struct frame_info *frame;
+{
+ CORE_ADDR pc = frame->pc;
+ alpha_extra_func_info_t proc_desc;
+ int pcreg;
+
+ proc_desc = find_proc_desc (pc, frame->next, NULL);
+ pcreg = proc_desc ? PROC_PC_REG (proc_desc) : RA_REGNUM;
+
+ return read_register (pcreg);
+}
+
+/* Guaranteed to set frame->saved_regs to some values (it never leaves it
+ NULL). */
+
+static void
+alpha_find_saved_regs (frame)
+ struct frame_info *frame;
+{
+ int ireg;
+ CORE_ADDR reg_position;
+ unsigned long mask;
+ alpha_extra_func_info_t proc_desc;
+ int returnreg;
+
+ frame_saved_regs_zalloc (frame);
+
+ /* If it is the frame for __sigtramp, the saved registers are located in a
+ sigcontext structure somewhere on the stack. __sigtramp passes a pointer
+ to the sigcontext structure on the stack. If the stack layout for
+ __sigtramp changes, or if sigcontext offsets change, we might have to
+ update this code. */
+
+#ifndef SIGFRAME_PC_OFF
+#define SIGFRAME_PC_OFF (2 * 8)
+#define SIGFRAME_REGSAVE_OFF (4 * 8)
+#define SIGFRAME_FPREGSAVE_OFF (SIGFRAME_REGSAVE_OFF + 32 * 8 + 8)
+#endif
+
+ proc_desc = frame->proc_desc;
+ if (proc_desc == NULL)
+ /* I'm not sure how/whether this can happen. Normally when we can't
+ find a proc_desc, we "synthesize" one using heuristic_proc_desc
+ and set the saved_regs right away. */
+ return;
+
+ /* Fill in the offsets for the registers which gen_mask says
+ were saved. */
+
+ reg_position = frame->frame + PROC_REG_OFFSET (proc_desc);
+ mask = PROC_REG_MASK (proc_desc);
+
+ returnreg = PROC_PC_REG (proc_desc);
+
+ /* Note that RA is always saved first, regardless of its actual
+ register number. */
+ if (mask & (1 << returnreg))
+ {
+ frame->saved_regs[returnreg] = reg_position;
+ reg_position += 8;
+ mask &= ~(1 << returnreg); /* Clear bit for RA so we
+ don't save again later. */
+ }
+
+ for (ireg = 0; ireg <= 31; ireg++)
+ if (mask & (1 << ireg))
+ {
+ frame->saved_regs[ireg] = reg_position;
+ reg_position += 8;
+ }
+
+ /* Fill in the offsets for the registers which float_mask says
+ were saved. */
+
+ reg_position = frame->frame + PROC_FREG_OFFSET (proc_desc);
+ mask = PROC_FREG_MASK (proc_desc);
+
+ for (ireg = 0; ireg <= 31; ireg++)
+ if (mask & (1 << ireg))
+ {
+ frame->saved_regs[FP0_REGNUM + ireg] = reg_position;
+ reg_position += 8;
+ }
+
+ frame->saved_regs[PC_REGNUM] = frame->saved_regs[returnreg];
+}
+
+static CORE_ADDR
+read_next_frame_reg (fi, regno)
+ struct frame_info *fi;
+ int regno;
+{
+ CORE_ADDR result;
+ for (; fi; fi = fi->next)
+ {
+ /* We have to get the saved sp from the sigcontext
+ if it is a signal handler frame. */
+ if (regno == SP_REGNUM)
+ return fi->frame;
+ else
+ {
+ if (fi->saved_regs == 0)
+ alpha_find_saved_regs (fi);
+
+ if (fi->saved_regs[regno])
+ {
+ if (read_memory_safe8 (fi->saved_regs[regno], &result) == 0)
+ return result;
+ else
+ return 0;
+ }
+ }
+ }
+
+ return read_register (regno);
+}
+
+static CORE_ADDR
+alpha_frame_saved_pc (frame)
+ struct frame_info *frame;
+{
+ return read_next_frame_reg (frame, frame->pc_reg);
+}
+
+static struct alpha_extra_func_info temp_proc_desc;
+
+/* Nonzero if instruction at PC is a return instruction. "ret
+ $zero,($ra),1" on alpha. */
+
+static int
+alpha_about_to_return (pc)
+ CORE_ADDR pc;
+{
+ int inst;
+
+ read_memory_safe4 (pc, &inst);
+ return inst == 0x6bfa8001;
+}
+
+/* A heuristically computed start address for the subprogram
+ containing address PC. Returns 0 if none detected. */
+
+static CORE_ADDR
+heuristic_proc_start (pc)
+ CORE_ADDR pc;
+{
+ CORE_ADDR start_pc = pc;
+ CORE_ADDR fence = start_pc - heuristic_fence_post;
+
+ if (start_pc == 0)
+ return 0;
+
+ if (heuristic_fence_post == UINT_MAX
+ || fence < VM_MIN_ADDRESS)
+ fence = VM_MIN_ADDRESS;
+
+ /* search back for previous return */
+ for (start_pc -= 4; ; start_pc -= 4)
+ {
+ if (start_pc < fence)
+ return 0;
+ else if (alpha_about_to_return (start_pc))
+ break;
+ }
+
+ start_pc += 4; /* skip return */
+ return start_pc;
+}
+
+static alpha_extra_func_info_t
+heuristic_proc_desc (start_pc, limit_pc, next_frame, saved_regs_p)
+ CORE_ADDR start_pc;
+ CORE_ADDR limit_pc;
+ struct frame_info *next_frame;
+ struct frame_saved_regs *saved_regs_p;
+{
+ CORE_ADDR sp = read_next_frame_reg (next_frame, SP_REGNUM);
+ CORE_ADDR cur_pc;
+ int frame_size;
+ int has_frame_reg = 0;
+ unsigned long reg_mask = 0;
+ int pcreg = -1;
+
+ if (start_pc == 0)
+ return 0;
+
+ memset (&temp_proc_desc, '\0', sizeof (temp_proc_desc));
+ if (saved_regs_p != 0)
+ memset (saved_regs_p, '\0', sizeof (struct frame_saved_regs));
+
+ PROC_LOW_ADDR (&temp_proc_desc) = start_pc;
+
+ if (start_pc + 200 < limit_pc)
+ limit_pc = start_pc + 200;
+
+ frame_size = 0;
+ for (cur_pc = start_pc; cur_pc < limit_pc; cur_pc += 4)
+ {
+ unsigned int word;
+ int status;
+
+ status = read_memory_safe4 (cur_pc, &word);
+ if (status)
+ return 0;
+
+ if ((word & 0xffff0000) == 0x23de0000) /* lda $sp,n($sp) */
+ {
+ if (word & 0x8000)
+ frame_size += (-word) & 0xffff;
+ else
+ /* Exit loop if a positive stack adjustment is found, which
+ usually means that the stack cleanup code in the function
+ epilogue is reached. */
+ break;
+ }
+ else if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */
+ && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */
+ {
+ int reg = (word & 0x03e00000) >> 21;
+
+ reg_mask |= 1 << reg;
+ if (saved_regs_p != 0)
+ saved_regs_p->regs[reg] = sp + (short) word;
+
+ /* Starting with OSF/1-3.2C, the system libraries are shipped
+ without local symbols, but they still contain procedure
+ descriptors without a symbol reference. GDB is currently
+ unable to find these procedure descriptors and uses
+ heuristic_proc_desc instead.
+ As some low level compiler support routines (__div*, __add*)
+ use a non-standard return address register, we have to
+ add some heuristics to determine the return address register,
+ or stepping over these routines will fail.
+ Usually the return address register is the first register
+ saved on the stack, but assembler optimization might
+ rearrange the register saves.
+ So we recognize only a few registers (t7, t9, ra) within
+ the procedure prologue as valid return address registers.
+ If we encounter a return instruction, we extract the
+ the return address register from it.
+
+ FIXME: Rewriting GDB to access the procedure descriptors,
+ e.g. via the minimal symbol table, might obviate this hack. */
+ if (pcreg == -1
+ && cur_pc < (start_pc + 80)
+ && (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM))
+ pcreg = reg;
+ }
+ else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */
+ pcreg = (word >> 16) & 0x1f;
+ else if (word == 0x47de040f) /* bis sp,sp fp */
+ has_frame_reg = 1;
+ }
+
+ if (pcreg == -1)
+ {
+ /* If we haven't found a valid return address register yet,
+ keep searching in the procedure prologue. */
+ while (cur_pc < (limit_pc + 80) && cur_pc < (start_pc + 80))
+ {
+ unsigned int word;
+
+ if (read_memory_safe4 (cur_pc, &word))
+ break;
+ cur_pc += 4;
+
+ if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */
+ && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */
+ {
+ int reg = (word & 0x03e00000) >> 21;
+
+ if (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM)
+ {
+ pcreg = reg;
+ break;
+ }
+ }
+ else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */
+ {
+ pcreg = (word >> 16) & 0x1f;
+ break;
+ }
+ }
+ }
+
+ if (has_frame_reg)
+ PROC_FRAME_REG (&temp_proc_desc) = GCC_FP_REGNUM;
+ else
+ PROC_FRAME_REG (&temp_proc_desc) = SP_REGNUM;
+
+ PROC_FRAME_OFFSET (&temp_proc_desc) = frame_size;
+ PROC_REG_MASK (&temp_proc_desc) = reg_mask;
+ PROC_PC_REG (&temp_proc_desc) = (pcreg == -1) ? RA_REGNUM : pcreg;
+ PROC_LOCALOFF (&temp_proc_desc) = 0; /* XXX - bogus */
+
+ return &temp_proc_desc;
+}
+
+static alpha_extra_func_info_t
+find_proc_desc (pc, next_frame, saved_regs)
+ CORE_ADDR pc;
+ struct frame_info *next_frame;
+ struct frame_saved_regs *saved_regs;
+{
+ CORE_ADDR startaddr;
+
+ /* If heuristic_fence_post is non-zero, determine the procedure
+ start address by examining the instructions.
+ This allows us to find the start address of static functions which
+ have no symbolic information, as startaddr would have been set to
+ the preceding global function start address by the
+ find_pc_partial_function call above. */
+ startaddr = heuristic_proc_start (pc);
+
+ return heuristic_proc_desc (startaddr, pc, next_frame, saved_regs);
+}
+
+static CORE_ADDR
+alpha_frame_chain (frame)
+ struct frame_info *frame;
+{
+ alpha_extra_func_info_t proc_desc;
+ CORE_ADDR saved_pc = FRAME_SAVED_PC (frame);
+
+ if (saved_pc == 0 || inside_entry_file (saved_pc))
+ return 0;
+
+ proc_desc = find_proc_desc (saved_pc, frame, NULL);
+ if (!proc_desc)
+ return 0;
+
+ /* If no frame pointer and frame size is zero, we must be at end
+ of stack (or otherwise hosed). If we don't check frame size,
+ we loop forever if we see a zero size frame. */
+ if (PROC_FRAME_REG (proc_desc) == SP_REGNUM
+ && PROC_FRAME_OFFSET (proc_desc) == 0)
+ return 0;
+ else
+ return read_next_frame_reg (frame, PROC_FRAME_REG (proc_desc))
+ + PROC_FRAME_OFFSET (proc_desc);
+}
+
+static void
+init_extra_frame_info (frame)
+ struct frame_info *frame;
+{
+ struct frame_saved_regs temp_saved_regs;
+ alpha_extra_func_info_t proc_desc =
+ find_proc_desc (frame->pc, frame->next, &temp_saved_regs);
+
+ frame->saved_regs = NULL;
+ frame->localoff = 0;
+ frame->pc_reg = RA_REGNUM;
+ frame->proc_desc = proc_desc;
+
+ if (proc_desc)
+ {
+ /* Get the locals offset and the saved pc register from the
+ procedure descriptor, they are valid even if we are in the
+ middle of the prologue. */
+ frame->localoff = PROC_LOCALOFF (proc_desc);
+ frame->pc_reg = PROC_PC_REG (proc_desc);
+
+ /* Fixup frame-pointer - only needed for top frame */
+
+ /* This may not be quite right, if proc has a real frame register.
+ Get the value of the frame relative sp, procedure might have been
+ interrupted by a signal at it's very start. */
+ if (frame->pc == PROC_LOW_ADDR (proc_desc))
+ frame->frame = read_next_frame_reg (frame->next, SP_REGNUM);
+ else
+ frame->frame
+ = (read_next_frame_reg (frame->next, PROC_FRAME_REG (proc_desc))
+ + PROC_FRAME_OFFSET (proc_desc));
+
+ frame->saved_regs
+ = (CORE_ADDR *) frame_obstack_alloc (SIZEOF_FRAME_SAVED_REGS);
+ memcpy
+ (frame->saved_regs, temp_saved_regs.regs, SIZEOF_FRAME_SAVED_REGS);
+ frame->saved_regs[PC_REGNUM] = frame->saved_regs[RA_REGNUM];
+ }
+}
+
+/* Create an arbitrary (i.e. address specified by user) or innermost frame.
+ Always returns a non-NULL value. */
+
+static struct frame_info *
+create_new_frame (addr, pc)
+ CORE_ADDR addr;
+ CORE_ADDR pc;
+{
+ struct frame_info *fi;
+
+ fi = (struct frame_info *)
+ trace_alloc (sizeof (struct frame_info));
+
+ /* Arbitrary frame */
+ fi->next = NULL;
+ fi->prev = NULL;
+ fi->frame = addr;
+ fi->pc = pc;
+
+#ifdef INIT_EXTRA_FRAME_INFO
+ INIT_EXTRA_FRAME_INFO (0, fi);
+#endif
+
+ return fi;
+}
+
+static CORE_ADDR current_pc;
+
+static void
+set_current_pc ()
+{
+ current_pc = (CORE_ADDR) __builtin_return_address (0);
+}
+
+static CORE_ADDR
+read_pc ()
+{
+ return current_pc;
+}
+
+static struct frame_info *
+get_current_frame ()
+{
+ return create_new_frame (0, read_pc ());
+}
+
+/* Return the frame that called FI.
+ If FI is the original frame (it has no caller), return 0. */
+
+static struct frame_info *
+get_prev_frame (next_frame)
+ struct frame_info *next_frame;
+{
+ CORE_ADDR address = 0;
+ struct frame_info *prev;
+ int fromleaf = 0;
+
+ /* If we have the prev one, return it */
+ if (next_frame->prev)
+ return next_frame->prev;
+
+ /* On some machines it is possible to call a function without
+ setting up a stack frame for it. On these machines, we
+ define this macro to take two args; a frameinfo pointer
+ identifying a frame and a variable to set or clear if it is
+ or isn't leafless. */
+
+ /* Two macros defined in tm.h specify the machine-dependent
+ actions to be performed here.
+
+ First, get the frame's chain-pointer. If that is zero, the frame
+ is the outermost frame or a leaf called by the outermost frame.
+ This means that if start calls main without a frame, we'll return
+ 0 (which is fine anyway).
+
+ Nope; there's a problem. This also returns when the current
+ routine is a leaf of main. This is unacceptable. We move
+ this to after the ffi test; I'd rather have backtraces from
+ start go curfluy than have an abort called from main not show
+ main. */
+
+ address = FRAME_CHAIN (next_frame);
+ if (!FRAME_CHAIN_VALID (address, next_frame))
+ return 0;
+ address = FRAME_CHAIN_COMBINE (address, next_frame);
+
+ if (address == 0)
+ return 0;
+
+ prev = (struct frame_info *) trace_alloc (sizeof (struct frame_info));
+
+ prev->saved_regs = NULL;
+ if (next_frame)
+ next_frame->prev = prev;
+
+ prev->next = next_frame;
+ prev->prev = (struct frame_info *) 0;
+ prev->frame = address;
+
+ /* This change should not be needed, FIXME! We should
+ determine whether any targets *need* INIT_FRAME_PC to happen
+ after INIT_EXTRA_FRAME_INFO and come up with a simple way to
+ express what goes on here.
+
+ INIT_EXTRA_FRAME_INFO is called from two places: create_new_frame
+ (where the PC is already set up) and here (where it isn't).
+ INIT_FRAME_PC is only called from here, always after
+ INIT_EXTRA_FRAME_INFO.
+
+ The catch is the MIPS, where INIT_EXTRA_FRAME_INFO requires the PC
+ value (which hasn't been set yet). Some other machines appear to
+ require INIT_EXTRA_FRAME_INFO before they can do INIT_FRAME_PC. Phoo.
+
+ We shouldn't need INIT_FRAME_PC_FIRST to add more complication to
+ an already overcomplicated part of GDB. gnu@cygnus.com, 15Sep92.
+
+ Assuming that some machines need INIT_FRAME_PC after
+ INIT_EXTRA_FRAME_INFO, one possible scheme:
+
+ SETUP_INNERMOST_FRAME()
+ Default version is just create_new_frame (read_fp ()),
+ read_pc ()). Machines with extra frame info would do that (or the
+ local equivalent) and then set the extra fields.
+ INIT_PREV_FRAME(fromleaf, prev)
+ Replace INIT_EXTRA_FRAME_INFO and INIT_FRAME_PC. This should
+ also return a flag saying whether to keep the new frame, or
+ whether to discard it, because on some machines (e.g. mips) it
+ is really awkward to have FRAME_CHAIN_VALID called *before*
+ INIT_EXTRA_FRAME_INFO (there is no good way to get information
+ deduced in FRAME_CHAIN_VALID into the extra fields of the new frame).
+ std_frame_pc(fromleaf, prev)
+ This is the default setting for INIT_PREV_FRAME. It just does what
+ the default INIT_FRAME_PC does. Some machines will call it from
+ INIT_PREV_FRAME (either at the beginning, the end, or in the middle).
+ Some machines won't use it.
+ kingdon@cygnus.com, 13Apr93, 31Jan94, 14Dec94. */
+
+#ifdef INIT_FRAME_PC_FIRST
+ INIT_FRAME_PC_FIRST (fromleaf, prev);
+#endif
+
+#ifdef INIT_EXTRA_FRAME_INFO
+ INIT_EXTRA_FRAME_INFO (fromleaf, prev);
+#endif
+
+ /* This entry is in the frame queue now, which is good since
+ FRAME_SAVED_PC may use that queue to figure out its value
+ (see tm-sparc.h). We want the pc saved in the inferior frame. */
+ INIT_FRAME_PC (fromleaf, prev);
+
+ /* If ->frame and ->pc are unchanged, we are in the process of getting
+ ourselves into an infinite backtrace. Some architectures check this
+ in FRAME_CHAIN or thereabouts, but it seems like there is no reason
+ this can't be an architecture-independent check. */
+ if (next_frame != NULL)
+ {
+ if (prev->frame == next_frame->frame
+ && prev->pc == next_frame->pc)
+ {
+ next_frame->prev = NULL;
+ free (prev);
+ return NULL;
+ }
+ }
+
+ return prev;
+}
+
+#define SAVE(regno,disp) \
+ "stq $" #regno ", " #disp "(%0)\n"
+
+int
+__gnat_backtrace (array, size, exclude_min, exclude_max)
+ void **array;
+ int size;
+ void *exclude_min;
+ void *exclude_max;
+{
+ struct frame_info* top;
+ struct frame_info* current;
+ int cnt;
+
+ /* This function is not thread safe, protect it */
+ (*Lock_Task) ();
+ asm volatile (
+ SAVE (9,72)
+ SAVE (10,80)
+ SAVE (11,88)
+ SAVE (12,96)
+ SAVE (13,104)
+ SAVE (14,112)
+ SAVE (15,120)
+ SAVE (16,128)
+ SAVE (17,136)
+ SAVE (18,144)
+ SAVE (19,152)
+ SAVE (20,160)
+ SAVE (21,168)
+ SAVE (22,176)
+ SAVE (23,184)
+ SAVE (24,192)
+ SAVE (25,200)
+ SAVE (26,208)
+ SAVE (27,216)
+ SAVE (28,224)
+ SAVE (29,232)
+ SAVE (30,240)
+ : : "r" (&theRegisters));
+
+ trace_alloc_chain = NULL;
+ set_current_pc ();
+
+ top = current = get_current_frame ();
+ cnt = 0;
+
+ /* We skip the call to this function, it makes no sense to record it. */
+ for (cnt = 0; cnt < SKIP_FRAME; cnt += 1) {
+ current = get_prev_frame (current);
+ }
+
+ cnt = 0;
+ while (cnt < size)
+ {
+ if (STOP_FRAME)
+ break;
+
+ if (current->pc < (CORE_ADDR) exclude_min
+ || current->pc > (CORE_ADDR) exclude_max)
+ array[cnt++] = (void*) (current->pc + PC_ADJUST);
+
+ current = get_prev_frame (current);
+ }
+
+ free_trace_alloc ();
+ (*Unlock_Task) ();
+
+ return cnt;
+}
+#endif
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * T R A N S *
+ * *
+ * C Implementation File *
+ * *
+ * $Revision: 1.2 $
+ * *
+ * 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). *
+ * *
+ ****************************************************************************/
+
+#include "config.h"
+#include "system.h"
+#include "tree.h"
+#include "real.h"
+#include "flags.h"
+#include "rtl.h"
+#include "expr.h"
+#include "ggc.h"
+#include "function.h"
+#include "debug.h"
+#include "output.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"
+
+int max_gnat_nodes;
+int number_names;
+struct Node *Nodes_Ptr;
+Node_Id *Next_Node_Ptr;
+Node_Id *Prev_Node_Ptr;
+struct Elist_Header *Elists_Ptr;
+struct Elmt_Item *Elmts_Ptr;
+struct String_Entry *Strings_Ptr;
+Char_Code *String_Chars_Ptr;
+struct List_Header *List_Headers_Ptr;
+
+/* Current filename without path. */
+const char *ref_filename;
+
+/* Flag indicating whether file names are discarded in exception messages */
+int discard_file_names;
+
+/* If true, then gigi is being called on an analyzed but unexpanded
+ tree, and the only purpose of the call is to properly annotate
+ types with representation information. */
+int type_annotate_only;
+
+/* List of TREE_LIST nodes representing a block stack. TREE_VALUE
+ of each gives the variable used for the setjmp buffer in the current
+ block, if any. TREE_PURPOSE gives the bottom condition for a loop,
+ if this block is for a loop. The latter is only used to save the tree
+ over GC. */
+tree gnu_block_stack;
+
+/* List of TREE_LIST nodes representing a stack of exception pointer
+ variables. TREE_VALUE is the VAR_DECL that stores the address of
+ the raised exception. Nonzero means we are in an exception
+ handler. Set to error_mark_node in the zero-cost case. */
+static tree gnu_except_ptr_stack;
+
+/* Map GNAT tree codes to GCC tree codes for simple expressions. */
+static enum tree_code gnu_codes[Number_Node_Kinds];
+
+/* Current node being treated, in case gigi_abort called. */
+Node_Id error_gnat_node;
+
+/* Variable that stores a list of labels to be used as a goto target instead of
+ a return in some functions. See processing for N_Subprogram_Body. */
+static tree gnu_return_label_stack;
+
+static tree tree_transform PARAMS((Node_Id));
+static void elaborate_all_entities PARAMS((Node_Id));
+static void process_freeze_entity PARAMS((Node_Id));
+static void process_inlined_subprograms PARAMS((Node_Id));
+static void process_decls PARAMS((List_Id, List_Id, Node_Id,
+ int, int));
+static tree emit_access_check PARAMS((tree));
+static tree emit_discriminant_check PARAMS((tree, Node_Id));
+static tree emit_range_check PARAMS((tree, Node_Id));
+static tree emit_index_check PARAMS((tree, tree, tree, tree));
+static tree emit_check PARAMS((tree, tree));
+static tree convert_with_check PARAMS((Entity_Id, tree,
+ int, int, int));
+static int addressable_p PARAMS((tree));
+static tree assoc_to_constructor PARAMS((Node_Id, tree));
+static tree extract_values PARAMS((tree, tree));
+static tree pos_to_constructor PARAMS((Node_Id, tree, Entity_Id));
+static tree maybe_implicit_deref PARAMS((tree));
+static tree gnat_stabilize_reference_1 PARAMS((tree, int));
+static int build_unit_elab PARAMS((Entity_Id, int, tree));
+
+/* Constants for +0.5 and -0.5 for float-to-integer rounding. */
+static REAL_VALUE_TYPE dconstp5;
+static REAL_VALUE_TYPE dconstmp5;
+\f
+/* This is the main program of the back-end. It sets up all the table
+ structures and then generates code. */
+
+void
+gigi (gnat_root, max_gnat_node, number_name,
+ nodes_ptr, next_node_ptr, prev_node_ptr, elists_ptr, elmts_ptr,
+ strings_ptr, string_chars_ptr, list_headers_ptr,
+ number_units, file_info_ptr,
+ standard_integer, standard_long_long_float, standard_exception_type,
+ gigi_operating_mode)
+
+ Node_Id gnat_root;
+ int max_gnat_node;
+ int number_name;
+
+ struct Node *nodes_ptr;
+ Node_Id *next_node_ptr;
+ Node_Id *prev_node_ptr;
+ struct Elist_Header *elists_ptr;
+ struct Elmt_Item *elmts_ptr;
+ struct String_Entry *strings_ptr;
+ Char_Code *string_chars_ptr;
+ struct List_Header *list_headers_ptr;
+ Int number_units ATTRIBUTE_UNUSED;
+ char *file_info_ptr ATTRIBUTE_UNUSED;
+
+ Entity_Id standard_integer;
+ Entity_Id standard_long_long_float;
+ Entity_Id standard_exception_type;
+
+ Int gigi_operating_mode;
+{
+ max_gnat_nodes = max_gnat_node;
+ number_names = number_name;
+ Nodes_Ptr = nodes_ptr - First_Node_Id;
+ Next_Node_Ptr = next_node_ptr - First_Node_Id;
+ Prev_Node_Ptr = prev_node_ptr - First_Node_Id;
+ Elists_Ptr = elists_ptr - First_Elist_Id;
+ Elmts_Ptr = elmts_ptr - First_Elmt_Id;
+ Strings_Ptr = strings_ptr - First_String_Id;
+ String_Chars_Ptr = string_chars_ptr;
+ List_Headers_Ptr = list_headers_ptr - First_List_Id;
+
+ type_annotate_only = (gigi_operating_mode == 1);
+
+ /* See if we should discard file names in exception messages. */
+ discard_file_names = (Global_Discard_Names || Debug_Flag_NN);
+
+ if (Nkind (gnat_root) != N_Compilation_Unit)
+ gigi_abort (301);
+
+ set_lineno (gnat_root, 0);
+
+ /* Initialize ourselves. */
+ init_gnat_to_gnu ();
+ init_dummy_type ();
+ init_code_table ();
+
+ /* Enable GNAT stack checking method if needed */
+ if (!Stack_Check_Probes_On_Target)
+ set_stack_check_libfunc (gen_rtx (SYMBOL_REF, Pmode, "_gnat_stack_check"));
+
+ /* Save the type we made for integer as the type for Standard.Integer.
+ Then make the rest of the standard types. Note that some of these
+ may be subtypes. */
+ save_gnu_tree (Base_Type (standard_integer),
+ TYPE_NAME (integer_type_node), 0);
+
+ ggc_add_tree_root (&gnu_block_stack, 1);
+ ggc_add_tree_root (&gnu_except_ptr_stack, 1);
+ ggc_add_tree_root (&gnu_return_label_stack, 1);
+ gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
+
+ dconstp5 = REAL_VALUE_ATOF ("0.5", DFmode);
+ dconstmp5 = REAL_VALUE_ATOF ("-0.5", DFmode);
+
+ init_gigi_decls (gnat_to_gnu_entity (Base_Type (standard_long_long_float),
+ NULL_TREE, 0),
+ gnat_to_gnu_entity (Base_Type (standard_exception_type),
+ NULL_TREE, 0));
+
+ /* Emit global symbols containing context list info for the SGI Workshop
+ debugger */
+
+#ifdef MIPS_DEBUGGING_INFO
+ if (Spec_Context_List != 0)
+ emit_unit_label (Spec_Context_List, Spec_Filename);
+
+ if (Body_Context_List != 0)
+ emit_unit_label (Body_Context_List, Body_Filename);
+#endif
+
+#ifdef ASM_OUTPUT_IDENT
+ if (Present (Ident_String (Main_Unit)))
+ ASM_OUTPUT_IDENT
+ (asm_out_file,
+ TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
+#endif
+
+ gnat_to_code (gnat_root);
+}
+
+\f
+/* This function is the driver of the GNAT to GCC tree transformation process.
+ GNAT_NODE is the root of some gnat tree. It generates code for that
+ part of the tree. */
+
+void
+gnat_to_code (gnat_node)
+ Node_Id gnat_node;
+{
+ tree gnu_root;
+
+ /* Save node number in case error */
+ error_gnat_node = gnat_node;
+
+ gnu_root = tree_transform (gnat_node);
+
+ /* This should just generate code, not return a value. If it returns
+ a value, something is wrong. */
+ if (gnu_root != error_mark_node)
+ gigi_abort (302);
+}
+
+/* GNAT_NODE is the root of some GNAT tree. Return the root of the GCC
+ tree corresponding to that GNAT tree. Normally, no code is generated.
+ We just return an equivalent tree which is used elsewhere to generate
+ code. */
+
+tree
+gnat_to_gnu (gnat_node)
+ Node_Id gnat_node;
+{
+ tree gnu_root;
+
+ /* Save node number in case error */
+ error_gnat_node = gnat_node;
+
+ gnu_root = tree_transform (gnat_node);
+
+ /* If we got no code as a result, something is wrong. */
+ if (gnu_root == error_mark_node && ! type_annotate_only)
+ gigi_abort (303);
+
+ return gnu_root;
+}
+\f
+/* This function is the driver of the GNAT to GCC tree transformation process.
+ It is the entry point of the tree transformer. GNAT_NODE is the root of
+ some GNAT tree. Return the root of the corresponding GCC tree or
+ error_mark_node to signal that there is no GCC tree to return.
+
+ The latter is the case if only code generation actions have to be performed
+ like in the case of if statements, loops, etc. This routine is wrapped
+ in the above two routines for most purposes. */
+
+static tree
+tree_transform (gnat_node)
+ Node_Id gnat_node;
+{
+ tree gnu_result = error_mark_node; /* Default to no value. */
+ tree gnu_result_type = void_type_node;
+ tree gnu_expr;
+ tree gnu_lhs, gnu_rhs;
+ Node_Id gnat_temp;
+ Entity_Id gnat_temp_type;
+
+ /* Set input_file_name and lineno from the Sloc in the GNAT tree. */
+ set_lineno (gnat_node, 0);
+
+ /* If this is a Statement and we are at top level, we add the statement
+ as an elaboration for a null tree. That will cause it to be placed
+ in the elaboration procedure. */
+ if (global_bindings_p ()
+ && ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
+ && Nkind (gnat_node) != N_Null_Statement)
+ || Nkind (gnat_node) == N_Procedure_Call_Statement
+ || Nkind (gnat_node) == N_Label
+ || (Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
+ && (Present (Exception_Handlers (gnat_node))
+ || Present (At_End_Proc (gnat_node))))
+ || ((Nkind (gnat_node) == N_Raise_Constraint_Error
+ || Nkind (gnat_node) == N_Raise_Storage_Error
+ || Nkind (gnat_node) == N_Raise_Program_Error)
+ && (Ekind (Etype (gnat_node)) == E_Void))))
+ {
+ add_pending_elaborations (NULL_TREE, make_transform_expr (gnat_node));
+
+ return error_mark_node;
+ }
+
+ /* If this node is a non-static subexpression and we are only
+ annotating types, make this into a NULL_EXPR for non-VOID types
+ and error_mark_node for void return types. But allow
+ N_Identifier since we use it for lots of things, including
+ getting trees for discriminants. */
+
+ if (type_annotate_only
+ && IN (Nkind (gnat_node), N_Subexpr)
+ && Nkind (gnat_node) != N_Identifier
+ && ! Compile_Time_Known_Value (gnat_node))
+ {
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ if (TREE_CODE (gnu_result_type) == VOID_TYPE)
+ return error_mark_node;
+ else
+ return build1 (NULL_EXPR, gnu_result_type,
+ build_call_raise (raise_constraint_error_decl));
+ }
+
+ switch (Nkind (gnat_node))
+ {
+ /********************************/
+ /* Chapter 2: Lexical Elements: */
+ /********************************/
+
+ case N_Identifier:
+ case N_Expanded_Name:
+ case N_Operator_Symbol:
+ case N_Defining_Identifier:
+
+ /* If the Etype of this node does not equal the Etype of the
+ Entity, something is wrong with the entity map, probably in
+ generic instantiation. However, this does not apply to
+ types. Since we sometime have strange Ekind's, just do
+ this test for objects. Also, if the Etype of the Entity
+ is private, the Etype of the N_Identifier is allowed to be the
+ full type and also we consider a packed array type to be the
+ same as the original type. Finally, if the types are Itypes,
+ one may be a copy of the other, which is also legal. */
+
+ gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
+ ? gnat_node : Entity (gnat_node));
+ gnat_temp_type = Etype (gnat_temp);
+
+ if (Etype (gnat_node) != gnat_temp_type
+ && ! (Is_Packed (gnat_temp_type)
+ && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
+ && ! (IN (Ekind (gnat_temp_type), Private_Kind)
+ && Present (Full_View (gnat_temp_type))
+ && ((Etype (gnat_node) == Full_View (gnat_temp_type))
+ || (Is_Packed (Full_View (gnat_temp_type))
+ && Etype (gnat_node) ==
+ Packed_Array_Type (Full_View (gnat_temp_type)))))
+ && (!Is_Itype (Etype (gnat_node)) || !Is_Itype (gnat_temp_type))
+ && (Ekind (gnat_temp) == E_Variable
+ || Ekind (gnat_temp) == E_Component
+ || Ekind (gnat_temp) == E_Constant
+ || Ekind (gnat_temp) == E_Loop_Parameter
+ || IN (Ekind (gnat_temp), Formal_Kind)))
+ gigi_abort (304);
+
+ /* If this is a reference to a deferred constant whose partial view
+ is an unconstrained private type, the proper type is on the full
+ view of the constant, not on the full view of the type, which may
+ be unconstrained.
+
+ This may be a reference to a type, for example in the prefix of the
+ attribute Position, generated for dispatching code (see Make_DT in
+ exp_disp,adb). In that case we need the type itself, not is parent,
+ in particular if it is a derived type */
+
+ if (Is_Private_Type (gnat_temp_type)
+ && Has_Unknown_Discriminants (gnat_temp_type)
+ && Present (Full_View (gnat_temp))
+ && ! Is_Type (gnat_temp))
+ {
+ gnat_temp = Full_View (gnat_temp);
+ gnat_temp_type = Etype (gnat_temp);
+ gnu_result_type = get_unpadded_type (gnat_temp_type);
+ }
+ else
+ {
+ /* Expand the type of this identitier first, in case it is
+ an enumeral literal, which only get made when the type
+ is expanded. There is no order-of-elaboration issue here.
+ We want to use the Actual_Subtype if it has already been
+ elaborated, otherwise the Etype. Avoid using Actual_Subtype
+ for packed arrays to simplify things. */
+ if ((Ekind (gnat_temp) == E_Constant
+ || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
+ && ! (Is_Array_Type (Etype (gnat_temp))
+ && Present (Packed_Array_Type (Etype (gnat_temp))))
+ && Present (Actual_Subtype (gnat_temp))
+ && present_gnu_tree (Actual_Subtype (gnat_temp)))
+ gnat_temp_type = Actual_Subtype (gnat_temp);
+ else
+ gnat_temp_type = Etype (gnat_node);
+
+ gnu_result_type = get_unpadded_type (gnat_temp_type);
+ }
+
+ gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
+
+ /* If we are in an exception handler, force this variable into memory
+ to ensure optimization does not remove stores that appear
+ redundant but are actually needed in case an exception occurs.
+
+ ??? Note that we need not do this if the variable is declared within
+ the handler, only if it is referenced in the handler and declared
+ in an enclosing block, but we have no way of testing that
+ right now. */
+ if (TREE_VALUE (gnu_except_ptr_stack) != 0)
+ {
+ mark_addressable (gnu_result);
+ flush_addressof (gnu_result);
+ }
+
+ /* Some objects (such as parameters passed by reference, globals of
+ variable size, and renamed objects) actually represent the address
+ of the object. In that case, we must do the dereference. Likewise,
+ deal with parameters to foreign convention subprograms. Call fold
+ here since GNU_RESULT may be a CONST_DECL. */
+ if (DECL_P (gnu_result)
+ && (DECL_BY_REF_P (gnu_result)
+ || DECL_BY_COMPONENT_PTR_P (gnu_result)))
+ {
+ int ro = DECL_POINTS_TO_READONLY_P (gnu_result);
+
+ if (DECL_BY_COMPONENT_PTR_P (gnu_result))
+ gnu_result = convert (build_pointer_type (gnu_result_type),
+ gnu_result);
+
+ gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
+ fold (gnu_result));
+ TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
+ }
+
+ /* The GNAT tree has the type of a function as the type of its result.
+ Also use the type of the result if the Etype is a subtype which
+ is nominally unconstrained. But remove any padding from the
+ resulting type. */
+ if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
+ || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
+ {
+ gnu_result_type = TREE_TYPE (gnu_result);
+ if (TREE_CODE (gnu_result_type) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (gnu_result_type))
+ gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
+ }
+
+ /* We always want to return the underlying INTEGER_CST for an
+ enumeration literal to avoid the need to call fold in lots
+ of places. But don't do this is the parent will be taking
+ the address of this object. */
+ if (TREE_CODE (gnu_result) == CONST_DECL)
+ {
+ gnat_temp = Parent (gnat_node);
+ if (DECL_CONST_CORRESPONDING_VAR (gnu_result) == 0
+ || (Nkind (gnat_temp) != N_Reference
+ && ! (Nkind (gnat_temp) == N_Attribute_Reference
+ && ((Get_Attribute_Id (Attribute_Name (gnat_temp))
+ == Attr_Address)
+ || (Get_Attribute_Id (Attribute_Name (gnat_temp))
+ == Attr_Access)
+ || (Get_Attribute_Id (Attribute_Name (gnat_temp))
+ == Attr_Unchecked_Access)
+ || (Get_Attribute_Id (Attribute_Name (gnat_temp))
+ == Attr_Unrestricted_Access)))))
+ gnu_result = DECL_INITIAL (gnu_result);
+ }
+ break;
+
+ case N_Integer_Literal:
+ {
+ tree gnu_type;
+
+ /* Get the type of the result, looking inside any padding and
+ left-justified modular types. Then get the value in that type. */
+ gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ if (TREE_CODE (gnu_type) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type))
+ gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
+
+ gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
+ /* Get the type of the result, looking inside any padding and
+ left-justified modular types. Then get the value in that type. */
+ gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ if (TREE_CODE (gnu_type) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type))
+ gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
+
+ gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
+
+ /* If the result overflows (meaning it doesn't fit in its base type)
+ or is outside of the range of the subtype, we have an illegal tree
+ entry, so abort. Note that the test for of types with biased
+ representation is harder, so we don't test in that case. */
+ if (TREE_CONSTANT_OVERFLOW (gnu_result)
+ || (TREE_CODE (TYPE_MIN_VALUE (gnu_result_type)) == INTEGER_CST
+ && ! TYPE_BIASED_REPRESENTATION_P (gnu_result_type)
+ && tree_int_cst_lt (gnu_result,
+ TYPE_MIN_VALUE (gnu_result_type)))
+ || (TREE_CODE (TYPE_MAX_VALUE (gnu_result_type)) == INTEGER_CST
+ && ! TYPE_BIASED_REPRESENTATION_P (gnu_result_type)
+ && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_result_type),
+ gnu_result)))
+ gigi_abort (305);
+ }
+ break;
+
+ case N_Character_Literal:
+ /* If a Entity is present, it means that this was one of the
+ literals in a user-defined character type. In that case,
+ just return the value in the CONST_DECL. Otherwise, use the
+ character code. In that case, the base type should be an
+ INTEGER_TYPE, but we won't bother checking for that. */
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ if (Present (Entity (gnat_node)))
+ gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
+ else
+ gnu_result = convert (gnu_result_type,
+ build_int_2 (Char_Literal_Value (gnat_node), 0));
+ break;
+
+ case N_Real_Literal:
+ /* If this is of a fixed-point type, the value we want is the
+ value of the corresponding integer. */
+ if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
+ {
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
+ gnu_result_type);
+ if (TREE_CONSTANT_OVERFLOW (gnu_result)
+#if 0
+ || (TREE_CODE (TYPE_MIN_VALUE (gnu_result_type)) == INTEGER_CST
+ && tree_int_cst_lt (gnu_result,
+ TYPE_MIN_VALUE (gnu_result_type)))
+ || (TREE_CODE (TYPE_MAX_VALUE (gnu_result_type)) == INTEGER_CST
+ && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_result_type),
+ gnu_result))
+#endif
+ )
+ gigi_abort (305);
+ }
+ /* We should never see a Vax_Float type literal, since the front end
+ is supposed to transform these using appropriate conversions */
+ else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
+ gigi_abort (334);
+
+ else
+ {
+ Ureal ur_realval = Realval (gnat_node);
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ /* If the real value is zero, so is the result. Otherwise,
+ convert it to a machine number if it isn't already. That
+ forces BASE to 0 or 2 and simplifies the rest of our logic. */
+ if (UR_Is_Zero (ur_realval))
+ gnu_result = convert (gnu_result_type, integer_zero_node);
+ else
+ {
+ if (! Is_Machine_Number (gnat_node))
+ ur_realval =
+ Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
+ ur_realval);
+
+ gnu_result
+ = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
+
+ /* If we have a base of zero, divide by the denominator.
+ Otherwise, the base must be 2 and we scale the value, which
+ we know can fit in the mantissa of the type (hence the use
+ of that type above). */
+ if (Rbase (ur_realval) == 0)
+ gnu_result
+ = build_binary_op (RDIV_EXPR,
+ get_base_type (gnu_result_type),
+ gnu_result,
+ UI_To_gnu (Denominator (ur_realval),
+ gnu_result_type));
+ else if (Rbase (ur_realval) != 2)
+ gigi_abort (336);
+
+ else
+ gnu_result
+ = build_real (gnu_result_type,
+ REAL_VALUE_LDEXP
+ (TREE_REAL_CST (gnu_result),
+ - UI_To_Int (Denominator (ur_realval))));
+ }
+
+ /* Now see if we need to negate the result. Do it this way to
+ properly handle -0. */
+ if (UR_Is_Negative (Realval (gnat_node)))
+ gnu_result
+ = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
+ gnu_result);
+ }
+
+ break;
+
+ case N_String_Literal:
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
+ {
+ /* We assume here that all strings are of type standard.string.
+ "Weird" types of string have been converted to an aggregate
+ by the expander. */
+ String_Id gnat_string = Strval (gnat_node);
+ int length = String_Length (gnat_string);
+ char *string = (char *) alloca (length + 1);
+ int i;
+
+ /* Build the string with the characters in the literal. Note
+ that Ada strings are 1-origin. */
+ for (i = 0; i < length; i++)
+ string[i] = Get_String_Char (gnat_string, i + 1);
+
+ /* Put a null at the end of the string in case it's in a context
+ where GCC will want to treat it as a C string. */
+ string[i] = 0;
+
+ gnu_result = build_string (length, string);
+
+ /* Strings in GCC don't normally have types, but we want
+ this to not be converted to the array type. */
+ TREE_TYPE (gnu_result) = gnu_result_type;
+ }
+ else
+ {
+ /* Build a list consisting of each character, then make
+ the aggregate. */
+ String_Id gnat_string = Strval (gnat_node);
+ int length = String_Length (gnat_string);
+ int i;
+ tree gnu_list = NULL_TREE;
+
+ for (i = 0; i < length; i++)
+ gnu_list
+ = tree_cons (NULL_TREE,
+ convert (TREE_TYPE (gnu_result_type),
+ build_int_2 (Get_String_Char (gnat_string,
+ i + 1),
+ 0)),
+ gnu_list);
+
+ gnu_result
+ = build_constructor (gnu_result_type, nreverse (gnu_list));
+ }
+ break;
+
+ case N_Pragma:
+ if (type_annotate_only)
+ break;
+
+ /* Check for (and ignore) unrecognized pragma */
+ if (! Is_Pragma_Name (Chars (gnat_node)))
+ break;
+
+ switch (Get_Pragma_Id (Chars (gnat_node)))
+ {
+ case Pragma_Inspection_Point:
+ /* Do nothing at top level: all such variables are already
+ viewable. */
+ if (global_bindings_p ())
+ break;
+
+ set_lineno (gnat_node, 1);
+ for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
+ Present (gnat_temp);
+ gnat_temp = Next (gnat_temp))
+ {
+ gnu_expr = gnat_to_gnu (Expression (gnat_temp));
+ if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
+ gnu_expr = TREE_OPERAND (gnu_expr, 0);
+
+ gnu_expr = build1 (USE_EXPR, void_type_node, gnu_expr);
+ TREE_SIDE_EFFECTS (gnu_expr) = 1;
+ expand_expr_stmt (gnu_expr);
+ }
+ break;
+
+ case Pragma_Optimize:
+ switch (Chars (Expression
+ (First (Pragma_Argument_Associations (gnat_node)))))
+ {
+ case Name_Time: case Name_Space:
+ if (optimize == 0)
+ post_error ("insufficient -O value?", gnat_node);
+ break;
+
+ case Name_Off:
+ if (optimize != 0)
+ post_error ("must specify -O0?", gnat_node);
+ break;
+
+ default:
+ gigi_abort (331);
+ break;
+ }
+ break;
+
+ case Pragma_Reviewable:
+ if (write_symbols == NO_DEBUG)
+ post_error ("must specify -g?", gnat_node);
+ break;
+ }
+ break;
+
+ /**************************************/
+ /* Chapter 3: Declarations and Types: */
+ /**************************************/
+
+ case N_Subtype_Declaration:
+ case N_Full_Type_Declaration:
+ case N_Incomplete_Type_Declaration:
+ case N_Private_Type_Declaration:
+ case N_Private_Extension_Declaration:
+ case N_Task_Type_Declaration:
+ process_type (Defining_Entity (gnat_node));
+ break;
+
+ case N_Object_Declaration:
+ case N_Exception_Declaration:
+ gnat_temp = Defining_Entity (gnat_node);
+
+ /* If we are just annotating types and this object has an unconstrained
+ or task type, don't elaborate it. */
+ if (type_annotate_only
+ && (((Is_Array_Type (Etype (gnat_temp))
+ || Is_Record_Type (Etype (gnat_temp)))
+ && ! Is_Constrained (Etype (gnat_temp)))
+ || Is_Concurrent_Type (Etype (gnat_temp))))
+ break;
+
+ if (Present (Expression (gnat_node))
+ && ! (Nkind (gnat_node) == N_Object_Declaration
+ && No_Initialization (gnat_node))
+ && (! type_annotate_only
+ || Compile_Time_Known_Value (Expression (gnat_node))))
+ {
+ gnu_expr = gnat_to_gnu (Expression (gnat_node));
+ if (Do_Range_Check (Expression (gnat_node)))
+ gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp));
+
+ /* If this object has its elaboration delayed, we must force
+ evaluation of GNU_EXPR right now and save it for when the object
+ is frozen. */
+ if (Present (Freeze_Node (gnat_temp)))
+ {
+ if ((Is_Public (gnat_temp) || global_bindings_p ())
+ && ! TREE_CONSTANT (gnu_expr))
+ gnu_expr
+ = create_var_decl (create_concat_name (gnat_temp, "init"),
+ NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
+ 0, Is_Public (gnat_temp), 0, 0, 0);
+ else
+ gnu_expr = maybe_variable (gnu_expr, Expression (gnat_node));
+
+ save_gnu_tree (gnat_node, gnu_expr, 1);
+ }
+ }
+ else
+ gnu_expr = 0;
+
+ if (type_annotate_only && gnu_expr != 0
+ && TREE_CODE (gnu_expr) == ERROR_MARK)
+ gnu_expr = 0;
+
+ if (No (Freeze_Node (gnat_temp)))
+ gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
+ break;
+
+ case N_Object_Renaming_Declaration:
+
+ gnat_temp = Defining_Entity (gnat_node);
+
+ /* Don't do anything if this renaming handled by the front end.
+ or if we are just annotating types and this object has an
+ unconstrained or task type, don't elaborate it. */
+ if (! Is_Renaming_Of_Object (gnat_temp)
+ && ! (type_annotate_only
+ && (((Is_Array_Type (Etype (gnat_temp))
+ || Is_Record_Type (Etype (gnat_temp)))
+ && ! Is_Constrained (Etype (gnat_temp)))
+ || Is_Concurrent_Type (Etype (gnat_temp)))))
+ {
+ gnu_expr = gnat_to_gnu (Renamed_Object (gnat_temp));
+ gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
+ }
+ break;
+
+ case N_Implicit_Label_Declaration:
+ gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
+ break;
+
+ case N_Subprogram_Renaming_Declaration:
+ case N_Package_Renaming_Declaration:
+ case N_Exception_Renaming_Declaration:
+ case N_Number_Declaration:
+ /* These are fully handled in the front end. */
+ break;
+
+ /*************************************/
+ /* Chapter 4: Names and Expressions: */
+ /*************************************/
+
+ case N_Explicit_Dereference:
+ gnu_result = gnat_to_gnu (Prefix (gnat_node));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ /* Emit access check if necessary */
+ if (Do_Access_Check (gnat_node))
+ gnu_result = emit_access_check (gnu_result);
+
+ gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
+ break;
+
+ case N_Indexed_Component:
+ {
+ tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
+ tree gnu_type;
+ int ndim;
+ int i;
+ Node_Id *gnat_expr_array;
+
+ /* Emit access check if necessary */
+ if (Do_Access_Check (gnat_node))
+ gnu_array_object = emit_access_check (gnu_array_object);
+
+ gnu_array_object = maybe_implicit_deref (gnu_array_object);
+ gnu_array_object = maybe_unconstrained_array (gnu_array_object);
+
+ /* If we got a padded type, remove it too. */
+ if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
+ gnu_array_object
+ = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
+ gnu_array_object);
+
+ gnu_result = gnu_array_object;
+
+ /* First compute the number of dimensions of the array, then
+ fill the expression array, the order depending on whether
+ this is a Convention_Fortran array or not. */
+ for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
+ TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
+ ndim++, gnu_type = TREE_TYPE (gnu_type))
+ ;
+
+ gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id));
+
+ if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
+ for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
+ i >= 0;
+ i--, gnat_temp = Next (gnat_temp))
+ gnat_expr_array[i] = gnat_temp;
+ else
+ for (i = 0, gnat_temp = First (Expressions (gnat_node));
+ i < ndim;
+ i++, gnat_temp = Next (gnat_temp))
+ gnat_expr_array[i] = gnat_temp;
+
+ for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
+ i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
+ {
+ if (TREE_CODE (gnu_type) != ARRAY_TYPE)
+ gigi_abort (307);
+
+ gnat_temp = gnat_expr_array[i];
+ gnu_expr = gnat_to_gnu (gnat_temp);
+
+ if (Do_Range_Check (gnat_temp))
+ gnu_expr
+ = emit_index_check
+ (gnu_array_object, gnu_expr,
+ TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
+ TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
+
+ gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
+ gnu_result, gnu_expr);
+ }
+ }
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ break;
+
+ case N_Slice:
+ {
+ tree gnu_type;
+ Node_Id gnat_range_node = Discrete_Range (gnat_node);
+
+ gnu_result = gnat_to_gnu (Prefix (gnat_node));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ /* Emit access check if necessary */
+ if (Do_Access_Check (gnat_node))
+ gnu_result = emit_access_check (gnu_result);
+
+ /* Do any implicit dereferences of the prefix and do any needed
+ range check. */
+ gnu_result = maybe_implicit_deref (gnu_result);
+ gnu_result = maybe_unconstrained_array (gnu_result);
+ gnu_type = TREE_TYPE (gnu_result);
+ if (Do_Range_Check (gnat_range_node))
+ {
+ /* Get the bounds of the slice. */
+ tree gnu_index_type
+ = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
+ tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
+ tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
+ tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
+
+ /* Check to see that the minimum slice value is in range */
+ gnu_expr_l
+ = emit_index_check
+ (gnu_result, gnu_min_expr,
+ TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
+ TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
+
+ /* Check to see that the maximum slice value is in range */
+ gnu_expr_h
+ = emit_index_check
+ (gnu_result, gnu_max_expr,
+ TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
+ TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
+
+ /* Derive a good type to convert everything too */
+ gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l));
+
+ /* Build a compound expression that does the range checks */
+ gnu_expr
+ = build_binary_op (COMPOUND_EXPR, gnu_expr_type,
+ convert (gnu_expr_type, gnu_expr_h),
+ convert (gnu_expr_type, gnu_expr_l));
+
+ /* Build a conditional expression that returns the range checks
+ expression if the slice range is not null (max >= min) or
+ returns the min if the slice range is null */
+ gnu_expr
+ = fold (build (COND_EXPR, gnu_expr_type,
+ build_binary_op (GE_EXPR, gnu_expr_type,
+ convert (gnu_expr_type,
+ gnu_max_expr),
+ convert (gnu_expr_type,
+ gnu_min_expr)),
+ gnu_expr, gnu_min_expr));
+ }
+ else
+ gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
+
+ gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
+ gnu_result, gnu_expr);
+ }
+ break;
+
+ case N_Selected_Component:
+ {
+ tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
+ Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
+ Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
+ tree gnu_field;
+
+ while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
+ || IN (Ekind (gnat_pref_type), Access_Kind))
+ {
+ if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
+ gnat_pref_type = Underlying_Type (gnat_pref_type);
+ else if (IN (Ekind (gnat_pref_type), Access_Kind))
+ gnat_pref_type = Designated_Type (gnat_pref_type);
+ }
+
+ if (Do_Access_Check (gnat_node))
+ gnu_prefix = emit_access_check (gnu_prefix);
+
+ gnu_prefix = maybe_implicit_deref (gnu_prefix);
+
+ /* For discriminant references in tagged types always substitute the
+ corresponding discriminant as the actual selected component. */
+
+ if (Is_Tagged_Type (gnat_pref_type))
+ while (Present (Corresponding_Discriminant (gnat_field)))
+ gnat_field = Corresponding_Discriminant (gnat_field);
+
+ /* For discriminant references of untagged types always substitute the
+ corresponding girder discriminant. */
+
+ else if (Present (Corresponding_Discriminant (gnat_field)))
+ gnat_field = Original_Record_Component (gnat_field);
+
+ /* Handle extracting the real or imaginary part of a complex.
+ The real part is the first field and the imaginary the last. */
+
+ if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
+ gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
+ ? REALPART_EXPR : IMAGPART_EXPR,
+ NULL_TREE, gnu_prefix);
+ else
+ {
+ gnu_field = gnat_to_gnu_entity (gnat_field, NULL_TREE, 0);
+
+ /* If there are discriminants, the prefix might be
+ evaluated more than once, which is a problem if it has
+ side-effects. */
+
+ if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
+ ? Designated_Type (Etype
+ (Prefix (gnat_node)))
+ : Etype (Prefix (gnat_node)))
+ && TREE_SIDE_EFFECTS (gnu_prefix))
+ gnu_prefix = make_save_expr (gnu_prefix);
+
+ /* Emit discriminant check if necessary. */
+ if (Do_Discriminant_Check (gnat_node))
+ gnu_prefix = emit_discriminant_check (gnu_prefix, gnat_node);
+ gnu_result
+ = build_component_ref (gnu_prefix, NULL_TREE, gnu_field);
+ }
+
+ if (gnu_result == 0)
+ gigi_abort (308);
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ }
+ break;
+
+ case N_Attribute_Reference:
+ {
+ /* The attribute designator (like an enumeration value). */
+ int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
+ int prefix_unused = 0;
+ tree gnu_prefix;
+ tree gnu_type;
+
+ /* The Elab_Spec and Elab_Body attributes are special in that
+ Prefix is a unit, not an object with a GCC equivalent. Similarly
+ for Elaborated, since that variable isn't otherwise known. */
+ if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec)
+ {
+ gnu_prefix
+ = create_subprog_decl
+ (create_concat_name (Entity (Prefix (gnat_node)),
+ attribute == Attr_Elab_Body
+ ? "elabb" : "elabs"),
+ NULL_TREE, void_ftype, NULL_TREE, 0, 1, 1, 0);
+ return gnu_prefix;
+ }
+
+ gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
+ gnu_type = TREE_TYPE (gnu_prefix);
+
+ /* If the input is a NULL_EXPR, make a new one. */
+ if (TREE_CODE (gnu_prefix) == NULL_EXPR)
+ {
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result = build1 (NULL_EXPR, gnu_result_type,
+ TREE_OPERAND (gnu_prefix, 0));
+ break;
+ }
+
+ switch (attribute)
+ {
+ case Attr_Pos:
+ case Attr_Val:
+ /* These are just conversions until since representation
+ clauses for enumerations are handled in the front end. */
+ {
+ int check_p = Do_Range_Check (First (Expressions (gnat_node)));
+
+ gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
+ check_p, check_p, 1);
+ }
+ break;
+
+ case Attr_Pred:
+ case Attr_Succ:
+ /* These just add or subject the constant 1. Representation
+ clauses for enumerations are handled in the front-end. */
+ gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ if (Do_Range_Check (First (Expressions (gnat_node))))
+ {
+ gnu_expr = make_save_expr (gnu_expr);
+ gnu_expr
+ = emit_check
+ (build_binary_op (EQ_EXPR, integer_type_node,
+ gnu_expr,
+ attribute == Attr_Pred
+ ? TYPE_MIN_VALUE (gnu_result_type)
+ : TYPE_MAX_VALUE (gnu_result_type)),
+ gnu_expr);
+ }
+
+ gnu_result
+ = build_binary_op (attribute == Attr_Pred
+ ? MINUS_EXPR : PLUS_EXPR,
+ gnu_result_type, gnu_expr,
+ convert (gnu_result_type, integer_one_node));
+ break;
+
+ case Attr_Address:
+ case Attr_Unrestricted_Access:
+
+ /* Conversions don't change something's address but can cause
+ us to miss the COMPONENT_REF case below, so strip them off. */
+ gnu_prefix = remove_conversions (gnu_prefix);
+
+ /* If we are taking 'Address of an unconstrained object,
+ this is the pointer to the underlying array. */
+ gnu_prefix = maybe_unconstrained_array (gnu_prefix);
+
+ /* ... fall through ... */
+
+ case Attr_Access:
+ case Attr_Unchecked_Access:
+ case Attr_Code_Address:
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result
+ = build_unary_op (attribute == Attr_Address
+ || attribute == Attr_Unrestricted_Access
+ ? ATTR_ADDR_EXPR : ADDR_EXPR,
+ gnu_result_type, gnu_prefix);
+
+ /* For 'Code_Address, find an inner ADDR_EXPR and mark it
+ so that we don't try to build a trampoline. */
+ if (attribute == Attr_Code_Address)
+ {
+ for (gnu_expr = gnu_result;
+ TREE_CODE (gnu_expr) == NOP_EXPR
+ || TREE_CODE (gnu_expr) == CONVERT_EXPR;
+ gnu_expr = TREE_OPERAND (gnu_expr, 0))
+ TREE_CONSTANT (gnu_expr) = 1;
+ ;
+
+ if (TREE_CODE (gnu_expr) == ADDR_EXPR)
+ TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
+ }
+
+ break;
+
+ case Attr_Size:
+ case Attr_Object_Size:
+ case Attr_Value_Size:
+ case Attr_Max_Size_In_Storage_Elements:
+
+ gnu_expr = gnu_prefix;
+
+ /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
+ We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
+ while (TREE_CODE (gnu_expr) == NOP_EXPR)
+ gnu_expr = TREE_OPERAND (gnu_expr, 0);
+
+ gnu_prefix = remove_conversions (gnu_prefix);
+ prefix_unused = 1;
+ gnu_type = TREE_TYPE (gnu_prefix);
+
+ /* Replace an unconstrained array type with the type of the
+ underlying array. We can't do this with a call to
+ maybe_unconstrained_array since we may have a TYPE_DECL.
+ For 'Max_Size_In_Storage_Elements, use the record type
+ that will be used to allocate the object and its template. */
+
+ if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
+ {
+ gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
+ if (attribute != Attr_Max_Size_In_Storage_Elements)
+ gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
+ }
+
+ /* If we are looking for the size of a field, return the
+ field size. Otherwise, if the prefix is an object,
+ or if 'Object_Size or 'Max_Size_In_Storage_Elements has
+ been specified, the result is the GCC size of the type.
+ Otherwise, the result is the RM_Size of the type. */
+ if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
+ gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
+ else if (TREE_CODE (gnu_prefix) != TYPE_DECL
+ || attribute == Attr_Object_Size
+ || attribute == Attr_Max_Size_In_Storage_Elements)
+ {
+ /* If this is a padded type, the GCC size isn't relevant
+ to the programmer. Normally, what we want is the RM_Size,
+ which was set from the specified size, but if it was not
+ set, we want the size of the relevant field. Using the MAX
+ of those two produces the right result in all case. Don't
+ use the size of the field if it's a self-referential type,
+ since that's never what's wanted. */
+ if (TREE_CODE (gnu_type) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (gnu_type)
+ && TREE_CODE (gnu_expr) == COMPONENT_REF)
+ {
+ gnu_result = rm_size (gnu_type);
+ if (! (contains_placeholder_p
+ (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))))
+ gnu_result
+ = size_binop (MAX_EXPR, gnu_result,
+ DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
+ }
+ else
+ gnu_result = TYPE_SIZE (gnu_type);
+ }
+ else
+ gnu_result = rm_size (gnu_type);
+
+ if (gnu_result == 0)
+ gigi_abort (325);
+
+ /* Deal with a self-referential size by returning the maximum
+ size for a type and by qualifying the size with
+ the object for 'Size of an object. */
+
+ if (TREE_CODE (gnu_result) != INTEGER_CST
+ && contains_placeholder_p (gnu_result))
+ {
+ if (TREE_CODE (gnu_prefix) != TYPE_DECL)
+ gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
+ gnu_result, gnu_prefix);
+ else
+ gnu_result = max_size (gnu_result, 1);
+ }
+
+ /* If the type contains a template, subtract the size of the
+ template. */
+ if (TREE_CODE (gnu_type) == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
+ gnu_result = size_binop (MINUS_EXPR, gnu_result,
+ DECL_SIZE (TYPE_FIELDS (gnu_type)));
+
+ /* If the type contains a template, subtract the size of the
+ template. */
+ if (TREE_CODE (gnu_type) == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
+ gnu_result = size_binop (MINUS_EXPR, gnu_result,
+ DECL_SIZE (TYPE_FIELDS (gnu_type)));
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ /* Always perform division using unsigned arithmetic as the
+ size cannot be negative, but may be an overflowed positive
+ value. This provides correct results for sizes up to 512 MB.
+ ??? Size should be calculated in storage elements directly. */
+
+ if (attribute == Attr_Max_Size_In_Storage_Elements)
+ gnu_result = convert (sizetype,
+ fold (build (CEIL_DIV_EXPR, bitsizetype,
+ gnu_result,
+ bitsize_unit_node)));
+ break;
+
+ case Attr_Alignment:
+ if (TREE_CODE (gnu_prefix) == COMPONENT_REF
+ && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
+ == RECORD_TYPE)
+ && (TYPE_IS_PADDING_P
+ (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
+ gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
+
+ gnu_type = TREE_TYPE (gnu_prefix);
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ prefix_unused = 1;
+
+ if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
+ gnu_result
+ = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)));
+ else
+ gnu_result = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
+ break;
+
+ case Attr_First:
+ case Attr_Last:
+ case Attr_Range_Length:
+ prefix_unused = 1;
+
+ if (INTEGRAL_TYPE_P (gnu_type)
+ || TREE_CODE (gnu_type) == REAL_TYPE)
+ {
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ if (attribute == Attr_First)
+ gnu_result = TYPE_MIN_VALUE (gnu_type);
+ else if (attribute == Attr_Last)
+ gnu_result = TYPE_MAX_VALUE (gnu_type);
+ else
+ gnu_result
+ = build_binary_op
+ (MAX_EXPR, get_base_type (gnu_result_type),
+ build_binary_op
+ (PLUS_EXPR, get_base_type (gnu_result_type),
+ build_binary_op (MINUS_EXPR,
+ get_base_type (gnu_result_type),
+ convert (gnu_result_type,
+ TYPE_MAX_VALUE (gnu_type)),
+ convert (gnu_result_type,
+ TYPE_MIN_VALUE (gnu_type))),
+ convert (gnu_result_type, integer_one_node)),
+ convert (gnu_result_type, integer_zero_node));
+
+ break;
+ }
+ /* ... fall through ... */
+ case Attr_Length:
+ {
+ int Dimension
+ = (Present (Expressions (gnat_node))
+ ? UI_To_Int (Intval (First (Expressions (gnat_node))))
+ : 1);
+
+ /* Emit access check if necessary */
+ if (Do_Access_Check (gnat_node))
+ gnu_prefix = emit_access_check (gnu_prefix);
+
+ /* Make sure any implicit dereference gets done. */
+ gnu_prefix = maybe_implicit_deref (gnu_prefix);
+ gnu_prefix = maybe_unconstrained_array (gnu_prefix);
+ gnu_type = TREE_TYPE (gnu_prefix);
+ prefix_unused = 1;
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
+ {
+ int ndim;
+ tree gnu_type_temp;
+
+ for (ndim = 1, gnu_type_temp = gnu_type;
+ TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
+ ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
+ ;
+
+ Dimension = ndim + 1 - Dimension;
+ }
+
+ for (; Dimension > 1; Dimension--)
+ gnu_type = TREE_TYPE (gnu_type);
+
+ if (TREE_CODE (gnu_type) != ARRAY_TYPE)
+ gigi_abort (309);
+
+ if (attribute == Attr_First)
+ gnu_result
+ = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
+ else if (attribute == Attr_Last)
+ gnu_result
+ = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
+ else
+ /* 'Length or 'Range_Length. */
+ {
+ tree gnu_compute_type
+ = signed_or_unsigned_type
+ (0, get_base_type (gnu_result_type));
+
+ gnu_result
+ = build_binary_op
+ (MAX_EXPR, gnu_compute_type,
+ build_binary_op
+ (PLUS_EXPR, gnu_compute_type,
+ build_binary_op
+ (MINUS_EXPR, gnu_compute_type,
+ convert (gnu_compute_type,
+ TYPE_MAX_VALUE
+ (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))),
+ convert (gnu_compute_type,
+ TYPE_MIN_VALUE
+ (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))),
+ convert (gnu_compute_type, integer_one_node)),
+ convert (gnu_compute_type, integer_zero_node));
+ }
+
+ /* If this has a PLACEHOLDER_EXPR, qualify it by the object
+ we are handling. Note that these attributes could not
+ have been used on an unconstrained array type. */
+ if (TREE_CODE (gnu_result) != INTEGER_CST
+ && contains_placeholder_p (gnu_result))
+ gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
+ gnu_result, gnu_prefix);
+
+ break;
+ }
+
+ case Attr_Bit_Position:
+ case Attr_Position:
+ case Attr_First_Bit:
+ case Attr_Last_Bit:
+ case Attr_Bit:
+ {
+ HOST_WIDE_INT bitsize;
+ HOST_WIDE_INT bitpos;
+ tree gnu_offset;
+ tree gnu_field_bitpos;
+ tree gnu_field_offset;
+ tree gnu_inner;
+ enum machine_mode mode;
+ int unsignedp, volatilep;
+ unsigned int alignment;
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_prefix = remove_conversions (gnu_prefix);
+ prefix_unused = 1;
+
+ /* We can have 'Bit on any object, but if it isn't a
+ COMPONENT_REF, the result is zero. Do not allow
+ 'Bit on a bare component, though. */
+ if (attribute == Attr_Bit
+ && TREE_CODE (gnu_prefix) != COMPONENT_REF
+ && TREE_CODE (gnu_prefix) != FIELD_DECL)
+ {
+ gnu_result = integer_zero_node;
+ break;
+ }
+
+ else if (TREE_CODE (gnu_prefix) != COMPONENT_REF
+ && ! (attribute == Attr_Bit_Position
+ && TREE_CODE (gnu_prefix) == FIELD_DECL))
+ gigi_abort (310);
+
+ get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
+ &mode, &unsignedp, &volatilep, &alignment);
+
+
+ if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
+ {
+ gnu_field_bitpos
+ = bit_position (TREE_OPERAND (gnu_prefix, 1));
+ gnu_field_offset
+ = byte_position (TREE_OPERAND (gnu_prefix, 1));
+
+ for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
+ TREE_CODE (gnu_inner) == COMPONENT_REF
+ && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
+ gnu_inner = TREE_OPERAND (gnu_inner, 0))
+ {
+ gnu_field_bitpos
+ = size_binop (PLUS_EXPR, gnu_field_bitpos,
+ bit_position (TREE_OPERAND (gnu_inner,
+ 1)));
+ gnu_field_offset
+ = size_binop (PLUS_EXPR, gnu_field_offset,
+ byte_position (TREE_OPERAND (gnu_inner,
+ 1)));
+ }
+ }
+ else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
+ {
+ gnu_field_bitpos = bit_position (gnu_prefix);
+ gnu_field_offset = byte_position (gnu_prefix);
+ }
+ else
+ {
+ gnu_field_bitpos = bitsize_zero_node;
+ gnu_field_offset = size_zero_node;
+ }
+
+ switch (attribute)
+ {
+ case Attr_Position:
+ gnu_result = gnu_field_offset;
+ break;
+
+
+ case Attr_First_Bit:
+ case Attr_Bit:
+ gnu_result = size_int (bitpos % BITS_PER_UNIT);
+ break;
+
+
+ case Attr_Last_Bit:
+ gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
+ gnu_result
+ = size_binop (PLUS_EXPR, gnu_result,
+ TYPE_SIZE (TREE_TYPE (gnu_prefix)));
+ gnu_result = size_binop (MINUS_EXPR, gnu_result,
+ bitsize_one_node);
+ break;
+
+ case Attr_Bit_Position:
+ gnu_result = gnu_field_bitpos;
+ break;
+ }
+
+ /* If this has a PLACEHOLDER_EXPR, qualify it by the object
+ we are handling. */
+ if (TREE_CODE (gnu_result) != INTEGER_CST
+ && contains_placeholder_p (gnu_result))
+ gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
+ gnu_result, gnu_prefix);
+
+ break;
+ }
+
+ case Attr_Min:
+ case Attr_Max:
+ gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
+ gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result = build_binary_op (attribute == Attr_Min
+ ? MIN_EXPR : MAX_EXPR,
+ gnu_result_type, gnu_lhs, gnu_rhs);
+ break;
+
+ case Attr_Passed_By_Reference:
+ gnu_result = size_int (default_pass_by_ref (gnu_type)
+ || must_pass_by_ref (gnu_type));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ break;
+
+ case Attr_Component_Size:
+ if (TREE_CODE (gnu_prefix) == COMPONENT_REF
+ && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
+ == RECORD_TYPE)
+ && (TYPE_IS_PADDING_P
+ (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
+ gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
+
+ gnu_prefix = maybe_implicit_deref (gnu_prefix);
+ gnu_type = TREE_TYPE (gnu_prefix);
+
+ if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
+ gnu_type
+ = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
+
+ while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
+ gnu_type = TREE_TYPE (gnu_type);
+
+ if (TREE_CODE (gnu_type) != ARRAY_TYPE)
+ gigi_abort (330);
+
+ /* Note this size cannot be self-referential. */
+ gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ prefix_unused = 1;
+ break;
+
+ case Attr_Null_Parameter:
+ /* This is just a zero cast to the pointer type for
+ our prefix and dereferenced. */
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result
+ = build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert (build_pointer_type (gnu_result_type),
+ integer_zero_node));
+ TREE_PRIVATE (gnu_result) = 1;
+ break;
+
+ case Attr_Mechanism_Code:
+ {
+ int code;
+ Entity_Id gnat_obj = Entity (Prefix (gnat_node));
+
+ prefix_unused = 1;
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ if (Present (Expressions (gnat_node)))
+ {
+ int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
+
+ for (gnat_obj = First_Formal (gnat_obj); i > 1;
+ i--, gnat_obj = Next_Formal (gnat_obj))
+ ;
+ }
+
+ code = Mechanism (gnat_obj);
+ if (code == Default)
+ code = ((present_gnu_tree (gnat_obj)
+ && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
+ || (DECL_BY_COMPONENT_PTR_P
+ (get_gnu_tree (gnat_obj)))))
+ ? By_Reference : By_Copy);
+ gnu_result = convert (gnu_result_type, size_int (- code));
+ }
+ break;
+
+ default:
+ /* Say we have an unimplemented attribute. Then set the
+ value to be returned to be a zero and hope that's something
+ we can convert to the type of this attribute. */
+
+ post_error ("unimplemented attribute", gnat_node);
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result = integer_zero_node;
+ break;
+ }
+
+ /* If this is an attribute where the prefix was unused,
+ force a use of it if it has a side-effect. */
+ if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix))
+ gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result),
+ gnu_prefix, gnu_result));
+ }
+ break;
+
+ case N_Reference:
+ /* Like 'Access as far as we are concerned. */
+ gnu_result = gnat_to_gnu (Prefix (gnat_node));
+ gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ break;
+
+ case N_Aggregate:
+ case N_Extension_Aggregate:
+ {
+ tree gnu_aggr_type;
+
+ /* ??? It is wrong to evaluate the type now, but there doesn't
+ seem to be any other practical way of doing it. */
+
+ gnu_aggr_type = gnu_result_type
+ = get_unpadded_type (Etype (gnat_node));
+
+ if (TREE_CODE (gnu_result_type) == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
+ gnu_aggr_type
+ = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
+
+ if (Null_Record_Present (gnat_node))
+ gnu_result = build_constructor (gnu_aggr_type, NULL_TREE);
+
+ else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE)
+ gnu_result
+ = assoc_to_constructor (First (Component_Associations (gnat_node)),
+ gnu_aggr_type);
+ else if (TREE_CODE (gnu_aggr_type) == UNION_TYPE)
+ {
+ /* The first element is the discrimant, which we ignore. The
+ next is the field we're building. Convert the expression
+ to the type of the field and then to the union type. */
+ Node_Id gnat_assoc
+ = Next (First (Component_Associations (gnat_node)));
+ Entity_Id gnat_field = Entity (First (Choices (gnat_assoc)));
+ tree gnu_field_type
+ = TREE_TYPE (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0));
+
+ gnu_result = convert (gnu_field_type,
+ gnat_to_gnu (Expression (gnat_assoc)));
+ }
+ else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
+ gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
+ gnu_aggr_type,
+ Component_Type (Etype (gnat_node)));
+ else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
+ gnu_result
+ = build_binary_op
+ (COMPLEX_EXPR, gnu_aggr_type,
+ gnat_to_gnu (Expression (First
+ (Component_Associations (gnat_node)))),
+ gnat_to_gnu (Expression
+ (Next
+ (First (Component_Associations (gnat_node))))));
+ else
+ gigi_abort (312);
+
+ gnu_result = convert (gnu_result_type, gnu_result);
+ }
+ break;
+
+ case N_Null:
+ gnu_result = null_pointer_node;
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ break;
+
+ case N_Type_Conversion:
+ case N_Qualified_Expression:
+ /* Get the operand expression. */
+ gnu_result = gnat_to_gnu (Expression (gnat_node));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ gnu_result
+ = convert_with_check (Etype (gnat_node), gnu_result,
+ Do_Overflow_Check (gnat_node),
+ Do_Range_Check (Expression (gnat_node)),
+ Nkind (gnat_node) == N_Type_Conversion
+ && Float_Truncate (gnat_node));
+ break;
+
+ case N_Unchecked_Type_Conversion:
+ gnu_result = gnat_to_gnu (Expression (gnat_node));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ /* If the result is a pointer type, see if we are improperly
+ converting to a stricter alignment. */
+
+ if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
+ && IN (Ekind (Etype (gnat_node)), Access_Kind))
+ {
+ unsigned int align = known_alignment (gnu_result);
+ tree gnu_obj_type = TREE_TYPE (gnu_result_type);
+ unsigned int oalign
+ = TREE_CODE (gnu_obj_type) == FUNCTION_TYPE
+ ? FUNCTION_BOUNDARY : TYPE_ALIGN (gnu_obj_type);
+
+ if (align != 0 && align < oalign && ! TYPE_ALIGN_OK_P (gnu_obj_type))
+ post_error_ne_tree_2
+ ("?source alignment (^) < alignment of & (^)",
+ gnat_node, Designated_Type (Etype (gnat_node)),
+ size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
+ }
+
+ gnu_result = unchecked_convert (gnu_result_type, gnu_result);
+ break;
+
+ case N_In:
+ case N_Not_In:
+ {
+ tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
+ Node_Id gnat_range = Right_Opnd (gnat_node);
+ tree gnu_low;
+ tree gnu_high;
+
+ /* GNAT_RANGE is either an N_Range node or an identifier
+ denoting a subtype. */
+ if (Nkind (gnat_range) == N_Range)
+ {
+ gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
+ gnu_high = gnat_to_gnu (High_Bound (gnat_range));
+ }
+ else if (Nkind (gnat_range) == N_Identifier
+ || Nkind (gnat_range) == N_Expanded_Name)
+ {
+ tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
+
+ gnu_low = TYPE_MIN_VALUE (gnu_range_type);
+ gnu_high = TYPE_MAX_VALUE (gnu_range_type);
+ }
+ else
+ gigi_abort (313);
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ /* If LOW and HIGH are identical, perform an equality test.
+ Otherwise, ensure that GNU_OBJECT is only evaluated once
+ and perform a full range test. */
+ if (operand_equal_p (gnu_low, gnu_high, 0))
+ gnu_result = build_binary_op (EQ_EXPR, gnu_result_type,
+ gnu_object, gnu_low);
+ else
+ {
+ gnu_object = make_save_expr (gnu_object);
+ gnu_result
+ = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type,
+ build_binary_op (GE_EXPR, gnu_result_type,
+ gnu_object, gnu_low),
+ build_binary_op (LE_EXPR, gnu_result_type,
+ gnu_object, gnu_high));
+ }
+
+ if (Nkind (gnat_node) == N_Not_In)
+ gnu_result = invert_truthvalue (gnu_result);
+ }
+ break;
+
+ case N_Op_Divide:
+ gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
+ gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
+ ? RDIV_EXPR
+ : (Rounded_Result (gnat_node)
+ ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
+ gnu_result_type, gnu_lhs, gnu_rhs);
+ break;
+
+ case N_And_Then: case N_Or_Else:
+ {
+ enum tree_code code = gnu_codes[Nkind (gnat_node)];
+ tree gnu_rhs_side;
+
+ /* The elaboration of the RHS may generate code. If so,
+ we need to make sure it gets executed after the LHS. */
+ gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
+ clear_last_expr ();
+ gnu_rhs_side = expand_start_stmt_expr ();
+ gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
+ expand_end_stmt_expr (gnu_rhs_side);
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ if (RTL_EXPR_SEQUENCE (gnu_rhs_side) != 0)
+ gnu_rhs = build (COMPOUND_EXPR, gnu_result_type, gnu_rhs_side,
+ gnu_rhs);
+
+ gnu_result = build_binary_op (code, gnu_result_type, gnu_lhs, gnu_rhs);
+ }
+ break;
+
+ case N_Op_Or: case N_Op_And: case N_Op_Xor:
+ /* These can either be operations on booleans or on modular types.
+ Fall through for boolean types since that's the way GNU_CODES is
+ set up. */
+ if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
+ Modular_Integer_Kind))
+ {
+ enum tree_code code
+ = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR
+ : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR
+ : BIT_XOR_EXPR);
+
+ gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
+ gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result = build_binary_op (code, gnu_result_type,
+ gnu_lhs, gnu_rhs);
+ break;
+ }
+
+ /* ... fall through ... */
+
+ case N_Op_Eq: case N_Op_Ne: case N_Op_Lt:
+ case N_Op_Le: case N_Op_Gt: case N_Op_Ge:
+ case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply:
+ case N_Op_Mod: case N_Op_Rem:
+ case N_Op_Rotate_Left:
+ case N_Op_Rotate_Right:
+ case N_Op_Shift_Left:
+ case N_Op_Shift_Right:
+ case N_Op_Shift_Right_Arithmetic:
+ {
+ enum tree_code code = gnu_codes[Nkind (gnat_node)];
+ tree gnu_type;
+
+ gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
+ gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
+ gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ /* If this is a comparison operator, convert any references to
+ an unconstrained array value into a reference to the
+ actual array. */
+ if (TREE_CODE_CLASS (code) == '<')
+ {
+ gnu_lhs = maybe_unconstrained_array (gnu_lhs);
+ gnu_rhs = maybe_unconstrained_array (gnu_rhs);
+ }
+
+ /* If this is a shift whose count is not guaranteed to be correct,
+ we need to adjust the shift count. */
+ if (IN (Nkind (gnat_node), N_Op_Shift)
+ && ! Shift_Count_OK (gnat_node))
+ {
+ tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
+ tree gnu_max_shift
+ = convert (gnu_count_type, TYPE_SIZE (gnu_type));
+
+ if (Nkind (gnat_node) == N_Op_Rotate_Left
+ || Nkind (gnat_node) == N_Op_Rotate_Right)
+ gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
+ gnu_rhs, gnu_max_shift);
+ else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic)
+ gnu_rhs
+ = build_binary_op
+ (MIN_EXPR, gnu_count_type,
+ build_binary_op (MINUS_EXPR,
+ gnu_count_type,
+ gnu_max_shift,
+ convert (gnu_count_type,
+ integer_one_node)),
+ gnu_rhs);
+ }
+
+ /* For right shifts, the type says what kind of shift to do,
+ so we may need to choose a different type. */
+ if (Nkind (gnat_node) == N_Op_Shift_Right
+ && ! TREE_UNSIGNED (gnu_type))
+ gnu_type = unsigned_type (gnu_type);
+ else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
+ && TREE_UNSIGNED (gnu_type))
+ gnu_type = signed_type (gnu_type);
+
+ if (gnu_type != gnu_result_type)
+ {
+ gnu_lhs = convert (gnu_type, gnu_lhs);
+ gnu_rhs = convert (gnu_type, gnu_rhs);
+ }
+
+ gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
+
+ /* If this is a logical shift with the shift count not verified,
+ we must return zero if it is too large. We cannot compensate
+ above in this case. */
+ if ((Nkind (gnat_node) == N_Op_Shift_Left
+ || Nkind (gnat_node) == N_Op_Shift_Right)
+ && ! Shift_Count_OK (gnat_node))
+ gnu_result
+ = build_cond_expr
+ (gnu_type,
+ build_binary_op (GE_EXPR, integer_type_node,
+ gnu_rhs,
+ convert (TREE_TYPE (gnu_rhs),
+ TYPE_SIZE (gnu_type))),
+ convert (gnu_type, integer_zero_node),
+ gnu_result);
+ }
+ break;
+
+ case N_Conditional_Expression:
+ {
+ tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
+ tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
+ tree gnu_false
+ = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result = build_cond_expr (gnu_result_type,
+ truthvalue_conversion (gnu_cond),
+ gnu_true, gnu_false);
+ }
+ break;
+
+ case N_Op_Plus:
+ gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ break;
+
+ case N_Op_Not:
+ /* This case can apply to a boolean or a modular type.
+ Fall through for a boolean operand since GNU_CODES is set
+ up to handle this. */
+ if (IN (Ekind (Etype (gnat_node)), Modular_Integer_Kind))
+ {
+ gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
+ gnu_expr);
+ break;
+ }
+
+ /* ... fall through ... */
+
+ case N_Op_Minus: case N_Op_Abs:
+ gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
+
+ if (Ekind (Etype (gnat_node)) != E_Private_Type)
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ else
+ gnu_result_type = get_unpadded_type (Base_Type
+ (Full_View (Etype (gnat_node))));
+
+ gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
+ gnu_result_type, gnu_expr);
+ break;
+
+ case N_Allocator:
+ {
+ tree gnu_init = 0;
+ tree gnu_type;
+
+ gnat_temp = Expression (gnat_node);
+
+ /* The Expression operand can either be an N_Identifier or
+ Expanded_Name, which must represent a type, or a
+ N_Qualified_Expression, which contains both the object type and an
+ initial value for the object. */
+ if (Nkind (gnat_temp) == N_Identifier
+ || Nkind (gnat_temp) == N_Expanded_Name)
+ gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
+ else if (Nkind (gnat_temp) == N_Qualified_Expression)
+ {
+ Entity_Id gnat_desig_type
+ = Designated_Type (Underlying_Type (Etype (gnat_node)));
+
+ gnu_init = gnat_to_gnu (Expression (gnat_temp));
+
+ gnu_init = maybe_unconstrained_array (gnu_init);
+ if (Do_Range_Check (Expression (gnat_temp)))
+ gnu_init = emit_range_check (gnu_init, gnat_desig_type);
+
+ if (Is_Elementary_Type (gnat_desig_type)
+ || Is_Constrained (gnat_desig_type))
+ {
+ gnu_type = gnat_to_gnu_type (gnat_desig_type);
+ gnu_init = convert (gnu_type, gnu_init);
+ }
+ else
+ {
+ gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
+ if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
+ gnu_type = TREE_TYPE (gnu_init);
+
+ gnu_init = convert (gnu_type, gnu_init);
+ }
+ }
+ else
+ gigi_abort (315);
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ return build_allocator (gnu_type, gnu_init, gnu_result_type,
+ Procedure_To_Call (gnat_node),
+ Storage_Pool (gnat_node));
+ }
+ break;
+
+ /***************************/
+ /* Chapter 5: Statements: */
+ /***************************/
+
+ case N_Label:
+ if (! type_annotate_only)
+ {
+ tree gnu_label = gnat_to_gnu (Identifier (gnat_node));
+ Node_Id gnat_parent = Parent (gnat_node);
+
+ expand_label (gnu_label);
+
+ /* If this is the first label of an exception handler, we must
+ mark that any CALL_INSN can jump to it. */
+ if (Present (gnat_parent)
+ && Nkind (gnat_parent) == N_Exception_Handler
+ && First (Statements (gnat_parent)) == gnat_node)
+ nonlocal_goto_handler_labels
+ = gen_rtx_EXPR_LIST (VOIDmode, label_rtx (gnu_label),
+ nonlocal_goto_handler_labels);
+ }
+ break;
+
+ case N_Null_Statement:
+ break;
+
+ case N_Assignment_Statement:
+ if (type_annotate_only)
+ break;
+
+ /* Get the LHS and RHS of the statement and convert any reference to an
+ unconstrained array into a reference to the underlying array. */
+ gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
+ gnu_rhs
+ = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
+
+ /* If range check is needed, emit code to generate it */
+ if (Do_Range_Check (Expression (gnat_node)))
+ gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
+
+ set_lineno (gnat_node, 1);
+
+ /* If either side's type has a size that overflows, convert this
+ into raise of Storage_Error: execution shouldn't have gotten
+ here anyway. */
+ if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs))) == INTEGER_CST
+ && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs))))
+ || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST
+ && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs)))))
+ expand_expr_stmt (build_call_raise (raise_storage_error_decl));
+ else
+ expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
+ gnu_lhs, gnu_rhs));
+ break;
+
+ case N_If_Statement:
+ /* Start an IF statement giving the condition. */
+ gnu_expr = gnat_to_gnu (Condition (gnat_node));
+ set_lineno (gnat_node, 1);
+ expand_start_cond (gnu_expr, 0);
+
+ /* Generate code for the statements to be executed if the condition
+ is true. */
+
+ for (gnat_temp = First (Then_Statements (gnat_node));
+ Present (gnat_temp);
+ gnat_temp = Next (gnat_temp))
+ gnat_to_code (gnat_temp);
+
+ /* Generate each of the "else if" parts. */
+ if (Present (Elsif_Parts (gnat_node)))
+ {
+ for (gnat_temp = First (Elsif_Parts (gnat_node));
+ Present (gnat_temp);
+ gnat_temp = Next (gnat_temp))
+ {
+ Node_Id gnat_statement;
+
+ expand_start_else ();
+
+ /* Set up the line numbers for each condition we test. */
+ set_lineno (Condition (gnat_temp), 1);
+ expand_elseif (gnat_to_gnu (Condition (gnat_temp)));
+
+ for (gnat_statement = First (Then_Statements (gnat_temp));
+ Present (gnat_statement);
+ gnat_statement = Next (gnat_statement))
+ gnat_to_code (gnat_statement);
+ }
+ }
+
+ /* Finally, handle any statements in the "else" part. */
+ if (Present (Else_Statements (gnat_node)))
+ {
+ expand_start_else ();
+
+ for (gnat_temp = First (Else_Statements (gnat_node));
+ Present (gnat_temp);
+ gnat_temp = Next (gnat_temp))
+ gnat_to_code (gnat_temp);
+ }
+
+ expand_end_cond ();
+ break;
+
+ case N_Case_Statement:
+ {
+ Node_Id gnat_when;
+ Node_Id gnat_choice;
+ tree gnu_label;
+ Node_Id gnat_statement;
+
+ gnu_expr = gnat_to_gnu (Expression (gnat_node));
+ gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
+
+ set_lineno (gnat_node, 1);
+ expand_start_case (1, gnu_expr, TREE_TYPE (gnu_expr), "case");
+
+ for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
+ Present (gnat_when);
+ gnat_when = Next_Non_Pragma (gnat_when))
+ {
+ /* First compile all the different case choices for the current
+ WHEN alternative. */
+
+ for (gnat_choice = First (Discrete_Choices (gnat_when));
+ Present (gnat_choice); gnat_choice = Next (gnat_choice))
+ {
+ int error_code;
+
+ gnu_label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
+
+ set_lineno (gnat_choice, 1);
+ switch (Nkind (gnat_choice))
+ {
+ case N_Range:
+ /* Abort on all errors except range empty, which
+ means we ignore this alternative. */
+ error_code
+ = pushcase_range (gnat_to_gnu (Low_Bound (gnat_choice)),
+ gnat_to_gnu (High_Bound (gnat_choice)),
+ convert, gnu_label, 0);
+
+ if (error_code != 0 && error_code != 4)
+ gigi_abort (332);
+ break;
+
+ case N_Subtype_Indication:
+ error_code
+ = pushcase_range
+ (gnat_to_gnu (Low_Bound (Range_Expression
+ (Constraint (gnat_choice)))),
+ gnat_to_gnu (High_Bound (Range_Expression
+ (Constraint (gnat_choice)))),
+ convert, gnu_label, 0);
+
+ if (error_code != 0 && error_code != 4)
+ gigi_abort (332);
+ break;
+
+ case N_Identifier:
+ case N_Expanded_Name:
+ /* This represents either a subtype range or a static value
+ of some kind; Ekind says which. If a static value,
+ fall through to the next case. */
+ if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
+ {
+ tree type = get_unpadded_type (Entity (gnat_choice));
+
+ error_code
+ = pushcase_range (fold (TYPE_MIN_VALUE (type)),
+ fold (TYPE_MAX_VALUE (type)),
+ convert, gnu_label, 0);
+
+ if (error_code != 0 && error_code != 4)
+ gigi_abort (332);
+ break;
+ }
+ /* ... fall through ... */
+ case N_Character_Literal:
+ case N_Integer_Literal:
+ if (pushcase (gnat_to_gnu (gnat_choice), convert,
+ gnu_label, 0))
+ gigi_abort (332);
+ break;
+
+ case N_Others_Choice:
+ if (pushcase (NULL_TREE, convert, gnu_label, 0))
+ gigi_abort (332);
+ break;
+
+ default:
+ gigi_abort (316);
+ }
+ }
+
+ /* After compiling the choices attached to the WHEN compile the
+ body of statements that have to be executed, should the
+ "WHEN ... =>" be taken. */
+ for (gnat_statement = First (Statements (gnat_when));
+ Present (gnat_statement);
+ gnat_statement = Next (gnat_statement))
+ gnat_to_code (gnat_statement);
+
+ /* Communicate to GCC that we are done with the current WHEN,
+ i.e. insert a "break" statement. */
+ expand_exit_something ();
+ }
+
+ expand_end_case (gnu_expr);
+ }
+ break;
+
+ case N_Loop_Statement:
+ {
+ /* The loop variable in GCC form, if any. */
+ tree gnu_loop_var = NULL_TREE;
+ /* PREINCREMENT_EXPR or PREDECREMENT_EXPR. */
+ enum tree_code gnu_update = ERROR_MARK;
+ /* Used if this is a named loop for so EXIT can work. */
+ struct nesting *loop_id;
+ /* Condition to continue loop tested at top of loop. */
+ tree gnu_top_condition = integer_one_node;
+ /* Similar, but tested at bottom of loop. */
+ tree gnu_bottom_condition = integer_one_node;
+ Node_Id gnat_statement;
+ Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
+ Node_Id gnat_top_condition = Empty;
+ int enclosing_if_p = 0;
+
+ /* Set the condition that under which the loop should continue.
+ For "LOOP .... END LOOP;" the condition is always true. */
+ if (No (gnat_iter_scheme))
+ ;
+ /* The case "WHILE condition LOOP ..... END LOOP;" */
+ else if (Present (Condition (gnat_iter_scheme)))
+ gnat_top_condition = Condition (gnat_iter_scheme);
+ else
+ {
+ /* We have an iteration scheme. */
+ Node_Id gnat_loop_spec
+ = Loop_Parameter_Specification (gnat_iter_scheme);
+ Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
+ Entity_Id gnat_type = Etype (gnat_loop_var);
+ tree gnu_type = get_unpadded_type (gnat_type);
+ tree gnu_low = TYPE_MIN_VALUE (gnu_type);
+ tree gnu_high = TYPE_MAX_VALUE (gnu_type);
+ int reversep = Reverse_Present (gnat_loop_spec);
+ tree gnu_first = reversep ? gnu_high : gnu_low;
+ tree gnu_last = reversep ? gnu_low : gnu_high;
+ enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR;
+ tree gnu_base_type = get_base_type (gnu_type);
+ tree gnu_limit
+ = (reversep ? TYPE_MIN_VALUE (gnu_base_type)
+ : TYPE_MAX_VALUE (gnu_base_type));
+
+ /* We know the loop variable will not overflow if GNU_LAST is
+ a constant and is not equal to GNU_LIMIT. If it might
+ overflow, we have to move the limit test to the end of
+ the loop. In that case, we have to test for an
+ empty loop outside the loop. */
+ if (TREE_CODE (gnu_last) != INTEGER_CST
+ || TREE_CODE (gnu_limit) != INTEGER_CST
+ || tree_int_cst_equal (gnu_last, gnu_limit))
+ {
+ gnu_expr = build_binary_op (LE_EXPR, integer_type_node,
+ gnu_low, gnu_high);
+ set_lineno (gnat_loop_spec, 1);
+ expand_start_cond (gnu_expr, 0);
+ enclosing_if_p = 1;
+ }
+
+ /* Open a new nesting level that will surround the loop to declare
+ the loop index variable. */
+ pushlevel (0);
+ expand_start_bindings (0);
+
+ /* Declare the loop index and set it to its initial value. */
+ gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
+ if (DECL_BY_REF_P (gnu_loop_var))
+ gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE,
+ gnu_loop_var);
+
+ /* The loop variable might be a padded type, so use `convert' to
+ get a reference to the inner variable if so. */
+ gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
+
+ /* Set either the top or bottom exit condition as
+ appropriate depending on whether we know an overflow
+ cannot occur or not. */
+ if (enclosing_if_p)
+ gnu_bottom_condition
+ = build_binary_op (NE_EXPR, integer_type_node,
+ gnu_loop_var, gnu_last);
+ else
+ gnu_top_condition
+ = build_binary_op (end_code, integer_type_node,
+ gnu_loop_var, gnu_last);
+
+ gnu_update = reversep ? PREDECREMENT_EXPR : PREINCREMENT_EXPR;
+ }
+
+ set_lineno (gnat_node, 1);
+ if (gnu_loop_var)
+ loop_id = expand_start_loop_continue_elsewhere (1);
+ else
+ loop_id = expand_start_loop (1);
+
+ /* If the loop was named, have the name point to this loop. In this
+ case, the association is not a ..._DECL node; in fact, it isn't
+ a GCC tree node at all. Since this name is referenced inside
+ the loop, do it before we process the statements of the loop. */
+ if (Present (Identifier (gnat_node)))
+ {
+ tree gnu_loop_id = make_node (GNAT_LOOP_ID);
+
+ TREE_LOOP_ID (gnu_loop_id) = (rtx) loop_id;
+ save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_id, 1);
+ }
+
+ set_lineno (gnat_node, 1);
+
+ /* We must evaluate the condition after we've entered the
+ loop so that any expression actions get done in the right
+ place. */
+ if (Present (gnat_top_condition))
+ gnu_top_condition = gnat_to_gnu (gnat_top_condition);
+
+ expand_exit_loop_if_false (0, gnu_top_condition);
+
+ /* Make the loop body into its own block, so any allocated
+ storage will be released every iteration. This is needed
+ for stack allocation. */
+
+ pushlevel (0);
+ gnu_block_stack
+ = tree_cons (gnu_bottom_condition, NULL_TREE, gnu_block_stack);
+ expand_start_bindings (0);
+
+ for (gnat_statement = First (Statements (gnat_node));
+ Present (gnat_statement);
+ gnat_statement = Next (gnat_statement))
+ gnat_to_code (gnat_statement);
+
+ expand_end_bindings (getdecls (), kept_level_p (), 0);
+ poplevel (kept_level_p (), 1, 0);
+ gnu_block_stack = TREE_CHAIN (gnu_block_stack);
+
+ set_lineno (gnat_node, 1);
+ expand_exit_loop_if_false (0, gnu_bottom_condition);
+
+ if (gnu_loop_var)
+ {
+ expand_loop_continue_here ();
+ gnu_expr = build_binary_op (gnu_update, TREE_TYPE (gnu_loop_var),
+ gnu_loop_var,
+ convert (TREE_TYPE (gnu_loop_var),
+ integer_one_node));
+ set_lineno (gnat_iter_scheme, 1);
+ expand_expr_stmt (gnu_expr);
+ }
+
+ set_lineno (gnat_node, 1);
+ expand_end_loop ();
+
+ if (gnu_loop_var)
+ {
+ /* Close the nesting level that sourround the loop that was used to
+ declare the loop index variable. */
+ set_lineno (gnat_node, 1);
+ expand_end_bindings (getdecls (), 1, 0);
+ poplevel (1, 1, 0);
+ }
+
+ if (enclosing_if_p)
+ {
+ set_lineno (gnat_node, 1);
+ expand_end_cond ();
+ }
+ }
+ break;
+
+ case N_Block_Statement:
+ pushlevel (0);
+ gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
+ expand_start_bindings (0);
+ process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
+ gnat_to_code (Handled_Statement_Sequence (gnat_node));
+ expand_end_bindings (getdecls (), kept_level_p (), 0);
+ poplevel (kept_level_p (), 1, 0);
+ gnu_block_stack = TREE_CHAIN (gnu_block_stack);
+ if (Present (Identifier (gnat_node)))
+ mark_out_of_scope (Entity (Identifier (gnat_node)));
+ break;
+
+ case N_Exit_Statement:
+ {
+ /* Which loop to exit, NULL if the current loop. */
+ struct nesting *loop_id = 0;
+ /* The GCC version of the optional GNAT condition node attached to the
+ exit statement. Exit the loop if this is false. */
+ tree gnu_cond = integer_zero_node;
+
+ if (Present (Name (gnat_node)))
+ loop_id
+ = (struct nesting *)
+ TREE_LOOP_ID (get_gnu_tree (Entity (Name (gnat_node))));
+
+ if (Present (Condition (gnat_node)))
+ gnu_cond
+ = invert_truthvalue
+ (truthvalue_conversion (gnat_to_gnu (Condition (gnat_node))));
+
+ set_lineno (gnat_node, 1);
+ expand_exit_loop_if_false (loop_id, gnu_cond);
+ }
+ break;
+
+ case N_Return_Statement:
+ if (type_annotate_only)
+ break;
+
+ {
+ /* The gnu function type of the subprogram currently processed. */
+ tree gnu_subprog_type = TREE_TYPE (current_function_decl);
+ /* The return value from the subprogram. */
+ tree gnu_ret_val = 0;
+
+ /* If we are dealing with a "return;" from an Ada procedure with
+ parameters passed by copy in copy out, we need to return a record
+ containing the final values of these parameters. If the list
+ contains only one entry, return just that entry.
+
+ For a full description of the copy in copy out parameter mechanism,
+ see the part of the gnat_to_gnu_entity routine dealing with the
+ translation of subprograms.
+
+ But if we have a return label defined, convert this into
+ a branch to that label. */
+
+ if (TREE_VALUE (gnu_return_label_stack) != 0)
+ expand_goto (TREE_VALUE (gnu_return_label_stack));
+
+ else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
+ {
+ if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
+ gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
+ else
+ gnu_ret_val
+ = build_constructor (TREE_TYPE (gnu_subprog_type),
+ TYPE_CI_CO_LIST (gnu_subprog_type));
+ }
+
+ /* If the Ada subprogram is a function, we just need to return the
+ expression. If the subprogram returns an unconstrained
+ array, we have to allocate a new version of the result and
+ return it. If we return by reference, return a pointer. */
+
+ else if (Present (Expression (gnat_node)))
+ {
+ gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
+
+ /* Do not remove the padding from GNU_RET_VAL if the inner
+ type is self-referential since we want to allocate the fixed
+ size in that case. */
+ if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
+ && (TYPE_IS_PADDING_P
+ (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
+ && contains_placeholder_p
+ (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))
+ gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
+
+ if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
+ || By_Ref (gnat_node))
+ gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
+
+ else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
+ {
+ gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
+
+ /* We have two cases: either the function returns with
+ depressed stack or not. If not, we allocate on the
+ secondary stack. If so, we allocate in the stack frame.
+ if no copy is needed, the front end will set By_Ref,
+ which we handle in the case above. */
+ if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
+ gnu_ret_val
+ = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
+ TREE_TYPE (gnu_subprog_type), 0, -1);
+ else
+ gnu_ret_val
+ = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
+ TREE_TYPE (gnu_subprog_type),
+ Procedure_To_Call (gnat_node),
+ Storage_Pool (gnat_node));
+ }
+ }
+
+ set_lineno (gnat_node, 1);
+ if (gnu_ret_val)
+ expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE,
+ DECL_RESULT (current_function_decl),
+ gnu_ret_val));
+ else
+ expand_null_return ();
+
+ }
+ break;
+
+ case N_Goto_Statement:
+ if (type_annotate_only)
+ break;
+
+ gnu_expr = gnat_to_gnu (Name (gnat_node));
+ TREE_USED (gnu_expr) = 1;
+ set_lineno (gnat_node, 1);
+ expand_goto (gnu_expr);
+ break;
+
+ /****************************/
+ /* Chapter 6: Subprograms: */
+ /****************************/
+
+ case N_Subprogram_Declaration:
+ /* Unless there is a freeze node, declare the subprogram. We consider
+ this a "definition" even though we're not generating code for
+ the subprogram because we will be making the corresponding GCC
+ node here. */
+
+ if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
+ gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
+ NULL_TREE, 1);
+
+ break;
+
+ case N_Abstract_Subprogram_Declaration:
+ /* This subprogram doesn't exist for code generation purposes, but we
+ have to elaborate the types of any parameters, unless they are
+ imported types (nothing to generate in this case). */
+ for (gnat_temp
+ = First_Formal (Defining_Entity (Specification (gnat_node)));
+ Present (gnat_temp);
+ gnat_temp = Next_Formal_With_Extras (gnat_temp))
+ if (Is_Itype (Etype (gnat_temp))
+ && !From_With_Type (Etype (gnat_temp)))
+ gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
+
+ break;
+
+ case N_Defining_Program_Unit_Name:
+ /* For a child unit identifier go up a level to get the
+ specificaton. We get this when we try to find the spec of
+ a child unit package that is the compilation unit being compiled. */
+ gnat_to_code (Parent (gnat_node));
+ break;
+
+ case N_Subprogram_Body:
+ {
+ /* Save debug output mode in case it is reset. */
+ enum debug_info_type save_write_symbols = write_symbols;
+ struct gcc_debug_hooks *save_debug_hooks = debug_hooks;
+ /* Definining identifier of a parameter to the subprogram. */
+ Entity_Id gnat_param;
+ /* The defining identifier for the subprogram body. Note that if a
+ specification has appeared before for this body, then the identifier
+ occurring in that specification will also be a defining identifier
+ and all the calls to this subprogram will point to that
+ specification. */
+ Entity_Id gnat_subprog_id
+ = (Present (Corresponding_Spec (gnat_node))
+ ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
+
+ /* The FUNCTION_DECL node corresponding to the subprogram spec. */
+ tree gnu_subprog_decl;
+ /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
+ tree gnu_subprog_type;
+ tree gnu_cico_list;
+
+ /* If this is a generic object or if it has been eliminated,
+ ignore it. */
+
+ if (Ekind (gnat_subprog_id) == E_Generic_Procedure
+ || Ekind (gnat_subprog_id) == E_Generic_Function
+ || Is_Eliminated (gnat_subprog_id))
+ break;
+
+ /* If debug information is suppressed for the subprogram,
+ turn debug mode off for the duration of processing. */
+ if (Debug_Info_Off (gnat_subprog_id))
+ {
+ write_symbols = NO_DEBUG;
+ debug_hooks = &do_nothing_debug_hooks;
+ }
+
+ /* If this subprogram acts as its own spec, define it. Otherwise,
+ just get the already-elaborated tree node. However, if this
+ subprogram had its elaboration deferred, we will already have
+ made a tree node for it. So treat it as not being defined in
+ that case. Such a subprogram cannot have an address clause or
+ a freeze node, so this test is safe, though it does disable
+ some otherwise-useful error checking. */
+ gnu_subprog_decl
+ = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
+ Acts_As_Spec (gnat_node)
+ && ! present_gnu_tree (gnat_subprog_id));
+
+ gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
+
+ /* Set the line number in the decl to correspond to that of
+ the body so that the line number notes are written
+ correctly. */
+ set_lineno (gnat_node, 0);
+ DECL_SOURCE_FILE (gnu_subprog_decl) = input_filename;
+ DECL_SOURCE_LINE (gnu_subprog_decl) = lineno;
+
+ begin_subprog_body (gnu_subprog_decl);
+ set_lineno (gnat_node, 1);
+
+ pushlevel (0);
+ gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
+ expand_start_bindings (0);
+
+ gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
+
+ /* If there are OUT parameters, we need to ensure that the
+ return statement properly copies them out. We do this by
+ making a new block and converting any inner return into a goto
+ to a label at the end of the block. */
+
+ if (gnu_cico_list != 0)
+ {
+ gnu_return_label_stack
+ = tree_cons (NULL_TREE,
+ build_decl (LABEL_DECL, NULL_TREE, NULL_TREE),
+ gnu_return_label_stack);
+ pushlevel (0);
+ expand_start_bindings (0);
+ }
+ else
+ gnu_return_label_stack
+ = tree_cons (NULL_TREE, NULL_TREE, gnu_return_label_stack);
+
+ /* See if there are any parameters for which we don't yet have
+ GCC entities. These must be for OUT parameters for which we
+ will be making VAR_DECL nodes here. Fill them in to
+ TYPE_CI_CO_LIST, which must contain the empty entry as well.
+ We can match up the entries because TYPE_CI_CO_LIST is in the
+ order of the parameters. */
+
+ for (gnat_param = First_Formal (gnat_subprog_id);
+ Present (gnat_param);
+ gnat_param = Next_Formal_With_Extras (gnat_param))
+ if (present_gnu_tree (gnat_param))
+ adjust_decl_rtl (get_gnu_tree (gnat_param));
+ else
+ {
+ /* Skip any entries that have been already filled in; they
+ must correspond to IN OUT parameters. */
+ for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0;
+ gnu_cico_list = TREE_CHAIN (gnu_cico_list))
+ ;
+
+ /* Do any needed references for padded types. */
+ TREE_VALUE (gnu_cico_list)
+ = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
+ gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
+ }
+
+ process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
+
+ /* Generate the code of the subprogram itself. A return statement
+ will be present and any OUT parameters will be handled there. */
+ gnat_to_code (Handled_Statement_Sequence (gnat_node));
+
+ expand_end_bindings (getdecls (), kept_level_p (), 0);
+ poplevel (kept_level_p (), 1, 0);
+ gnu_block_stack = TREE_CHAIN (gnu_block_stack);
+
+ if (TREE_VALUE (gnu_return_label_stack) != 0)
+ {
+ tree gnu_retval;
+
+ expand_end_bindings (NULL_TREE, kept_level_p (), 0);
+ poplevel (kept_level_p (), 1, 0);
+ expand_label (TREE_VALUE (gnu_return_label_stack));
+
+ gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
+ set_lineno (gnat_node, 1);
+ if (list_length (gnu_cico_list) == 1)
+ gnu_retval = TREE_VALUE (gnu_cico_list);
+ else
+ gnu_retval = build_constructor (TREE_TYPE (gnu_subprog_type),
+ gnu_cico_list);
+
+ if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval))
+ gnu_retval
+ = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
+
+ expand_return
+ (build_binary_op (MODIFY_EXPR, NULL_TREE,
+ DECL_RESULT (current_function_decl),
+ gnu_retval));
+
+ }
+
+ gnu_return_label_stack = TREE_CHAIN (gnu_return_label_stack);
+
+ /* Disconnect the trees for parameters that we made variables for
+ from the GNAT entities since these will become unusable after
+ we end the function. */
+ for (gnat_param = First_Formal (gnat_subprog_id);
+ Present (gnat_param);
+ gnat_param = Next_Formal_With_Extras (gnat_param))
+ if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
+ save_gnu_tree (gnat_param, NULL_TREE, 0);
+
+ end_subprog_body ();
+ mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
+ write_symbols = save_write_symbols;
+ debug_hooks = save_debug_hooks;
+ }
+ break;
+
+ case N_Function_Call:
+ case N_Procedure_Call_Statement:
+
+ if (type_annotate_only)
+ break;
+
+ {
+ /* The GCC node corresponding to the GNAT subprogram name. This can
+ either be a FUNCTION_DECL node if we are dealing with a standard
+ subprogram call, or an indirect reference expression (an
+ INDIRECT_REF node) pointing to a subprogram. */
+ tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
+ /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
+ tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
+ tree gnu_subprog_addr
+ = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog_node);
+ Entity_Id gnat_formal;
+ Node_Id gnat_actual;
+ tree gnu_actual_list = NULL_TREE;
+ tree gnu_name_list = NULL_TREE;
+ tree gnu_after_list = NULL_TREE;
+ tree gnu_subprog_call;
+
+ switch (Nkind (Name (gnat_node)))
+ {
+ case N_Identifier:
+ case N_Operator_Symbol:
+ case N_Expanded_Name:
+ case N_Attribute_Reference:
+ if (Is_Eliminated (Entity (Name (gnat_node))))
+ post_error_ne ("cannot call eliminated subprogram &!",
+ gnat_node, Entity (Name (gnat_node)));
+ }
+
+ if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE)
+ gigi_abort (317);
+
+ /* If we are calling a stubbed function, make this into a
+ raise of Program_Error. Elaborate all our args first. */
+
+ if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
+ && DECL_STUBBED_P (gnu_subprog_node))
+ {
+ for (gnat_actual = First_Actual (gnat_node);
+ Present (gnat_actual);
+ gnat_actual = Next_Actual (gnat_actual))
+ expand_expr_stmt (gnat_to_gnu (gnat_actual));
+
+ if (Nkind (gnat_node) == N_Function_Call)
+ {
+ gnu_result_type = TREE_TYPE (gnu_subprog_type);
+ gnu_result
+ = build1 (NULL_EXPR, gnu_result_type,
+ build_call_raise (raise_program_error_decl));
+ }
+ else
+ expand_expr_stmt (build_call_raise (raise_program_error_decl));
+ break;
+ }
+
+ /* The only way we can be making a call via an access type is
+ if Name is an explicit dereference. In that case, get the
+ list of formal args from the type the access type is pointing
+ to. Otherwise, get the formals from entity being called. */
+ if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
+ gnat_formal = First_Formal (Etype (Name (gnat_node)));
+ else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
+ /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
+ gnat_formal = 0;
+ else
+ gnat_formal = First_Formal (Entity (Name (gnat_node)));
+
+ /* Create the list of the actual parameters as GCC expects it, namely
+ a chain of TREE_LIST nodes in which the TREE_VALUE field of each
+ node is a parameter-expression and the TREE_PURPOSE field is
+ null. Skip OUT parameters that are not passed by reference. */
+
+ for (gnat_actual = First_Actual (gnat_node);
+ Present (gnat_actual);
+ gnat_formal = Next_Formal_With_Extras (gnat_formal),
+ gnat_actual = Next_Actual (gnat_actual))
+ {
+ tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
+ Node_Id gnat_name
+ = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
+ ? Expression (gnat_actual) : gnat_actual);
+ tree gnu_name = gnat_to_gnu (gnat_name);
+ tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
+ tree gnu_actual;
+
+ /* If it's possible we may need to use this expression twice,
+ make sure than any side-effects are handled via SAVE_EXPRs.
+ Likewise if we need to force side-effects before the call.
+ ??? This is more conservative than we need since we don't
+ need to do this for pass-by-ref with no conversion.
+ If we are passing a non-addressable Out or In Out parameter by
+ reference, pass the address of a copy and set up to copy back
+ out after the call. */
+
+ if (Ekind (gnat_formal) != E_In_Parameter)
+ {
+ gnu_name = gnat_stabilize_reference (gnu_name, 1);
+ if (! addressable_p (gnu_name)
+ && present_gnu_tree (gnat_formal)
+ && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
+ || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
+ || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal))))
+ {
+ tree gnu_copy = gnu_name;
+
+ /* Remove any unpadding on the actual and make a copy.
+ But if the actual is a left-justified modular type,
+ first convert to it. */
+ if (TREE_CODE (gnu_name) == COMPONENT_REF
+ && (TYPE_IS_PADDING_P
+ (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))))
+ gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
+ else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
+ && (TYPE_LEFT_JUSTIFIED_MODULAR_P
+ (gnu_name_type)))
+ gnu_name = convert (gnu_name_type, gnu_name);
+
+ gnu_actual = save_expr (gnu_name);
+
+ /* Set up to move the copy back to the original. */
+ gnu_after_list = tree_cons (gnu_copy, gnu_actual,
+ gnu_after_list);
+
+ gnu_name = gnu_actual;
+ }
+ }
+
+ /* If this was a procedure call, we may not have removed any
+ padding. So do it here for the part we will use as an
+ input, if any. */
+ gnu_actual = gnu_name;
+ if (Ekind (gnat_formal) != E_Out_Parameter
+ && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
+ gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
+ gnu_actual);
+
+ if (Ekind (gnat_formal) != E_Out_Parameter
+ && Nkind (gnat_actual) != N_Unchecked_Type_Conversion
+ && Do_Range_Check (gnat_actual))
+ gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
+
+ /* Do any needed conversions. We need only check for
+ unchecked conversion since normal conversions will be handled
+ by just converting to the formal type. */
+ if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
+ {
+ gnu_actual
+ = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
+ gnu_actual);
+
+ /* One we've done the unchecked conversion, we still
+ must ensure that the object is in range of the formal's
+ type. */
+ if (Ekind (gnat_formal) != E_Out_Parameter
+ && Do_Range_Check (gnat_actual))
+ gnu_actual = emit_range_check (gnu_actual,
+ Etype (gnat_formal));
+ }
+ else
+ /* We may have suppressed a conversion to the Etype of the
+ actual since the parent is a procedure call. So add the
+ conversion here. */
+ gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
+ gnu_actual);
+
+ gnu_actual = convert (gnu_formal_type, gnu_actual);
+
+ /* If we have not saved a GCC object for the formal, it means
+ it is an OUT parameter not passed by reference. Otherwise,
+ look at the PARM_DECL to see if it is passed by reference. */
+ if (present_gnu_tree (gnat_formal)
+ && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
+ && DECL_BY_REF_P (get_gnu_tree (gnat_formal)))
+ {
+ if (Ekind (gnat_formal) != E_In_Parameter)
+ {
+ gnu_actual = gnu_name;
+
+ /* If we have a padded type, be sure we've removed the
+ padding. */
+ if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
+ gnu_actual
+ = convert (get_unpadded_type (Etype (gnat_actual)),
+ gnu_actual);
+ }
+
+ /* The symmetry of the paths to the type of an entity is
+ broken here since arguments don't know that they will
+ be passed by ref. */
+ gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
+ gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type,
+ gnu_actual);
+ }
+ else if (present_gnu_tree (gnat_formal)
+ && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
+ && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)))
+ {
+ gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
+ gnu_actual = maybe_implicit_deref (gnu_actual);
+ gnu_actual = maybe_unconstrained_array (gnu_actual);
+
+ if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (gnu_formal_type))
+ {
+ gnu_formal_type
+ = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
+ gnu_actual = convert (gnu_formal_type, gnu_actual);
+ }
+
+ /* Take the address of the object and convert to the
+ proper pointer type. We'd like to actually compute
+ the address of the beginning of the array using
+ an ADDR_EXPR of an ARRAY_REF, but there's a possibility
+ that the ARRAY_REF might return a constant and we'd
+ be getting the wrong address. Neither approach is
+ exactly correct, but this is the most likely to work
+ in all cases. */
+ gnu_actual = convert (gnu_formal_type,
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ gnu_actual));
+ }
+ else if (present_gnu_tree (gnat_formal)
+ && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
+ && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal)))
+ {
+ /* If arg is 'Null_Parameter, pass zero descriptor. */
+ if ((TREE_CODE (gnu_actual) == INDIRECT_REF
+ || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
+ && TREE_PRIVATE (gnu_actual))
+ gnu_actual
+ = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
+ integer_zero_node);
+ else
+ gnu_actual
+ = build_unary_op (ADDR_EXPR, NULL_TREE,
+ fill_vms_descriptor (gnu_actual,
+ gnat_formal));
+ }
+ else
+ {
+ tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
+
+ if (Ekind (gnat_formal) != E_In_Parameter)
+ gnu_name_list
+ = chainon (gnu_name_list,
+ build_tree_list (NULL_TREE, gnu_name));
+
+ if (! present_gnu_tree (gnat_formal)
+ || TREE_CODE (get_gnu_tree (gnat_formal)) != PARM_DECL)
+ continue;
+
+ /* If this is 'Null_Parameter, pass a zero even though we are
+ dereferencing it. */
+ else if (TREE_CODE (gnu_actual) == INDIRECT_REF
+ && TREE_PRIVATE (gnu_actual)
+ && host_integerp (gnu_actual_size, 1)
+ && 0 >= compare_tree_int (gnu_actual_size,
+ BITS_PER_WORD))
+ gnu_actual
+ = unchecked_convert
+ (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
+ convert (type_for_size
+ (tree_low_cst (gnu_actual_size, 1), 1),
+ integer_zero_node));
+ else
+ gnu_actual
+ = convert (TYPE_MAIN_VARIANT
+ (DECL_ARG_TYPE (get_gnu_tree (gnat_formal))),
+ gnu_actual);
+ }
+
+ gnu_actual_list
+ = chainon (gnu_actual_list,
+ build_tree_list (NULL_TREE, gnu_actual));
+ }
+
+ gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
+ gnu_subprog_addr, gnu_actual_list,
+ NULL_TREE);
+ TREE_SIDE_EFFECTS (gnu_subprog_call) = 1;
+
+ /* If it is a function call, the result is the call expression. */
+ if (Nkind (gnat_node) == N_Function_Call)
+ {
+ gnu_result = gnu_subprog_call;
+
+ /* If the function returns an unconstrained array or by reference,
+ we have to de-dereference the pointer. */
+ if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
+ || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
+ gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
+ gnu_result);
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ }
+
+ /* If this is the case where the GNAT tree contains a procedure call
+ but the Ada procedure has copy in copy out parameters, the special
+ parameter passing mechanism must be used. */
+ else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
+ {
+ /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
+ in copy out parameters. */
+ tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
+ int length = list_length (scalar_return_list);
+
+ if (length > 1)
+ {
+ tree gnu_name;
+
+ gnu_subprog_call = make_save_expr (gnu_subprog_call);
+
+ /* If any of the names had side-effects, ensure they are
+ all evaluated before the call. */
+ for (gnu_name = gnu_name_list; gnu_name;
+ gnu_name = TREE_CHAIN (gnu_name))
+ if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
+ gnu_subprog_call
+ = build (COMPOUND_EXPR, TREE_TYPE (gnu_subprog_call),
+ TREE_VALUE (gnu_name), gnu_subprog_call);
+ }
+
+ if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
+ gnat_formal = First_Formal (Etype (Name (gnat_node)));
+ else
+ gnat_formal = First_Formal (Entity (Name (gnat_node)));
+
+ for (gnat_actual = First_Actual (gnat_node);
+ Present (gnat_actual);
+ gnat_formal = Next_Formal_With_Extras (gnat_formal),
+ gnat_actual = Next_Actual (gnat_actual))
+ /* If we are dealing with a copy in copy out parameter, we must
+ retrieve its value from the record returned in the function
+ call. */
+ if (! (present_gnu_tree (gnat_formal)
+ && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
+ && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
+ || (DECL_BY_COMPONENT_PTR_P
+ (get_gnu_tree (gnat_formal)))
+ || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal))))
+ && Ekind (gnat_formal) != E_In_Parameter)
+ {
+ /* Get the value to assign to this OUT or IN OUT
+ parameter. It is either the result of the function if
+ there is only a single such parameter or the appropriate
+ field from the record returned. */
+ tree gnu_result
+ = length == 1 ? gnu_subprog_call
+ : build_component_ref
+ (gnu_subprog_call, NULL_TREE,
+ TREE_PURPOSE (scalar_return_list));
+ int unchecked_conversion
+ = Nkind (gnat_actual) == N_Unchecked_Type_Conversion;
+ /* If the actual is a conversion, get the inner expression,
+ which will be the real destination, and convert the
+ result to the type of the actual parameter. */
+ tree gnu_actual
+ = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
+
+ /* If the result is a padded type, remove the padding. */
+ if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
+ gnu_result
+ = convert (TREE_TYPE (TYPE_FIELDS
+ (TREE_TYPE (gnu_result))),
+ gnu_result);
+
+ /* If the result is a type conversion, do it. */
+ if (Nkind (gnat_actual) == N_Type_Conversion)
+ gnu_result
+ = convert_with_check
+ (Etype (Expression (gnat_actual)), gnu_result,
+ Do_Overflow_Check (gnat_actual),
+ Do_Range_Check (Expression (gnat_actual)),
+ Float_Truncate (gnat_actual));
+
+ else if (unchecked_conversion)
+ gnu_result
+ = unchecked_convert (TREE_TYPE (gnu_actual), gnu_result);
+ else
+ {
+ if (Do_Range_Check (gnat_actual))
+ gnu_result = emit_range_check (gnu_result,
+ Etype (gnat_actual));
+
+ if (! (! TREE_CONSTANT (TYPE_SIZE
+ (TREE_TYPE (gnu_actual)))
+ && TREE_CONSTANT (TYPE_SIZE
+ (TREE_TYPE (gnu_result)))))
+ gnu_result = convert (TREE_TYPE (gnu_actual),
+ gnu_result);
+ }
+
+ set_lineno (gnat_node, 1);
+ expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
+ gnu_actual, gnu_result));
+ scalar_return_list = TREE_CHAIN (scalar_return_list);
+ gnu_name_list = TREE_CHAIN (gnu_name_list);
+ }
+ }
+ else
+ {
+ set_lineno (gnat_node, 1);
+ expand_expr_stmt (gnu_subprog_call);
+ }
+
+ /* Handle anything we need to assign back. */
+ for (gnu_expr = gnu_after_list;
+ gnu_expr;
+ gnu_expr = TREE_CHAIN (gnu_expr))
+ expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
+ TREE_PURPOSE (gnu_expr),
+ TREE_VALUE (gnu_expr)));
+ }
+ break;
+
+ /*************************/
+ /* Chapter 7: Packages: */
+ /*************************/
+
+ case N_Package_Declaration:
+ gnat_to_code (Specification (gnat_node));
+ break;
+
+ case N_Package_Specification:
+
+ process_decls (Visible_Declarations (gnat_node),
+ Private_Declarations (gnat_node), Empty, 1, 1);
+ break;
+
+ case N_Package_Body:
+
+ /* If this is the body of a generic package - do nothing */
+ if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
+ break;
+
+ process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
+
+ if (Present (Handled_Statement_Sequence (gnat_node)))
+ {
+ gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
+ gnat_to_code (Handled_Statement_Sequence (gnat_node));
+ gnu_block_stack = TREE_CHAIN (gnu_block_stack);
+ }
+ break;
+
+ /*********************************/
+ /* Chapter 8: Visibility Rules: */
+ /*********************************/
+
+ case N_Use_Package_Clause:
+ case N_Use_Type_Clause:
+ /* Nothing to do here - but these may appear in list of declarations */
+ break;
+
+ /***********************/
+ /* Chapter 9: Tasks: */
+ /***********************/
+
+ case N_Protected_Type_Declaration:
+ break;
+
+ case N_Single_Task_Declaration:
+ gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
+ break;
+
+ /***********************************************************/
+ /* Chapter 10: Program Structure and Compilation Issues: */
+ /***********************************************************/
+
+ case N_Compilation_Unit:
+
+ /* For a body, first process the spec if there is one. */
+ if (Nkind (Unit (gnat_node)) == N_Package_Body
+ || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
+ && ! Acts_As_Spec (gnat_node)))
+ gnat_to_code (Library_Unit (gnat_node));
+
+ process_inlined_subprograms (gnat_node);
+
+ if (type_annotate_only && gnat_node == Cunit (Main_Unit))
+ {
+ elaborate_all_entities (gnat_node);
+
+ if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
+ || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
+ || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
+ break;
+ };
+
+ process_decls (Declarations (Aux_Decls_Node (gnat_node)),
+ Empty, Empty, 1, 1);
+
+ gnat_to_code (Unit (gnat_node));
+
+ /* Process any pragmas following the unit. */
+ if (Present (Pragmas_After (Aux_Decls_Node (gnat_node))))
+ for (gnat_temp = First (Pragmas_After (Aux_Decls_Node (gnat_node)));
+ gnat_temp; gnat_temp = Next (gnat_temp))
+ gnat_to_code (gnat_temp);
+
+ /* Put all the Actions into the elaboration routine if we already had
+ elaborations. This will happen anyway if they are statements, but we
+ want to force declarations there too due to order-of-elaboration
+ issues. Most should have Is_Statically_Allocated set. If we
+ have had no elaborations, we have no order-of-elaboration issue and
+ don't want to create elaborations here. */
+ if (Is_Non_Empty_List (Actions (Aux_Decls_Node (gnat_node))))
+ for (gnat_temp = First (Actions (Aux_Decls_Node (gnat_node)));
+ Present (gnat_temp); gnat_temp = Next (gnat_temp))
+ {
+ if (pending_elaborations_p ())
+ add_pending_elaborations (NULL_TREE,
+ make_transform_expr (gnat_temp));
+ else
+ gnat_to_code (gnat_temp);
+ }
+
+ /* Generate elaboration code for this unit, if necessary, and
+ say whether we did or not. */
+ Set_Has_No_Elaboration_Code
+ (gnat_node,
+ build_unit_elab
+ (Defining_Entity (Unit (gnat_node)),
+ Nkind (Unit (gnat_node)) == N_Package_Body
+ || Nkind (Unit (gnat_node)) == N_Subprogram_Body,
+ get_pending_elaborations ()));
+
+ break;
+
+ case N_Subprogram_Body_Stub:
+ case N_Package_Body_Stub:
+ case N_Protected_Body_Stub:
+ case N_Task_Body_Stub:
+ /* Simply process whatever unit is being inserted. */
+ gnat_to_code (Unit (Library_Unit (gnat_node)));
+ break;
+
+ case N_Subunit:
+ gnat_to_code (Proper_Body (gnat_node));
+ break;
+
+ /***************************/
+ /* Chapter 11: Exceptions: */
+ /***************************/
+
+ case N_Handled_Sequence_Of_Statements:
+ /* If there are exception handlers, start a new binding level that
+ we can exit (since each exception handler will do so). Then
+ declare a variable to save the old __gnat_jmpbuf value and a
+ variable for our jmpbuf. Call setjmp and handle each of the
+ possible exceptions if it returns one. */
+
+ if (! type_annotate_only && Present (Exception_Handlers (gnat_node)))
+ {
+ tree gnu_jmpsave_decl = 0;
+ tree gnu_jmpbuf_decl = 0;
+ tree gnu_cleanup_call = 0;
+ tree gnu_cleanup_decl;
+
+ pushlevel (0);
+ expand_start_bindings (1);
+
+ if (! Zero_Cost_Handling (gnat_node))
+ {
+ gnu_jmpsave_decl
+ = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
+ jmpbuf_ptr_type,
+ build_call_0_expr (get_jmpbuf_decl),
+ 0, 0, 0, 0, 0);
+
+ gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
+ NULL_TREE, jmpbuf_type,
+ NULL_TREE, 0, 0, 0, 0,
+ 0);
+ TREE_VALUE (gnu_block_stack) = gnu_jmpbuf_decl;
+ }
+
+ /* See if we are to call a function when exiting this block. */
+ if (Present (At_End_Proc (gnat_node)))
+ {
+ gnu_cleanup_call
+ = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node)));
+
+ gnu_cleanup_decl
+ = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE,
+ integer_type_node, NULL_TREE, 0, 0, 0, 0,
+ 0);
+
+ expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
+ }
+
+ if (! Zero_Cost_Handling (gnat_node))
+ {
+ /* When we exit this block, restore the saved value. */
+ expand_decl_cleanup (gnu_jmpsave_decl,
+ build_call_1_expr (set_jmpbuf_decl,
+ gnu_jmpsave_decl));
+
+ /* Call setjmp and handle exceptions if it returns one. */
+ set_lineno (gnat_node, 1);
+ expand_start_cond
+ (build_call_1_expr (setjmp_decl,
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ gnu_jmpbuf_decl)),
+ 0);
+
+ /* Restore our incoming longjmp value before we do anything. */
+ expand_expr_stmt (build_call_1_expr (set_jmpbuf_decl,
+ gnu_jmpsave_decl));
+
+ pushlevel (0);
+ expand_start_bindings (0);
+
+ gnu_except_ptr_stack
+ = tree_cons (NULL_TREE,
+ create_var_decl
+ (get_identifier ("EXCEPT_PTR"), NULL_TREE,
+ build_pointer_type (except_type_node),
+ build_call_0_expr (get_excptr_decl),
+ 0, 0, 0, 0, 0),
+ gnu_except_ptr_stack);
+
+ /* Generate code for each exception handler. The code at
+ N_Exception_Handler below does the real work. Note that
+ we ignore the dummy exception handler for the identifier
+ case, this is used only by the front end */
+ if (Present (Exception_Handlers (gnat_node)))
+ for (gnat_temp
+ = First_Non_Pragma (Exception_Handlers (gnat_node));
+ Present (gnat_temp);
+ gnat_temp = Next_Non_Pragma (gnat_temp))
+ gnat_to_code (gnat_temp);
+
+ /* If none of the exception handlers did anything, re-raise
+ but do not defer abortion. */
+ set_lineno (gnat_node, 1);
+ expand_expr_stmt
+ (build_call_1_expr (raise_nodefer_decl,
+ TREE_VALUE (gnu_except_ptr_stack)));
+
+ gnu_except_ptr_stack = TREE_CHAIN (gnu_except_ptr_stack);
+ expand_end_bindings (getdecls (), kept_level_p (), 0);
+ poplevel (kept_level_p (), 1, 0);
+
+ /* End the "if" on setjmp. Note that we have arranged things so
+ control never returns here. */
+ expand_end_cond ();
+
+ /* This is now immediately before the body proper. Set
+ our jmp_buf as the current buffer. */
+ expand_expr_stmt
+ (build_call_1_expr (set_jmpbuf_decl,
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ gnu_jmpbuf_decl)));
+ }
+ }
+
+ /* If there are no exception handlers, we must not have an at end
+ cleanup identifier, since the cleanup identifier should always
+ generate a corresponding exception handler. */
+ else if (! type_annotate_only && Present (At_End_Proc (gnat_node)))
+ gigi_abort (335);
+
+ /* Generate code and declarations for the prefix of this block,
+ if any. */
+ if (Present (First_Real_Statement (gnat_node)))
+ process_decls (Statements (gnat_node), Empty,
+ First_Real_Statement (gnat_node), 1, 1);
+
+ /* Generate code for each statement in the block. */
+ for (gnat_temp = (Present (First_Real_Statement (gnat_node))
+ ? First_Real_Statement (gnat_node)
+ : First (Statements (gnat_node)));
+ Present (gnat_temp); gnat_temp = Next (gnat_temp))
+ gnat_to_code (gnat_temp);
+
+ /* For zero-cost exceptions, exit the block and then compile
+ the handlers. */
+ if (! type_annotate_only && Zero_Cost_Handling (gnat_node)
+ && Present (Exception_Handlers (gnat_node)))
+ {
+ expand_exit_something ();
+ gnu_except_ptr_stack
+ = tree_cons (NULL_TREE, error_mark_node, gnu_except_ptr_stack);
+
+ for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
+ Present (gnat_temp);
+ gnat_temp = Next_Non_Pragma (gnat_temp))
+ gnat_to_code (gnat_temp);
+
+ gnu_except_ptr_stack = TREE_CHAIN (gnu_except_ptr_stack);
+ }
+
+ /* If we have handlers, close the block we made. */
+ if (! type_annotate_only && Present (Exception_Handlers (gnat_node)))
+ {
+ expand_end_bindings (getdecls (), kept_level_p (), 0);
+ poplevel (kept_level_p (), 1, 0);
+ }
+
+ break;
+
+ case N_Exception_Handler:
+ if (! Zero_Cost_Handling (gnat_node))
+ {
+ /* Unless this is "Others" or the special "Non-Ada" exception
+ for Ada, make an "if" statement to select the proper
+ exceptions. For "Others", exclude exceptions where
+ Handled_By_Others is nonzero unless the All_Others flag is set.
+ For "Non-ada", accept an exception if "Lang" is 'V'. */
+ tree gnu_choice = integer_zero_node;
+
+ for (gnat_temp = First (Exception_Choices (gnat_node));
+ gnat_temp; gnat_temp = Next (gnat_temp))
+ {
+ tree this_choice;
+
+ if (Nkind (gnat_temp) == N_Others_Choice)
+ {
+ if (All_Others (gnat_temp))
+ this_choice = integer_one_node;
+ else
+ this_choice
+ = build_binary_op
+ (EQ_EXPR, integer_type_node,
+ convert
+ (integer_type_node,
+ build_component_ref
+ (build_unary_op
+ (INDIRECT_REF, NULL_TREE,
+ TREE_VALUE (gnu_except_ptr_stack)),
+ get_identifier ("not_handled_by_others"), NULL_TREE)),
+ integer_zero_node);
+ }
+
+ else if (Nkind (gnat_temp) == N_Identifier
+ || Nkind (gnat_temp) == N_Expanded_Name)
+ {
+ /* ??? Note that we have to use gnat_to_gnu_entity here
+ since the type of the exception will be wrong in the
+ VMS case and that's exactly what this test is for. */
+ gnu_expr
+ = gnat_to_gnu_entity (Entity (gnat_temp), NULL_TREE, 0);
+
+ /* If this was a VMS exception, check import_code
+ against the value of the exception. */
+ if (TREE_CODE (TREE_TYPE (gnu_expr)) == INTEGER_TYPE)
+ this_choice
+ = build_binary_op
+ (EQ_EXPR, integer_type_node,
+ build_component_ref
+ (build_unary_op
+ (INDIRECT_REF, NULL_TREE,
+ TREE_VALUE (gnu_except_ptr_stack)),
+ get_identifier ("import_code"), NULL_TREE),
+ gnu_expr);
+ else
+ this_choice
+ = build_binary_op
+ (EQ_EXPR, integer_type_node,
+ TREE_VALUE (gnu_except_ptr_stack),
+ convert
+ (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
+ build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
+
+ /* If this is the distinguished exception "Non_Ada_Error"
+ (and we are in VMS mode), also allow a non-Ada
+ exception (a VMS condition) to match. */
+ if (Is_Non_Ada_Error (Entity (gnat_temp)))
+ {
+ tree gnu_comp
+ = build_component_ref
+ (build_unary_op
+ (INDIRECT_REF, NULL_TREE,
+ TREE_VALUE (gnu_except_ptr_stack)),
+ get_identifier ("lang"), NULL_TREE);
+
+ this_choice
+ = build_binary_op
+ (TRUTH_ORIF_EXPR, integer_type_node,
+ build_binary_op
+ (EQ_EXPR, integer_type_node, gnu_comp,
+ convert (TREE_TYPE (gnu_comp),
+ build_int_2 ('V', 0))),
+ this_choice);
+ }
+ }
+ else
+ gigi_abort (318);
+
+ gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
+ gnu_choice, this_choice);
+ }
+
+ set_lineno (gnat_node, 1);
+
+ expand_start_cond (gnu_choice, 0);
+ }
+
+ for (gnat_temp = First (Statements (gnat_node));
+ gnat_temp; gnat_temp = Next (gnat_temp))
+ gnat_to_code (gnat_temp);
+
+ /* At the end of the handler, exit the block. We made this block
+ in N_Handled_Sequence_Of_Statements. */
+ expand_exit_something ();
+
+ if (! Zero_Cost_Handling (gnat_node))
+ expand_end_cond ();
+
+ break;
+
+ /*******************************/
+ /* Chapter 12: Generic Units: */
+ /*******************************/
+
+ case N_Generic_Function_Renaming_Declaration:
+ case N_Generic_Package_Renaming_Declaration:
+ case N_Generic_Procedure_Renaming_Declaration:
+ case N_Generic_Package_Declaration:
+ case N_Generic_Subprogram_Declaration:
+ case N_Package_Instantiation:
+ case N_Procedure_Instantiation:
+ case N_Function_Instantiation:
+ /* These nodes can appear on a declaration list but there is nothing to
+ to be done with them. */
+ break;
+
+
+ /***************************************************/
+ /* Chapter 13: Representation Clauses and */
+ /* Implementation-Dependent Features: */
+ /***************************************************/
+
+ case N_Attribute_Definition_Clause:
+
+ /* The only one we need deal with is for 'Address. For the others, SEM
+ puts the information elsewhere. We need only deal with 'Address
+ if the object has a Freeze_Node (which it never will currently). */
+ if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
+ || No (Freeze_Node (Entity (Name (gnat_node)))))
+ break;
+
+ /* Get the value to use as the address and save it as the
+ equivalent for GNAT_TEMP. When the object is frozen,
+ gnat_to_gnu_entity will do the right thing. */
+ gnu_expr = gnat_to_gnu (Expression (gnat_node));
+ save_gnu_tree (Entity (Name (gnat_node)), gnu_expr, 1);
+ break;
+
+ case N_Enumeration_Representation_Clause:
+ case N_Record_Representation_Clause:
+ case N_At_Clause:
+ /* We do nothing with these. SEM puts the information elsewhere. */
+ break;
+
+ case N_Code_Statement:
+ if (! type_annotate_only)
+ {
+ tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
+ tree gnu_input_list = 0, gnu_output_list = 0, gnu_orig_out_list = 0;
+ tree gnu_clobber_list = 0;
+ char *clobber;
+
+ /* First process inputs, then outputs, then clobbers. */
+ Setup_Asm_Inputs (gnat_node);
+ while (Present (gnat_temp = Asm_Input_Value ()))
+ {
+ gnu_input_list = tree_cons (gnat_to_gnu
+ (Asm_Input_Constraint ()),
+ gnat_to_gnu (gnat_temp),
+ gnu_input_list);
+ Next_Asm_Input ();
+ }
+
+ Setup_Asm_Outputs (gnat_node);
+ while (Present (gnat_temp = Asm_Output_Variable ()))
+ {
+ tree gnu_value = gnat_to_gnu (gnat_temp);
+ tree gnu_constr = gnat_to_gnu (Asm_Output_Constraint ());
+
+ gnu_orig_out_list
+ = tree_cons (gnu_constr, gnu_value, gnu_orig_out_list);
+ gnu_output_list
+ = tree_cons (gnu_constr, gnu_value, gnu_output_list);
+ Next_Asm_Output ();
+ }
+
+ Clobber_Setup (gnat_node);
+ while ((clobber = Clobber_Get_Next ()) != 0)
+ gnu_clobber_list
+ = tree_cons (NULL_TREE,
+ build_string (strlen (clobber) + 1, clobber),
+ gnu_clobber_list);
+
+ expand_asm_operands (gnu_template, nreverse (gnu_output_list),
+ nreverse (gnu_input_list), gnu_clobber_list,
+ Is_Asm_Volatile (gnat_node),
+ input_filename, lineno);
+
+ /* Copy all the intermediate outputs into the specified outputs. */
+ for (; gnu_output_list;
+ (gnu_output_list = TREE_CHAIN (gnu_output_list),
+ gnu_orig_out_list = TREE_CHAIN (gnu_orig_out_list)))
+ if (TREE_VALUE (gnu_orig_out_list) != TREE_VALUE (gnu_output_list))
+ {
+ expand_expr_stmt
+ (build_binary_op (MODIFY_EXPR, NULL_TREE,
+ TREE_VALUE (gnu_orig_out_list),
+ TREE_VALUE (gnu_output_list)));
+ free_temp_slots ();
+ }
+ }
+ break;
+
+ /***************************************************/
+ /* Added Nodes */
+ /***************************************************/
+
+ case N_Freeze_Entity:
+ process_freeze_entity (gnat_node);
+ process_decls (Actions (gnat_node), Empty, Empty, 1, 1);
+ break;
+
+ case N_Itype_Reference:
+ if (! present_gnu_tree (Itype (gnat_node)))
+ process_type (Itype (gnat_node));
+ break;
+
+ case N_Free_Statement:
+ if (! type_annotate_only)
+ {
+ tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
+ tree gnu_obj_type;
+ tree gnu_obj_size;
+ int align;
+
+ /* If this is an unconstrained array, we know the object must
+ have been allocated with the template in front of the object.
+ So pass the template address, but get the total size. Do this
+ by converting to a thin pointer. */
+ if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
+ gnu_ptr
+ = convert (build_pointer_type
+ (TYPE_OBJECT_RECORD_TYPE
+ (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
+ gnu_ptr);
+
+ gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
+ gnu_obj_size = TYPE_SIZE_UNIT (gnu_obj_type);
+ align = TYPE_ALIGN (gnu_obj_type);
+
+ if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
+ {
+ tree gnu_char_ptr_type = build_pointer_type (char_type_node);
+ tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
+ tree gnu_byte_offset
+ = convert (gnu_char_ptr_type,
+ size_diffop (size_zero_node, gnu_pos));
+
+ gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
+ gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
+ gnu_ptr, gnu_byte_offset);
+ }
+
+ set_lineno (gnat_node, 1);
+ expand_expr_stmt
+ (build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
+ Procedure_To_Call (gnat_node),
+ Storage_Pool (gnat_node)));
+ }
+ break;
+
+ case N_Raise_Constraint_Error:
+ case N_Raise_Program_Error:
+ case N_Raise_Storage_Error:
+
+ if (type_annotate_only)
+ break;
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result
+ = build_call_raise
+ (Nkind (gnat_node) == N_Raise_Constraint_Error
+ ? raise_constraint_error_decl
+ : Nkind (gnat_node) == N_Raise_Program_Error
+ ? raise_program_error_decl : raise_storage_error_decl);
+
+ /* If the type is VOID, this is a statement, so we need to
+ generate the code for the call. Handle a Condition, if there
+ is one. */
+ if (TREE_CODE (gnu_result_type) == VOID_TYPE)
+ {
+ set_lineno (gnat_node, 1);
+
+ if (Present (Condition (gnat_node)))
+ expand_start_cond (gnat_to_gnu (Condition (gnat_node)), 0);
+
+ expand_expr_stmt (gnu_result);
+ if (Present (Condition (gnat_node)))
+ expand_end_cond ();
+ gnu_result = error_mark_node;
+ }
+ else
+ gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
+ break;
+
+ /* Nothing to do, since front end does all validation using the
+ values that Gigi back-annotates. */
+ case N_Validate_Unchecked_Conversion:
+ break;
+
+ case N_Raise_Statement:
+ case N_Function_Specification:
+ case N_Procedure_Specification:
+ case N_Op_Concat:
+ case N_Component_Association:
+ case N_Task_Body:
+ default:
+ if (! type_annotate_only)
+ gigi_abort (321);
+ }
+
+ /* If the result is a constant that overflows, raise constraint error. */
+ if (TREE_CODE (gnu_result) == INTEGER_CST
+ && TREE_CONSTANT_OVERFLOW (gnu_result))
+ {
+ post_error ("Constraint_Error will be raised at run-time?", gnat_node);
+
+ gnu_result
+ = build1 (NULL_EXPR, gnu_result_type,
+ build_call_raise (raise_constraint_error_decl));
+ }
+
+ /* If our result has side-effects and is of an unconstrained type,
+ make a SAVE_EXPR so that we can be sure it will only be referenced
+ once. Note we must do this before any conversions. */
+ if (TREE_SIDE_EFFECTS (gnu_result)
+ && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
+ || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
+ && contains_placeholder_p (TYPE_SIZE (gnu_result_type)))))
+ gnu_result = gnat_stabilize_reference (gnu_result, 0);
+
+ /* Now convert the result to the proper type. If the type is void or if
+ we have no result, return error_mark_node to show we have no result.
+ If the type of the result is correct or if we have a label (which doesn't
+ have any well-defined type), return our result. Also don't do the
+ conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
+ since those are the cases where the front end may have the type wrong due
+ to "instantiating" the unconstrained record with discriminant values
+ or if this is a FIELD_DECL. If this is the Name of an assignment
+ statement or a parameter of a procedure call, return what we have since
+ the RHS has to be converted to our type there in that case, unless
+ GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
+ record types with the same name, the expression type has integral mode,
+ and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when
+ we are converting from a packable type to its actual type and we need
+ those conversions to be NOPs in order for assignments into these types to
+ work properly if the inner object is a bitfield and hence can't have
+ its address taken. Finally, don't convert integral types that are the
+ operand of an unchecked conversion since we need to ignore those
+ conversions (for 'Valid). Otherwise, convert the result to the proper
+ type. */
+
+ if (Present (Parent (gnat_node))
+ && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
+ && Name (Parent (gnat_node)) == gnat_node)
+ || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
+ && Name (Parent (gnat_node)) != gnat_node)
+ || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
+ && ! AGGREGATE_TYPE_P (gnu_result_type)
+ && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
+ || Nkind (Parent (gnat_node)) == N_Parameter_Association)
+ && ! (TYPE_SIZE (gnu_result_type) != 0
+ && TYPE_SIZE (TREE_TYPE (gnu_result)) != 0
+ && (AGGREGATE_TYPE_P (gnu_result_type)
+ == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
+ && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
+ && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
+ != INTEGER_CST))
+ || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
+ && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
+ != INTEGER_CST)
+ && ! (contains_placeholder_p (TYPE_SIZE (gnu_result_type)))
+ && (contains_placeholder_p
+ (TYPE_SIZE (TREE_TYPE (gnu_result))))))
+ && ! (TREE_CODE (gnu_result_type) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type))))
+ {
+ /* In this case remove padding only if the inner object is of
+ self-referential size: in that case it must be an object of
+ unconstrained type with a default discriminant. In other cases,
+ we want to avoid copying too much data. */
+ if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
+ && contains_placeholder_p (TYPE_SIZE
+ (TREE_TYPE (TYPE_FIELDS
+ (TREE_TYPE (gnu_result))))))
+ gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
+ gnu_result);
+ }
+
+ else if (TREE_CODE (gnu_result) == LABEL_DECL
+ || TREE_CODE (gnu_result) == FIELD_DECL
+ || TREE_CODE (gnu_result) == ERROR_MARK
+ || (TYPE_SIZE (gnu_result_type) != 0
+ && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
+ && TREE_CODE (gnu_result) != INDIRECT_REF
+ && contains_placeholder_p (TYPE_SIZE (gnu_result_type)))
+ || ((TYPE_NAME (gnu_result_type)
+ == TYPE_NAME (TREE_TYPE (gnu_result)))
+ && TREE_CODE (gnu_result_type) == RECORD_TYPE
+ && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
+ && TYPE_MODE (gnu_result_type) == BLKmode
+ && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result)))
+ == MODE_INT)))
+ {
+ /* Remove any padding record, but do nothing more in this case. */
+ if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
+ gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
+ gnu_result);
+ }
+
+ else if (gnu_result == error_mark_node
+ || gnu_result_type == void_type_node)
+ gnu_result = error_mark_node;
+ else if (gnu_result_type != TREE_TYPE (gnu_result))
+ gnu_result = convert (gnu_result_type, gnu_result);
+
+ /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
+ while ((TREE_CODE (gnu_result) == NOP_EXPR
+ || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
+ && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
+ gnu_result = TREE_OPERAND (gnu_result, 0);
+
+ return gnu_result;
+}
+\f
+/* Force references to each of the entities in packages GNAT_NODE with's
+ so that the debugging information for all of them are identical
+ in all clients. Operate recursively on anything it with's, but check
+ that we aren't elaborating something more than once. */
+
+/* The reason for this routine's existence is two-fold.
+ First, with some debugging formats, notably MDEBUG on SGI
+ IRIX, the linker will remove duplicate debugging information if two
+ clients have identical debugguing information. With the normal scheme
+ of elaboration, this does not usually occur, since entities in with'ed
+ packages are elaborated on demand, and if clients have different usage
+ patterns, the normal case, then the order and selection of entities
+ will differ. In most cases however, it seems that linkers do not know
+ how to eliminate duplicate debugging information, even if it is
+ identical, so the use of this routine would increase the total amount
+ of debugging information in the final executable.
+
+ Second, this routine is called in type_annotate mode, to compute DDA
+ information for types in withed units, for ASIS use */
+
+static void
+elaborate_all_entities (gnat_node)
+ Node_Id gnat_node;
+{
+ Entity_Id gnat_with_clause, gnat_entity;
+
+ save_gnu_tree (gnat_node, integer_zero_node, 1);
+
+ /* Save entities in all context units. A body may have an implicit_with
+ on its own spec, if the context includes a child unit, so don't save
+ the spec twice. */
+
+ for (gnat_with_clause = First (Context_Items (gnat_node));
+ Present (gnat_with_clause);
+ gnat_with_clause = Next (gnat_with_clause))
+ if (Nkind (gnat_with_clause) == N_With_Clause
+ && ! present_gnu_tree (Library_Unit (gnat_with_clause))
+ && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
+ {
+ elaborate_all_entities (Library_Unit (gnat_with_clause));
+
+ if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
+ for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
+ Present (gnat_entity);
+ gnat_entity = Next_Entity (gnat_entity))
+ if (Is_Public (gnat_entity)
+ && Convention (gnat_entity) != Convention_Intrinsic
+ && Ekind (gnat_entity) != E_Package
+ && Ekind (gnat_entity) != E_Package_Body
+ && Ekind (gnat_entity) != E_Operator
+ && ! (IN (Ekind (gnat_entity), Type_Kind)
+ && ! Is_Frozen (gnat_entity))
+ && ! ((Ekind (gnat_entity) == E_Procedure
+ || Ekind (gnat_entity) == E_Function)
+ && Is_Intrinsic_Subprogram (gnat_entity))
+ && ! IN (Ekind (gnat_entity), Named_Kind)
+ && ! IN (Ekind (gnat_entity), Generic_Unit_Kind))
+ gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
+ }
+
+ if (Nkind (Unit (gnat_node)) == N_Package_Body && type_annotate_only)
+ elaborate_all_entities (Library_Unit (gnat_node));
+}
+\f
+/* Do the processing of N_Freeze_Entity, GNAT_NODE. */
+
+static void
+process_freeze_entity (gnat_node)
+ Node_Id gnat_node;
+{
+ Entity_Id gnat_entity = Entity (gnat_node);
+ tree gnu_old;
+ tree gnu_new;
+ tree gnu_init
+ = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
+ && present_gnu_tree (Declaration_Node (gnat_entity)))
+ ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
+
+ /* If this is a package, need to generate code for the package. */
+ if (Ekind (gnat_entity) == E_Package)
+ {
+ insert_code_for
+ (Parent (Corresponding_Body
+ (Parent (Declaration_Node (gnat_entity)))));
+ return;
+ }
+
+ /* Check for old definition after the above call. This Freeze_Node
+ might be for one its Itypes. */
+ gnu_old
+ = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
+
+ /* If this entity has an Address representation clause, GNU_OLD is the
+ address, so discard it here. */
+ if (Present (Address_Clause (gnat_entity)))
+ gnu_old = 0;
+
+ /* Don't do anything for class-wide types they are always
+ transformed into their root type. */
+ if (Ekind (gnat_entity) == E_Class_Wide_Type
+ || (Ekind (gnat_entity) == E_Class_Wide_Subtype
+ && Present (Equivalent_Type (gnat_entity))))
+ return;
+
+ /* If we have a non-dummy type old tree, we have nothing to do. Unless
+ this is the public view of a private type whose full view was not
+ delayed, this node was never delayed as it should have been.
+ Also allow this to happen for concurrent types since we may have
+ frozen both the Corresponding_Record_Type and this type. */
+ if (gnu_old != 0
+ && ! (TREE_CODE (gnu_old) == TYPE_DECL
+ && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
+ {
+ if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
+ && Present (Full_View (gnat_entity))
+ && No (Freeze_Node (Full_View (gnat_entity))))
+ return;
+ else if (Is_Concurrent_Type (gnat_entity))
+ return;
+ else
+ gigi_abort (320);
+ }
+
+ /* Reset the saved tree, if any, and elaborate the object or type for real.
+ If there is a full declaration, elaborate it and copy the type to
+ GNAT_ENTITY. Likewise if this is the record subtype corresponding to
+ a class wide type or subtype. */
+ if (gnu_old != 0)
+ {
+ save_gnu_tree (gnat_entity, NULL_TREE, 0);
+ if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
+ && Present (Full_View (gnat_entity))
+ && present_gnu_tree (Full_View (gnat_entity)))
+ save_gnu_tree (Full_View (gnat_entity), NULL_TREE, 0);
+ if (Present (Class_Wide_Type (gnat_entity))
+ && Class_Wide_Type (gnat_entity) != gnat_entity)
+ save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, 0);
+ }
+
+ if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
+ && Present (Full_View (gnat_entity)))
+ {
+ gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
+
+ /* The above call may have defined this entity (the simplest example
+ of this is when we have a private enumeral type since the bounds
+ will have the public view. */
+ if (! present_gnu_tree (gnat_entity))
+ save_gnu_tree (gnat_entity, gnu_new, 0);
+ if (Present (Class_Wide_Type (gnat_entity))
+ && Class_Wide_Type (gnat_entity) != gnat_entity)
+ save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, 0);
+ }
+ else
+ gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
+
+ /* If we've made any pointers to the old version of this type, we
+ have to update them. Also copy the name of the old object to
+ the new one. */
+
+ if (gnu_old != 0)
+ {
+ DECL_NAME (gnu_new) = DECL_NAME (gnu_old);
+ update_pointer_to (TREE_TYPE (gnu_old), TREE_TYPE (gnu_new));
+ }
+}
+\f
+/* Process the list of inlined subprograms of GNAT_NODE, which is an
+ N_Compilation_Unit. */
+
+static void
+process_inlined_subprograms (gnat_node)
+ Node_Id gnat_node;
+{
+ Entity_Id gnat_entity;
+ Node_Id gnat_body;
+
+ /* If we can inline, generate RTL for all the inlined subprograms.
+ Define the entity first so we set DECL_EXTERNAL. */
+ if (optimize > 0 && ! flag_no_inline)
+ for (gnat_entity = First_Inlined_Subprogram (gnat_node);
+ Present (gnat_entity);
+ gnat_entity = Next_Inlined_Subprogram (gnat_entity))
+ {
+ gnat_body = Parent (Declaration_Node (gnat_entity));
+
+ if (Nkind (gnat_body) != N_Subprogram_Body)
+ {
+ /* ??? This really should always be Present. */
+ if (No (Corresponding_Body (gnat_body)))
+ continue;
+
+ gnat_body
+ = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
+ }
+
+ if (Present (gnat_body))
+ {
+ gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
+ gnat_to_code (gnat_body);
+ }
+ }
+}
+\f
+/* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
+ We make two passes, one to elaborate anything other than bodies (but
+ we declare a function if there was no spec). The second pass
+ elaborates the bodies.
+
+ GNAT_END_LIST gives the element in the list past the end. Normally,
+ this is Empty, but can be First_Real_Statement for a
+ Handled_Sequence_Of_Statements.
+
+ We make a complete pass through both lists if PASS1P is true, then make
+ the second pass over both lists if PASS2P is true. The lists usually
+ correspond to the public and private parts of a package. */
+
+static void
+process_decls (gnat_decls, gnat_decls2, gnat_end_list, pass1p, pass2p)
+ List_Id gnat_decls, gnat_decls2;
+ Node_Id gnat_end_list;
+ int pass1p, pass2p;
+{
+ List_Id gnat_decl_array[2];
+ Node_Id gnat_decl;
+ int i;
+
+ gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
+
+ if (pass1p)
+ for (i = 0; i <= 1; i++)
+ if (Present (gnat_decl_array[i]))
+ for (gnat_decl = First (gnat_decl_array[i]);
+ gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
+ {
+ set_lineno (gnat_decl, 0);
+
+ /* For package specs, we recurse inside the declarations,
+ thus taking the two pass approach inside the boundary. */
+ if (Nkind (gnat_decl) == N_Package_Declaration
+ && (Nkind (Specification (gnat_decl)
+ == N_Package_Specification)))
+ process_decls (Visible_Declarations (Specification (gnat_decl)),
+ Private_Declarations (Specification (gnat_decl)),
+ Empty, 1, 0);
+
+ /* Similarly for any declarations in the actions of a
+ freeze node. */
+ else if (Nkind (gnat_decl) == N_Freeze_Entity)
+ {
+ process_freeze_entity (gnat_decl);
+ process_decls (Actions (gnat_decl), Empty, Empty, 1, 0);
+ }
+
+ /* Package bodies with freeze nodes get their elaboration deferred
+ until the freeze node, but the code must be placed in the right
+ place, so record the code position now. */
+ else if (Nkind (gnat_decl) == N_Package_Body
+ && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
+ record_code_position (gnat_decl);
+
+ else if (Nkind (gnat_decl) == N_Package_Body_Stub
+ && Present (Library_Unit (gnat_decl))
+ && Present (Freeze_Node
+ (Corresponding_Spec
+ (Proper_Body (Unit
+ (Library_Unit (gnat_decl)))))))
+ record_code_position
+ (Proper_Body (Unit (Library_Unit (gnat_decl))));
+
+ /* We defer most subprogram bodies to the second pass.
+ However, Init_Proc subprograms cannot be defered, but luckily
+ don't need to be. */
+ else if ((Nkind (gnat_decl) == N_Subprogram_Body
+ && (Chars (Defining_Entity (gnat_decl))
+ != Name_uInit_Proc)))
+ {
+ if (Acts_As_Spec (gnat_decl))
+ {
+ Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
+
+ if (Ekind (gnat_subprog_id) != E_Generic_Procedure
+ && Ekind (gnat_subprog_id) != E_Generic_Function)
+ gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
+ }
+ }
+ /* For bodies and stubs that act as their own specs, the entity
+ itself must be elaborated in the first pass, because it may
+ be used in other declarations. */
+ else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
+ {
+ Node_Id gnat_subprog_id =
+ Defining_Entity (Specification (gnat_decl));
+
+ if (Ekind (gnat_subprog_id) != E_Subprogram_Body
+ && Ekind (gnat_subprog_id) != E_Generic_Procedure
+ && Ekind (gnat_subprog_id) != E_Generic_Function)
+ gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
+ }
+
+ /* Concurrent stubs stand for the corresponding subprogram bodies,
+ which are deferred like other bodies. */
+ else if (Nkind (gnat_decl) == N_Task_Body_Stub
+ || Nkind (gnat_decl) == N_Protected_Body_Stub)
+ ;
+
+ else
+ gnat_to_code (gnat_decl);
+ }
+
+ /* Here we elaborate everything we deferred above except for package bodies,
+ which are elaborated at their freeze nodes. Note that we must also
+ go inside things (package specs and freeze nodes) the first pass did. */
+ if (pass2p)
+ for (i = 0; i <= 1; i++)
+ if (Present (gnat_decl_array[i]))
+ for (gnat_decl = First (gnat_decl_array[i]);
+ gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
+ {
+ if ((Nkind (gnat_decl) == N_Subprogram_Body
+ && (Chars (Defining_Entity (gnat_decl))
+ != Name_uInit_Proc))
+ || Nkind (gnat_decl) == N_Subprogram_Body_Stub
+ || Nkind (gnat_decl) == N_Task_Body_Stub
+ || Nkind (gnat_decl) == N_Protected_Body_Stub)
+ gnat_to_code (gnat_decl);
+
+ else if (Nkind (gnat_decl) == N_Package_Declaration
+ && (Nkind (Specification (gnat_decl)
+ == N_Package_Specification)))
+ process_decls (Visible_Declarations (Specification (gnat_decl)),
+ Private_Declarations (Specification (gnat_decl)),
+ Empty, 0, 1);
+
+ else if (Nkind (gnat_decl) == N_Freeze_Entity)
+ process_decls (Actions (gnat_decl), Empty, Empty, 0, 1);
+ }
+}
+\f
+/* Emits an access check. GNU_EXPR is the expression that needs to be
+ checked against the NULL pointer. */
+
+static tree
+emit_access_check (gnu_expr)
+ tree gnu_expr;
+{
+ tree gnu_type = TREE_TYPE (gnu_expr);
+
+ /* This only makes sense if GNU_TYPE is a pointer of some sort. */
+ if (! POINTER_TYPE_P (gnu_type) && ! TYPE_FAT_POINTER_P (gnu_type))
+ gigi_abort (322);
+
+ /* Checked expressions must be evaluated only once. */
+ gnu_expr = make_save_expr (gnu_expr);
+
+ return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
+ gnu_expr,
+ convert (TREE_TYPE (gnu_expr),
+ integer_zero_node)),
+ gnu_expr);
+}
+
+/* Emits a discriminant check. GNU_EXPR is the expression to be checked and
+ GNAT_NODE a N_Selected_Component node. */
+
+static tree
+emit_discriminant_check (gnu_expr, gnat_node)
+ tree gnu_expr;
+ Node_Id gnat_node;
+{
+ Entity_Id orig_comp
+ = Original_Record_Component (Entity (Selector_Name (gnat_node)));
+ Entity_Id gnat_discr_fct = Discriminant_Checking_Func (orig_comp);
+ tree gnu_discr_fct;
+ Entity_Id gnat_discr;
+ tree gnu_actual_list = NULL_TREE;
+ tree gnu_cond;
+ Entity_Id gnat_pref_type;
+ tree gnu_pref_type;
+
+ if (Is_Tagged_Type (Scope (orig_comp)))
+ gnat_pref_type = Scope (orig_comp);
+ else
+ gnat_pref_type = Etype (Prefix (gnat_node));
+
+ if (! Present (gnat_discr_fct))
+ return gnu_expr;
+
+ gnu_discr_fct = gnat_to_gnu (gnat_discr_fct);
+
+ /* Checked expressions must be evaluated only once. */
+ gnu_expr = make_save_expr (gnu_expr);
+
+ /* Create the list of the actual parameters as GCC expects it.
+ This list is the list of the discriminant fields of the
+ record expression to be discriminant checked. For documentation
+ on what is the GCC format for this list see under the
+ N_Function_Call case */
+
+ while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
+ || IN (Ekind (gnat_pref_type), Access_Kind))
+ {
+ if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
+ gnat_pref_type = Underlying_Type (gnat_pref_type);
+ else if (IN (Ekind (gnat_pref_type), Access_Kind))
+ gnat_pref_type = Designated_Type (gnat_pref_type);
+ }
+
+ gnu_pref_type
+ = TREE_TYPE (gnat_to_gnu_entity (gnat_pref_type, NULL_TREE, 0));
+
+ for (gnat_discr = First_Discriminant (gnat_pref_type);
+ Present (gnat_discr); gnat_discr = Next_Discriminant (gnat_discr))
+ {
+ Entity_Id gnat_real_discr
+ = ((Present (Corresponding_Discriminant (gnat_discr))
+ && Present (Parent_Subtype (gnat_pref_type)))
+ ? Corresponding_Discriminant (gnat_discr) : gnat_discr);
+ tree gnu_discr = gnat_to_gnu_entity (gnat_real_discr, NULL_TREE, 0);
+
+ gnu_actual_list
+ = chainon (gnu_actual_list,
+ build_tree_list (NULL_TREE,
+ build_component_ref
+ (convert (gnu_pref_type, gnu_expr),
+ NULL_TREE, gnu_discr)));
+ }
+
+ gnu_cond = build (CALL_EXPR,
+ TREE_TYPE (TREE_TYPE (gnu_discr_fct)),
+ build_unary_op (ADDR_EXPR, NULL_TREE, gnu_discr_fct),
+ gnu_actual_list,
+ NULL_TREE);
+ TREE_SIDE_EFFECTS (gnu_cond) = 1;
+
+ return
+ build_unary_op
+ (INDIRECT_REF, NULL_TREE,
+ emit_check (gnu_cond,
+ build_unary_op (ADDR_EXPR,
+ build_reference_type (TREE_TYPE (gnu_expr)),
+ gnu_expr)));
+}
+\f
+/* Emit code for a range check. GNU_EXPR is the expression to be checked,
+ GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
+ which we have to check. */
+
+static tree
+emit_range_check (gnu_expr, gnat_range_type)
+ tree gnu_expr;
+ Entity_Id gnat_range_type;
+{
+ tree gnu_range_type = get_unpadded_type (gnat_range_type);
+ tree gnu_low = TYPE_MIN_VALUE (gnu_range_type);
+ tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
+ tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
+
+ /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
+ we can't do anything since we might be truncating the bounds. No
+ check is needed in this case. */
+ if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
+ && (TYPE_PRECISION (gnu_compare_type)
+ < TYPE_PRECISION (get_base_type (gnu_range_type))))
+ return gnu_expr;
+
+ /* Checked expressions must be evaluated only once. */
+ gnu_expr = make_save_expr (gnu_expr);
+
+ /* There's no good type to use here, so we might as well use
+ integer_type_node. Note that the form of the check is
+ (not (expr >= lo)) or (not (expr >= hi))
+ the reason for this slightly convoluted form is that NaN's
+ are not considered to be in range in the float case. */
+ return emit_check
+ (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
+ invert_truthvalue
+ (build_binary_op (GE_EXPR, integer_type_node,
+ convert (gnu_compare_type, gnu_expr),
+ convert (gnu_compare_type, gnu_low))),
+ invert_truthvalue
+ (build_binary_op (LE_EXPR, integer_type_node,
+ convert (gnu_compare_type, gnu_expr),
+ convert (gnu_compare_type,
+ gnu_high)))),
+ gnu_expr);
+}
+\f
+/* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
+ which we are about to index, GNU_EXPR is the index expression to be
+ checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
+ against which GNU_EXPR has to be checked. Note that for index
+ checking we cannot use the emit_range_check function (although very
+ similar code needs to be generated in both cases) since for index
+ checking the array type against which we are checking the indeces
+ may be unconstrained and consequently we need to retrieve the
+ actual index bounds from the array object itself
+ (GNU_ARRAY_OBJECT). The place where we need to do that is in
+ subprograms having unconstrained array formal parameters */
+
+static tree
+emit_index_check (gnu_array_object, gnu_expr, gnu_low, gnu_high)
+ tree gnu_array_object;
+ tree gnu_expr;
+ tree gnu_low;
+ tree gnu_high;
+{
+ tree gnu_expr_check;
+
+ /* Checked expressions must be evaluated only once. */
+ gnu_expr = make_save_expr (gnu_expr);
+
+ /* Must do this computation in the base type in case the expression's
+ type is an unsigned subtypes. */
+ gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
+
+ /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
+ the object we are handling. */
+ if (TREE_CODE (gnu_low) != INTEGER_CST && contains_placeholder_p (gnu_low))
+ gnu_low = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_low),
+ gnu_low, gnu_array_object);
+
+ if (TREE_CODE (gnu_high) != INTEGER_CST && contains_placeholder_p (gnu_high))
+ gnu_high = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_high),
+ gnu_high, gnu_array_object);
+
+ /* There's no good type to use here, so we might as well use
+ integer_type_node. */
+ return emit_check
+ (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
+ build_binary_op (LT_EXPR, integer_type_node,
+ gnu_expr_check,
+ convert (TREE_TYPE (gnu_expr_check),
+ gnu_low)),
+ build_binary_op (GT_EXPR, integer_type_node,
+ gnu_expr_check,
+ convert (TREE_TYPE (gnu_expr_check),
+ gnu_high))),
+ gnu_expr);
+}
+\f
+/* Given GNU_COND which contains the condition corresponding to an access,
+ discriminant or range check, of value GNU_EXPR, build a COND_EXPR
+ that returns GNU_EXPR if GNU_COND is false and raises a
+ CONSTRAINT_ERROR if GNU_COND is true. */
+
+static tree
+emit_check (gnu_cond, gnu_expr)
+ tree gnu_cond;
+ tree gnu_expr;
+{
+ tree gnu_call;
+
+ gnu_call = build_call_raise (raise_constraint_error_decl);
+
+ /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will
+ get evaluated in front of the comparison in case it ends
+ up being a SAVE_EXPR. Put the whole thing inside its own
+ SAVE_EXPR do the inner SAVE_EXPR doesn't leak out. */
+
+ return make_save_expr (build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
+ fold (build (COND_EXPR, TREE_TYPE (gnu_expr),
+ gnu_cond,
+ build (COMPOUND_EXPR,
+ TREE_TYPE (gnu_expr),
+ gnu_call, gnu_expr),
+ gnu_expr))));
+}
+\f
+/* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
+ overflow checks if OVERFLOW_P is nonzero and range checks if
+ RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
+ If TRUNCATE_P is nonzero, do a float to integer conversion with
+ truncation; otherwise round. */
+
+static tree
+convert_with_check (gnat_type, gnu_expr, overflow_p, range_p, truncate_p)
+ Entity_Id gnat_type;
+ tree gnu_expr;
+ int overflow_p;
+ int range_p;
+ int truncate_p;
+{
+ tree gnu_type = get_unpadded_type (gnat_type);
+ tree gnu_in_type = TREE_TYPE (gnu_expr);
+ tree gnu_in_basetype = get_base_type (gnu_in_type);
+ tree gnu_base_type = get_base_type (gnu_type);
+ tree gnu_ada_base_type = get_ada_base_type (gnu_type);
+ tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
+ tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
+ tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
+ tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
+ tree gnu_result = gnu_expr;
+
+ /* If we are not doing any checks, the output is an integral type, and
+ the input is not a floating type, just do the conversion. This
+ shortcut is required to avoid problems with packed array types
+ and simplifies code in all cases anyway. */
+ if (! range_p && ! overflow_p && INTEGRAL_TYPE_P (gnu_base_type)
+ && ! FLOAT_TYPE_P (gnu_in_type))
+ return convert (gnu_type, gnu_expr);
+
+ /* First convert the expression to its base type. This
+ will never generate code, but makes the tests below much simpler.
+ But don't do this if converting from an integer type to an unconstrained
+ array type since then we need to get the bounds from the original
+ (unpacked) type. */
+ if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
+ gnu_result = convert (gnu_in_basetype, gnu_result);
+
+ /* If overflow checks are requested, we need to be sure the result will
+ fit in the output base type. But don't do this if the input
+ is integer and the output floating-point. */
+ if (overflow_p
+ && ! (FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
+ {
+ /* Ensure GNU_EXPR only gets evaluated once. */
+ tree gnu_input = make_save_expr (gnu_result);
+ tree gnu_cond = integer_zero_node;
+
+ /* Convert the lower bounds to signed types, so we're sure we're
+ comparing them properly. Likewise, convert the upper bounds
+ to unsigned types. */
+ if (INTEGRAL_TYPE_P (gnu_in_basetype) && TREE_UNSIGNED (gnu_in_basetype))
+ gnu_in_lb = convert (signed_type (gnu_in_basetype), gnu_in_lb);
+
+ if (INTEGRAL_TYPE_P (gnu_in_basetype)
+ && ! TREE_UNSIGNED (gnu_in_basetype))
+ gnu_in_ub = convert (unsigned_type (gnu_in_basetype), gnu_in_ub);
+
+ if (INTEGRAL_TYPE_P (gnu_base_type) && TREE_UNSIGNED (gnu_base_type))
+ gnu_out_lb = convert (signed_type (gnu_base_type), gnu_out_lb);
+
+ if (INTEGRAL_TYPE_P (gnu_base_type) && ! TREE_UNSIGNED (gnu_base_type))
+ gnu_out_ub = convert (unsigned_type (gnu_base_type), gnu_out_ub);
+
+ /* Check each bound separately and only if the result bound
+ is tighter than the bound on the input type. Note that all the
+ types are base types, so the bounds must be constant. Also,
+ the comparison is done in the base type of the input, which
+ always has the proper signedness. First check for input
+ integer (which means output integer), output float (which means
+ both float), or mixed, in which case we always compare.
+ Note that we have to do the comparison which would *fail* in the
+ case of an error since if it's an FP comparison and one of the
+ values is a NaN or Inf, the comparison will fail. */
+ if (INTEGRAL_TYPE_P (gnu_in_basetype)
+ ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
+ : (FLOAT_TYPE_P (gnu_base_type)
+ ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
+ TREE_REAL_CST (gnu_out_lb))
+ : 1))
+ gnu_cond
+ = invert_truthvalue
+ (build_binary_op (GE_EXPR, integer_type_node,
+ gnu_input, convert (gnu_in_basetype,
+ gnu_out_lb)));
+
+ if (INTEGRAL_TYPE_P (gnu_in_basetype)
+ ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
+ : (FLOAT_TYPE_P (gnu_base_type)
+ ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
+ TREE_REAL_CST (gnu_in_lb))
+ : 1))
+ gnu_cond
+ = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
+ invert_truthvalue
+ (build_binary_op (LE_EXPR, integer_type_node,
+ gnu_input,
+ convert (gnu_in_basetype,
+ gnu_out_ub))));
+
+ if (! integer_zerop (gnu_cond))
+ gnu_result = emit_check (gnu_cond, gnu_input);
+ }
+
+ /* Now convert to the result base type. If this is a non-truncating
+ float-to-integer conversion, round. */
+ if (INTEGRAL_TYPE_P (gnu_ada_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
+ && ! truncate_p)
+ {
+ tree gnu_point_5 = build_real (gnu_in_basetype, dconstp5);
+ tree gnu_minus_point_5 = build_real (gnu_in_basetype, dconstmp5);
+ tree gnu_zero = convert (gnu_in_basetype, integer_zero_node);
+ tree gnu_saved_result = save_expr (gnu_result);
+ tree gnu_comp = build (GE_EXPR, integer_type_node,
+ gnu_saved_result, gnu_zero);
+ tree gnu_adjust = build (COND_EXPR, gnu_in_basetype, gnu_comp,
+ gnu_point_5, gnu_minus_point_5);
+
+ gnu_result
+ = build (PLUS_EXPR, gnu_in_basetype, gnu_saved_result, gnu_adjust);
+ }
+
+ if (TREE_CODE (gnu_ada_base_type) == INTEGER_TYPE
+ && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type)
+ && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
+ gnu_result = unchecked_convert (gnu_ada_base_type, gnu_result);
+ else
+ gnu_result = convert (gnu_ada_base_type, gnu_result);
+
+ /* Finally, do the range check if requested. Note that if the
+ result type is a modular type, the range check is actually
+ an overflow check. */
+
+ if (range_p
+ || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
+ && TYPE_MODULAR_P (gnu_base_type) && overflow_p))
+ gnu_result = emit_range_check (gnu_result, gnat_type);
+
+ return convert (gnu_type, gnu_result);
+}
+\f
+/* Return 1 if GNU_EXPR can be directly addressed. This is the case unless
+ it is an expression involving computation or if it involves a bitfield
+ reference. This returns the same as mark_addressable in most cases. */
+
+static int
+addressable_p (gnu_expr)
+ tree gnu_expr;
+{
+ switch (TREE_CODE (gnu_expr))
+ {
+ case UNCONSTRAINED_ARRAY_REF:
+ case INDIRECT_REF:
+ case VAR_DECL:
+ case PARM_DECL:
+ case FUNCTION_DECL:
+ case RESULT_DECL:
+ case CONSTRUCTOR:
+ case NULL_EXPR:
+ return 1;
+
+ case COMPONENT_REF:
+ return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
+ && addressable_p (TREE_OPERAND (gnu_expr, 0)));
+
+ case ARRAY_REF: case ARRAY_RANGE_REF:
+ case REALPART_EXPR: case IMAGPART_EXPR:
+ case NOP_EXPR:
+ return addressable_p (TREE_OPERAND (gnu_expr, 0));
+
+ case CONVERT_EXPR:
+ return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
+ && addressable_p (TREE_OPERAND (gnu_expr, 0)));
+
+ case UNCHECKED_CONVERT_EXPR:
+ {
+ /* This is addressable if the code in gnat_expand_expr can do
+ it by either just taking the operand or by pointer punning. */
+ tree inner = TREE_OPERAND (gnu_expr, 0);
+ tree type = TREE_TYPE (gnu_expr);
+ tree inner_type = TREE_TYPE (inner);
+
+ return ((TYPE_MODE (type) == TYPE_MODE (inner_type)
+ && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
+ || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
+ || ((TYPE_MODE (type) == BLKmode
+ || TYPE_MODE (inner_type) == BLKmode)
+ && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
+ || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
+ || TYPE_ALIGN_OK_P (type)
+ || TYPE_ALIGN_OK_P (inner_type))));
+ }
+
+ default:
+ return 0;
+ }
+}
+\f
+/* Do the processing for the declaration of a GNAT_ENTITY, a type. If
+ a separate Freeze node exists, delay the bulk of the processing. Otherwise
+ make a GCC type for GNAT_ENTITY and set up the correspondance. */
+
+void
+process_type (gnat_entity)
+ Entity_Id gnat_entity;
+{
+ tree gnu_old
+ = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
+ tree gnu_new;
+
+ /* If we are to delay elaboration of this type, just do any
+ elaborations needed for expressions within the declaration and
+ make a dummy type entry for this node and its Full_View (if
+ any) in case something points to it. Don't do this if it
+ has already been done (the only way that can happen is if
+ the private completion is also delayed). */
+ if (Present (Freeze_Node (gnat_entity))
+ || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
+ && Present (Full_View (gnat_entity))
+ && Freeze_Node (Full_View (gnat_entity))
+ && ! present_gnu_tree (Full_View (gnat_entity))))
+ {
+ elaborate_entity (gnat_entity);
+
+ if (gnu_old == 0)
+ {
+ tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
+ make_dummy_type (gnat_entity),
+ 0, 0, 0);
+
+ save_gnu_tree (gnat_entity, gnu_decl, 0);
+ if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
+ && Present (Full_View (gnat_entity)))
+ save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0);
+ }
+
+ return;
+ }
+
+ /* If we saved away a dummy type for this node it means that this
+ made the type that corresponds to the full type of an incomplete
+ type. Clear that type for now and then update the type in the
+ pointers. */
+ if (gnu_old != 0)
+ {
+ if (TREE_CODE (gnu_old) != TYPE_DECL
+ || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))
+ {
+ /* If this was a withed access type, this is not an error
+ and merely indicates we've already elaborated the type
+ already. */
+ if (Is_Type (gnat_entity) && From_With_Type (gnat_entity))
+ return;
+
+ gigi_abort (323);
+ }
+
+ save_gnu_tree (gnat_entity, NULL_TREE, 0);
+ }
+
+ /* Now fully elaborate the type. */
+ gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
+ if (TREE_CODE (gnu_new) != TYPE_DECL)
+ gigi_abort (324);
+
+ /* If we have an old type and we've made pointers to this type,
+ update those pointers. */
+ if (gnu_old != 0)
+ update_pointer_to (TREE_TYPE (gnu_old), TREE_TYPE (gnu_new));
+
+ /* If this is a record type corresponding to a task or protected type
+ that is a completion of an incomplete type, perform a similar update
+ on the type. */
+ /* ??? Including protected types here is a guess. */
+
+ if (IN (Ekind (gnat_entity), Record_Kind)
+ && Is_Concurrent_Record_Type (gnat_entity)
+ && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
+ {
+ tree gnu_task_old
+ = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
+
+ save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
+ NULL_TREE, 0);
+ save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
+ gnu_new, 0);
+
+ update_pointer_to (TREE_TYPE (gnu_task_old), TREE_TYPE (gnu_new));
+ }
+}
+\f
+/* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
+ GNU_TYPE is the GCC type of the corresponding record.
+
+ Return a CONSTRUCTOR to build the record. */
+
+static tree
+assoc_to_constructor (gnat_assoc, gnu_type)
+ Node_Id gnat_assoc;
+ tree gnu_type;
+{
+ tree gnu_field, gnu_list, gnu_result;
+
+ /* We test for GNU_FIELD being empty in the case where a variant
+ was the last thing since we don't take things off GNAT_ASSOC in
+ that case. We check GNAT_ASSOC in case we have a variant, but it
+ has no fields. */
+
+ for (gnu_list = NULL_TREE; Present (gnat_assoc);
+ gnat_assoc = Next (gnat_assoc))
+ {
+ Node_Id gnat_field = First (Choices (gnat_assoc));
+ tree gnu_field = gnat_to_gnu_entity (Entity (gnat_field), NULL_TREE, 0);
+ tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
+
+ /* The expander is supposed to put a single component selector name
+ in every record component association */
+ if (Next (gnat_field))
+ gigi_abort (328);
+
+ /* Before assigning a value in an aggregate make sure range checks
+ are done if required. Then convert to the type of the field. */
+ if (Do_Range_Check (Expression (gnat_assoc)))
+ gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field));
+
+ gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
+
+ /* Add the field and expression to the list. */
+ gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
+ }
+
+ gnu_result = extract_values (gnu_list, gnu_type);
+
+ /* Verify every enty in GNU_LIST was used. */
+ for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
+ if (! TREE_ADDRESSABLE (gnu_field))
+ gigi_abort (311);
+
+ return gnu_result;
+}
+
+/* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
+ is the first element of an array aggregate. It may itself be an
+ aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
+ corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
+ of the array component. It is needed for range checking. */
+
+static tree
+pos_to_constructor (gnat_expr, gnu_array_type, gnat_component_type)
+ Node_Id gnat_expr;
+ tree gnu_array_type;
+ Entity_Id gnat_component_type;
+{
+ tree gnu_expr;
+ tree gnu_expr_list = NULL_TREE;
+
+ for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
+ {
+ /* If the expression is itself an array aggregate then first build the
+ innermost constructor if it is part of our array (multi-dimensional
+ case). */
+
+ if (Nkind (gnat_expr) == N_Aggregate
+ && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
+ gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
+ TREE_TYPE (gnu_array_type),
+ gnat_component_type);
+ else
+ {
+ gnu_expr = gnat_to_gnu (gnat_expr);
+
+ /* before assigning the element to the array make sure it is
+ in range */
+ if (Do_Range_Check (gnat_expr))
+ gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
+ }
+
+ gnu_expr_list
+ = tree_cons (NULL_TREE, convert (TREE_TYPE (gnu_array_type), gnu_expr),
+ gnu_expr_list);
+ }
+
+ return build_constructor (gnu_array_type, nreverse (gnu_expr_list));
+}
+\f
+/* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
+ some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
+ of the associations that are from RECORD_TYPE. If we see an internal
+ record, make a recursive call to fill it in as well. */
+
+static tree
+extract_values (values, record_type)
+ tree values;
+ tree record_type;
+{
+ tree result = NULL_TREE;
+ tree field, tem;
+
+ for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
+ {
+ tree value = 0;
+
+ /* _Parent is an internal field, but may have values in the aggregate,
+ so check for values first. */
+ if ((tem = purpose_member (field, values)) != 0)
+ {
+ value = TREE_VALUE (tem);
+ TREE_ADDRESSABLE (tem) = 1;
+ }
+
+ else if (DECL_INTERNAL_P (field))
+ {
+ value = extract_values (values, TREE_TYPE (field));
+ if (TREE_CODE (value) == CONSTRUCTOR
+ && CONSTRUCTOR_ELTS (value) == 0)
+ value = 0;
+ }
+ else
+ /* If we have a record subtype, the names will match, but not the
+ actual FIELD_DECLs. */
+ for (tem = values; tem; tem = TREE_CHAIN (tem))
+ if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
+ {
+ value = convert (TREE_TYPE (field), TREE_VALUE (tem));
+ TREE_ADDRESSABLE (tem) = 1;
+ }
+
+ if (value == 0)
+ continue;
+
+ result = tree_cons (field, value, result);
+ }
+
+ return build_constructor (record_type, nreverse (result));
+}
+\f
+/* EXP is to be treated as an array or record. Handle the cases when it is
+ an access object and perform the required dereferences. */
+
+static tree
+maybe_implicit_deref (exp)
+ tree exp;
+{
+ /* If the type is a pointer, dereference it. */
+
+ if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
+ exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
+
+ /* If we got a padded type, remove it too. */
+ if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
+ exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
+
+ return exp;
+}
+\f
+/* Surround EXP with a SAVE_EXPR, but handle unconstrained objects specially
+ since it doesn't make any sense to put them in a SAVE_EXPR. */
+
+tree
+make_save_expr (exp)
+ tree exp;
+{
+ tree type = TREE_TYPE (exp);
+
+ /* If this is an unchecked conversion, save the input since we may need to
+ handle this expression separately if it's the operand of a component
+ reference. */
+ if (TREE_CODE (exp) == UNCHECKED_CONVERT_EXPR)
+ return build1 (UNCHECKED_CONVERT_EXPR, type,
+ make_save_expr (TREE_OPERAND (exp, 0)));
+
+ /* If this is an aggregate type, we may be doing a dereference of it in
+ the LHS side of an assignment. In that case, we need to evaluate
+ it , take its address, make a SAVE_EXPR of that, then do the indirect
+ reference. Note that for an unconstrained array, the effect will be
+ to make a SAVE_EXPR of the fat pointer.
+
+ ??? This is an efficiency problem in the case of a type that can be
+ placed into memory, but until we can deal with the LHS issue,
+ we have to take that hit. This really should test for BLKmode. */
+ else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE
+ || (AGGREGATE_TYPE_P (type) && ! TYPE_FAT_POINTER_P (type)))
+ return
+ build_unary_op (INDIRECT_REF, type,
+ save_expr (build_unary_op (ADDR_EXPR,
+ build_reference_type (type),
+ exp)));
+
+ /* Otherwise, just do the usual thing. */
+ return save_expr (exp);
+}
+\f
+/* This is equivalent to stabilize_reference in GCC's tree.c, but we know
+ how to handle our new nodes and we take an extra argument that says
+ whether to force evaluation of everything. */
+
+tree
+gnat_stabilize_reference (ref, force)
+ tree ref;
+ int force;
+{
+ register tree type = TREE_TYPE (ref);
+ register enum tree_code code = TREE_CODE (ref);
+ register tree result;
+
+ switch (code)
+ {
+ case VAR_DECL:
+ case PARM_DECL:
+ case RESULT_DECL:
+ /* No action is needed in this case. */
+ return ref;
+
+ case NOP_EXPR:
+ case CONVERT_EXPR:
+ case FLOAT_EXPR:
+ case FIX_TRUNC_EXPR:
+ case FIX_FLOOR_EXPR:
+ case FIX_ROUND_EXPR:
+ case FIX_CEIL_EXPR:
+ case UNCHECKED_CONVERT_EXPR:
+ case ADDR_EXPR:
+ result
+ = build1 (code, type,
+ gnat_stabilize_reference (TREE_OPERAND (ref, 0), force));
+ break;
+
+ case INDIRECT_REF:
+ case UNCONSTRAINED_ARRAY_REF:
+ result = build1 (code, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
+ force));
+ break;
+
+ case COMPONENT_REF:
+ result = build (COMPONENT_REF, type,
+ gnat_stabilize_reference (TREE_OPERAND (ref, 0),
+ force),
+ TREE_OPERAND (ref, 1));
+ break;
+
+ case BIT_FIELD_REF:
+ result = build (BIT_FIELD_REF, type,
+ gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
+ force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
+ force));
+ break;
+
+ case ARRAY_REF:
+ result = build (ARRAY_REF, type,
+ gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
+ force));
+ break;
+
+ case ARRAY_RANGE_REF:
+ result = build (ARRAY_RANGE_REF, type,
+ gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
+ force));
+ break;
+
+ case COMPOUND_EXPR:
+ result = build (COMPOUND_EXPR, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
+ force),
+ gnat_stabilize_reference (TREE_OPERAND (ref, 1),
+ force));
+ break;
+
+ case RTL_EXPR:
+ result = build1 (INDIRECT_REF, type,
+ save_expr (build1 (ADDR_EXPR,
+ build_reference_type (type), ref)));
+ break;
+
+ /* If arg isn't a kind of lvalue we recognize, make no change.
+ Caller should recognize the error for an invalid lvalue. */
+ default:
+ return ref;
+
+ case ERROR_MARK:
+ return error_mark_node;
+ }
+
+ TREE_READONLY (result) = TREE_READONLY (ref);
+ return result;
+}
+
+/* Similar to stabilize_reference_1 in tree.c, but supports an extra
+ arg to force a SAVE_EXPR for everything. */
+
+static tree
+gnat_stabilize_reference_1 (e, force)
+ tree e;
+ int force;
+{
+ register enum tree_code code = TREE_CODE (e);
+ register tree type = TREE_TYPE (e);
+ register tree result;
+
+ /* We cannot ignore const expressions because it might be a reference
+ to a const array but whose index contains side-effects. But we can
+ ignore things that are actual constant or that already have been
+ handled by this function. */
+
+ if (TREE_CONSTANT (e) || code == SAVE_EXPR)
+ return e;
+
+ switch (TREE_CODE_CLASS (code))
+ {
+ case 'x':
+ case 't':
+ case 'd':
+ case 'b':
+ case '<':
+ case 's':
+ case 'e':
+ case 'r':
+ if (TREE_SIDE_EFFECTS (e) || force)
+ return save_expr (e);
+ return e;
+
+ case 'c':
+ /* Constants need no processing. In fact, we should never reach
+ here. */
+ return e;
+
+ case '2':
+ /* Division is slow and tends to be compiled with jumps,
+ especially the division by powers of 2 that is often
+ found inside of an array reference. So do it just once. */
+ if (code == TRUNC_DIV_EXPR || code == TRUNC_MOD_EXPR
+ || code == FLOOR_DIV_EXPR || code == FLOOR_MOD_EXPR
+ || code == CEIL_DIV_EXPR || code == CEIL_MOD_EXPR
+ || code == ROUND_DIV_EXPR || code == ROUND_MOD_EXPR)
+ return save_expr (e);
+ /* Recursively stabilize each operand. */
+ result = build (code, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
+ break;
+
+ case '1':
+ /* Recursively stabilize each operand. */
+ result = build1 (code, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
+ force));
+ break;
+
+ default:
+ abort ();
+ }
+
+ TREE_READONLY (result) = TREE_READONLY (e);
+ return result;
+}
+\f
+/* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
+ either a spec or a body, BODY_P says which. If needed, make a function
+ to be the elaboration routine for that object and perform the elaborations
+ in GNU_ELAB_LIST.
+
+ Return 1 if we didn't need an elaboration function, zero otherwise. */
+
+static int
+build_unit_elab (gnat_unit, body_p, gnu_elab_list)
+ Entity_Id gnat_unit;
+ int body_p;
+ tree gnu_elab_list;
+{
+ tree gnu_decl;
+ rtx insn;
+ int result = 1;
+
+ /* If we have nothing to do, return. */
+ if (gnu_elab_list == 0)
+ return 1;
+
+ /* Set our file and line number to that of the object and set up the
+ elaboration routine. */
+ gnu_decl = create_subprog_decl (create_concat_name (gnat_unit,
+ body_p ?
+ "elabb" : "elabs"),
+ NULL_TREE, void_ftype, NULL_TREE, 0, 1, 0,
+ 0);
+ DECL_ELABORATION_PROC_P (gnu_decl) = 1;
+
+ begin_subprog_body (gnu_decl);
+ set_lineno (gnat_unit, 1);
+ pushlevel (0);
+ gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
+ expand_start_bindings (0);
+
+ /* Emit the assignments for the elaborations we have to do. If there
+ is no destination, this is just a call to execute some statement
+ that was placed within the declarative region. But first save a
+ pointer so we can see if any insns were generated. */
+
+ insn = get_last_insn ();
+
+ for (; gnu_elab_list; gnu_elab_list = TREE_CHAIN (gnu_elab_list))
+ if (TREE_PURPOSE (gnu_elab_list) == NULL_TREE)
+ {
+ if (TREE_VALUE (gnu_elab_list) != 0)
+ expand_expr_stmt (TREE_VALUE (gnu_elab_list));
+ }
+ else
+ {
+ tree lhs = TREE_PURPOSE (gnu_elab_list);
+
+ input_filename = DECL_SOURCE_FILE (lhs);
+ lineno = DECL_SOURCE_LINE (lhs);
+
+ /* If LHS has a padded type, convert it to the unpadded type
+ so the assignment is done properly. */
+ if (TREE_CODE (TREE_TYPE (lhs)) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (lhs)))
+ lhs = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs))), lhs);
+
+ emit_line_note (input_filename, lineno);
+ expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
+ TREE_PURPOSE (gnu_elab_list),
+ TREE_VALUE (gnu_elab_list)));
+ }
+
+ /* See if any non-NOTE insns were generated. */
+ for (insn = NEXT_INSN (insn); insn; insn = NEXT_INSN (insn))
+ if (GET_RTX_CLASS (GET_CODE (insn)) == 'i')
+ {
+ result = 0;
+ break;
+ }
+
+ expand_end_bindings (getdecls (), kept_level_p (), 0);
+ poplevel (kept_level_p (), 1, 0);
+ gnu_block_stack = TREE_CHAIN (gnu_block_stack);
+ end_subprog_body ();
+
+ /* If there were no insns, we don't need an elab routine. It would
+ be nice to not output this one, but there's no good way to do that. */
+ return result;
+}
+\f
+extern char *__gnat_to_canonical_file_spec PARAMS ((char *));
+
+/* Determine the input_filename and the lineno from the source location
+ (Sloc) of GNAT_NODE node. Set the global variable input_filename and
+ lineno. If WRITE_NOTE_P is true, emit a line number note. */
+
+void
+set_lineno (gnat_node, write_note_p)
+ Node_Id gnat_node;
+ int write_note_p;
+{
+ Source_Ptr source_location = Sloc (gnat_node);
+
+ /* If node not from source code, ignore. */
+ if (source_location < 0)
+ return;
+
+ /* Use the identifier table to make a hashed, permanent copy of the filename,
+ since the name table gets reallocated after Gigi returns but before all
+ the debugging information is output. The call to
+ __gnat_to_canonical_file_spec translates filenames from pragmas
+ Source_Reference that contain host style syntax not understood by gdb. */
+ input_filename
+ = IDENTIFIER_POINTER
+ (get_identifier
+ (__gnat_to_canonical_file_spec
+ (Get_Name_String
+ (Debug_Source_Name (Get_Source_File_Index (source_location))))));
+
+ /* ref_filename is the reference file name as given by sinput (i.e no
+ directory) */
+ ref_filename
+ = IDENTIFIER_POINTER
+ (get_identifier
+ (Get_Name_String
+ (Reference_Name (Get_Source_File_Index (source_location)))));;
+ lineno = Get_Logical_Line_Number (source_location);
+
+ if (write_note_p)
+ emit_line_note (input_filename, lineno);
+}
+\f
+/* Post an error message. MSG is the error message, properly annotated.
+ NODE is the node at which to post the error and the node to use for the
+ "&" substitution. */
+
+void
+post_error (msg, node)
+ const char *msg;
+ Node_Id node;
+{
+ String_Template temp;
+ Fat_Pointer fp;
+
+ temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
+ fp.Array = msg, fp.Bounds = &temp;
+ if (Present (node))
+ Error_Msg_N (fp, node);
+}
+
+/* Similar, but NODE is the node at which to post the error and ENT
+ is the node to use for the "&" substitution. */
+
+void
+post_error_ne (msg, node, ent)
+ const char *msg;
+ Node_Id node;
+ Entity_Id ent;
+{
+ String_Template temp;
+ Fat_Pointer fp;
+
+ temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
+ fp.Array = msg, fp.Bounds = &temp;
+ if (Present (node))
+ Error_Msg_NE (fp, node, ent);
+}
+
+/* Similar, but NODE is the node at which to post the error, ENT is the node
+ to use for the "&" substitution, and N is the number to use for the ^. */
+
+void
+post_error_ne_num (msg, node, ent, n)
+ const char *msg;
+ Node_Id node;
+ Entity_Id ent;
+ int n;
+{
+ String_Template temp;
+ Fat_Pointer fp;
+
+ temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
+ fp.Array = msg, fp.Bounds = &temp;
+ Error_Msg_Uint_1 = UI_From_Int (n);
+
+ if (Present (node))
+ Error_Msg_NE (fp, node, ent);
+}
+\f
+/* Similar to post_error_ne_num, but T is a GCC tree representing the
+ number to write. If the tree represents a constant that fits within
+ a host integer, the text inside curly brackets in MSG will be output
+ (presumably including a '^'). Otherwise that text will not be output
+ and the text inside square brackets will be output instead. */
+
+void
+post_error_ne_tree (msg, node, ent, t)
+ const char *msg;
+ Node_Id node;
+ Entity_Id ent;
+ tree t;
+{
+ char *newmsg = alloca (strlen (msg) + 1);
+ String_Template temp = {1, 0};
+ Fat_Pointer fp;
+ char start_yes, end_yes, start_no, end_no;
+ const char *p;
+ char *q;
+
+ fp.Array = newmsg, fp.Bounds = &temp;
+
+ if (host_integerp (t, 1)
+#if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
+ && compare_tree_int (t, 1 << (HOST_BITS_PER_INT - 2)) < 0
+#endif
+ )
+ {
+ Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
+ start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
+ }
+ else
+ start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
+
+ for (p = msg, q = newmsg; *p != 0; p++)
+ {
+ if (*p == start_yes)
+ for (p++; *p != end_yes; p++)
+ *q++ = *p;
+ else if (*p == start_no)
+ for (p++; *p != end_no; p++)
+ ;
+ else
+ *q++ = *p;
+ }
+
+ *q = 0;
+
+ temp.High_Bound = strlen (newmsg);
+ if (Present (node))
+ Error_Msg_NE (fp, node, ent);
+}
+
+/* Similar to post_error_ne_tree, except that NUM is a second
+ integer to write in the message. */
+
+void
+post_error_ne_tree_2 (msg, node, ent, t, num)
+ const char *msg;
+ Node_Id node;
+ Entity_Id ent;
+ tree t;
+ int num;
+{
+ Error_Msg_Uint_2 = UI_From_Int (num);
+ post_error_ne_tree (msg, node, ent, t);
+}
+
+/* Set the node for a second '&' in the error message. */
+
+void
+set_second_error_entity (e)
+ Entity_Id e;
+{
+ Error_Msg_Node_2 = e;
+}
+\f
+/* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
+ as the relevant node that provides the location info for the error */
+
+void
+gigi_abort (code)
+ int code;
+{
+ String_Template temp = {1, 10};
+ Fat_Pointer fp;
+
+ fp.Array = "Gigi abort", fp.Bounds = &temp;
+
+ Current_Error_Node = error_gnat_node;
+ Compiler_Abort (fp, code);
+}
+\f
+/* Initialize the table that maps GNAT codes to GCC codes for simple
+ binary and unary operations. */
+
+void
+init_code_table ()
+{
+ gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
+ gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
+
+ gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
+ gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
+ gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
+ gnu_codes[N_Op_Eq] = EQ_EXPR;
+ gnu_codes[N_Op_Ne] = NE_EXPR;
+ gnu_codes[N_Op_Lt] = LT_EXPR;
+ gnu_codes[N_Op_Le] = LE_EXPR;
+ gnu_codes[N_Op_Gt] = GT_EXPR;
+ gnu_codes[N_Op_Ge] = GE_EXPR;
+ gnu_codes[N_Op_Add] = PLUS_EXPR;
+ gnu_codes[N_Op_Subtract] = MINUS_EXPR;
+ gnu_codes[N_Op_Multiply] = MULT_EXPR;
+ gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
+ gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
+ gnu_codes[N_Op_Minus] = NEGATE_EXPR;
+ gnu_codes[N_Op_Abs] = ABS_EXPR;
+ gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
+ gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
+ gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
+ gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
+ gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
+ gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
+}
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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.
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- T R E E P R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.128 $
+-- --
+-- 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 Csets; use Csets;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Output; use Output;
+with Sem_Mech; use Sem_Mech;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Sinput; use Sinput;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Treeprs; use Treeprs;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Uname; use Uname;
+with Unchecked_Deallocation;
+
+package body Treepr is
+
+ use Atree.Unchecked_Access;
+ -- This module uses the unchecked access functions in package Atree
+ -- since it does an untyped traversal of the tree (we do not want to
+ -- count on the structure of the tree being correct in this routine!)
+
+ ----------------------------------
+ -- Approach Used for Tree Print --
+ ----------------------------------
+
+ -- When a complete subtree is being printed, a trace phase first marks
+ -- the nodes and lists to be printed. This trace phase allocates logical
+ -- numbers corresponding to the order in which the nodes and lists will
+ -- be printed. The Node_Id, List_Id and Elist_Id values are mapped to
+ -- logical node numbers using a hash table. Output is done using a set
+ -- of Print_xxx routines, which are similar to the Write_xxx routines
+ -- with the same name, except that they do not generate any output in
+ -- the marking phase. This allows identical logic to be used in the
+ -- two phases.
+
+ -- Note that the hash table not only holds the serial numbers, but also
+ -- acts as a record of which nodes have already been visited. In the
+ -- marking phase, a node has been visited if it is already in the hash
+ -- table, and in the printing phase, we can tell whether a node has
+ -- already been printed by looking at the value of the serial number.
+
+ ----------------------
+ -- Global Variables --
+ ----------------------
+
+ type Hash_Record is record
+ Serial : Nat;
+ -- Serial number for hash table entry. A value of zero means that
+ -- the entry is currently unused.
+
+ Id : Int;
+ -- If serial number field is non-zero, contains corresponding Id value
+ end record;
+
+ type Hash_Table_Type is array (Nat range <>) of Hash_Record;
+ type Access_Hash_Table_Type is access Hash_Table_Type;
+ Hash_Table : Access_Hash_Table_Type;
+ -- The hash table itself, see Serial_Number function for details of use
+
+ Hash_Table_Len : Nat;
+ -- Range of Hash_Table is from 0 .. Hash_Table_Len - 1 so that dividing
+ -- by Hash_Table_Len gives a remainder that is in Hash_Table'Range.
+
+ Next_Serial_Number : Nat;
+ -- Number of last visited node or list. Used during the marking phase to
+ -- set proper node numbers in the hash table, and during the printing
+ -- phase to make sure that a given node is not printed more than once.
+ -- (nodes are printed in order during the printing phase, that's the
+ -- point of numbering them in the first place!)
+
+ Printing_Descendants : Boolean;
+ -- True if descendants are being printed, False if not. In the false case,
+ -- only node Id's are printed. In the true case, node numbers as well as
+ -- node Id's are printed, as described above.
+
+ type Phase_Type is (Marking, Printing);
+ -- Type for Phase variable
+
+ Phase : Phase_Type;
+ -- When an entire tree is being printed, the traversal operates in two
+ -- phases. The first phase marks the nodes in use by installing node
+ -- numbers in the node number table. The second phase prints the nodes.
+ -- This variable indicates the current phase.
+
+ ----------------------
+ -- Local Procedures --
+ ----------------------
+
+ procedure Print_End_Span (N : Node_Id);
+ -- Special routine to print contents of End_Span field of node N.
+ -- The format includes the implicit source location as well as the
+ -- value of the field.
+
+ procedure Print_Init;
+ -- Initialize for printing of tree with descendents
+
+ procedure Print_Term;
+ -- Clean up after printing of tree with descendents
+
+ procedure Print_Char (C : Character);
+ -- Print character C if currently in print phase, noop if in marking phase
+
+ procedure Print_Name (N : Name_Id);
+ -- Print name from names table if currently in print phase, noop if in
+ -- marking phase. Note that the name is output in mixed case mode.
+
+ procedure Print_Node_Kind (N : Node_Id);
+ -- Print node kind name in mixed case if in print phase, noop if in
+ -- marking phase.
+
+ procedure Print_Str (S : String);
+ -- Print string S if currently in print phase, noop if in marking phase
+
+ procedure Print_Str_Mixed_Case (S : String);
+ -- Like Print_Str, except that the string is printed in mixed case mode
+
+ procedure Print_Int (I : Int);
+ -- Print integer I if currently in print phase, noop if in marking phase
+
+ procedure Print_Eol;
+ -- Print end of line if currently in print phase, noop if in marking phase
+
+ procedure Print_Node_Ref (N : Node_Id);
+ -- Print "<empty>", "<error>" or "Node #nnn" with additional information
+ -- in the latter case, including the Id and the Nkind of the node.
+
+ procedure Print_List_Ref (L : List_Id);
+ -- Print "<no list>", or "<empty node list>" or "Node list #nnn"
+
+ procedure Print_Elist_Ref (E : Elist_Id);
+ -- Print "<no elist>", or "<empty element list>" or "Element list #nnn"
+
+ procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String);
+ -- Called if the node being printed is an entity. Prints fields from the
+ -- extension, using routines in Einfo to get the field names and flags.
+
+ procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto);
+ -- Print representation of Field value (name, tree, string, uint, charcode)
+ -- The format parameter controls the format of printing in the case of an
+ -- integer value (see UI_Write for details).
+
+ procedure Print_Flag (F : Boolean);
+ -- Print True or False
+
+ procedure Print_Node
+ (N : Node_Id;
+ Prefix_Str : String;
+ Prefix_Char : Character);
+ -- This is the internal routine used to print a single node. Each line of
+ -- output is preceded by Prefix_Str (which is used to set the indentation
+ -- level and the bars used to link list elements). In addition, for lines
+ -- other than the first, an additional character Prefix_Char is output.
+
+ function Serial_Number (Id : Int) return Nat;
+ -- Given a Node_Id, List_Id or Elist_Id, returns the previously assigned
+ -- serial number, or zero if no serial number has yet been assigned.
+
+ procedure Set_Serial_Number;
+ -- Can be called only immediately following a call to Serial_Number that
+ -- returned a value of zero. Causes the value of Next_Serial_Number to be
+ -- placed in the hash table (corresponding to the Id argument used in the
+ -- Serial_Number call), and increments Next_Serial_Number.
+
+ procedure Visit_Node
+ (N : Node_Id;
+ Prefix_Str : String;
+ Prefix_Char : Character);
+ -- Called to process a single node in the case where descendents are to
+ -- be printed before every line, and Prefix_Char added to all lines
+ -- except the header line for the node.
+
+ procedure Visit_List (L : List_Id; Prefix_Str : String);
+ -- Visit_List is called to process a list in the case where descendents
+ -- are to be printed. Prefix_Str is to be added to all printed lines.
+
+ procedure Visit_Elist (E : Elist_Id; Prefix_Str : String);
+ -- Visit_Elist is called to process an element list in the case where
+ -- descendents are to be printed. Prefix_Str is to be added to all
+ -- printed lines.
+
+ --------
+ -- PE --
+ --------
+
+ procedure PE (E : Elist_Id) is
+ begin
+ Print_Tree_Elist (E);
+ end PE;
+
+ --------
+ -- PL --
+ --------
+
+ procedure PL (L : List_Id) is
+ begin
+ Print_Tree_List (L);
+ end PL;
+
+ --------
+ -- PN --
+ --------
+
+ procedure PN (N : Node_Id) is
+ begin
+ Print_Tree_Node (N);
+ end PN;
+
+ ----------------
+ -- Print_Char --
+ ----------------
+
+ procedure Print_Char (C : Character) is
+ begin
+ if Phase = Printing then
+ Write_Char (C);
+ end if;
+ end Print_Char;
+
+ ---------------------
+ -- Print_Elist_Ref --
+ ---------------------
+
+ procedure Print_Elist_Ref (E : Elist_Id) is
+ begin
+ if Phase /= Printing then
+ return;
+ end if;
+
+ if E = No_Elist then
+ Write_Str ("<no elist>");
+
+ elsif Is_Empty_Elmt_List (E) then
+ Write_Str ("Empty elist, (Elist_Id=");
+ Write_Int (Int (E));
+ Write_Char (')');
+
+ else
+ Write_Str ("(Elist_Id=");
+ Write_Int (Int (E));
+ Write_Char (')');
+
+ if Printing_Descendants then
+ Write_Str (" #");
+ Write_Int (Serial_Number (Int (E)));
+ end if;
+ end if;
+ end Print_Elist_Ref;
+
+ -------------------------
+ -- Print_Elist_Subtree --
+ -------------------------
+
+ procedure Print_Elist_Subtree (E : Elist_Id) is
+ begin
+ Print_Init;
+
+ Next_Serial_Number := 1;
+ Phase := Marking;
+ Visit_Elist (E, "");
+
+ Next_Serial_Number := 1;
+ Phase := Printing;
+ Visit_Elist (E, "");
+
+ Print_Term;
+ end Print_Elist_Subtree;
+
+ --------------------
+ -- Print_End_Span --
+ --------------------
+
+ procedure Print_End_Span (N : Node_Id) is
+ Val : constant Uint := End_Span (N);
+
+ begin
+ UI_Write (Val);
+ Write_Str (" (Uint = ");
+ Write_Int (Int (Field5 (N)));
+ Write_Str (") ");
+
+ if Val /= No_Uint then
+ Write_Location (End_Location (N));
+ end if;
+ end Print_End_Span;
+
+ -----------------------
+ -- Print_Entity_Info --
+ -----------------------
+
+ procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String) is
+ function Field_Present (U : Union_Id) return Boolean;
+ -- Returns False unless the value U represents a missing value
+ -- (Empty, No_Uint, No_Ureal or No_String)
+
+ function Field_Present (U : Union_Id) return Boolean is
+ begin
+ return
+ U /= Union_Id (Empty) and then
+ U /= To_Union (No_Uint) and then
+ U /= To_Union (No_Ureal) and then
+ U /= Union_Id (No_String);
+ end Field_Present;
+
+ -- Start of processing for Print_Entity_Info
+
+ begin
+ Print_Str (Prefix);
+ Print_Str ("Ekind = ");
+ Print_Str_Mixed_Case (Entity_Kind'Image (Ekind (Ent)));
+ Print_Eol;
+
+ Print_Str (Prefix);
+ Print_Str ("Etype = ");
+ Print_Node_Ref (Etype (Ent));
+ Print_Eol;
+
+ if Convention (Ent) /= Convention_Ada then
+ Print_Str (Prefix);
+ Print_Str ("Convention = ");
+
+ -- Print convention name skipping the Convention_ at the start
+
+ declare
+ S : constant String := Convention_Id'Image (Convention (Ent));
+
+ begin
+ Print_Str_Mixed_Case (S (12 .. S'Last));
+ Print_Eol;
+ end;
+ end if;
+
+ if Field_Present (Field6 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field6_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field6 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field7 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field7_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field7 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field8 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field8_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field8 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field9 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field9_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field9 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field10 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field10_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field10 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field11 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field11_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field11 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field12 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field12_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field12 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field13 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field13_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field13 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field14 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field14_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field14 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field15 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field15_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field15 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field16 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field16_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field16 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field17 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field17_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field17 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field18 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field18_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field18 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field19 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field19_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field19 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field20 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field20_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field20 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field21 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field21_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field21 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field22 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field22_Name (Ent);
+ Write_Str (" = ");
+
+ -- Mechanism case has to be handled specially
+
+ if Ekind (Ent) = E_Function or else Is_Formal (Ent) then
+ declare
+ M : constant Mechanism_Type := Mechanism (Ent);
+
+ begin
+ case M is
+ when Default_Mechanism => Write_Str ("Default");
+ when By_Copy => Write_Str ("By_Copy");
+ when By_Reference => Write_Str ("By_Reference");
+ when By_Descriptor => Write_Str ("By_Descriptor");
+ when By_Descriptor_UBS => Write_Str ("By_Descriptor_UBS");
+ when By_Descriptor_UBSB => Write_Str ("By_Descriptor_UBSB");
+ when By_Descriptor_UBA => Write_Str ("By_Descriptor_UBA");
+ when By_Descriptor_S => Write_Str ("By_Descriptor_S");
+ when By_Descriptor_SB => Write_Str ("By_Descriptor_SB");
+ when By_Descriptor_A => Write_Str ("By_Descriptor_A");
+ when By_Descriptor_NCA => Write_Str ("By_Descriptor_NCA");
+
+ when 1 .. Mechanism_Type'Last =>
+ Write_Str ("By_Copy if size <= ");
+ Write_Int (Int (M));
+
+ end case;
+ end;
+
+ -- Normal case (not Mechanism)
+
+ else
+ Print_Field (Field22 (Ent));
+ end if;
+
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field23 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field23_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field23 (Ent));
+ Print_Eol;
+ end if;
+
+ Write_Entity_Flags (Ent, Prefix);
+
+ end Print_Entity_Info;
+
+ ---------------
+ -- Print_Eol --
+ ---------------
+
+ procedure Print_Eol is
+ begin
+ if Phase = Printing then
+ Write_Eol;
+ end if;
+ end Print_Eol;
+
+ -----------------
+ -- Print_Field --
+ -----------------
+
+ procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto) is
+ begin
+ if Phase /= Printing then
+ return;
+ end if;
+
+ if Val in Node_Range then
+ Print_Node_Ref (Node_Id (Val));
+
+ elsif Val in List_Range then
+ Print_List_Ref (List_Id (Val));
+
+ elsif Val in Elist_Range then
+ Print_Elist_Ref (Elist_Id (Val));
+
+ elsif Val in Names_Range then
+ Print_Name (Name_Id (Val));
+ Write_Str (" (Name_Id=");
+ Write_Int (Int (Val));
+ Write_Char (')');
+
+ elsif Val in Strings_Range then
+ Write_String_Table_Entry (String_Id (Val));
+ Write_Str (" (String_Id=");
+ Write_Int (Int (Val));
+ Write_Char (')');
+
+ elsif Val in Uint_Range then
+ UI_Write (From_Union (Val), Format);
+ Write_Str (" (Uint = ");
+ Write_Int (Int (Val));
+ Write_Char (')');
+
+ elsif Val in Ureal_Range then
+ UR_Write (From_Union (Val));
+ Write_Str (" (Ureal = ");
+ Write_Int (Int (Val));
+ Write_Char (')');
+
+ elsif Val in Char_Code_Range then
+ Write_Str ("Character code = ");
+
+ declare
+ C : Char_Code := Char_Code (Val - Char_Code_Bias);
+
+ begin
+ Write_Int (Int (C));
+ Write_Str (" ('");
+ Write_Char_Code (C);
+ Write_Str ("')");
+ end;
+
+ else
+ Print_Str ("****** Incorrect value = ");
+ Print_Int (Int (Val));
+ end if;
+ end Print_Field;
+
+ ----------------
+ -- Print_Flag --
+ ----------------
+
+ procedure Print_Flag (F : Boolean) is
+ begin
+ if F then
+ Print_Str ("True");
+ else
+ Print_Str ("False");
+ end if;
+ end Print_Flag;
+
+ ----------------
+ -- Print_Init --
+ ----------------
+
+ procedure Print_Init is
+ begin
+ Printing_Descendants := True;
+ Write_Eol;
+
+ -- Allocate and clear serial number hash table. The size is 150% of
+ -- the maximum possible number of entries, so that the hash table
+ -- cannot get significantly overloaded.
+
+ Hash_Table_Len := (150 * (Num_Nodes + Num_Lists + Num_Elists)) / 100;
+ Hash_Table := new Hash_Table_Type (0 .. Hash_Table_Len - 1);
+
+ for J in Hash_Table'Range loop
+ Hash_Table (J).Serial := 0;
+ end loop;
+
+ end Print_Init;
+
+ ---------------
+ -- Print_Int --
+ ---------------
+
+ procedure Print_Int (I : Int) is
+ begin
+ if Phase = Printing then
+ Write_Int (I);
+ end if;
+ end Print_Int;
+
+ --------------------
+ -- Print_List_Ref --
+ --------------------
+
+ procedure Print_List_Ref (L : List_Id) is
+ begin
+ if Phase /= Printing then
+ return;
+ end if;
+
+ if No (L) then
+ Write_Str ("<no list>");
+
+ elsif Is_Empty_List (L) then
+ Write_Str ("<empty list> (List_Id=");
+ Write_Int (Int (L));
+ Write_Char (')');
+
+ else
+ Write_Str ("List");
+
+ if Printing_Descendants then
+ Write_Str (" #");
+ Write_Int (Serial_Number (Int (L)));
+ end if;
+
+ Write_Str (" (List_Id=");
+ Write_Int (Int (L));
+ Write_Char (')');
+ end if;
+ end Print_List_Ref;
+
+ ------------------------
+ -- Print_List_Subtree --
+ ------------------------
+
+ procedure Print_List_Subtree (L : List_Id) is
+ begin
+ Print_Init;
+
+ Next_Serial_Number := 1;
+ Phase := Marking;
+ Visit_List (L, "");
+
+ Next_Serial_Number := 1;
+ Phase := Printing;
+ Visit_List (L, "");
+
+ Print_Term;
+ end Print_List_Subtree;
+
+ ----------------
+ -- Print_Name --
+ ----------------
+
+ procedure Print_Name (N : Name_Id) is
+ begin
+ if Phase = Printing then
+ if N = No_Name then
+ Print_Str ("<No_Name>");
+
+ elsif N = Error_Name then
+ Print_Str ("<Error_Name>");
+
+ else
+ Get_Name_String (N);
+ Print_Char ('"');
+ Write_Name (N);
+ Print_Char ('"');
+ end if;
+ end if;
+ end Print_Name;
+
+ ----------------
+ -- Print_Node --
+ ----------------
+
+ procedure Print_Node
+ (N : Node_Id;
+ Prefix_Str : String;
+ Prefix_Char : Character)
+ is
+ F : Fchar;
+ P : Natural := Pchar_Pos (Nkind (N));
+
+ Field_To_Be_Printed : Boolean;
+ Prefix_Str_Char : String (Prefix_Str'First .. Prefix_Str'Last + 1);
+
+ Sfile : Source_File_Index;
+ Notes : Boolean;
+ Fmt : UI_Format;
+
+ begin
+ if Phase /= Printing then
+ return;
+ end if;
+
+ if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then
+ Fmt := Hex;
+ else
+ Fmt := Auto;
+ end if;
+
+ Prefix_Str_Char (Prefix_Str'Range) := Prefix_Str;
+ Prefix_Str_Char (Prefix_Str'Last + 1) := Prefix_Char;
+
+ -- Print header line
+
+ Print_Str (Prefix_Str);
+ Print_Node_Ref (N);
+
+ Notes := False;
+
+ if Comes_From_Source (N) then
+ Notes := True;
+ Print_Str (" (source");
+ end if;
+
+ if Analyzed (N) then
+ if not Notes then
+ Notes := True;
+ Print_Str (" (");
+ else
+ Print_Str (",");
+ end if;
+
+ Print_Str ("analyzed");
+ end if;
+
+ if Error_Posted (N) then
+ if not Notes then
+ Notes := True;
+ Print_Str (" (");
+ else
+ Print_Str (",");
+ end if;
+
+ Print_Str ("posted");
+ end if;
+
+ if Notes then
+ Print_Char (')');
+ end if;
+
+ Print_Eol;
+
+ if Is_Rewrite_Substitution (N) then
+ Print_Str (Prefix_Str);
+ Print_Str (" Rewritten: original node = ");
+ Print_Node_Ref (Original_Node (N));
+ Print_Eol;
+ end if;
+
+ if N = Empty then
+ return;
+ end if;
+
+ if not Is_List_Member (N) then
+ Print_Str (Prefix_Str);
+ Print_Str (" Parent = ");
+ Print_Node_Ref (Parent (N));
+ Print_Eol;
+ end if;
+
+ -- Print Sloc field if it is set
+
+ if Sloc (N) /= No_Location then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Sloc = ");
+
+ if Sloc (N) = Standard_Location then
+ Print_Str ("Standard_Location");
+
+ elsif Sloc (N) = Standard_ASCII_Location then
+ Print_Str ("Standard_ASCII_Location");
+
+ else
+ Sfile := Get_Source_File_Index (Sloc (N));
+ Print_Int (Int (Sloc (N)) - Int (Source_Text (Sfile)'First));
+ Write_Str (" ");
+ Write_Location (Sloc (N));
+ end if;
+
+ Print_Eol;
+ end if;
+
+ -- Print Chars field if present
+
+ if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Chars = ");
+ Print_Name (Chars (N));
+ Write_Str (" (Name_Id=");
+ Write_Int (Int (Chars (N)));
+ Write_Char (')');
+ Print_Eol;
+ end if;
+
+ -- Special field print operations for non-entity nodes
+
+ if Nkind (N) not in N_Entity then
+
+ -- Deal with Left_Opnd and Right_Opnd fields
+
+ if Nkind (N) in N_Op
+ or else Nkind (N) = N_And_Then
+ or else Nkind (N) = N_In
+ or else Nkind (N) = N_Not_In
+ or else Nkind (N) = N_Or_Else
+ then
+ -- Print Left_Opnd if present
+
+ if Nkind (N) not in N_Unary_Op then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Left_Opnd = ");
+ Print_Node_Ref (Left_Opnd (N));
+ Print_Eol;
+ end if;
+
+ -- Print Right_Opnd
+
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Right_Opnd = ");
+ Print_Node_Ref (Right_Opnd (N));
+ Print_Eol;
+ end if;
+
+ -- Print Entity field if operator (other cases of Entity
+ -- are in the table, so are handled in the normal circuit)
+
+ if Nkind (N) in N_Op and then Present (Entity (N)) then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Entity = ");
+ Print_Node_Ref (Entity (N));
+ Print_Eol;
+ end if;
+
+ -- Print special fields if we have a subexpression
+
+ if Nkind (N) in N_Subexpr then
+
+ if Assignment_OK (N) then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Assignment_OK = True");
+ Print_Eol;
+ end if;
+
+ if Do_Range_Check (N) then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Do_Range_Check = True");
+ Print_Eol;
+ end if;
+
+ if Has_Dynamic_Length_Check (N) then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Has_Dynamic_Length_Check = True");
+ Print_Eol;
+ end if;
+
+ if Has_Dynamic_Range_Check (N) then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Has_Dynamic_Range_Check = True");
+ Print_Eol;
+ end if;
+
+ if Is_Controlling_Actual (N) then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Is_Controlling_Actual = True");
+ Print_Eol;
+ end if;
+
+ if Is_Overloaded (N) then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Is_Overloaded = True");
+ Print_Eol;
+ end if;
+
+ if Is_Static_Expression (N) then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Is_Static_Expression = True");
+ Print_Eol;
+ end if;
+
+ if Must_Not_Freeze (N) then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Must_Not_Freeze = True");
+ Print_Eol;
+ end if;
+
+ if Paren_Count (N) /= 0 then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Paren_Count = ");
+ Print_Int (Int (Paren_Count (N)));
+ Print_Eol;
+ end if;
+
+ if Raises_Constraint_Error (N) then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Raise_Constraint_Error = True");
+ Print_Eol;
+ end if;
+
+ end if;
+
+ -- Print Do_Overflow_Check field if present
+
+ if Nkind (N) in N_Op and then Do_Overflow_Check (N) then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Do_Overflow_Check = True");
+ Print_Eol;
+ end if;
+
+ -- Print Etype field if present (printing of this field for entities
+ -- is handled by the Print_Entity_Info procedure).
+
+ if Nkind (N) in N_Has_Etype
+ and then Present (Etype (N))
+ then
+ Print_Str (Prefix_Str_Char);
+ Print_Str ("Etype = ");
+ Print_Node_Ref (Etype (N));
+ Print_Eol;
+ end if;
+ end if;
+
+ -- Loop to print fields included in Pchars array
+
+ while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop
+ F := Pchars (P);
+ P := P + 1;
+
+ -- Check for case of False flag, which we never print, or
+ -- an Empty field, which is also never printed
+
+ case F is
+ when F_Field1 =>
+ Field_To_Be_Printed := Field1 (N) /= Union_Id (Empty);
+
+ when F_Field2 =>
+ Field_To_Be_Printed := Field2 (N) /= Union_Id (Empty);
+
+ when F_Field3 =>
+ Field_To_Be_Printed := Field3 (N) /= Union_Id (Empty);
+
+ when F_Field4 =>
+ Field_To_Be_Printed := Field4 (N) /= Union_Id (Empty);
+
+ when F_Field5 =>
+ Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty);
+
+ when F_Flag4 => Field_To_Be_Printed := Flag4 (N);
+ when F_Flag5 => Field_To_Be_Printed := Flag5 (N);
+ when F_Flag6 => Field_To_Be_Printed := Flag6 (N);
+ when F_Flag7 => Field_To_Be_Printed := Flag7 (N);
+ when F_Flag8 => Field_To_Be_Printed := Flag8 (N);
+ when F_Flag9 => Field_To_Be_Printed := Flag9 (N);
+ when F_Flag10 => Field_To_Be_Printed := Flag10 (N);
+ when F_Flag11 => Field_To_Be_Printed := Flag11 (N);
+ when F_Flag12 => Field_To_Be_Printed := Flag12 (N);
+ when F_Flag13 => Field_To_Be_Printed := Flag13 (N);
+ when F_Flag14 => Field_To_Be_Printed := Flag14 (N);
+ when F_Flag15 => Field_To_Be_Printed := Flag15 (N);
+ when F_Flag16 => Field_To_Be_Printed := Flag16 (N);
+ when F_Flag17 => Field_To_Be_Printed := Flag17 (N);
+ when F_Flag18 => Field_To_Be_Printed := Flag18 (N);
+
+ -- Flag1,2,3 are no longer used
+
+ when F_Flag1 => raise Program_Error;
+ when F_Flag2 => raise Program_Error;
+ when F_Flag3 => raise Program_Error;
+
+ end case;
+
+ -- Print field if it is to be printed
+
+ if Field_To_Be_Printed then
+ Print_Str (Prefix_Str_Char);
+
+ while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
+ and then Pchars (P) not in Fchar
+ loop
+ Print_Char (Pchars (P));
+ P := P + 1;
+ end loop;
+
+ Print_Str (" = ");
+
+ case F is
+ when F_Field1 => Print_Field (Field1 (N), Fmt);
+ when F_Field2 => Print_Field (Field2 (N), Fmt);
+ when F_Field3 => Print_Field (Field3 (N), Fmt);
+ when F_Field4 => Print_Field (Field4 (N), Fmt);
+
+ -- Special case End_Span = Uint5
+
+ when F_Field5 =>
+ if Nkind (N) = N_Case_Statement
+ or else Nkind (N) = N_If_Statement
+ then
+ Print_End_Span (N);
+ else
+ Print_Field (Field5 (N), Fmt);
+ end if;
+
+ when F_Flag4 => Print_Flag (Flag4 (N));
+ when F_Flag5 => Print_Flag (Flag5 (N));
+ when F_Flag6 => Print_Flag (Flag6 (N));
+ when F_Flag7 => Print_Flag (Flag7 (N));
+ when F_Flag8 => Print_Flag (Flag8 (N));
+ when F_Flag9 => Print_Flag (Flag9 (N));
+ when F_Flag10 => Print_Flag (Flag10 (N));
+ when F_Flag11 => Print_Flag (Flag11 (N));
+ when F_Flag12 => Print_Flag (Flag12 (N));
+ when F_Flag13 => Print_Flag (Flag13 (N));
+ when F_Flag14 => Print_Flag (Flag14 (N));
+ when F_Flag15 => Print_Flag (Flag15 (N));
+ when F_Flag16 => Print_Flag (Flag16 (N));
+ when F_Flag17 => Print_Flag (Flag17 (N));
+ when F_Flag18 => Print_Flag (Flag18 (N));
+
+ -- Flag1,2,3 are no longer used
+
+ when F_Flag1 => raise Program_Error;
+ when F_Flag2 => raise Program_Error;
+ when F_Flag3 => raise Program_Error;
+ end case;
+
+ Print_Eol;
+
+ -- Field is not to be printed (False flag field)
+
+ else
+ while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
+ and then Pchars (P) not in Fchar
+ loop
+ P := P + 1;
+ end loop;
+ end if;
+
+ end loop;
+
+ -- Print entity information for entities
+
+ if Nkind (N) in N_Entity then
+ Print_Entity_Info (N, Prefix_Str_Char);
+ end if;
+
+ end Print_Node;
+
+ ---------------------
+ -- Print_Node_Kind --
+ ---------------------
+
+ procedure Print_Node_Kind (N : Node_Id) is
+ Ucase : Boolean;
+ S : constant String := Node_Kind'Image (Nkind (N));
+
+ begin
+ if Phase = Printing then
+ Ucase := True;
+
+ -- Note: the call to Fold_Upper in this loop is to get past the GNAT
+ -- bug of 'Image returning lower case instead of upper case.
+
+ for J in S'Range loop
+ if Ucase then
+ Write_Char (Fold_Upper (S (J)));
+ else
+ Write_Char (Fold_Lower (S (J)));
+ end if;
+
+ Ucase := (S (J) = '_');
+ end loop;
+ end if;
+ end Print_Node_Kind;
+
+ --------------------
+ -- Print_Node_Ref --
+ --------------------
+
+ procedure Print_Node_Ref (N : Node_Id) is
+ S : Nat;
+
+ begin
+ if Phase /= Printing then
+ return;
+ end if;
+
+ if N = Empty then
+ Write_Str ("<empty>");
+
+ elsif N = Error then
+ Write_Str ("<error>");
+
+ else
+ if Printing_Descendants then
+ S := Serial_Number (Int (N));
+
+ if S /= 0 then
+ Write_Str ("Node");
+ Write_Str (" #");
+ Write_Int (S);
+ Write_Char (' ');
+ end if;
+ end if;
+
+ Print_Node_Kind (N);
+
+ if Nkind (N) in N_Has_Chars then
+ Write_Char (' ');
+ Print_Name (Chars (N));
+ end if;
+
+ if Nkind (N) in N_Entity then
+ Write_Str (" (Entity_Id=");
+ else
+ Write_Str (" (Node_Id=");
+ end if;
+
+ Write_Int (Int (N));
+
+ if Sloc (N) <= Standard_Location then
+ Write_Char ('s');
+ end if;
+
+ Write_Char (')');
+
+ end if;
+ end Print_Node_Ref;
+
+ ------------------------
+ -- Print_Node_Subtree --
+ ------------------------
+
+ procedure Print_Node_Subtree (N : Node_Id) is
+ begin
+ Print_Init;
+
+ Next_Serial_Number := 1;
+ Phase := Marking;
+ Visit_Node (N, "", ' ');
+
+ Next_Serial_Number := 1;
+ Phase := Printing;
+ Visit_Node (N, "", ' ');
+
+ Print_Term;
+ end Print_Node_Subtree;
+
+ ---------------
+ -- Print_Str --
+ ---------------
+
+ procedure Print_Str (S : String) is
+ begin
+ if Phase = Printing then
+ Write_Str (S);
+ end if;
+ end Print_Str;
+
+ --------------------------
+ -- Print_Str_Mixed_Case --
+ --------------------------
+
+ procedure Print_Str_Mixed_Case (S : String) is
+ Ucase : Boolean;
+
+ begin
+ if Phase = Printing then
+ Ucase := True;
+
+ for J in S'Range loop
+ if Ucase then
+ Write_Char (S (J));
+ else
+ Write_Char (Fold_Lower (S (J)));
+ end if;
+
+ Ucase := (S (J) = '_');
+ end loop;
+ end if;
+ end Print_Str_Mixed_Case;
+
+ ----------------
+ -- Print_Term --
+ ----------------
+
+ procedure Print_Term is
+ procedure Free is new Unchecked_Deallocation
+ (Hash_Table_Type, Access_Hash_Table_Type);
+
+ begin
+ Free (Hash_Table);
+ end Print_Term;
+
+ ---------------------
+ -- Print_Tree_Elist --
+ ---------------------
+
+ procedure Print_Tree_Elist (E : Elist_Id) is
+ M : Elmt_Id;
+
+ begin
+ Printing_Descendants := False;
+ Phase := Printing;
+
+ Print_Elist_Ref (E);
+ Print_Eol;
+
+ M := First_Elmt (E);
+
+ if No (M) then
+ Print_Str ("<empty element list>");
+ Print_Eol;
+
+ else
+ loop
+ Print_Char ('|');
+ Print_Eol;
+ exit when No (Next_Elmt (M));
+ Print_Node (Node (M), "", '|');
+ Next_Elmt (M);
+ end loop;
+
+ Print_Node (Node (M), "", ' ');
+ Print_Eol;
+ end if;
+ end Print_Tree_Elist;
+
+ ---------------------
+ -- Print_Tree_List --
+ ---------------------
+
+ procedure Print_Tree_List (L : List_Id) is
+ N : Node_Id;
+
+ begin
+ Printing_Descendants := False;
+ Phase := Printing;
+
+ Print_List_Ref (L);
+ Print_Str (" List_Id=");
+ Print_Int (Int (L));
+ Print_Eol;
+
+ N := First (L);
+
+ if N = Empty then
+ Print_Str ("<empty node list>");
+ Print_Eol;
+
+ else
+ loop
+ Print_Char ('|');
+ Print_Eol;
+ exit when Next (N) = Empty;
+ Print_Node (N, "", '|');
+ Next (N);
+ end loop;
+
+ Print_Node (N, "", ' ');
+ Print_Eol;
+ end if;
+ end Print_Tree_List;
+
+ ---------------------
+ -- Print_Tree_Node --
+ ---------------------
+
+ procedure Print_Tree_Node (N : Node_Id; Label : String := "") is
+ begin
+ Printing_Descendants := False;
+ Phase := Printing;
+ Print_Node (N, Label, ' ');
+ end Print_Tree_Node;
+
+ --------
+ -- PT --
+ --------
+
+ procedure PT (N : Node_Id) is
+ begin
+ Print_Node_Subtree (N);
+ end PT;
+
+ -------------------
+ -- Serial_Number --
+ -------------------
+
+ -- The hashing algorithm is to use the remainder of the ID value divided
+ -- by the hash table length as the starting point in the table, and then
+ -- handle collisions by serial searching wrapping at the end of the table.
+
+ Hash_Slot : Nat;
+ -- Set by an unsuccessful call to Serial_Number (one which returns zero)
+ -- to save the slot that should be used if Set_Serial_Number is called.
+
+ function Serial_Number (Id : Int) return Nat is
+ H : Int := Id mod Hash_Table_Len;
+
+ begin
+ while Hash_Table (H).Serial /= 0 loop
+
+ if Id = Hash_Table (H).Id then
+ return Hash_Table (H).Serial;
+ end if;
+
+ H := H + 1;
+
+ if H > Hash_Table'Last then
+ H := 0;
+ end if;
+ end loop;
+
+ -- Entry was not found, save slot number for possible subsequent call
+ -- to Set_Serial_Number, and unconditionally save the Id in this slot
+ -- in case of such a call (the Id field is never read if the serial
+ -- number of the slot is zero, so this is harmless in the case where
+ -- Set_Serial_Number is not subsequently called).
+
+ Hash_Slot := H;
+ Hash_Table (H).Id := Id;
+ return 0;
+
+ end Serial_Number;
+
+ -----------------------
+ -- Set_Serial_Number --
+ -----------------------
+
+ procedure Set_Serial_Number is
+ begin
+ Hash_Table (Hash_Slot).Serial := Next_Serial_Number;
+ Next_Serial_Number := Next_Serial_Number + 1;
+ end Set_Serial_Number;
+
+ ---------------
+ -- Tree_Dump --
+ ---------------
+
+ procedure Tree_Dump is
+ procedure Underline;
+ -- Put underline under string we just printed
+
+ procedure Underline is
+ Col : constant Int := Column;
+
+ begin
+ Write_Eol;
+
+ while Col > Column loop
+ Write_Char ('-');
+ end loop;
+
+ Write_Eol;
+ end Underline;
+
+ -- Start of processing for Tree_Dump. Note that we turn off the tree dump
+ -- flags immediately, before starting the dump. This avoids generating two
+ -- copies of the dump if an abort occurs after printing the dump, and more
+ -- importantly, avoids an infinite loop if an abort occurs during the dump.
+
+ -- Note: unlike in the source print case (in Sprint), we do not output
+ -- separate trees for each unit. Instead the -df debug switch causes the
+ -- tree that is output from the main unit to trace references into other
+ -- units (normally such references are not traced). Since all other units
+ -- are linked to the main unit by at least one reference, this causes all
+ -- tree nodes to be included in the output tree.
+
+ begin
+ if Debug_Flag_Y then
+ Debug_Flag_Y := False;
+ Write_Eol;
+ Write_Str ("Tree created for Standard (spec) ");
+ Underline;
+ Print_Node_Subtree (Standard_Package_Node);
+ Write_Eol;
+ end if;
+
+ if Debug_Flag_T then
+ Debug_Flag_T := False;
+
+ Write_Eol;
+ Write_Str ("Tree created for ");
+ Write_Unit_Name (Unit_Name (Main_Unit));
+ Underline;
+ Print_Node_Subtree (Cunit (Main_Unit));
+ Write_Eol;
+ end if;
+
+ end Tree_Dump;
+
+ -----------------
+ -- Visit_Elist --
+ -----------------
+
+ procedure Visit_Elist (E : Elist_Id; Prefix_Str : String) is
+ M : Elmt_Id;
+ N : Node_Id;
+ S : constant Nat := Serial_Number (Int (E));
+
+ begin
+ -- In marking phase, return if already marked, otherwise set next
+ -- serial number in hash table for later reference.
+
+ if Phase = Marking then
+ if S /= 0 then
+ return; -- already visited
+ else
+ Set_Serial_Number;
+ end if;
+
+ -- In printing phase, if already printed, then return, otherwise we
+ -- are printing the next item, so increment the serial number.
+
+ else
+ if S < Next_Serial_Number then
+ return; -- already printed
+ else
+ Next_Serial_Number := Next_Serial_Number + 1;
+ end if;
+ end if;
+
+ -- Now process the list (Print calls have no effect in marking phase)
+
+ Print_Str (Prefix_Str);
+ Print_Elist_Ref (E);
+ Print_Eol;
+
+ if Is_Empty_Elmt_List (E) then
+ Print_Str (Prefix_Str);
+ Print_Str ("(Empty element list)");
+ Print_Eol;
+ Print_Eol;
+
+ else
+ if Phase = Printing then
+ M := First_Elmt (E);
+ while Present (M) loop
+ N := Node (M);
+ Print_Str (Prefix_Str);
+ Print_Str (" ");
+ Print_Node_Ref (N);
+ Print_Eol;
+ Next_Elmt (M);
+ end loop;
+
+ Print_Str (Prefix_Str);
+ Print_Eol;
+ end if;
+
+ M := First_Elmt (E);
+ while Present (M) loop
+ Visit_Node (Node (M), Prefix_Str, ' ');
+ Next_Elmt (M);
+ end loop;
+ end if;
+ end Visit_Elist;
+
+ ----------------
+ -- Visit_List --
+ ----------------
+
+ procedure Visit_List (L : List_Id; Prefix_Str : String) is
+ N : Node_Id;
+ S : constant Nat := Serial_Number (Int (L));
+
+ begin
+ -- In marking phase, return if already marked, otherwise set next
+ -- serial number in hash table for later reference.
+
+ if Phase = Marking then
+ if S /= 0 then
+ return;
+ else
+ Set_Serial_Number;
+ end if;
+
+ -- In printing phase, if already printed, then return, otherwise we
+ -- are printing the next item, so increment the serial number.
+
+ else
+ if S < Next_Serial_Number then
+ return; -- already printed
+ else
+ Next_Serial_Number := Next_Serial_Number + 1;
+ end if;
+ end if;
+
+ -- Now process the list (Print calls have no effect in marking phase)
+
+ Print_Str (Prefix_Str);
+ Print_List_Ref (L);
+ Print_Eol;
+
+ Print_Str (Prefix_Str);
+ Print_Str ("|Parent = ");
+ Print_Node_Ref (Parent (L));
+ Print_Eol;
+
+ N := First (L);
+
+ if N = Empty then
+ Print_Str (Prefix_Str);
+ Print_Str ("(Empty list)");
+ Print_Eol;
+ Print_Eol;
+
+ else
+ Print_Str (Prefix_Str);
+ Print_Char ('|');
+ Print_Eol;
+
+ while Next (N) /= Empty loop
+ Visit_Node (N, Prefix_Str, '|');
+ Next (N);
+ end loop;
+ end if;
+
+ Visit_Node (N, Prefix_Str, ' ');
+ end Visit_List;
+
+ ----------------
+ -- Visit_Node --
+ ----------------
+
+ procedure Visit_Node
+ (N : Node_Id;
+ Prefix_Str : String;
+ Prefix_Char : Character)
+ is
+ New_Prefix : String (Prefix_Str'First .. Prefix_Str'Last + 2);
+ -- Prefix string for printing referenced fields
+
+ procedure Visit_Descendent
+ (D : Union_Id;
+ No_Indent : Boolean := False);
+ -- This procedure tests the given value of one of the Fields referenced
+ -- by the current node to determine whether to visit it recursively.
+ -- Normally No_Indent is false, which means tha the visited node will
+ -- be indented using New_Prefix. If No_Indent is set to True, then
+ -- this indentation is skipped, and Prefix_Str is used for the call
+ -- to print the descendent. No_Indent is effective only if the
+ -- referenced descendent is a node.
+
+ ----------------------
+ -- Visit_Descendent --
+ ----------------------
+
+ procedure Visit_Descendent
+ (D : Union_Id;
+ No_Indent : Boolean := False)
+ is
+ begin
+ -- Case of descendent is a node
+
+ if D in Node_Range then
+
+ -- Don't bother about Empty or Error descendents
+
+ if D <= Union_Id (Empty_Or_Error) then
+ return;
+ end if;
+
+ declare
+ Nod : constant Node_Or_Entity_Id := Node_Or_Entity_Id (D);
+
+ begin
+ -- Descendents in one of the standardly compiled internal
+ -- packages are normally ignored, unless the parent is also
+ -- in such a package (happens when Standard itself is output)
+ -- or if the -df switch is set which causes all links to be
+ -- followed, even into package standard.
+
+ if Sloc (Nod) <= Standard_Location then
+ if Sloc (N) > Standard_Location
+ and then not Debug_Flag_F
+ then
+ return;
+ end if;
+
+ -- Don't bother about a descendent in a different unit than
+ -- the node we came from unless the -df switch is set. Note
+ -- that we know at this point that Sloc (D) > Standard_Location
+
+ -- Note: the tests for No_Location here just make sure that we
+ -- don't blow up on a node which is missing an Sloc value. This
+ -- should not normally happen.
+
+ else
+ if (Sloc (N) <= Standard_Location
+ or else Sloc (N) = No_Location
+ or else Sloc (Nod) = No_Location
+ or else not In_Same_Source_Unit (Nod, N))
+ and then not Debug_Flag_F
+ then
+ return;
+ end if;
+ end if;
+
+ -- Don't bother visiting a source node that has a parent which
+ -- is not the node we came from. We prefer to trace such nodes
+ -- from their real parents. This causes the tree to be printed
+ -- in a more coherent order, e.g. a defining identifier listed
+ -- next to its corresponding declaration, instead of next to
+ -- some semantic reference.
+
+ -- This test is skipped for nodes in standard packages unless
+ -- the -dy option is set (which outputs the tree for standard)
+
+ -- Also, always follow pointers to Is_Itype entities,
+ -- since we want to list these when they are first referenced.
+
+ if Parent (Nod) /= Empty
+ and then Comes_From_Source (Nod)
+ and then Parent (Nod) /= N
+ and then (Sloc (N) > Standard_Location or else Debug_Flag_Y)
+ then
+ return;
+ end if;
+
+ -- If we successfully fall through all the above tests (which
+ -- execute a return if the node is not to be visited), we can
+ -- go ahead and visit the node!
+
+ if No_Indent then
+ Visit_Node (Nod, Prefix_Str, Prefix_Char);
+ else
+ Visit_Node (Nod, New_Prefix, ' ');
+ end if;
+ end;
+
+ -- Case of descendent is a list
+
+ elsif D in List_Range then
+
+ -- Don't bother with a missing list, empty list or error list
+
+ if D = Union_Id (No_List)
+ or else D = Union_Id (Error_List)
+ or else Is_Empty_List (List_Id (D))
+ then
+ return;
+
+ -- Otherwise we can visit the list. Note that we don't bother
+ -- to do the parent test that we did for the node case, because
+ -- it just does not happen that lists are referenced more than
+ -- one place in the tree. We aren't counting on this being the
+ -- case to generate valid output, it is just that we don't need
+ -- in practice to worry about listing the list at a place that
+ -- is inconvenient.
+
+ else
+ Visit_List (List_Id (D), New_Prefix);
+ end if;
+
+ -- Case of descendent is an element list
+
+ elsif D in Elist_Range then
+
+ -- Don't bother with a missing list, or an empty list
+
+ if D = Union_Id (No_Elist)
+ or else Is_Empty_Elmt_List (Elist_Id (D))
+ then
+ return;
+
+ -- Otherwise, visit the referenced element list
+
+ else
+ Visit_Elist (Elist_Id (D), New_Prefix);
+ end if;
+
+ -- For all other kinds of descendents (strings, names, uints etc),
+ -- there is nothing to visit (the contents of the field will be
+ -- printed when we print the containing node, but what concerns
+ -- us now is looking for descendents in the tree.
+
+ else
+ null;
+ end if;
+ end Visit_Descendent;
+
+ -- Start of processing for Visit_Node
+
+ begin
+ if N = Empty then
+ return;
+ end if;
+
+ -- Set fatal error node in case we get a blow up during the trace
+
+ Current_Error_Node := N;
+
+ New_Prefix (Prefix_Str'Range) := Prefix_Str;
+ New_Prefix (Prefix_Str'Last + 1) := Prefix_Char;
+ New_Prefix (Prefix_Str'Last + 2) := ' ';
+
+ -- In the marking phase, all we do is to set the serial number
+
+ if Phase = Marking then
+ if Serial_Number (Int (N)) /= 0 then
+ return; -- already visited
+ else
+ Set_Serial_Number;
+ end if;
+
+ -- In the printing phase, we print the node
+
+ else
+ if Serial_Number (Int (N)) < Next_Serial_Number then
+
+ -- Here we have already visited the node, but if it is in
+ -- a list, we still want to print the reference, so that
+ -- it is clear that it belongs to the list.
+
+ if Is_List_Member (N) then
+ Print_Str (Prefix_Str);
+ Print_Node_Ref (N);
+ Print_Eol;
+ Print_Str (Prefix_Str);
+ Print_Char (Prefix_Char);
+ Print_Str ("(already output)");
+ Print_Eol;
+ Print_Str (Prefix_Str);
+ Print_Char (Prefix_Char);
+ Print_Eol;
+ end if;
+
+ return;
+
+ else
+ Print_Node (N, Prefix_Str, Prefix_Char);
+ Print_Str (Prefix_Str);
+ Print_Char (Prefix_Char);
+ Print_Eol;
+ Next_Serial_Number := Next_Serial_Number + 1;
+ end if;
+ end if;
+
+ -- Visit all descendents of this node
+
+ if Nkind (N) not in N_Entity then
+ Visit_Descendent (Field1 (N));
+ Visit_Descendent (Field2 (N));
+ Visit_Descendent (Field3 (N));
+ Visit_Descendent (Field4 (N));
+ Visit_Descendent (Field5 (N));
+
+ -- Entity case
+
+ else
+ Visit_Descendent (Field1 (N));
+ Visit_Descendent (Field3 (N));
+ Visit_Descendent (Field4 (N));
+ Visit_Descendent (Field5 (N));
+ Visit_Descendent (Field6 (N));
+ Visit_Descendent (Field7 (N));
+ Visit_Descendent (Field8 (N));
+ Visit_Descendent (Field9 (N));
+ Visit_Descendent (Field10 (N));
+ Visit_Descendent (Field11 (N));
+ Visit_Descendent (Field12 (N));
+ Visit_Descendent (Field13 (N));
+ Visit_Descendent (Field14 (N));
+ Visit_Descendent (Field15 (N));
+ Visit_Descendent (Field16 (N));
+ Visit_Descendent (Field17 (N));
+ Visit_Descendent (Field18 (N));
+ Visit_Descendent (Field19 (N));
+ Visit_Descendent (Field20 (N));
+ Visit_Descendent (Field21 (N));
+ Visit_Descendent (Field22 (N));
+ Visit_Descendent (Field23 (N));
+
+ -- You may be wondering why we omitted Field2 above. The answer
+ -- is that this is the Next_Entity field, and we want to treat
+ -- it rather specially. Why? Because a Next_Entity link does not
+ -- correspond to a level deeper in the tree, and we do not want
+ -- the tree to march off to the right of the page due to bogus
+ -- indentations coming from this effect.
+
+ -- To prevent this, what we do is to control references via
+ -- Next_Entity only from the first entity on a given scope
+ -- chain, and we keep them all at the same level. Of course
+ -- if an entity has already been referenced it is not printed.
+
+ if Present (Next_Entity (N))
+ and then Present (Scope (N))
+ and then First_Entity (Scope (N)) = N
+ then
+ declare
+ Nod : Node_Id;
+
+ begin
+ Nod := N;
+ while Present (Nod) loop
+ Visit_Descendent (Union_Id (Next_Entity (Nod)));
+ Nod := Next_Entity (Nod);
+ end loop;
+ end;
+ end if;
+ end if;
+ end Visit_Node;
+
+end Treepr;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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)
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- U I N T P --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.74 $
+-- --
+-- 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 Output; use Output;
+with Tree_IO; use Tree_IO;
+
+package body Uintp is
+
+ ------------------------
+ -- Local Declarations --
+ ------------------------
+
+ Uint_Int_First : Uint := Uint_0;
+ -- Uint value containing Int'First value, set by Initialize. The initial
+ -- value of Uint_0 is used for an assertion check that ensures that this
+ -- value is not used before it is initialized. This value is used in the
+ -- UI_Is_In_Int_Range predicate, and it is right that this is a host
+ -- value, since the issue is host representation of integer values.
+
+ Uint_Int_Last : Uint;
+ -- Uint value containing Int'Last value set by Initialize.
+
+ UI_Power_2 : array (Int range 0 .. 64) of Uint;
+ -- This table is used to memoize exponentiations by powers of 2. The Nth
+ -- entry, if set, contains the Uint value 2 ** N. Initially UI_Power_2_Set
+ -- is zero and only the 0'th entry is set, the invariant being that all
+ -- entries in the range 0 .. UI_Power_2_Set are initialized.
+
+ UI_Power_2_Set : Nat;
+ -- Number of entries set in UI_Power_2;
+
+ UI_Power_10 : array (Int range 0 .. 64) of Uint;
+ -- This table is used to memoize exponentiations by powers of 10 in the
+ -- same manner as described above for UI_Power_2.
+
+ UI_Power_10_Set : Nat;
+ -- Number of entries set in UI_Power_10;
+
+ Uints_Min : Uint;
+ Udigits_Min : Int;
+ -- These values are used to make sure that the mark/release mechanism
+ -- does not destroy values saved in the U_Power tables. Whenever an
+ -- entry is made in the U_Power tables, Uints_Min and Udigits_Min are
+ -- updated to protect the entry, and Release never cuts back beyond
+ -- these minimum values.
+
+ Int_0 : constant Int := 0;
+ Int_1 : constant Int := 1;
+ Int_2 : constant Int := 2;
+ -- These values are used in some cases where the use of numeric literals
+ -- would cause ambiguities (integer vs Uint).
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Direct (U : Uint) return Boolean;
+ pragma Inline (Direct);
+ -- Returns True if U is represented directly
+
+ function Direct_Val (U : Uint) return Int;
+ -- U is a Uint for is represented directly. The returned result
+ -- is the value represented.
+
+ function GCD (Jin, Kin : Int) return Int;
+ -- Compute GCD of two integers. Assumes that Jin >= Kin >= 0
+
+ procedure Image_Out
+ (Input : Uint;
+ To_Buffer : Boolean;
+ Format : UI_Format);
+ -- Common processing for UI_Image and UI_Write, To_Buffer is set
+ -- True for UI_Image, and false for UI_Write, and Format is copied
+ -- from the Format parameter to UI_Image or UI_Write.
+
+ procedure Init_Operand (UI : Uint; Vec : out UI_Vector);
+ pragma Inline (Init_Operand);
+ -- This procedure puts the value of UI into the vector in canonical
+ -- multiple precision format. The parameter should be of the correct
+ -- size as determined by a previous call to N_Digits (UI). The first
+ -- digit of Vec contains the sign, all other digits are always non-
+ -- negative. Note that the input may be directly represented, and in
+ -- this case Vec will contain the corresponding one or two digit value.
+
+ function Least_Sig_Digit (Arg : Uint) return Int;
+ pragma Inline (Least_Sig_Digit);
+ -- Returns the Least Significant Digit of Arg quickly. When the given
+ -- Uint is less than 2**15, the value returned is the input value, in
+ -- this case the result may be negative. It is expected that any use
+ -- will mask off unnecessary bits. This is used for finding Arg mod B
+ -- where B is a power of two. Hence the actual base is irrelevent as
+ -- long as it is a power of two.
+
+ procedure Most_Sig_2_Digits
+ (Left : Uint;
+ Right : Uint;
+ Left_Hat : out Int;
+ Right_Hat : out Int);
+ -- Returns leading two significant digits from the given pair of Uint's.
+ -- Mathematically: returns Left / (Base ** K) and Right / (Base ** K)
+ -- where K is as small as possible S.T. Right_Hat < Base * Base.
+ -- It is required that Left > Right for the algorithm to work.
+
+ function N_Digits (Input : Uint) return Int;
+ pragma Inline (N_Digits);
+ -- Returns number of "digits" in a Uint
+
+ function Sum_Digits (Left : Uint; Sign : Int) return Int;
+ -- If Sign = 1 return the sum of the "digits" of Abs (Left). If the
+ -- total has more then one digit then return Sum_Digits of total.
+
+ function Sum_Double_Digits (Left : Uint; Sign : Int) return Int;
+ -- Same as above but work in New_Base = Base * Base
+
+ function Vector_To_Uint
+ (In_Vec : UI_Vector;
+ Negative : Boolean)
+ return Uint;
+ -- Functions that calculate values in UI_Vectors, call this function
+ -- to create and return the Uint value. In_Vec contains the multiple
+ -- precision (Base) representation of a non-negative value. Leading
+ -- zeroes are permitted. Negative is set if the desired result is
+ -- the negative of the given value. The result will be either the
+ -- appropriate directly represented value, or a table entry in the
+ -- proper canonical format is created and returned.
+ --
+ -- Note that Init_Operand puts a signed value in the result vector,
+ -- but Vector_To_Uint is always presented with a non-negative value.
+ -- The processing of signs is something that is done by the caller
+ -- before calling Vector_To_Uint.
+
+ ------------
+ -- Direct --
+ ------------
+
+ function Direct (U : Uint) return Boolean is
+ begin
+ return Int (U) <= Int (Uint_Direct_Last);
+ end Direct;
+
+ ----------------
+ -- Direct_Val --
+ ----------------
+
+ function Direct_Val (U : Uint) return Int is
+ begin
+ pragma Assert (Direct (U));
+ return Int (U) - Int (Uint_Direct_Bias);
+ end Direct_Val;
+
+ ---------
+ -- GCD --
+ ---------
+
+ function GCD (Jin, Kin : Int) return Int is
+ J, K, Tmp : Int;
+
+ begin
+ pragma Assert (Jin >= Kin);
+ pragma Assert (Kin >= Int_0);
+
+ J := Jin;
+ K := Kin;
+
+ while K /= Uint_0 loop
+ Tmp := J mod K;
+ J := K;
+ K := Tmp;
+ end loop;
+
+ return J;
+ end GCD;
+
+ ---------------
+ -- Image_Out --
+ ---------------
+
+ procedure Image_Out
+ (Input : Uint;
+ To_Buffer : Boolean;
+ Format : UI_Format)
+ is
+ Marks : constant Uintp.Save_Mark := Uintp.Mark;
+ Base : Uint;
+ Ainput : Uint;
+
+ Digs_Output : Natural := 0;
+ -- Counts digits output. In hex mode, but not in decimal mode, we
+ -- put an underline after every four hex digits that are output.
+
+ Exponent : Natural := 0;
+ -- If the number is too long to fit in the buffer, we switch to an
+ -- approximate output format with an exponent. This variable records
+ -- the exponent value.
+
+ function Better_In_Hex return Boolean;
+ -- Determines if it is better to generate digits in base 16 (result
+ -- is true) or base 10 (result is false). The choice is purely a
+ -- matter of convenience and aesthetics, so it does not matter which
+ -- value is returned from a correctness point of view.
+
+ procedure Image_Char (C : Character);
+ -- Internal procedure to output one character
+
+ procedure Image_Exponent (N : Natural);
+ -- Output non-zero exponent. Note that we only use the exponent
+ -- form in the buffer case, so we know that To_Buffer is true.
+
+ procedure Image_Uint (U : Uint);
+ -- Internal procedure to output characters of non-negative Uint
+
+ -------------------
+ -- Better_In_Hex --
+ -------------------
+
+ function Better_In_Hex return Boolean is
+ T16 : constant Uint := Uint_2 ** Int'(16);
+ A : Uint;
+
+ begin
+ A := UI_Abs (Input);
+
+ -- Small values up to 2**16 can always be in decimal
+
+ if A < T16 then
+ return False;
+ end if;
+
+ -- Otherwise, see if we are a power of 2 or one less than a power
+ -- of 2. For the moment these are the only cases printed in hex.
+
+ if A mod Uint_2 = Uint_1 then
+ A := A + Uint_1;
+ end if;
+
+ loop
+ if A mod T16 /= Uint_0 then
+ return False;
+
+ else
+ A := A / T16;
+ end if;
+
+ exit when A < T16;
+ end loop;
+
+ while A > Uint_2 loop
+ if A mod Uint_2 /= Uint_0 then
+ return False;
+
+ else
+ A := A / Uint_2;
+ end if;
+ end loop;
+
+ return True;
+ end Better_In_Hex;
+
+ ----------------
+ -- Image_Char --
+ ----------------
+
+ procedure Image_Char (C : Character) is
+ begin
+ if To_Buffer then
+ if UI_Image_Length + 6 > UI_Image_Max then
+ Exponent := Exponent + 1;
+ else
+ UI_Image_Length := UI_Image_Length + 1;
+ UI_Image_Buffer (UI_Image_Length) := C;
+ end if;
+ else
+ Write_Char (C);
+ end if;
+ end Image_Char;
+
+ --------------------
+ -- Image_Exponent --
+ --------------------
+
+ procedure Image_Exponent (N : Natural) is
+ begin
+ if N >= 10 then
+ Image_Exponent (N / 10);
+ end if;
+
+ UI_Image_Length := UI_Image_Length + 1;
+ UI_Image_Buffer (UI_Image_Length) :=
+ Character'Val (Character'Pos ('0') + N mod 10);
+ end Image_Exponent;
+
+ ----------------
+ -- Image_Uint --
+ ----------------
+
+ procedure Image_Uint (U : Uint) is
+ H : array (Int range 0 .. 15) of Character := "0123456789ABCDEF";
+
+ begin
+ if U >= Base then
+ Image_Uint (U / Base);
+ end if;
+
+ if Digs_Output = 4 and then Base = Uint_16 then
+ Image_Char ('_');
+ Digs_Output := 0;
+ end if;
+
+ Image_Char (H (UI_To_Int (U rem Base)));
+
+ Digs_Output := Digs_Output + 1;
+ end Image_Uint;
+
+ -- Start of processing for Image_Out
+
+ begin
+ if Input = No_Uint then
+ Image_Char ('?');
+ return;
+ end if;
+
+ UI_Image_Length := 0;
+
+ if Input < Uint_0 then
+ Image_Char ('-');
+ Ainput := -Input;
+ else
+ Ainput := Input;
+ end if;
+
+ if Format = Hex
+ or else (Format = Auto and then Better_In_Hex)
+ then
+ Base := Uint_16;
+ Image_Char ('1');
+ Image_Char ('6');
+ Image_Char ('#');
+ Image_Uint (Ainput);
+ Image_Char ('#');
+
+ else
+ Base := Uint_10;
+ Image_Uint (Ainput);
+ end if;
+
+ if Exponent /= 0 then
+ UI_Image_Length := UI_Image_Length + 1;
+ UI_Image_Buffer (UI_Image_Length) := 'E';
+ Image_Exponent (Exponent);
+ end if;
+
+ Uintp.Release (Marks);
+ end Image_Out;
+
+ -------------------
+ -- Init_Operand --
+ -------------------
+
+ procedure Init_Operand (UI : Uint; Vec : out UI_Vector) is
+ Loc : Int;
+
+ begin
+ if Direct (UI) then
+ Vec (1) := Direct_Val (UI);
+
+ if Vec (1) >= Base then
+ Vec (2) := Vec (1) rem Base;
+ Vec (1) := Vec (1) / Base;
+ end if;
+
+ else
+ Loc := Uints.Table (UI).Loc;
+
+ for J in 1 .. Uints.Table (UI).Length loop
+ Vec (J) := Udigits.Table (Loc + J - 1);
+ end loop;
+ end if;
+ end Init_Operand;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Uints.Init;
+ Udigits.Init;
+
+ Uint_Int_First := UI_From_Int (Int'First);
+ Uint_Int_Last := UI_From_Int (Int'Last);
+
+ UI_Power_2 (0) := Uint_1;
+ UI_Power_2_Set := 0;
+
+ UI_Power_10 (0) := Uint_1;
+ UI_Power_10_Set := 0;
+
+ Uints_Min := Uints.Last;
+ Udigits_Min := Udigits.Last;
+
+ end Initialize;
+
+ ---------------------
+ -- Least_Sig_Digit --
+ ---------------------
+
+ function Least_Sig_Digit (Arg : Uint) return Int is
+ V : Int;
+
+ begin
+ if Direct (Arg) then
+ V := Direct_Val (Arg);
+
+ if V >= Base then
+ V := V mod Base;
+ end if;
+
+ -- Note that this result may be negative
+
+ return V;
+
+ else
+ return
+ Udigits.Table
+ (Uints.Table (Arg).Loc + Uints.Table (Arg).Length - 1);
+ end if;
+ end Least_Sig_Digit;
+
+ ----------
+ -- Mark --
+ ----------
+
+ function Mark return Save_Mark is
+ begin
+ return (Save_Uint => Uints.Last, Save_Udigit => Udigits.Last);
+ end Mark;
+
+ -----------------------
+ -- Most_Sig_2_Digits --
+ -----------------------
+
+ procedure Most_Sig_2_Digits
+ (Left : Uint;
+ Right : Uint;
+ Left_Hat : out Int;
+ Right_Hat : out Int)
+ is
+ begin
+ pragma Assert (Left >= Right);
+
+ if Direct (Left) then
+ Left_Hat := Direct_Val (Left);
+ Right_Hat := Direct_Val (Right);
+ return;
+
+ else
+ declare
+ L1 : constant Int :=
+ Udigits.Table (Uints.Table (Left).Loc);
+ L2 : constant Int :=
+ Udigits.Table (Uints.Table (Left).Loc + 1);
+
+ begin
+ -- It is not so clear what to return when Arg is negative???
+
+ Left_Hat := abs (L1) * Base + L2;
+ end;
+ end if;
+
+ declare
+ Length_L : constant Int := Uints.Table (Left).Length;
+ Length_R : Int;
+ R1 : Int;
+ R2 : Int;
+ T : Int;
+
+ begin
+ if Direct (Right) then
+ T := Direct_Val (Left);
+ R1 := abs (T / Base);
+ R2 := T rem Base;
+ Length_R := 2;
+
+ else
+ R1 := abs (Udigits.Table (Uints.Table (Right).Loc));
+ R2 := Udigits.Table (Uints.Table (Right).Loc + 1);
+ Length_R := Uints.Table (Right).Length;
+ end if;
+
+ if Length_L = Length_R then
+ Right_Hat := R1 * Base + R2;
+ elsif Length_L = Length_R + Int_1 then
+ Right_Hat := R1;
+ else
+ Right_Hat := 0;
+ end if;
+ end;
+ end Most_Sig_2_Digits;
+
+ ---------------
+ -- N_Digits --
+ ---------------
+
+ -- Note: N_Digits returns 1 for No_Uint
+
+ function N_Digits (Input : Uint) return Int is
+ begin
+ if Direct (Input) then
+ if Direct_Val (Input) >= Base then
+ return 2;
+ else
+ return 1;
+ end if;
+
+ else
+ return Uints.Table (Input).Length;
+ end if;
+ end N_Digits;
+
+ --------------
+ -- Num_Bits --
+ --------------
+
+ function Num_Bits (Input : Uint) return Nat is
+ Bits : Nat;
+ Num : Nat;
+
+ begin
+ if UI_Is_In_Int_Range (Input) then
+ Num := UI_To_Int (Input);
+ Bits := 0;
+
+ else
+ Bits := Base_Bits * (Uints.Table (Input).Length - 1);
+ Num := abs (Udigits.Table (Uints.Table (Input).Loc));
+ end if;
+
+ while Types.">" (Num, 0) loop
+ Num := Num / 2;
+ Bits := Bits + 1;
+ end loop;
+
+ return Bits;
+ end Num_Bits;
+
+ ---------
+ -- pid --
+ ---------
+
+ procedure pid (Input : Uint) is
+ begin
+ UI_Write (Input, Decimal);
+ Write_Eol;
+ end pid;
+
+ ---------
+ -- pih --
+ ---------
+
+ procedure pih (Input : Uint) is
+ begin
+ UI_Write (Input, Hex);
+ Write_Eol;
+ end pih;
+
+ -------------
+ -- Release --
+ -------------
+
+ procedure Release (M : Save_Mark) is
+ begin
+ Uints.Set_Last (Uint'Max (M.Save_Uint, Uints_Min));
+ Udigits.Set_Last (Int'Max (M.Save_Udigit, Udigits_Min));
+ end Release;
+
+ ----------------------
+ -- Release_And_Save --
+ ----------------------
+
+ procedure Release_And_Save (M : Save_Mark; UI : in out Uint) is
+ begin
+ if Direct (UI) then
+ Release (M);
+
+ else
+ declare
+ UE_Len : Pos := Uints.Table (UI).Length;
+ UE_Loc : Int := Uints.Table (UI).Loc;
+
+ UD : Udigits.Table_Type (1 .. UE_Len) :=
+ Udigits.Table (UE_Loc .. UE_Loc + UE_Len - 1);
+
+ begin
+ Release (M);
+
+ Uints.Increment_Last;
+ UI := Uints.Last;
+
+ Uints.Table (UI) := (UE_Len, Udigits.Last + 1);
+
+ for J in 1 .. UE_Len loop
+ Udigits.Increment_Last;
+ Udigits.Table (Udigits.Last) := UD (J);
+ end loop;
+ end;
+ end if;
+ end Release_And_Save;
+
+ procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Uint) is
+ begin
+ if Direct (UI1) then
+ Release_And_Save (M, UI2);
+
+ elsif Direct (UI2) then
+ Release_And_Save (M, UI1);
+
+ else
+ declare
+ UE1_Len : Pos := Uints.Table (UI1).Length;
+ UE1_Loc : Int := Uints.Table (UI1).Loc;
+
+ UD1 : Udigits.Table_Type (1 .. UE1_Len) :=
+ Udigits.Table (UE1_Loc .. UE1_Loc + UE1_Len - 1);
+
+ UE2_Len : Pos := Uints.Table (UI2).Length;
+ UE2_Loc : Int := Uints.Table (UI2).Loc;
+
+ UD2 : Udigits.Table_Type (1 .. UE2_Len) :=
+ Udigits.Table (UE2_Loc .. UE2_Loc + UE2_Len - 1);
+
+ begin
+ Release (M);
+
+ Uints.Increment_Last;
+ UI1 := Uints.Last;
+
+ Uints.Table (UI1) := (UE1_Len, Udigits.Last + 1);
+
+ for J in 1 .. UE1_Len loop
+ Udigits.Increment_Last;
+ Udigits.Table (Udigits.Last) := UD1 (J);
+ end loop;
+
+ Uints.Increment_Last;
+ UI2 := Uints.Last;
+
+ Uints.Table (UI2) := (UE2_Len, Udigits.Last + 1);
+
+ for J in 1 .. UE2_Len loop
+ Udigits.Increment_Last;
+ Udigits.Table (Udigits.Last) := UD2 (J);
+ end loop;
+ end;
+ end if;
+ end Release_And_Save;
+
+ ----------------
+ -- Sum_Digits --
+ ----------------
+
+ -- This is done in one pass
+
+ -- Mathematically: assume base congruent to 1 and compute an equivelent
+ -- integer to Left.
+
+ -- If Sign = -1 return the alternating sum of the "digits".
+
+ -- D1 - D2 + D3 - D4 + D5 . . .
+
+ -- (where D1 is Least Significant Digit)
+
+ -- Mathematically: assume base congruent to -1 and compute an equivelent
+ -- integer to Left.
+
+ -- This is used in Rem and Base is assumed to be 2 ** 15
+
+ -- Note: The next two functions are very similar, any style changes made
+ -- to one should be reflected in both. These would be simpler if we
+ -- worked base 2 ** 32.
+
+ function Sum_Digits (Left : Uint; Sign : Int) return Int is
+ begin
+ pragma Assert (Sign = Int_1 or Sign = Int (-1));
+
+ -- First try simple case;
+
+ if Direct (Left) then
+ declare
+ Tmp_Int : Int := Direct_Val (Left);
+
+ begin
+ if Tmp_Int >= Base then
+ Tmp_Int := (Tmp_Int / Base) +
+ Sign * (Tmp_Int rem Base);
+
+ -- Now Tmp_Int is in [-(Base - 1) .. 2 * (Base - 1)]
+
+ if Tmp_Int >= Base then
+
+ -- Sign must be 1.
+
+ Tmp_Int := (Tmp_Int / Base) + 1;
+
+ end if;
+
+ -- Now Tmp_Int is in [-(Base - 1) .. (Base - 1)]
+
+ end if;
+
+ return Tmp_Int;
+ end;
+
+ -- Otherwise full circuit is needed
+
+ else
+ declare
+ L_Length : Int := N_Digits (Left);
+ L_Vec : UI_Vector (1 .. L_Length);
+ Tmp_Int : Int;
+ Carry : Int;
+ Alt : Int;
+
+ begin
+ Init_Operand (Left, L_Vec);
+ L_Vec (1) := abs L_Vec (1);
+ Tmp_Int := 0;
+ Carry := 0;
+ Alt := 1;
+
+ for J in reverse 1 .. L_Length loop
+ Tmp_Int := Tmp_Int + Alt * (L_Vec (J) + Carry);
+
+ -- Tmp_Int is now between [-2 * Base + 1 .. 2 * Base - 1],
+ -- since old Tmp_Int is between [-(Base - 1) .. Base - 1]
+ -- and L_Vec is in [0 .. Base - 1] and Carry in [-1 .. 1]
+
+ if Tmp_Int >= Base then
+ Tmp_Int := Tmp_Int - Base;
+ Carry := 1;
+
+ elsif Tmp_Int <= -Base then
+ Tmp_Int := Tmp_Int + Base;
+ Carry := -1;
+
+ else
+ Carry := 0;
+ end if;
+
+ -- Tmp_Int is now between [-Base + 1 .. Base - 1]
+
+ Alt := Alt * Sign;
+ end loop;
+
+ Tmp_Int := Tmp_Int + Alt * Carry;
+
+ -- Tmp_Int is now between [-Base .. Base]
+
+ if Tmp_Int >= Base then
+ Tmp_Int := Tmp_Int - Base + Alt * Sign * 1;
+
+ elsif Tmp_Int <= -Base then
+ Tmp_Int := Tmp_Int + Base + Alt * Sign * (-1);
+ end if;
+
+ -- Now Tmp_Int is in [-(Base - 1) .. (Base - 1)]
+
+ return Tmp_Int;
+ end;
+ end if;
+ end Sum_Digits;
+
+ -----------------------
+ -- Sum_Double_Digits --
+ -----------------------
+
+ -- Note: This is used in Rem, Base is assumed to be 2 ** 15
+
+ function Sum_Double_Digits (Left : Uint; Sign : Int) return Int is
+ begin
+ -- First try simple case;
+
+ pragma Assert (Sign = Int_1 or Sign = Int (-1));
+
+ if Direct (Left) then
+ return Direct_Val (Left);
+
+ -- Otherwise full circuit is needed
+
+ else
+ declare
+ L_Length : Int := N_Digits (Left);
+ L_Vec : UI_Vector (1 .. L_Length);
+ Most_Sig_Int : Int;
+ Least_Sig_Int : Int;
+ Carry : Int;
+ J : Int;
+ Alt : Int;
+
+ begin
+ Init_Operand (Left, L_Vec);
+ L_Vec (1) := abs L_Vec (1);
+ Most_Sig_Int := 0;
+ Least_Sig_Int := 0;
+ Carry := 0;
+ Alt := 1;
+ J := L_Length;
+
+ while J > Int_1 loop
+
+ Least_Sig_Int := Least_Sig_Int + Alt * (L_Vec (J) + Carry);
+
+ -- Least is in [-2 Base + 1 .. 2 * Base - 1]
+ -- Since L_Vec in [0 .. Base - 1] and Carry in [-1 .. 1]
+ -- and old Least in [-Base + 1 .. Base - 1]
+
+ if Least_Sig_Int >= Base then
+ Least_Sig_Int := Least_Sig_Int - Base;
+ Carry := 1;
+
+ elsif Least_Sig_Int <= -Base then
+ Least_Sig_Int := Least_Sig_Int + Base;
+ Carry := -1;
+
+ else
+ Carry := 0;
+ end if;
+
+ -- Least is now in [-Base + 1 .. Base - 1]
+
+ Most_Sig_Int := Most_Sig_Int + Alt * (L_Vec (J - 1) + Carry);
+
+ -- Most is in [-2 Base + 1 .. 2 * Base - 1]
+ -- Since L_Vec in [0 .. Base - 1] and Carry in [-1 .. 1]
+ -- and old Most in [-Base + 1 .. Base - 1]
+
+ if Most_Sig_Int >= Base then
+ Most_Sig_Int := Most_Sig_Int - Base;
+ Carry := 1;
+
+ elsif Most_Sig_Int <= -Base then
+ Most_Sig_Int := Most_Sig_Int + Base;
+ Carry := -1;
+ else
+ Carry := 0;
+ end if;
+
+ -- Most is now in [-Base + 1 .. Base - 1]
+
+ J := J - 2;
+ Alt := Alt * Sign;
+ end loop;
+
+ if J = Int_1 then
+ Least_Sig_Int := Least_Sig_Int + Alt * (L_Vec (J) + Carry);
+ else
+ Least_Sig_Int := Least_Sig_Int + Alt * Carry;
+ end if;
+
+ if Least_Sig_Int >= Base then
+ Least_Sig_Int := Least_Sig_Int - Base;
+ Most_Sig_Int := Most_Sig_Int + Alt * 1;
+
+ elsif Least_Sig_Int <= -Base then
+ Least_Sig_Int := Least_Sig_Int + Base;
+ Most_Sig_Int := Most_Sig_Int + Alt * (-1);
+ end if;
+
+ if Most_Sig_Int >= Base then
+ Most_Sig_Int := Most_Sig_Int - Base;
+ Alt := Alt * Sign;
+ Least_Sig_Int :=
+ Least_Sig_Int + Alt * 1; -- cannot overflow again
+
+ elsif Most_Sig_Int <= -Base then
+ Most_Sig_Int := Most_Sig_Int + Base;
+ Alt := Alt * Sign;
+ Least_Sig_Int :=
+ Least_Sig_Int + Alt * (-1); -- cannot overflow again.
+ end if;
+
+ return Most_Sig_Int * Base + Least_Sig_Int;
+ end;
+ end if;
+ end Sum_Double_Digits;
+
+ ---------------
+ -- Tree_Read --
+ ---------------
+
+ procedure Tree_Read is
+ begin
+ Uints.Tree_Read;
+ Udigits.Tree_Read;
+
+ Tree_Read_Int (Int (Uint_Int_First));
+ Tree_Read_Int (Int (Uint_Int_Last));
+ Tree_Read_Int (UI_Power_2_Set);
+ Tree_Read_Int (UI_Power_10_Set);
+ Tree_Read_Int (Int (Uints_Min));
+ Tree_Read_Int (Udigits_Min);
+
+ for J in 0 .. UI_Power_2_Set loop
+ Tree_Read_Int (Int (UI_Power_2 (J)));
+ end loop;
+
+ for J in 0 .. UI_Power_10_Set loop
+ Tree_Read_Int (Int (UI_Power_10 (J)));
+ end loop;
+
+ end Tree_Read;
+
+ ----------------
+ -- Tree_Write --
+ ----------------
+
+ procedure Tree_Write is
+ begin
+ Uints.Tree_Write;
+ Udigits.Tree_Write;
+
+ Tree_Write_Int (Int (Uint_Int_First));
+ Tree_Write_Int (Int (Uint_Int_Last));
+ Tree_Write_Int (UI_Power_2_Set);
+ Tree_Write_Int (UI_Power_10_Set);
+ Tree_Write_Int (Int (Uints_Min));
+ Tree_Write_Int (Udigits_Min);
+
+ for J in 0 .. UI_Power_2_Set loop
+ Tree_Write_Int (Int (UI_Power_2 (J)));
+ end loop;
+
+ for J in 0 .. UI_Power_10_Set loop
+ Tree_Write_Int (Int (UI_Power_10 (J)));
+ end loop;
+
+ end Tree_Write;
+
+ -------------
+ -- UI_Abs --
+ -------------
+
+ function UI_Abs (Right : Uint) return Uint is
+ begin
+ if Right < Uint_0 then
+ return -Right;
+ else
+ return Right;
+ end if;
+ end UI_Abs;
+
+ -------------
+ -- UI_Add --
+ -------------
+
+ function UI_Add (Left : Int; Right : Uint) return Uint is
+ begin
+ return UI_Add (UI_From_Int (Left), Right);
+ end UI_Add;
+
+ function UI_Add (Left : Uint; Right : Int) return Uint is
+ begin
+ return UI_Add (Left, UI_From_Int (Right));
+ end UI_Add;
+
+ function UI_Add (Left : Uint; Right : Uint) return Uint is
+ begin
+ -- Simple cases of direct operands and addition of zero
+
+ if Direct (Left) then
+ if Direct (Right) then
+ return UI_From_Int (Direct_Val (Left) + Direct_Val (Right));
+
+ elsif Int (Left) = Int (Uint_0) then
+ return Right;
+ end if;
+
+ elsif Direct (Right) and then Int (Right) = Int (Uint_0) then
+ return Left;
+ end if;
+
+ -- Otherwise full circuit is needed
+
+ declare
+ L_Length : Int := N_Digits (Left);
+ R_Length : Int := N_Digits (Right);
+ L_Vec : UI_Vector (1 .. L_Length);
+ R_Vec : UI_Vector (1 .. R_Length);
+ Sum_Length : Int;
+ Tmp_Int : Int;
+ Carry : Int;
+ Borrow : Int;
+ X_Bigger : Boolean := False;
+ Y_Bigger : Boolean := False;
+ Result_Neg : Boolean := False;
+
+ begin
+ Init_Operand (Left, L_Vec);
+ Init_Operand (Right, R_Vec);
+
+ -- At least one of the two operands is in multi-digit form.
+ -- Calculate the number of digits sufficient to hold result.
+
+ if L_Length > R_Length then
+ Sum_Length := L_Length + 1;
+ X_Bigger := True;
+ else
+ Sum_Length := R_Length + 1;
+ if R_Length > L_Length then Y_Bigger := True; end if;
+ end if;
+
+ -- Make copies of the absolute values of L_Vec and R_Vec into
+ -- X and Y both with lengths equal to the maximum possibly
+ -- needed. This makes looping over the digits much simpler.
+
+ declare
+ X : UI_Vector (1 .. Sum_Length);
+ Y : UI_Vector (1 .. Sum_Length);
+ Tmp_UI : UI_Vector (1 .. Sum_Length);
+
+ begin
+ for J in 1 .. Sum_Length - L_Length loop
+ X (J) := 0;
+ end loop;
+
+ X (Sum_Length - L_Length + 1) := abs L_Vec (1);
+
+ for J in 2 .. L_Length loop
+ X (J + (Sum_Length - L_Length)) := L_Vec (J);
+ end loop;
+
+ for J in 1 .. Sum_Length - R_Length loop
+ Y (J) := 0;
+ end loop;
+
+ Y (Sum_Length - R_Length + 1) := abs R_Vec (1);
+
+ for J in 2 .. R_Length loop
+ Y (J + (Sum_Length - R_Length)) := R_Vec (J);
+ end loop;
+
+ if (L_Vec (1) < Int_0) = (R_Vec (1) < Int_0) then
+
+ -- Same sign so just add
+
+ Carry := 0;
+ for J in reverse 1 .. Sum_Length loop
+ Tmp_Int := X (J) + Y (J) + Carry;
+
+ if Tmp_Int >= Base then
+ Tmp_Int := Tmp_Int - Base;
+ Carry := 1;
+ else
+ Carry := 0;
+ end if;
+
+ X (J) := Tmp_Int;
+ end loop;
+
+ return Vector_To_Uint (X, L_Vec (1) < Int_0);
+
+ else
+ -- Find which one has bigger magnitude
+
+ if not (X_Bigger or Y_Bigger) then
+ for J in L_Vec'Range loop
+ if abs L_Vec (J) > abs R_Vec (J) then
+ X_Bigger := True;
+ exit;
+ elsif abs R_Vec (J) > abs L_Vec (J) then
+ Y_Bigger := True;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ -- If they have identical magnitude, just return 0, else
+ -- swap if necessary so that X had the bigger magnitude.
+ -- Determine if result is negative at this time.
+
+ Result_Neg := False;
+
+ if not (X_Bigger or Y_Bigger) then
+ return Uint_0;
+
+ elsif Y_Bigger then
+ if R_Vec (1) < Int_0 then
+ Result_Neg := True;
+ end if;
+
+ Tmp_UI := X;
+ X := Y;
+ Y := Tmp_UI;
+
+ else
+ if L_Vec (1) < Int_0 then
+ Result_Neg := True;
+ end if;
+ end if;
+
+ -- Subtract Y from the bigger X
+
+ Borrow := 0;
+
+ for J in reverse 1 .. Sum_Length loop
+ Tmp_Int := X (J) - Y (J) + Borrow;
+
+ if Tmp_Int < Int_0 then
+ Tmp_Int := Tmp_Int + Base;
+ Borrow := -1;
+ else
+ Borrow := 0;
+ end if;
+
+ X (J) := Tmp_Int;
+ end loop;
+
+ return Vector_To_Uint (X, Result_Neg);
+
+ end if;
+ end;
+ end;
+ end UI_Add;
+
+ --------------------------
+ -- UI_Decimal_Digits_Hi --
+ --------------------------
+
+ function UI_Decimal_Digits_Hi (U : Uint) return Nat is
+ begin
+ -- The maximum value of a "digit" is 32767, which is 5 decimal
+ -- digits, so an N_Digit number could take up to 5 times this
+ -- number of digits. This is certainly too high for large
+ -- numbers but it is not worth worrying about.
+
+ return 5 * N_Digits (U);
+ end UI_Decimal_Digits_Hi;
+
+ --------------------------
+ -- UI_Decimal_Digits_Lo --
+ --------------------------
+
+ function UI_Decimal_Digits_Lo (U : Uint) return Nat is
+ begin
+ -- The maximum value of a "digit" is 32767, which is more than four
+ -- decimal digits, but not a full five digits. The easily computed
+ -- minimum number of decimal digits is thus 1 + 4 * the number of
+ -- digits. This is certainly too low for large numbers but it is
+ -- not worth worrying about.
+
+ return 1 + 4 * (N_Digits (U) - 1);
+ end UI_Decimal_Digits_Lo;
+
+ ------------
+ -- UI_Div --
+ ------------
+
+ function UI_Div (Left : Int; Right : Uint) return Uint is
+ begin
+ return UI_Div (UI_From_Int (Left), Right);
+ end UI_Div;
+
+ function UI_Div (Left : Uint; Right : Int) return Uint is
+ begin
+ return UI_Div (Left, UI_From_Int (Right));
+ end UI_Div;
+
+ function UI_Div (Left, Right : Uint) return Uint is
+ begin
+ pragma Assert (Right /= Uint_0);
+
+ -- Cases where both operands are represented directly
+
+ if Direct (Left) and then Direct (Right) then
+ return UI_From_Int (Direct_Val (Left) / Direct_Val (Right));
+ end if;
+
+ declare
+ L_Length : constant Int := N_Digits (Left);
+ R_Length : constant Int := N_Digits (Right);
+ Q_Length : constant Int := L_Length - R_Length + 1;
+ L_Vec : UI_Vector (1 .. L_Length);
+ R_Vec : UI_Vector (1 .. R_Length);
+ D : Int;
+ Remainder : Int;
+ Tmp_Divisor : Int;
+ Carry : Int;
+ Tmp_Int : Int;
+ Tmp_Dig : Int;
+
+ begin
+ -- Result is zero if left operand is shorter than right
+
+ if L_Length < R_Length then
+ return Uint_0;
+ end if;
+
+ Init_Operand (Left, L_Vec);
+ Init_Operand (Right, R_Vec);
+
+ -- Case of right operand is single digit. Here we can simply divide
+ -- each digit of the left operand by the divisor, from most to least
+ -- significant, carrying the remainder to the next digit (just like
+ -- ordinary long division by hand).
+
+ if R_Length = Int_1 then
+ Remainder := 0;
+ Tmp_Divisor := abs R_Vec (1);
+
+ declare
+ Quotient : UI_Vector (1 .. L_Length);
+
+ begin
+ for J in L_Vec'Range loop
+ Tmp_Int := Remainder * Base + abs L_Vec (J);
+ Quotient (J) := Tmp_Int / Tmp_Divisor;
+ Remainder := Tmp_Int rem Tmp_Divisor;
+ end loop;
+
+ return
+ Vector_To_Uint
+ (Quotient, (L_Vec (1) < Int_0 xor R_Vec (1) < Int_0));
+ end;
+ end if;
+
+ -- The possible simple cases have been exhausted. Now turn to the
+ -- algorithm D from the section of Knuth mentioned at the top of
+ -- this package.
+
+ Algorithm_D : declare
+ Dividend : UI_Vector (1 .. L_Length + 1);
+ Divisor : UI_Vector (1 .. R_Length);
+ Quotient : UI_Vector (1 .. Q_Length);
+ Divisor_Dig1 : Int;
+ Divisor_Dig2 : Int;
+ Q_Guess : Int;
+
+ begin
+ -- [ NORMALIZE ] (step D1 in the algorithm). First calculate the
+ -- scale d, and then multiply Left and Right (u and v in the book)
+ -- by d to get the dividend and divisor to work with.
+
+ D := Base / (abs R_Vec (1) + 1);
+
+ Dividend (1) := 0;
+ Dividend (2) := abs L_Vec (1);
+
+ for J in 3 .. L_Length + Int_1 loop
+ Dividend (J) := L_Vec (J - 1);
+ end loop;
+
+ Divisor (1) := abs R_Vec (1);
+
+ for J in Int_2 .. R_Length loop
+ Divisor (J) := R_Vec (J);
+ end loop;
+
+ if D > Int_1 then
+
+ -- Multiply Dividend by D
+
+ Carry := 0;
+ for J in reverse Dividend'Range loop
+ Tmp_Int := Dividend (J) * D + Carry;
+ Dividend (J) := Tmp_Int rem Base;
+ Carry := Tmp_Int / Base;
+ end loop;
+
+ -- Multiply Divisor by d.
+
+ Carry := 0;
+ for J in reverse Divisor'Range loop
+ Tmp_Int := Divisor (J) * D + Carry;
+ Divisor (J) := Tmp_Int rem Base;
+ Carry := Tmp_Int / Base;
+ end loop;
+ end if;
+
+ -- Main loop of long division algorithm.
+
+ Divisor_Dig1 := Divisor (1);
+ Divisor_Dig2 := Divisor (2);
+
+ for J in Quotient'Range loop
+
+ -- [ CALCULATE Q (hat) ] (step D3 in the algorithm).
+
+ Tmp_Int := Dividend (J) * Base + Dividend (J + 1);
+
+ -- Initial guess
+
+ if Dividend (J) = Divisor_Dig1 then
+ Q_Guess := Base - 1;
+ else
+ Q_Guess := Tmp_Int / Divisor_Dig1;
+ end if;
+
+ -- Refine the guess
+
+ while Divisor_Dig2 * Q_Guess >
+ (Tmp_Int - Q_Guess * Divisor_Dig1) * Base +
+ Dividend (J + 2)
+ loop
+ Q_Guess := Q_Guess - 1;
+ end loop;
+
+ -- [ MULTIPLY & SUBTRACT] (step D4). Q_Guess * Divisor is
+ -- subtracted from the remaining dividend.
+
+ Carry := 0;
+ for K in reverse Divisor'Range loop
+ Tmp_Int := Dividend (J + K) - Q_Guess * Divisor (K) + Carry;
+ Tmp_Dig := Tmp_Int rem Base;
+ Carry := Tmp_Int / Base;
+
+ if Tmp_Dig < Int_0 then
+ Tmp_Dig := Tmp_Dig + Base;
+ Carry := Carry - 1;
+ end if;
+
+ Dividend (J + K) := Tmp_Dig;
+ end loop;
+
+ Dividend (J) := Dividend (J) + Carry;
+
+ -- [ TEST REMAINDER ] & [ ADD BACK ] (steps D5 and D6)
+ -- Here there is a slight difference from the book: the last
+ -- carry is always added in above and below (cancelling each
+ -- other). In fact the dividend going negative is used as
+ -- the test.
+
+ -- If the Dividend went negative, then Q_Guess was off by
+ -- one, so it is decremented, and the divisor is added back
+ -- into the relevant portion of the dividend.
+
+ if Dividend (J) < Int_0 then
+ Q_Guess := Q_Guess - 1;
+
+ Carry := 0;
+ for K in reverse Divisor'Range loop
+ Tmp_Int := Dividend (J + K) + Divisor (K) + Carry;
+
+ if Tmp_Int >= Base then
+ Tmp_Int := Tmp_Int - Base;
+ Carry := 1;
+ else
+ Carry := 0;
+ end if;
+
+ Dividend (J + K) := Tmp_Int;
+ end loop;
+
+ Dividend (J) := Dividend (J) + Carry;
+ end if;
+
+ -- Finally we can get the next quotient digit
+
+ Quotient (J) := Q_Guess;
+ end loop;
+
+ return Vector_To_Uint
+ (Quotient, (L_Vec (1) < Int_0 xor R_Vec (1) < Int_0));
+
+ end Algorithm_D;
+ end;
+ end UI_Div;
+
+ ------------
+ -- UI_Eq --
+ ------------
+
+ function UI_Eq (Left : Int; Right : Uint) return Boolean is
+ begin
+ return not UI_Ne (UI_From_Int (Left), Right);
+ end UI_Eq;
+
+ function UI_Eq (Left : Uint; Right : Int) return Boolean is
+ begin
+ return not UI_Ne (Left, UI_From_Int (Right));
+ end UI_Eq;
+
+ function UI_Eq (Left : Uint; Right : Uint) return Boolean is
+ begin
+ return not UI_Ne (Left, Right);
+ end UI_Eq;
+
+ --------------
+ -- UI_Expon --
+ --------------
+
+ function UI_Expon (Left : Int; Right : Uint) return Uint is
+ begin
+ return UI_Expon (UI_From_Int (Left), Right);
+ end UI_Expon;
+
+ function UI_Expon (Left : Uint; Right : Int) return Uint is
+ begin
+ return UI_Expon (Left, UI_From_Int (Right));
+ end UI_Expon;
+
+ function UI_Expon (Left : Int; Right : Int) return Uint is
+ begin
+ return UI_Expon (UI_From_Int (Left), UI_From_Int (Right));
+ end UI_Expon;
+
+ function UI_Expon (Left : Uint; Right : Uint) return Uint is
+ begin
+ pragma Assert (Right >= Uint_0);
+
+ -- Any value raised to power of 0 is 1
+
+ if Right = Uint_0 then
+ return Uint_1;
+
+ -- 0 to any positive power is 0.
+
+ elsif Left = Uint_0 then
+ return Uint_0;
+
+ -- 1 to any power is 1
+
+ elsif Left = Uint_1 then
+ return Uint_1;
+
+ -- Any value raised to power of 1 is that value
+
+ elsif Right = Uint_1 then
+ return Left;
+
+ -- Cases which can be done by table lookup
+
+ elsif Right <= Uint_64 then
+
+ -- 2 ** N for N in 2 .. 64
+
+ if Left = Uint_2 then
+ declare
+ Right_Int : constant Int := Direct_Val (Right);
+
+ begin
+ if Right_Int > UI_Power_2_Set then
+ for J in UI_Power_2_Set + Int_1 .. Right_Int loop
+ UI_Power_2 (J) := UI_Power_2 (J - Int_1) * Int_2;
+ Uints_Min := Uints.Last;
+ Udigits_Min := Udigits.Last;
+ end loop;
+
+ UI_Power_2_Set := Right_Int;
+ end if;
+
+ return UI_Power_2 (Right_Int);
+ end;
+
+ -- 10 ** N for N in 2 .. 64
+
+ elsif Left = Uint_10 then
+ declare
+ Right_Int : constant Int := Direct_Val (Right);
+
+ begin
+ if Right_Int > UI_Power_10_Set then
+ for J in UI_Power_10_Set + Int_1 .. Right_Int loop
+ UI_Power_10 (J) := UI_Power_10 (J - Int_1) * Int (10);
+ Uints_Min := Uints.Last;
+ Udigits_Min := Udigits.Last;
+ end loop;
+
+ UI_Power_10_Set := Right_Int;
+ end if;
+
+ return UI_Power_10 (Right_Int);
+ end;
+ end if;
+ end if;
+
+ -- If we fall through, then we have the general case (see Knuth 4.6.3)
+
+ declare
+ N : Uint := Right;
+ Squares : Uint := Left;
+ Result : Uint := Uint_1;
+ M : constant Uintp.Save_Mark := Uintp.Mark;
+
+ begin
+ loop
+ if (Least_Sig_Digit (N) mod Int_2) = Int_1 then
+ Result := Result * Squares;
+ end if;
+
+ N := N / Uint_2;
+ exit when N = Uint_0;
+ Squares := Squares * Squares;
+ end loop;
+
+ Uintp.Release_And_Save (M, Result);
+ return Result;
+ end;
+ end UI_Expon;
+
+ ------------------
+ -- UI_From_Dint --
+ ------------------
+
+ function UI_From_Dint (Input : Dint) return Uint is
+ begin
+
+ if Dint (Min_Direct) <= Input and then Input <= Dint (Max_Direct) then
+ return Uint (Dint (Uint_Direct_Bias) + Input);
+
+ -- For values of larger magnitude, compute digits into a vector and
+ -- call Vector_To_Uint.
+
+ else
+ declare
+ Max_For_Dint : constant := 5;
+ -- Base is defined so that 5 Uint digits is sufficient
+ -- to hold the largest possible Dint value.
+
+ V : UI_Vector (1 .. Max_For_Dint);
+
+ Temp_Integer : Dint;
+
+ begin
+ for J in V'Range loop
+ V (J) := 0;
+ end loop;
+
+ Temp_Integer := Input;
+
+ for J in reverse V'Range loop
+ V (J) := Int (abs (Temp_Integer rem Dint (Base)));
+ Temp_Integer := Temp_Integer / Dint (Base);
+ end loop;
+
+ return Vector_To_Uint (V, Input < Dint'(0));
+ end;
+ end if;
+ end UI_From_Dint;
+
+ -----------------
+ -- UI_From_Int --
+ -----------------
+
+ function UI_From_Int (Input : Int) return Uint is
+ begin
+
+ if Min_Direct <= Input and then Input <= Max_Direct then
+ return Uint (Int (Uint_Direct_Bias) + Input);
+
+ -- For values of larger magnitude, compute digits into a vector and
+ -- call Vector_To_Uint.
+
+ else
+ declare
+ Max_For_Int : constant := 3;
+ -- Base is defined so that 3 Uint digits is sufficient
+ -- to hold the largest possible Int value.
+
+ V : UI_Vector (1 .. Max_For_Int);
+
+ Temp_Integer : Int;
+
+ begin
+ for J in V'Range loop
+ V (J) := 0;
+ end loop;
+
+ Temp_Integer := Input;
+
+ for J in reverse V'Range loop
+ V (J) := abs (Temp_Integer rem Base);
+ Temp_Integer := Temp_Integer / Base;
+ end loop;
+
+ return Vector_To_Uint (V, Input < Int_0);
+ end;
+ end if;
+ end UI_From_Int;
+
+ ------------
+ -- UI_GCD --
+ ------------
+
+ -- Lehmer's algorithm for GCD.
+
+ -- The idea is to avoid using multiple precision arithmetic wherever
+ -- possible, substituting Int arithmetic instead. See Knuth volume II,
+ -- Algorithm L (page 329).
+
+ -- We use the same notation as Knuth (U_Hat standing for the obvious!)
+
+ function UI_GCD (Uin, Vin : Uint) return Uint is
+ U, V : Uint;
+ -- Copies of Uin and Vin
+
+ U_Hat, V_Hat : Int;
+ -- The most Significant digits of U,V
+
+ A, B, C, D, T, Q, Den1, Den2 : Int;
+
+ Tmp_UI : Uint;
+ Marks : constant Uintp.Save_Mark := Uintp.Mark;
+ Iterations : Integer := 0;
+
+ begin
+ pragma Assert (Uin >= Vin);
+ pragma Assert (Vin >= Uint_0);
+
+ U := Uin;
+ V := Vin;
+
+ loop
+ Iterations := Iterations + 1;
+
+ if Direct (V) then
+ if V = Uint_0 then
+ return U;
+ else
+ return
+ UI_From_Int (GCD (Direct_Val (V), UI_To_Int (U rem V)));
+ end if;
+ end if;
+
+ Most_Sig_2_Digits (U, V, U_Hat, V_Hat);
+ A := 1;
+ B := 0;
+ C := 0;
+ D := 1;
+
+ loop
+ -- We might overflow and get division by zero here. This just
+ -- means we can not take the single precision step
+
+ Den1 := V_Hat + C;
+ Den2 := V_Hat + D;
+ exit when (Den1 * Den2) = Int_0;
+
+ -- Compute Q, the trial quotient
+
+ Q := (U_Hat + A) / Den1;
+
+ exit when Q /= ((U_Hat + B) / Den2);
+
+ -- A single precision step Euclid step will give same answer as
+ -- a multiprecision one.
+
+ T := A - (Q * C);
+ A := C;
+ C := T;
+
+ T := B - (Q * D);
+ B := D;
+ D := T;
+
+ T := U_Hat - (Q * V_Hat);
+ U_Hat := V_Hat;
+ V_Hat := T;
+
+ end loop;
+
+ -- Take a multiprecision Euclid step
+
+ if B = Int_0 then
+
+ -- No single precision steps take a regular Euclid step.
+
+ Tmp_UI := U rem V;
+ U := V;
+ V := Tmp_UI;
+
+ else
+ -- Use prior single precision steps to compute this Euclid step.
+
+ -- Fixed bug 1415-008 spends 80% of its time working on this
+ -- step. Perhaps we need a special case Int / Uint dot
+ -- product to speed things up. ???
+
+ -- Alternatively we could increase the single precision
+ -- iterations to handle Uint's of some small size ( <5
+ -- digits?). Then we would have more iterations on small Uint.
+ -- Fixed bug 1415-008 only gets 5 (on average) single
+ -- precision iterations per large iteration. ???
+
+ Tmp_UI := (UI_From_Int (A) * U) + (UI_From_Int (B) * V);
+ V := (UI_From_Int (C) * U) + (UI_From_Int (D) * V);
+ U := Tmp_UI;
+ end if;
+
+ -- If the operands are very different in magnitude, the loop
+ -- will generate large amounts of short-lived data, which it is
+ -- worth removing periodically.
+
+ if Iterations > 100 then
+ Release_And_Save (Marks, U, V);
+ Iterations := 0;
+ end if;
+ end loop;
+ end UI_GCD;
+
+ ------------
+ -- UI_Ge --
+ ------------
+
+ function UI_Ge (Left : Int; Right : Uint) return Boolean is
+ begin
+ return not UI_Lt (UI_From_Int (Left), Right);
+ end UI_Ge;
+
+ function UI_Ge (Left : Uint; Right : Int) return Boolean is
+ begin
+ return not UI_Lt (Left, UI_From_Int (Right));
+ end UI_Ge;
+
+ function UI_Ge (Left : Uint; Right : Uint) return Boolean is
+ begin
+ return not UI_Lt (Left, Right);
+ end UI_Ge;
+
+ ------------
+ -- UI_Gt --
+ ------------
+
+ function UI_Gt (Left : Int; Right : Uint) return Boolean is
+ begin
+ return UI_Lt (Right, UI_From_Int (Left));
+ end UI_Gt;
+
+ function UI_Gt (Left : Uint; Right : Int) return Boolean is
+ begin
+ return UI_Lt (UI_From_Int (Right), Left);
+ end UI_Gt;
+
+ function UI_Gt (Left : Uint; Right : Uint) return Boolean is
+ begin
+ return UI_Lt (Right, Left);
+ end UI_Gt;
+
+ ---------------
+ -- UI_Image --
+ ---------------
+
+ procedure UI_Image (Input : Uint; Format : UI_Format := Auto) is
+ begin
+ Image_Out (Input, True, Format);
+ end UI_Image;
+
+ -------------------------
+ -- UI_Is_In_Int_Range --
+ -------------------------
+
+ function UI_Is_In_Int_Range (Input : Uint) return Boolean is
+ begin
+ -- Make sure we don't get called before Initialize
+
+ pragma Assert (Uint_Int_First /= Uint_0);
+
+ if Direct (Input) then
+ return True;
+ else
+ return Input >= Uint_Int_First
+ and then Input <= Uint_Int_Last;
+ end if;
+ end UI_Is_In_Int_Range;
+
+ ------------
+ -- UI_Le --
+ ------------
+
+ function UI_Le (Left : Int; Right : Uint) return Boolean is
+ begin
+ return not UI_Lt (Right, UI_From_Int (Left));
+ end UI_Le;
+
+ function UI_Le (Left : Uint; Right : Int) return Boolean is
+ begin
+ return not UI_Lt (UI_From_Int (Right), Left);
+ end UI_Le;
+
+ function UI_Le (Left : Uint; Right : Uint) return Boolean is
+ begin
+ return not UI_Lt (Right, Left);
+ end UI_Le;
+
+ ------------
+ -- UI_Lt --
+ ------------
+
+ function UI_Lt (Left : Int; Right : Uint) return Boolean is
+ begin
+ return UI_Lt (UI_From_Int (Left), Right);
+ end UI_Lt;
+
+ function UI_Lt (Left : Uint; Right : Int) return Boolean is
+ begin
+ return UI_Lt (Left, UI_From_Int (Right));
+ end UI_Lt;
+
+ function UI_Lt (Left : Uint; Right : Uint) return Boolean is
+ begin
+ -- Quick processing for identical arguments
+
+ if Int (Left) = Int (Right) then
+ return False;
+
+ -- Quick processing for both arguments directly represented
+
+ elsif Direct (Left) and then Direct (Right) then
+ return Int (Left) < Int (Right);
+
+ -- At least one argument is more than one digit long
+
+ else
+ declare
+ L_Length : constant Int := N_Digits (Left);
+ R_Length : constant Int := N_Digits (Right);
+
+ L_Vec : UI_Vector (1 .. L_Length);
+ R_Vec : UI_Vector (1 .. R_Length);
+
+ begin
+ Init_Operand (Left, L_Vec);
+ Init_Operand (Right, R_Vec);
+
+ if L_Vec (1) < Int_0 then
+
+ -- First argument negative, second argument non-negative
+
+ if R_Vec (1) >= Int_0 then
+ return True;
+
+ -- Both arguments negative
+
+ else
+ if L_Length /= R_Length then
+ return L_Length > R_Length;
+
+ elsif L_Vec (1) /= R_Vec (1) then
+ return L_Vec (1) < R_Vec (1);
+
+ else
+ for J in 2 .. L_Vec'Last loop
+ if L_Vec (J) /= R_Vec (J) then
+ return L_Vec (J) > R_Vec (J);
+ end if;
+ end loop;
+
+ return False;
+ end if;
+ end if;
+
+ else
+ -- First argument non-negative, second argument negative
+
+ if R_Vec (1) < Int_0 then
+ return False;
+
+ -- Both arguments non-negative
+
+ else
+ if L_Length /= R_Length then
+ return L_Length < R_Length;
+ else
+ for J in L_Vec'Range loop
+ if L_Vec (J) /= R_Vec (J) then
+ return L_Vec (J) < R_Vec (J);
+ end if;
+ end loop;
+
+ return False;
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
+ end UI_Lt;
+
+ ------------
+ -- UI_Max --
+ ------------
+
+ function UI_Max (Left : Int; Right : Uint) return Uint is
+ begin
+ return UI_Max (UI_From_Int (Left), Right);
+ end UI_Max;
+
+ function UI_Max (Left : Uint; Right : Int) return Uint is
+ begin
+ return UI_Max (Left, UI_From_Int (Right));
+ end UI_Max;
+
+ function UI_Max (Left : Uint; Right : Uint) return Uint is
+ begin
+ if Left >= Right then
+ return Left;
+ else
+ return Right;
+ end if;
+ end UI_Max;
+
+ ------------
+ -- UI_Min --
+ ------------
+
+ function UI_Min (Left : Int; Right : Uint) return Uint is
+ begin
+ return UI_Min (UI_From_Int (Left), Right);
+ end UI_Min;
+
+ function UI_Min (Left : Uint; Right : Int) return Uint is
+ begin
+ return UI_Min (Left, UI_From_Int (Right));
+ end UI_Min;
+
+ function UI_Min (Left : Uint; Right : Uint) return Uint is
+ begin
+ if Left <= Right then
+ return Left;
+ else
+ return Right;
+ end if;
+ end UI_Min;
+
+ -------------
+ -- UI_Mod --
+ -------------
+
+ function UI_Mod (Left : Int; Right : Uint) return Uint is
+ begin
+ return UI_Mod (UI_From_Int (Left), Right);
+ end UI_Mod;
+
+ function UI_Mod (Left : Uint; Right : Int) return Uint is
+ begin
+ return UI_Mod (Left, UI_From_Int (Right));
+ end UI_Mod;
+
+ function UI_Mod (Left : Uint; Right : Uint) return Uint is
+ Urem : constant Uint := Left rem Right;
+
+ begin
+ if (Left < Uint_0) = (Right < Uint_0)
+ or else Urem = Uint_0
+ then
+ return Urem;
+ else
+ return Right + Urem;
+ end if;
+ end UI_Mod;
+
+ ------------
+ -- UI_Mul --
+ ------------
+
+ function UI_Mul (Left : Int; Right : Uint) return Uint is
+ begin
+ return UI_Mul (UI_From_Int (Left), Right);
+ end UI_Mul;
+
+ function UI_Mul (Left : Uint; Right : Int) return Uint is
+ begin
+ return UI_Mul (Left, UI_From_Int (Right));
+ end UI_Mul;
+
+ function UI_Mul (Left : Uint; Right : Uint) return Uint is
+ begin
+ -- Simple case of single length operands
+
+ if Direct (Left) and then Direct (Right) then
+ return
+ UI_From_Dint
+ (Dint (Direct_Val (Left)) * Dint (Direct_Val (Right)));
+ end if;
+
+ -- Otherwise we have the general case (Algorithm M in Knuth)
+
+ declare
+ L_Length : constant Int := N_Digits (Left);
+ R_Length : constant Int := N_Digits (Right);
+ L_Vec : UI_Vector (1 .. L_Length);
+ R_Vec : UI_Vector (1 .. R_Length);
+ Neg : Boolean;
+
+ begin
+ Init_Operand (Left, L_Vec);
+ Init_Operand (Right, R_Vec);
+ Neg := (L_Vec (1) < Int_0) xor (R_Vec (1) < Int_0);
+ L_Vec (1) := abs (L_Vec (1));
+ R_Vec (1) := abs (R_Vec (1));
+
+ Algorithm_M : declare
+ Product : UI_Vector (1 .. L_Length + R_Length);
+ Tmp_Sum : Int;
+ Carry : Int;
+
+ begin
+ for J in Product'Range loop
+ Product (J) := 0;
+ end loop;
+
+ for J in reverse R_Vec'Range loop
+ Carry := 0;
+ for K in reverse L_Vec'Range loop
+ Tmp_Sum :=
+ L_Vec (K) * R_Vec (J) + Product (J + K) + Carry;
+ Product (J + K) := Tmp_Sum rem Base;
+ Carry := Tmp_Sum / Base;
+ end loop;
+
+ Product (J) := Carry;
+ end loop;
+
+ return Vector_To_Uint (Product, Neg);
+ end Algorithm_M;
+ end;
+ end UI_Mul;
+
+ ------------
+ -- UI_Ne --
+ ------------
+
+ function UI_Ne (Left : Int; Right : Uint) return Boolean is
+ begin
+ return UI_Ne (UI_From_Int (Left), Right);
+ end UI_Ne;
+
+ function UI_Ne (Left : Uint; Right : Int) return Boolean is
+ begin
+ return UI_Ne (Left, UI_From_Int (Right));
+ end UI_Ne;
+
+ function UI_Ne (Left : Uint; Right : Uint) return Boolean is
+ begin
+ -- Quick processing for identical arguments. Note that this takes
+ -- care of the case of two No_Uint arguments.
+
+ if Int (Left) = Int (Right) then
+ return False;
+ end if;
+
+ -- See if left operand directly represented
+
+ if Direct (Left) then
+
+ -- If right operand directly represented then compare
+
+ if Direct (Right) then
+ return Int (Left) /= Int (Right);
+
+ -- Left operand directly represented, right not, must be unequal
+
+ else
+ return True;
+ end if;
+
+ -- Right operand directly represented, left not, must be unequal
+
+ elsif Direct (Right) then
+ return True;
+ end if;
+
+ -- Otherwise both multi-word, do comparison
+
+ declare
+ Size : constant Int := N_Digits (Left);
+ Left_Loc : Int;
+ Right_Loc : Int;
+
+ begin
+ if Size /= N_Digits (Right) then
+ return True;
+ end if;
+
+ Left_Loc := Uints.Table (Left).Loc;
+ Right_Loc := Uints.Table (Right).Loc;
+
+ for J in Int_0 .. Size - Int_1 loop
+ if Udigits.Table (Left_Loc + J) /=
+ Udigits.Table (Right_Loc + J)
+ then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end;
+ end UI_Ne;
+
+ ----------------
+ -- UI_Negate --
+ ----------------
+
+ function UI_Negate (Right : Uint) return Uint is
+ begin
+ -- Case where input is directly represented. Note that since the
+ -- range of Direct values is non-symmetrical, the result may not
+ -- be directly represented, this is taken care of in UI_From_Int.
+
+ if Direct (Right) then
+ return UI_From_Int (-Direct_Val (Right));
+
+ -- Full processing for multi-digit case. Note that we cannot just
+ -- copy the value to the end of the table negating the first digit,
+ -- since the range of Direct values is non-symmetrical, so we can
+ -- have a negative value that is not Direct whose negation can be
+ -- represented directly.
+
+ else
+ declare
+ R_Length : constant Int := N_Digits (Right);
+ R_Vec : UI_Vector (1 .. R_Length);
+ Neg : Boolean;
+
+ begin
+ Init_Operand (Right, R_Vec);
+ Neg := R_Vec (1) > Int_0;
+ R_Vec (1) := abs R_Vec (1);
+ return Vector_To_Uint (R_Vec, Neg);
+ end;
+ end if;
+ end UI_Negate;
+
+ -------------
+ -- UI_Rem --
+ -------------
+
+ function UI_Rem (Left : Int; Right : Uint) return Uint is
+ begin
+ return UI_Rem (UI_From_Int (Left), Right);
+ end UI_Rem;
+
+ function UI_Rem (Left : Uint; Right : Int) return Uint is
+ begin
+ return UI_Rem (Left, UI_From_Int (Right));
+ end UI_Rem;
+
+ function UI_Rem (Left, Right : Uint) return Uint is
+ Sign : Int;
+ Tmp : Int;
+
+ subtype Int1_12 is Integer range 1 .. 12;
+
+ begin
+ pragma Assert (Right /= Uint_0);
+
+ if Direct (Right) then
+ if Direct (Left) then
+ return UI_From_Int (Direct_Val (Left) rem Direct_Val (Right));
+
+ else
+ -- Special cases when Right is less than 13 and Left is larger
+ -- larger than one digit. All of these algorithms depend on the
+ -- base being 2 ** 15 We work with Abs (Left) and Abs(Right)
+ -- then multiply result by Sign (Left)
+
+ if (Right <= Uint_12) and then (Right >= Uint_Minus_12) then
+
+ if (Left < Uint_0) then
+ Sign := -1;
+ else
+ Sign := 1;
+ end if;
+
+ -- All cases are listed, grouped by mathematical method
+ -- It is not inefficient to do have this case list out
+ -- of order since GCC sorts the cases we list.
+
+ case Int1_12 (abs (Direct_Val (Right))) is
+
+ when 1 =>
+ return Uint_0;
+
+ -- Powers of two are simple AND's with LS Left Digit
+ -- GCC will recognise these constants as powers of 2
+ -- and replace the rem with simpler operations where
+ -- possible.
+
+ -- Least_Sig_Digit might return Negative numbers.
+
+ when 2 =>
+ return UI_From_Int (
+ Sign * (Least_Sig_Digit (Left) mod 2));
+
+ when 4 =>
+ return UI_From_Int (
+ Sign * (Least_Sig_Digit (Left) mod 4));
+
+ when 8 =>
+ return UI_From_Int (
+ Sign * (Least_Sig_Digit (Left) mod 8));
+
+ -- Some number theoretical tricks:
+
+ -- If B Rem Right = 1 then
+ -- Left Rem Right = Sum_Of_Digits_Base_B (Left) Rem Right
+
+ -- Note: 2^32 mod 3 = 1
+
+ when 3 =>
+ return UI_From_Int (
+ Sign * (Sum_Double_Digits (Left, 1) rem Int (3)));
+
+ -- Note: 2^15 mod 7 = 1
+
+ when 7 =>
+ return UI_From_Int (
+ Sign * (Sum_Digits (Left, 1) rem Int (7)));
+
+ -- Note: 2^32 mod 5 = -1
+ -- Alternating sums might be negative, but rem is always
+ -- positive hence we must use mod here.
+
+ when 5 =>
+ Tmp := Sum_Double_Digits (Left, -1) mod Int (5);
+ return UI_From_Int (Sign * Tmp);
+
+ -- Note: 2^15 mod 9 = -1
+ -- Alternating sums might be negative, but rem is always
+ -- positive hence we must use mod here.
+
+ when 9 =>
+ Tmp := Sum_Digits (Left, -1) mod Int (9);
+ return UI_From_Int (Sign * Tmp);
+
+ -- Note: 2^15 mod 11 = -1
+ -- Alternating sums might be negative, but rem is always
+ -- positive hence we must use mod here.
+
+ when 11 =>
+ Tmp := Sum_Digits (Left, -1) mod Int (11);
+ return UI_From_Int (Sign * Tmp);
+
+ -- Now resort to Chinese Remainder theorem
+ -- to reduce 6, 10, 12 to previous special cases
+
+ -- There is no reason we could not add more cases
+ -- like these if it proves useful.
+
+ -- Perhaps we should go up to 16, however
+ -- I have no "trick" for 13.
+
+ -- To find u mod m we:
+ -- Pick m1, m2 S.T.
+ -- GCD(m1, m2) = 1 AND m = (m1 * m2).
+ -- Next we pick (Basis) M1, M2 small S.T.
+ -- (M1 mod m1) = (M2 mod m2) = 1 AND
+ -- (M1 mod m2) = (M2 mod m1) = 0
+
+ -- So u mod m = (u1 * M1 + u2 * M2) mod m
+ -- Where u1 = (u mod m1) AND u2 = (u mod m2);
+ -- Under typical circumstances the last mod m
+ -- can be done with a (possible) single subtraction.
+
+ -- m1 = 2; m2 = 3; M1 = 3; M2 = 4;
+
+ when 6 =>
+ Tmp := 3 * (Least_Sig_Digit (Left) rem 2) +
+ 4 * (Sum_Double_Digits (Left, 1) rem 3);
+ return UI_From_Int (Sign * (Tmp rem 6));
+
+ -- m1 = 2; m2 = 5; M1 = 5; M2 = 6;
+
+ when 10 =>
+ Tmp := 5 * (Least_Sig_Digit (Left) rem 2) +
+ 6 * (Sum_Double_Digits (Left, -1) mod 5);
+ return UI_From_Int (Sign * (Tmp rem 10));
+
+ -- m1 = 3; m2 = 4; M1 = 4; M2 = 9;
+
+ when 12 =>
+ Tmp := 4 * (Sum_Double_Digits (Left, 1) rem 3) +
+ 9 * (Least_Sig_Digit (Left) rem 4);
+ return UI_From_Int (Sign * (Tmp rem 12));
+ end case;
+
+ end if;
+
+ -- Else fall through to general case.
+
+ -- ???This needs to be improved. We have the Rem when we do the
+ -- Div. Div throws it away!
+
+ -- The special case Length (Left) = Length(right) = 1 in Div
+ -- looks slow. It uses UI_To_Int when Int should suffice. ???
+ end if;
+ end if;
+
+ return Left - (Left / Right) * Right;
+ end UI_Rem;
+
+ ------------
+ -- UI_Sub --
+ ------------
+
+ function UI_Sub (Left : Int; Right : Uint) return Uint is
+ begin
+ return UI_Add (Left, -Right);
+ end UI_Sub;
+
+ function UI_Sub (Left : Uint; Right : Int) return Uint is
+ begin
+ return UI_Add (Left, -Right);
+ end UI_Sub;
+
+ function UI_Sub (Left : Uint; Right : Uint) return Uint is
+ begin
+ if Direct (Left) and then Direct (Right) then
+ return UI_From_Int (Direct_Val (Left) - Direct_Val (Right));
+ else
+ return UI_Add (Left, -Right);
+ end if;
+ end UI_Sub;
+
+ ----------------
+ -- UI_To_Int --
+ ----------------
+
+ function UI_To_Int (Input : Uint) return Int is
+ begin
+ if Direct (Input) then
+ return Direct_Val (Input);
+
+ -- Case of input is more than one digit
+
+ else
+ declare
+ In_Length : constant Int := N_Digits (Input);
+ In_Vec : UI_Vector (1 .. In_Length);
+ Ret_Int : Int;
+
+ begin
+ -- Uints of more than one digit could be outside the range for
+ -- Ints. Caller should have checked for this if not certain.
+ -- Fatal error to attempt to convert from value outside Int'Range.
+
+ pragma Assert (UI_Is_In_Int_Range (Input));
+
+ -- Otherwise, proceed ahead, we are OK
+
+ Init_Operand (Input, In_Vec);
+ Ret_Int := 0;
+
+ -- Calculate -|Input| and then negates if value is positive.
+ -- This handles our current definition of Int (based on
+ -- 2s complement). Is it secure enough?
+
+ for Idx in In_Vec'Range loop
+ Ret_Int := Ret_Int * Base - abs In_Vec (Idx);
+ end loop;
+
+ if In_Vec (1) < Int_0 then
+ return Ret_Int;
+ else
+ return -Ret_Int;
+ end if;
+ end;
+ end if;
+ end UI_To_Int;
+
+ --------------
+ -- UI_Write --
+ --------------
+
+ procedure UI_Write (Input : Uint; Format : UI_Format := Auto) is
+ begin
+ Image_Out (Input, False, Format);
+ end UI_Write;
+
+ ---------------------
+ -- Vector_To_Uint --
+ ---------------------
+
+ function Vector_To_Uint
+ (In_Vec : UI_Vector;
+ Negative : Boolean)
+ return Uint
+ is
+ Size : Int;
+ Val : Int;
+
+ begin
+ -- The vector can contain leading zeros. These are not stored in the
+ -- table, so loop through the vector looking for first non-zero digit
+
+ for J in In_Vec'Range loop
+ if In_Vec (J) /= Int_0 then
+
+ -- The length of the value is the length of the rest of the vector
+
+ Size := In_Vec'Last - J + 1;
+
+ -- One digit value can always be represented directly
+
+ if Size = Int_1 then
+ if Negative then
+ return Uint (Int (Uint_Direct_Bias) - In_Vec (J));
+ else
+ return Uint (Int (Uint_Direct_Bias) + In_Vec (J));
+ end if;
+
+ -- Positive two digit values may be in direct representation range
+
+ elsif Size = Int_2 and then not Negative then
+ Val := In_Vec (J) * Base + In_Vec (J + 1);
+
+ if Val <= Max_Direct then
+ return Uint (Int (Uint_Direct_Bias) + Val);
+ end if;
+ end if;
+
+ -- The value is outside the direct representation range and
+ -- must therefore be stored in the table. Expand the table
+ -- to contain the count and tigis. The index of the new table
+ -- entry will be returned as the result.
+
+ Uints.Increment_Last;
+ Uints.Table (Uints.Last).Length := Size;
+ Uints.Table (Uints.Last).Loc := Udigits.Last + 1;
+
+ Udigits.Increment_Last;
+
+ if Negative then
+ Udigits.Table (Udigits.Last) := -In_Vec (J);
+ else
+ Udigits.Table (Udigits.Last) := +In_Vec (J);
+ end if;
+
+ for K in 2 .. Size loop
+ Udigits.Increment_Last;
+ Udigits.Table (Udigits.Last) := In_Vec (J + K - 1);
+ end loop;
+
+ return Uints.Last;
+ end if;
+ end loop;
+
+ -- Dropped through loop only if vector contained all zeros
+
+ return Uint_0;
+ end Vector_To_Uint;
+
+end Uintp;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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)
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- U R E A L P --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.60 $
+-- --
+-- 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 Alloc;
+with Output; use Output;
+with Table;
+with Tree_IO; use Tree_IO;
+
+package body Urealp is
+
+ Ureal_First_Entry : constant Ureal := Ureal'Succ (No_Ureal);
+ -- First subscript allocated in Ureal table (note that we can't just
+ -- add 1 to No_Ureal, since "+" means something different for Ureals!
+
+ type Ureal_Entry is record
+ Num : Uint;
+ -- Numerator (always non-negative)
+
+ Den : Uint;
+ -- Denominator (always non-zero, always positive if base is zero)
+
+ Rbase : Nat;
+ -- Base value. If Rbase is zero, then the value is simply Num / Den.
+ -- If Rbase is non-zero, then the value is Num / (Rbase ** Den)
+
+ Negative : Boolean;
+ -- Flag set if value is negative
+
+ end record;
+
+ package Ureals is new Table.Table (
+ Table_Component_Type => Ureal_Entry,
+ Table_Index_Type => Ureal,
+ Table_Low_Bound => Ureal_First_Entry,
+ Table_Initial => Alloc.Ureals_Initial,
+ Table_Increment => Alloc.Ureals_Increment,
+ Table_Name => "Ureals");
+
+ -- The following universal reals are the values returned by the constant
+ -- functions. They are initialized by the initialization procedure.
+
+ UR_M_0 : Ureal;
+ UR_0 : Ureal;
+ UR_Tenth : Ureal;
+ UR_Half : Ureal;
+ UR_1 : Ureal;
+ UR_2 : Ureal;
+ UR_10 : Ureal;
+ UR_100 : Ureal;
+ UR_2_128 : Ureal;
+ UR_2_M_128 : Ureal;
+
+ Num_Ureal_Constants : constant := 10;
+ -- This is used for an assertion check in Tree_Read and Tree_Write to
+ -- help remember to add values to these routines when we add to the list.
+
+ Normalized_Real : Ureal := No_Ureal;
+ -- Used to memoize Norm_Num and Norm_Den, if either of these functions
+ -- is called, this value is set and Normalized_Entry contains the result
+ -- of the normalization. On subsequent calls, this is used to avoid the
+ -- call to Normalize if it has already been made.
+
+ Normalized_Entry : Ureal_Entry;
+ -- Entry built by most recent call to Normalize
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Decimal_Exponent_Hi (V : Ureal) return Int;
+ -- Returns an estimate of the exponent of Val represented as a normalized
+ -- decimal number (non-zero digit before decimal point), The estimate is
+ -- either correct, or high, but never low. The accuracy of the estimate
+ -- affects only the efficiency of the comparison routines.
+
+ function Decimal_Exponent_Lo (V : Ureal) return Int;
+ -- Returns an estimate of the exponent of Val represented as a normalized
+ -- decimal number (non-zero digit before decimal point), The estimate is
+ -- either correct, or low, but never high. The accuracy of the estimate
+ -- affects only the efficiency of the comparison routines.
+
+ function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int;
+ -- U is a Ureal entry for which the base value is non-zero, the value
+ -- returned is the equivalent decimal exponent value, i.e. the value of
+ -- Den, adjusted as though the base were base 10. The value is rounded
+ -- to the nearest integer, and so can be one off.
+
+ function Is_Integer (Num, Den : Uint) return Boolean;
+ -- Return true if the real quotient of Num / Den is an integer value
+
+ function Normalize (Val : Ureal_Entry) return Ureal_Entry;
+ -- Normalizes the Ureal_Entry by reducing it to lowest terms (with a
+ -- base value of 0).
+
+ function Same (U1, U2 : Ureal) return Boolean;
+ pragma Inline (Same);
+ -- Determines if U1 and U2 are the same Ureal. Note that we cannot use
+ -- the equals operator for this test, since that tests for equality,
+ -- not identity.
+
+ function Store_Ureal (Val : Ureal_Entry) return Ureal;
+ -- This store a new entry in the universal reals table and return
+ -- its index in the table.
+
+ -------------------------
+ -- Decimal_Exponent_Hi --
+ -------------------------
+
+ function Decimal_Exponent_Hi (V : Ureal) return Int is
+ Val : constant Ureal_Entry := Ureals.Table (V);
+
+ begin
+ -- Zero always returns zero
+
+ if UR_Is_Zero (V) then
+ return 0;
+
+ -- For numbers in rational form, get the maximum number of digits in the
+ -- numerator and the minimum number of digits in the denominator, and
+ -- subtract. For example:
+
+ -- 1000 / 99 = 1.010E+1
+ -- 9999 / 10 = 9.999E+2
+
+ -- This estimate may of course be high, but that is acceptable
+
+ elsif Val.Rbase = 0 then
+ return UI_Decimal_Digits_Hi (Val.Num) -
+ UI_Decimal_Digits_Lo (Val.Den);
+
+ -- For based numbers, just subtract the decimal exponent from the
+ -- high estimate of the number of digits in the numerator and add
+ -- one to accomodate possible round off errors for non-decimal
+ -- bases. For example:
+
+ -- 1_500_000 / 10**4 = 1.50E-2
+
+ else -- Val.Rbase /= 0
+ return UI_Decimal_Digits_Hi (Val.Num) -
+ Equivalent_Decimal_Exponent (Val) + 1;
+ end if;
+
+ end Decimal_Exponent_Hi;
+
+ -------------------------
+ -- Decimal_Exponent_Lo --
+ -------------------------
+
+ function Decimal_Exponent_Lo (V : Ureal) return Int is
+ Val : constant Ureal_Entry := Ureals.Table (V);
+
+ begin
+ -- Zero always returns zero
+
+ if UR_Is_Zero (V) then
+ return 0;
+
+ -- For numbers in rational form, get min digits in numerator, max digits
+ -- in denominator, and subtract and subtract one more for possible loss
+ -- during the division. For example:
+
+ -- 1000 / 99 = 1.010E+1
+ -- 9999 / 10 = 9.999E+2
+
+ -- This estimate may of course be low, but that is acceptable
+
+ elsif Val.Rbase = 0 then
+ return UI_Decimal_Digits_Lo (Val.Num) -
+ UI_Decimal_Digits_Hi (Val.Den) - 1;
+
+ -- For based numbers, just subtract the decimal exponent from the
+ -- low estimate of the number of digits in the numerator and subtract
+ -- one to accomodate possible round off errors for non-decimal
+ -- bases. For example:
+
+ -- 1_500_000 / 10**4 = 1.50E-2
+
+ else -- Val.Rbase /= 0
+ return UI_Decimal_Digits_Lo (Val.Num) -
+ Equivalent_Decimal_Exponent (Val) - 1;
+ end if;
+
+ end Decimal_Exponent_Lo;
+
+ -----------------
+ -- Denominator --
+ -----------------
+
+ function Denominator (Real : Ureal) return Uint is
+ begin
+ return Ureals.Table (Real).Den;
+ end Denominator;
+
+ ---------------------------------
+ -- Equivalent_Decimal_Exponent --
+ ---------------------------------
+
+ function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int is
+
+ -- The following table is a table of logs to the base 10
+
+ Logs : constant array (Nat range 1 .. 16) of Long_Float := (
+ 1 => 0.000000000000000,
+ 2 => 0.301029995663981,
+ 3 => 0.477121254719662,
+ 4 => 0.602059991327962,
+ 5 => 0.698970004336019,
+ 6 => 0.778151250383644,
+ 7 => 0.845098040014257,
+ 8 => 0.903089986991944,
+ 9 => 0.954242509439325,
+ 10 => 1.000000000000000,
+ 11 => 1.041392685158230,
+ 12 => 1.079181246047620,
+ 13 => 1.113943352306840,
+ 14 => 1.146128035678240,
+ 15 => 1.176091259055680,
+ 16 => 1.204119982655920);
+
+ begin
+ pragma Assert (U.Rbase /= 0);
+ return Int (Long_Float (UI_To_Int (U.Den)) * Logs (U.Rbase));
+ end Equivalent_Decimal_Exponent;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Ureals.Init;
+ UR_0 := UR_From_Components (Uint_0, Uint_1, 0, False);
+ UR_M_0 := UR_From_Components (Uint_0, Uint_1, 0, True);
+ UR_Half := UR_From_Components (Uint_1, Uint_1, 2, False);
+ UR_Tenth := UR_From_Components (Uint_1, Uint_1, 10, False);
+ UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False);
+ UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False);
+ UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False);
+ UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False);
+ UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False);
+ UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False);
+ end Initialize;
+
+ ----------------
+ -- Is_Integer --
+ ----------------
+
+ function Is_Integer (Num, Den : Uint) return Boolean is
+ begin
+ return (Num / Den) * Den = Num;
+ end Is_Integer;
+
+ ----------
+ -- Mark --
+ ----------
+
+ function Mark return Save_Mark is
+ begin
+ return Save_Mark (Ureals.Last);
+ end Mark;
+
+ --------------
+ -- Norm_Den --
+ --------------
+
+ function Norm_Den (Real : Ureal) return Uint is
+ begin
+ if not Same (Real, Normalized_Real) then
+ Normalized_Real := Real;
+ Normalized_Entry := Normalize (Ureals.Table (Real));
+ end if;
+
+ return Normalized_Entry.Den;
+ end Norm_Den;
+
+ --------------
+ -- Norm_Num --
+ --------------
+
+ function Norm_Num (Real : Ureal) return Uint is
+ begin
+ if not Same (Real, Normalized_Real) then
+ Normalized_Real := Real;
+ Normalized_Entry := Normalize (Ureals.Table (Real));
+ end if;
+
+ return Normalized_Entry.Num;
+ end Norm_Num;
+
+ ---------------
+ -- Normalize --
+ ---------------
+
+ function Normalize (Val : Ureal_Entry) return Ureal_Entry is
+ J : Uint;
+ K : Uint;
+ Tmp : Uint;
+ Num : Uint;
+ Den : Uint;
+ M : constant Uintp.Save_Mark := Uintp.Mark;
+
+ begin
+ -- Start by setting J to the greatest of the absolute values of the
+ -- numerator and the denominator (taking into account the base value),
+ -- and K to the lesser of the two absolute values. The gcd of Num and
+ -- Den is the gcd of J and K.
+
+ if Val.Rbase = 0 then
+ J := Val.Num;
+ K := Val.Den;
+
+ elsif Val.Den < 0 then
+ J := Val.Num * Val.Rbase ** (-Val.Den);
+ K := Uint_1;
+
+ else
+ J := Val.Num;
+ K := Val.Rbase ** Val.Den;
+ end if;
+
+ Num := J;
+ Den := K;
+
+ if K > J then
+ Tmp := J;
+ J := K;
+ K := Tmp;
+ end if;
+
+ J := UI_GCD (J, K);
+ Num := Num / J;
+ Den := Den / J;
+ Uintp.Release_And_Save (M, Num, Den);
+
+ -- Divide numerator and denominator by gcd and return result
+
+ return (Num => Num,
+ Den => Den,
+ Rbase => 0,
+ Negative => Val.Negative);
+ end Normalize;
+
+ ---------------
+ -- Numerator --
+ ---------------
+
+ function Numerator (Real : Ureal) return Uint is
+ begin
+ return Ureals.Table (Real).Num;
+ end Numerator;
+
+ --------
+ -- pr --
+ --------
+
+ procedure pr (Real : Ureal) is
+ begin
+ UR_Write (Real);
+ Write_Eol;
+ end pr;
+
+ -----------
+ -- Rbase --
+ -----------
+
+ function Rbase (Real : Ureal) return Nat is
+ begin
+ return Ureals.Table (Real).Rbase;
+ end Rbase;
+
+ -------------
+ -- Release --
+ -------------
+
+ procedure Release (M : Save_Mark) is
+ begin
+ Ureals.Set_Last (Ureal (M));
+ end Release;
+
+ ----------
+ -- Same --
+ ----------
+
+ function Same (U1, U2 : Ureal) return Boolean is
+ begin
+ return Int (U1) = Int (U2);
+ end Same;
+
+ -----------------
+ -- Store_Ureal --
+ -----------------
+
+ function Store_Ureal (Val : Ureal_Entry) return Ureal is
+ begin
+ Ureals.Increment_Last;
+ Ureals.Table (Ureals.Last) := Val;
+
+ -- Normalize representation of signed values
+
+ if Val.Num < 0 then
+ Ureals.Table (Ureals.Last).Negative := True;
+ Ureals.Table (Ureals.Last).Num := -Val.Num;
+ end if;
+
+ return Ureals.Last;
+ end Store_Ureal;
+
+ ---------------
+ -- Tree_Read --
+ ---------------
+
+ procedure Tree_Read is
+ begin
+ pragma Assert (Num_Ureal_Constants = 10);
+
+ Ureals.Tree_Read;
+ Tree_Read_Int (Int (UR_0));
+ Tree_Read_Int (Int (UR_M_0));
+ Tree_Read_Int (Int (UR_Tenth));
+ Tree_Read_Int (Int (UR_Half));
+ Tree_Read_Int (Int (UR_1));
+ Tree_Read_Int (Int (UR_2));
+ Tree_Read_Int (Int (UR_10));
+ Tree_Read_Int (Int (UR_100));
+ Tree_Read_Int (Int (UR_2_128));
+ Tree_Read_Int (Int (UR_2_M_128));
+
+ -- Clear the normalization cache
+
+ Normalized_Real := No_Ureal;
+ end Tree_Read;
+
+ ----------------
+ -- Tree_Write --
+ ----------------
+
+ procedure Tree_Write is
+ begin
+ pragma Assert (Num_Ureal_Constants = 10);
+
+ Ureals.Tree_Write;
+ Tree_Write_Int (Int (UR_0));
+ Tree_Write_Int (Int (UR_M_0));
+ Tree_Write_Int (Int (UR_Tenth));
+ Tree_Write_Int (Int (UR_Half));
+ Tree_Write_Int (Int (UR_1));
+ Tree_Write_Int (Int (UR_2));
+ Tree_Write_Int (Int (UR_10));
+ Tree_Write_Int (Int (UR_100));
+ Tree_Write_Int (Int (UR_2_128));
+ Tree_Write_Int (Int (UR_2_M_128));
+ end Tree_Write;
+
+ ------------
+ -- UR_Abs --
+ ------------
+
+ function UR_Abs (Real : Ureal) return Ureal is
+ Val : constant Ureal_Entry := Ureals.Table (Real);
+
+ begin
+ return Store_Ureal (
+ (Num => Val.Num,
+ Den => Val.Den,
+ Rbase => Val.Rbase,
+ Negative => False));
+ end UR_Abs;
+
+ ------------
+ -- UR_Add --
+ ------------
+
+ function UR_Add (Left : Uint; Right : Ureal) return Ureal is
+ begin
+ return UR_From_Uint (Left) + Right;
+ end UR_Add;
+
+ function UR_Add (Left : Ureal; Right : Uint) return Ureal is
+ begin
+ return Left + UR_From_Uint (Right);
+ end UR_Add;
+
+ function UR_Add (Left : Ureal; Right : Ureal) return Ureal is
+ Lval : Ureal_Entry := Ureals.Table (Left);
+ Rval : Ureal_Entry := Ureals.Table (Right);
+
+ Num : Uint;
+
+ begin
+ -- Note, in the temporary Ureal_Entry values used in this procedure,
+ -- we store the sign as the sign of the numerator (i.e. xxx.Num may
+ -- be negative, even though in stored entries this can never be so)
+
+ if Lval.Rbase /= 0 and then Lval.Rbase = Rval.Rbase then
+
+ declare
+ Opd_Min, Opd_Max : Ureal_Entry;
+ Exp_Min, Exp_Max : Uint;
+
+ begin
+ if Lval.Negative then
+ Lval.Num := (-Lval.Num);
+ end if;
+
+ if Rval.Negative then
+ Rval.Num := (-Rval.Num);
+ end if;
+
+ if Lval.Den < Rval.Den then
+ Exp_Min := Lval.Den;
+ Exp_Max := Rval.Den;
+ Opd_Min := Lval;
+ Opd_Max := Rval;
+ else
+ Exp_Min := Rval.Den;
+ Exp_Max := Lval.Den;
+ Opd_Min := Rval;
+ Opd_Max := Lval;
+ end if;
+
+ Num :=
+ Opd_Min.Num * Lval.Rbase ** (Exp_Max - Exp_Min) + Opd_Max.Num;
+
+ if Num = 0 then
+ return Store_Ureal (
+ (Num => Uint_0,
+ Den => Uint_1,
+ Rbase => 0,
+ Negative => Lval.Negative));
+
+ else
+ return Store_Ureal (
+ (Num => abs Num,
+ Den => Exp_Max,
+ Rbase => Lval.Rbase,
+ Negative => (Num < 0)));
+ end if;
+ end;
+
+ else
+ declare
+ Ln : Ureal_Entry := Normalize (Lval);
+ Rn : Ureal_Entry := Normalize (Rval);
+
+ begin
+ if Ln.Negative then
+ Ln.Num := (-Ln.Num);
+ end if;
+
+ if Rn.Negative then
+ Rn.Num := (-Rn.Num);
+ end if;
+
+ Num := (Ln.Num * Rn.Den) + (Rn.Num * Ln.Den);
+
+ if Num = 0 then
+ return Store_Ureal (
+ (Num => Uint_0,
+ Den => Uint_1,
+ Rbase => 0,
+ Negative => Lval.Negative));
+
+ else
+ return Store_Ureal (
+ Normalize (
+ (Num => abs Num,
+ Den => Ln.Den * Rn.Den,
+ Rbase => 0,
+ Negative => (Num < 0))));
+ end if;
+ end;
+ end if;
+ end UR_Add;
+
+ ----------------
+ -- UR_Ceiling --
+ ----------------
+
+ function UR_Ceiling (Real : Ureal) return Uint is
+ Val : Ureal_Entry := Normalize (Ureals.Table (Real));
+
+ begin
+ if Val.Negative then
+ return UI_Negate (Val.Num / Val.Den);
+ else
+ return (Val.Num + Val.Den - 1) / Val.Den;
+ end if;
+ end UR_Ceiling;
+
+ ------------
+ -- UR_Div --
+ ------------
+
+ function UR_Div (Left : Uint; Right : Ureal) return Ureal is
+ begin
+ return UR_From_Uint (Left) / Right;
+ end UR_Div;
+
+ function UR_Div (Left : Ureal; Right : Uint) return Ureal is
+ begin
+ return Left / UR_From_Uint (Right);
+ end UR_Div;
+
+ function UR_Div (Left, Right : Ureal) return Ureal is
+ Lval : constant Ureal_Entry := Ureals.Table (Left);
+ Rval : constant Ureal_Entry := Ureals.Table (Right);
+ Rneg : constant Boolean := Rval.Negative xor Lval.Negative;
+
+ begin
+ pragma Assert (Rval.Num /= Uint_0);
+
+ if Lval.Rbase = 0 then
+
+ if Rval.Rbase = 0 then
+ return Store_Ureal (
+ Normalize (
+ (Num => Lval.Num * Rval.Den,
+ Den => Lval.Den * Rval.Num,
+ Rbase => 0,
+ Negative => Rneg)));
+
+ elsif Is_Integer (Lval.Num, Rval.Num * Lval.Den) then
+ return Store_Ureal (
+ (Num => Lval.Num / (Rval.Num * Lval.Den),
+ Den => (-Rval.Den),
+ Rbase => Rval.Rbase,
+ Negative => Rneg));
+
+ elsif Rval.Den < 0 then
+ return Store_Ureal (
+ Normalize (
+ (Num => Lval.Num,
+ Den => Rval.Rbase ** (-Rval.Den) *
+ Rval.Num *
+ Lval.Den,
+ Rbase => 0,
+ Negative => Rneg)));
+
+ else
+ return Store_Ureal (
+ Normalize (
+ (Num => Lval.Num * Rval.Rbase ** Rval.Den,
+ Den => Rval.Num * Lval.Den,
+ Rbase => 0,
+ Negative => Rneg)));
+ end if;
+
+ elsif Is_Integer (Lval.Num, Rval.Num) then
+
+ if Rval.Rbase = Lval.Rbase then
+ return Store_Ureal (
+ (Num => Lval.Num / Rval.Num,
+ Den => Lval.Den - Rval.Den,
+ Rbase => Lval.Rbase,
+ Negative => Rneg));
+
+ elsif Rval.Rbase = 0 then
+ return Store_Ureal (
+ (Num => (Lval.Num / Rval.Num) * Rval.Den,
+ Den => Lval.Den,
+ Rbase => Lval.Rbase,
+ Negative => Rneg));
+
+ elsif Rval.Den < 0 then
+ declare
+ Num, Den : Uint;
+
+ begin
+ if Lval.Den < 0 then
+ Num := (Lval.Num / Rval.Num) * (Lval.Rbase ** (-Lval.Den));
+ Den := Rval.Rbase ** (-Rval.Den);
+ else
+ Num := Lval.Num / Rval.Num;
+ Den := (Lval.Rbase ** Lval.Den) *
+ (Rval.Rbase ** (-Rval.Den));
+ end if;
+
+ return Store_Ureal (
+ (Num => Num,
+ Den => Den,
+ Rbase => 0,
+ Negative => Rneg));
+ end;
+
+ else
+ return Store_Ureal (
+ (Num => (Lval.Num / Rval.Num) *
+ (Rval.Rbase ** Rval.Den),
+ Den => Lval.Den,
+ Rbase => Lval.Rbase,
+ Negative => Rneg));
+ end if;
+
+ else
+ declare
+ Num, Den : Uint;
+
+ begin
+ if Lval.Den < 0 then
+ Num := Lval.Num * (Lval.Rbase ** (-Lval.Den));
+ Den := Rval.Num;
+
+ else
+ Num := Lval.Num;
+ Den := Rval.Num * (Lval.Rbase ** Lval.Den);
+ end if;
+
+ if Rval.Rbase /= 0 then
+ if Rval.Den < 0 then
+ Den := Den * (Rval.Rbase ** (-Rval.Den));
+ else
+ Num := Num * (Rval.Rbase ** Rval.Den);
+ end if;
+
+ else
+ Num := Num * Rval.Den;
+ end if;
+
+ return Store_Ureal (
+ Normalize (
+ (Num => Num,
+ Den => Den,
+ Rbase => 0,
+ Negative => Rneg)));
+ end;
+ end if;
+ end UR_Div;
+
+ -----------
+ -- UR_Eq --
+ -----------
+
+ function UR_Eq (Left, Right : Ureal) return Boolean is
+ begin
+ return not UR_Ne (Left, Right);
+ end UR_Eq;
+
+ ---------------------
+ -- UR_Exponentiate --
+ ---------------------
+
+ function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal is
+ Bas : Ureal;
+ Val : Ureal_Entry;
+ X : Uint := abs N;
+ Neg : Boolean;
+ IBas : Uint;
+
+ begin
+ -- If base is negative, then the resulting sign depends on whether
+ -- the exponent is even or odd (even => positive, odd = negative)
+
+ if UR_Is_Negative (Real) then
+ Neg := (N mod 2) /= 0;
+ Bas := UR_Negate (Real);
+ else
+ Neg := False;
+ Bas := Real;
+ end if;
+
+ Val := Ureals.Table (Bas);
+
+ -- If the base is a small integer, then we can return the result in
+ -- exponential form, which can save a lot of time for junk exponents.
+
+ IBas := UR_Trunc (Bas);
+
+ if IBas <= 16
+ and then UR_From_Uint (IBas) = Bas
+ then
+ return Store_Ureal (
+ (Num => Uint_1,
+ Den => -N,
+ Rbase => UI_To_Int (UR_Trunc (Bas)),
+ Negative => Neg));
+
+ -- If the exponent is negative then we raise the numerator and the
+ -- denominator (after normalization) to the absolute value of the
+ -- exponent and we return the reciprocal. An assert error will happen
+ -- if the numerator is zero.
+
+ elsif N < 0 then
+ pragma Assert (Val.Num /= 0);
+ Val := Normalize (Val);
+
+ return Store_Ureal (
+ (Num => Val.Den ** X,
+ Den => Val.Num ** X,
+ Rbase => 0,
+ Negative => Neg));
+
+ -- If positive, we distinguish the case when the base is not zero, in
+ -- which case the new denominator is just the product of the old one
+ -- with the exponent,
+
+ else
+ if Val.Rbase /= 0 then
+
+ return Store_Ureal (
+ (Num => Val.Num ** X,
+ Den => Val.Den * X,
+ Rbase => Val.Rbase,
+ Negative => Neg));
+
+ -- And when the base is zero, in which case we exponentiate
+ -- the old denominator.
+
+ else
+ return Store_Ureal (
+ (Num => Val.Num ** X,
+ Den => Val.Den ** X,
+ Rbase => 0,
+ Negative => Neg));
+ end if;
+ end if;
+ end UR_Exponentiate;
+
+ --------------
+ -- UR_Floor --
+ --------------
+
+ function UR_Floor (Real : Ureal) return Uint is
+ Val : Ureal_Entry := Normalize (Ureals.Table (Real));
+
+ begin
+ if Val.Negative then
+ return UI_Negate ((Val.Num + Val.Den - 1) / Val.Den);
+ else
+ return Val.Num / Val.Den;
+ end if;
+ end UR_Floor;
+
+ -------------------------
+ -- UR_From_Components --
+ -------------------------
+
+ function UR_From_Components
+ (Num : Uint;
+ Den : Uint;
+ Rbase : Nat := 0;
+ Negative : Boolean := False)
+ return Ureal
+ is
+ begin
+ return Store_Ureal (
+ (Num => Num,
+ Den => Den,
+ Rbase => Rbase,
+ Negative => Negative));
+ end UR_From_Components;
+
+ ------------------
+ -- UR_From_Uint --
+ ------------------
+
+ function UR_From_Uint (UI : Uint) return Ureal is
+ begin
+ return UR_From_Components
+ (abs UI, Uint_1, Negative => (UI < 0));
+ end UR_From_Uint;
+
+ -----------
+ -- UR_Ge --
+ -----------
+
+ function UR_Ge (Left, Right : Ureal) return Boolean is
+ begin
+ return not (Left < Right);
+ end UR_Ge;
+
+ -----------
+ -- UR_Gt --
+ -----------
+
+ function UR_Gt (Left, Right : Ureal) return Boolean is
+ begin
+ return (Right < Left);
+ end UR_Gt;
+
+ --------------------
+ -- UR_Is_Negative --
+ --------------------
+
+ function UR_Is_Negative (Real : Ureal) return Boolean is
+ begin
+ return Ureals.Table (Real).Negative;
+ end UR_Is_Negative;
+
+ --------------------
+ -- UR_Is_Positive --
+ --------------------
+
+ function UR_Is_Positive (Real : Ureal) return Boolean is
+ begin
+ return not Ureals.Table (Real).Negative
+ and then Ureals.Table (Real).Num /= 0;
+ end UR_Is_Positive;
+
+ ----------------
+ -- UR_Is_Zero --
+ ----------------
+
+ function UR_Is_Zero (Real : Ureal) return Boolean is
+ begin
+ return Ureals.Table (Real).Num = 0;
+ end UR_Is_Zero;
+
+ -----------
+ -- UR_Le --
+ -----------
+
+ function UR_Le (Left, Right : Ureal) return Boolean is
+ begin
+ return not (Right < Left);
+ end UR_Le;
+
+ -----------
+ -- UR_Lt --
+ -----------
+
+ function UR_Lt (Left, Right : Ureal) return Boolean is
+ begin
+ -- An operand is not less than itself
+
+ if Same (Left, Right) then
+ return False;
+
+ -- Deal with zero cases
+
+ elsif UR_Is_Zero (Left) then
+ return UR_Is_Positive (Right);
+
+ elsif UR_Is_Zero (Right) then
+ return Ureals.Table (Left).Negative;
+
+ -- Different signs are decisive (note we dealt with zero cases)
+
+ elsif Ureals.Table (Left).Negative
+ and then not Ureals.Table (Right).Negative
+ then
+ return True;
+
+ elsif not Ureals.Table (Left).Negative
+ and then Ureals.Table (Right).Negative
+ then
+ return False;
+
+ -- Signs are same, do rapid check based on worst case estimates of
+ -- decimal exponent, which will often be decisive. Precise test
+ -- depends on whether operands are positive or negative.
+
+ elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) then
+ return UR_Is_Positive (Left);
+
+ elsif Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right) then
+ return UR_Is_Negative (Left);
+
+ -- If we fall through, full gruesome test is required. This happens
+ -- if the numbers are close together, or in some wierd (/=10) base.
+
+ else
+ declare
+ Imrk : constant Uintp.Save_Mark := Mark;
+ Rmrk : constant Urealp.Save_Mark := Mark;
+ Lval : Ureal_Entry;
+ Rval : Ureal_Entry;
+ Result : Boolean;
+
+ begin
+ Lval := Ureals.Table (Left);
+ Rval := Ureals.Table (Right);
+
+ -- An optimization. If both numbers are based, then subtract
+ -- common value of base to avoid unnecessarily giant numbers
+
+ if Lval.Rbase = Rval.Rbase and then Lval.Rbase /= 0 then
+ if Lval.Den < Rval.Den then
+ Rval.Den := Rval.Den - Lval.Den;
+ Lval.Den := Uint_0;
+ else
+ Lval.Den := Lval.Den - Rval.Den;
+ Rval.Den := Uint_0;
+ end if;
+ end if;
+
+ Lval := Normalize (Lval);
+ Rval := Normalize (Rval);
+
+ if Lval.Negative then
+ Result := (Lval.Num * Rval.Den) > (Rval.Num * Lval.Den);
+ else
+ Result := (Lval.Num * Rval.Den) < (Rval.Num * Lval.Den);
+ end if;
+
+ Release (Imrk);
+ Release (Rmrk);
+ return Result;
+ end;
+ end if;
+ end UR_Lt;
+
+ ------------
+ -- UR_Max --
+ ------------
+
+ function UR_Max (Left, Right : Ureal) return Ureal is
+ begin
+ if Left >= Right then
+ return Left;
+ else
+ return Right;
+ end if;
+ end UR_Max;
+
+ ------------
+ -- UR_Min --
+ ------------
+
+ function UR_Min (Left, Right : Ureal) return Ureal is
+ begin
+ if Left <= Right then
+ return Left;
+ else
+ return Right;
+ end if;
+ end UR_Min;
+
+ ------------
+ -- UR_Mul --
+ ------------
+
+ function UR_Mul (Left : Uint; Right : Ureal) return Ureal is
+ begin
+ return UR_From_Uint (Left) * Right;
+ end UR_Mul;
+
+ function UR_Mul (Left : Ureal; Right : Uint) return Ureal is
+ begin
+ return Left * UR_From_Uint (Right);
+ end UR_Mul;
+
+ function UR_Mul (Left, Right : Ureal) return Ureal is
+ Lval : constant Ureal_Entry := Ureals.Table (Left);
+ Rval : constant Ureal_Entry := Ureals.Table (Right);
+ Num : Uint := Lval.Num * Rval.Num;
+ Den : Uint;
+ Rneg : constant Boolean := Lval.Negative xor Rval.Negative;
+
+ begin
+ if Lval.Rbase = 0 then
+ if Rval.Rbase = 0 then
+ return Store_Ureal (
+ Normalize (
+ (Num => Num,
+ Den => Lval.Den * Rval.Den,
+ Rbase => 0,
+ Negative => Rneg)));
+
+ elsif Is_Integer (Num, Lval.Den) then
+ return Store_Ureal (
+ (Num => Num / Lval.Den,
+ Den => Rval.Den,
+ Rbase => Rval.Rbase,
+ Negative => Rneg));
+
+ elsif Rval.Den < 0 then
+ return Store_Ureal (
+ Normalize (
+ (Num => Num * (Rval.Rbase ** (-Rval.Den)),
+ Den => Lval.Den,
+ Rbase => 0,
+ Negative => Rneg)));
+
+ else
+ return Store_Ureal (
+ Normalize (
+ (Num => Num,
+ Den => Lval.Den * (Rval.Rbase ** Rval.Den),
+ Rbase => 0,
+ Negative => Rneg)));
+ end if;
+
+ elsif Lval.Rbase = Rval.Rbase then
+ return Store_Ureal (
+ (Num => Num,
+ Den => Lval.Den + Rval.Den,
+ Rbase => Lval.Rbase,
+ Negative => Rneg));
+
+ elsif Rval.Rbase = 0 then
+ if Is_Integer (Num, Rval.Den) then
+ return Store_Ureal (
+ (Num => Num / Rval.Den,
+ Den => Lval.Den,
+ Rbase => Lval.Rbase,
+ Negative => Rneg));
+
+ elsif Lval.Den < 0 then
+ return Store_Ureal (
+ Normalize (
+ (Num => Num * (Lval.Rbase ** (-Lval.Den)),
+ Den => Rval.Den,
+ Rbase => 0,
+ Negative => Rneg)));
+
+ else
+ return Store_Ureal (
+ Normalize (
+ (Num => Num,
+ Den => Rval.Den * (Lval.Rbase ** Lval.Den),
+ Rbase => 0,
+ Negative => Rneg)));
+ end if;
+
+ else
+ Den := Uint_1;
+
+ if Lval.Den < 0 then
+ Num := Num * (Lval.Rbase ** (-Lval.Den));
+ else
+ Den := Den * (Lval.Rbase ** Lval.Den);
+ end if;
+
+ if Rval.Den < 0 then
+ Num := Num * (Rval.Rbase ** (-Rval.Den));
+ else
+ Den := Den * (Rval.Rbase ** Rval.Den);
+ end if;
+
+ return Store_Ureal (
+ Normalize (
+ (Num => Num,
+ Den => Den,
+ Rbase => 0,
+ Negative => Rneg)));
+ end if;
+
+ end UR_Mul;
+
+ -----------
+ -- UR_Ne --
+ -----------
+
+ function UR_Ne (Left, Right : Ureal) return Boolean is
+ begin
+ -- Quick processing for case of identical Ureal values (note that
+ -- this also deals with comparing two No_Ureal values).
+
+ if Same (Left, Right) then
+ return False;
+
+ -- Deal with case of one or other operand is No_Ureal, but not both
+
+ elsif Same (Left, No_Ureal) or else Same (Right, No_Ureal) then
+ return True;
+
+ -- Do quick check based on number of decimal digits
+
+ elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) or else
+ Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right)
+ then
+ return True;
+
+ -- Otherwise full comparison is required
+
+ else
+ declare
+ Imrk : constant Uintp.Save_Mark := Mark;
+ Rmrk : constant Urealp.Save_Mark := Mark;
+ Lval : constant Ureal_Entry := Normalize (Ureals.Table (Left));
+ Rval : constant Ureal_Entry := Normalize (Ureals.Table (Right));
+ Result : Boolean;
+
+ begin
+ if UR_Is_Zero (Left) then
+ return not UR_Is_Zero (Right);
+
+ elsif UR_Is_Zero (Right) then
+ return not UR_Is_Zero (Left);
+
+ -- Both operands are non-zero
+
+ else
+ Result :=
+ Rval.Negative /= Lval.Negative
+ or else Rval.Num /= Lval.Num
+ or else Rval.Den /= Lval.Den;
+ Release (Imrk);
+ Release (Rmrk);
+ return Result;
+ end if;
+ end;
+ end if;
+ end UR_Ne;
+
+ ---------------
+ -- UR_Negate --
+ ---------------
+
+ function UR_Negate (Real : Ureal) return Ureal is
+ begin
+ return Store_Ureal (
+ (Num => Ureals.Table (Real).Num,
+ Den => Ureals.Table (Real).Den,
+ Rbase => Ureals.Table (Real).Rbase,
+ Negative => not Ureals.Table (Real).Negative));
+ end UR_Negate;
+
+ ------------
+ -- UR_Sub --
+ ------------
+
+ function UR_Sub (Left : Uint; Right : Ureal) return Ureal is
+ begin
+ return UR_From_Uint (Left) + UR_Negate (Right);
+ end UR_Sub;
+
+ function UR_Sub (Left : Ureal; Right : Uint) return Ureal is
+ begin
+ return Left + UR_From_Uint (-Right);
+ end UR_Sub;
+
+ function UR_Sub (Left, Right : Ureal) return Ureal is
+ begin
+ return Left + UR_Negate (Right);
+ end UR_Sub;
+
+ ----------------
+ -- UR_To_Uint --
+ ----------------
+
+ function UR_To_Uint (Real : Ureal) return Uint is
+ Val : Ureal_Entry := Normalize (Ureals.Table (Real));
+ Res : Uint;
+
+ begin
+ Res := (Val.Num + (Val.Den / 2)) / Val.Den;
+
+ if Val.Negative then
+ return UI_Negate (Res);
+ else
+ return Res;
+ end if;
+ end UR_To_Uint;
+
+ --------------
+ -- UR_Trunc --
+ --------------
+
+ function UR_Trunc (Real : Ureal) return Uint is
+ Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
+
+ begin
+ if Val.Negative then
+ return -(Val.Num / Val.Den);
+ else
+ return Val.Num / Val.Den;
+ end if;
+ end UR_Trunc;
+
+ --------------
+ -- UR_Write --
+ --------------
+
+ procedure UR_Write (Real : Ureal) is
+ Val : constant Ureal_Entry := Ureals.Table (Real);
+
+ begin
+ -- If value is negative, we precede the constant by a minus sign
+ -- and add an extra layer of parentheses on the outside since the
+ -- minus sign is part of the value, not a negation operator.
+
+ if Val.Negative then
+ Write_Str ("(-");
+ end if;
+
+ -- Constants in base 10 can be written in normal Ada literal style
+ -- If the literal is negative enclose in parens to emphasize that
+ -- it is part of the constant, and not a separate negation operator
+
+ if Val.Rbase = 10 then
+
+ UI_Write (Val.Num / 10);
+ Write_Char ('.');
+ UI_Write (Val.Num mod 10);
+
+ if Val.Den /= 0 then
+ Write_Char ('E');
+ UI_Write (1 - Val.Den);
+ end if;
+
+ -- Constants in a base other than 10 can still be easily written
+ -- in normal Ada literal style if the numerator is one.
+
+ elsif Val.Rbase /= 0 and then Val.Num = 1 then
+ Write_Int (Val.Rbase);
+ Write_Str ("#1.0#E");
+ UI_Write (-Val.Den);
+
+ -- Other constants with a base other than 10 are written using one
+ -- of the following forms, depending on the sign of the number
+ -- and the sign of the exponent (= minus denominator value)
+
+ -- (numerator.0*base**exponent)
+ -- (numerator.0*base**(-exponent))
+
+ elsif Val.Rbase /= 0 then
+ Write_Char ('(');
+ UI_Write (Val.Num, Decimal);
+ Write_Str (".0*");
+ Write_Int (Val.Rbase);
+ Write_Str ("**");
+
+ if Val.Den <= 0 then
+ UI_Write (-Val.Den, Decimal);
+
+ else
+ Write_Str ("(-");
+ UI_Write (Val.Den, Decimal);
+ Write_Char (')');
+ end if;
+
+ Write_Char (')');
+
+ -- Rational constants with a denominator of 1 can be written as
+ -- a real literal for the numerator integer.
+
+ elsif Val.Den = 1 then
+ UI_Write (Val.Num, Decimal);
+ Write_Str (".0");
+
+ -- Non-based (rational) constants are written in (num/den) style
+
+ else
+ Write_Char ('(');
+ UI_Write (Val.Num, Decimal);
+ Write_Str (".0/");
+ UI_Write (Val.Den, Decimal);
+ Write_Str (".0)");
+ end if;
+
+ -- Add trailing paren for negative values
+
+ if Val.Negative then
+ Write_Char (')');
+ end if;
+
+ end UR_Write;
+
+ -------------
+ -- Ureal_0 --
+ -------------
+
+ function Ureal_0 return Ureal is
+ begin
+ return UR_0;
+ end Ureal_0;
+
+ -------------
+ -- Ureal_1 --
+ -------------
+
+ function Ureal_1 return Ureal is
+ begin
+ return UR_1;
+ end Ureal_1;
+
+ -------------
+ -- Ureal_2 --
+ -------------
+
+ function Ureal_2 return Ureal is
+ begin
+ return UR_2;
+ end Ureal_2;
+
+ --------------
+ -- Ureal_10 --
+ --------------
+
+ function Ureal_10 return Ureal is
+ begin
+ return UR_10;
+ end Ureal_10;
+
+ ---------------
+ -- Ureal_100 --
+ ---------------
+
+ function Ureal_100 return Ureal is
+ begin
+ return UR_100;
+ end Ureal_100;
+
+ -----------------
+ -- Ureal_2_128 --
+ -----------------
+
+ function Ureal_2_128 return Ureal is
+ begin
+ return UR_2_128;
+ end Ureal_2_128;
+
+ -------------------
+ -- Ureal_2_M_128 --
+ -------------------
+
+ function Ureal_2_M_128 return Ureal is
+ begin
+ return UR_2_M_128;
+ end Ureal_2_M_128;
+
+ ----------------
+ -- Ureal_Half --
+ ----------------
+
+ function Ureal_Half return Ureal is
+ begin
+ return UR_Half;
+ end Ureal_Half;
+
+ ---------------
+ -- Ureal_M_0 --
+ ---------------
+
+ function Ureal_M_0 return Ureal is
+ begin
+ return UR_M_0;
+ end Ureal_M_0;
+
+ -----------------
+ -- Ureal_Tenth --
+ -----------------
+
+ function Ureal_Tenth return Ureal is
+ begin
+ return UR_Tenth;
+ end Ureal_Tenth;
+
+end Urealp;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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));
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * U T I L S *
+ * *
+ * C Implementation File *
+ * *
+ * $Revision: 1.4 $
+ * *
+ * 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). *
+ * *
+ ****************************************************************************/
+
+#include "config.h"
+#include "system.h"
+#include "tree.h"
+#include "flags.h"
+#include "defaults.h"
+#include "toplev.h"
+#include "output.h"
+#include "ggc.h"
+#include "convert.h"
+
+#include "ada.h"
+#include "types.h"
+#include "atree.h"
+#include "elists.h"
+#include "namet.h"
+#include "nlists.h"
+#include "stringt.h"
+#include "uintp.h"
+#include "fe.h"
+#include "sinfo.h"
+#include "einfo.h"
+#include "ada-tree.h"
+#include "gigi.h"
+
+#ifndef MAX_FIXED_MODE_SIZE
+#define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
+#endif
+
+#ifndef MAX_BITS_PER_WORD
+#define MAX_BITS_PER_WORD BITS_PER_WORD
+#endif
+
+/* If nonzero, pretend we are allocating at global level. */
+int force_global;
+
+/* Global Variables for the various types we create. */
+tree gnat_std_decls[(int) ADT_LAST];
+
+/* Associates a GNAT tree node to a GCC tree node. It is used in
+ `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
+ of `save_gnu_tree' for more info. */
+static tree *associate_gnat_to_gnu;
+
+/* This listhead is used to record any global objects that need elaboration.
+ TREE_PURPOSE is the variable to be elaborated and TREE_VALUE is the
+ initial value to assign. */
+
+static tree pending_elaborations;
+
+/* This stack allows us to momentarily switch to generating elaboration
+ lists for an inner context. */
+
+static struct e_stack {struct e_stack *next; tree elab_list; } *elist_stack;
+
+/* This variable keeps a table for types for each precision so that we only
+ allocate each of them once. Signed and unsigned types are kept separate.
+
+ Note that these types are only used when fold-const requests something
+ special. Perhaps we should NOT share these types; we'll see how it
+ goes later. */
+static tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2];
+
+/* Likewise for float types, but record these by mode. */
+static tree float_types[NUM_MACHINE_MODES];
+
+/* For each binding contour we allocate a binding_level structure which records
+ the entities defined or declared in that contour. Contours include:
+
+ the global one
+ one for each subprogram definition
+ one for each compound statement (declare block)
+
+ Binding contours are used to create GCC tree BLOCK nodes. */
+
+struct binding_level
+{
+ /* A chain of ..._DECL nodes for all variables, constants, functions,
+ parameters and type declarations. These ..._DECL nodes are chained
+ through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
+ in the reverse of the order supplied to be compatible with the
+ back-end. */
+ tree names;
+ /* For each level (except the global one), a chain of BLOCK nodes for all
+ the levels that were entered and exited one level down from this one. */
+ tree blocks;
+ /* The BLOCK node for this level, if one has been preallocated.
+ If 0, the BLOCK is allocated (if needed) when the level is popped. */
+ tree this_block;
+ /* The binding level containing this one (the enclosing binding level). */
+ struct binding_level *level_chain;
+};
+
+/* The binding level currently in effect. */
+static struct binding_level *current_binding_level = NULL;
+
+/* A chain of binding_level structures awaiting reuse. */
+static struct binding_level *free_binding_level = NULL;
+
+/* The outermost binding level. This binding level is created when the
+ compiler is started and it will exist through the entire compilation. */
+static struct binding_level *global_binding_level;
+
+/* Binding level structures are initialized by copying this one. */
+static struct binding_level clear_binding_level = {NULL, NULL, NULL, NULL};
+
+
+static tree merge_sizes PARAMS ((tree, tree, tree, int, int));
+static tree compute_related_constant PARAMS ((tree, tree));
+static tree split_plus PARAMS ((tree, tree *));
+static int value_zerop PARAMS ((tree));
+static tree float_type_for_size PARAMS ((int, enum machine_mode));
+static tree convert_to_fat_pointer PARAMS ((tree, tree));
+static tree convert_to_thin_pointer PARAMS ((tree, tree));
+static tree make_descriptor_field PARAMS ((const char *,tree, tree,
+ tree));
+static void mark_binding_level PARAMS((PTR));
+static void mark_e_stack PARAMS((PTR));
+\f
+/* Initialize the association of GNAT nodes to GCC trees. */
+
+void
+init_gnat_to_gnu ()
+{
+ Node_Id gnat_node;
+
+ associate_gnat_to_gnu = (tree *) xmalloc (max_gnat_nodes * sizeof (tree));
+ ggc_add_tree_root (associate_gnat_to_gnu, max_gnat_nodes);
+
+ for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++)
+ associate_gnat_to_gnu [gnat_node] = NULL_TREE;
+
+ associate_gnat_to_gnu -= First_Node_Id;
+
+ pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
+ ggc_add_tree_root (&pending_elaborations, 1);
+ ggc_add_root ((PTR) &elist_stack, 1, sizeof (struct e_stack), mark_e_stack);
+ ggc_add_tree_root (&signed_and_unsigned_types[0][0],
+ (sizeof signed_and_unsigned_types
+ / sizeof signed_and_unsigned_types[0][0]));
+ ggc_add_tree_root (float_types, sizeof float_types / sizeof float_types[0]);
+
+ ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
+ mark_binding_level);
+}
+
+/* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree
+ which is to be associated with GNAT_ENTITY. Such GCC tree node is always
+ a ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed.
+
+ If GNU_DECL is zero, a previous association is to be reset. */
+
+void
+save_gnu_tree (gnat_entity, gnu_decl, no_check)
+ Entity_Id gnat_entity;
+ tree gnu_decl;
+ int no_check;
+{
+ if (gnu_decl
+ && (associate_gnat_to_gnu [gnat_entity]
+ || (! no_check && ! DECL_P (gnu_decl))))
+ gigi_abort (401);
+
+ associate_gnat_to_gnu [gnat_entity] = gnu_decl;
+}
+
+/* GNAT_ENTITY is a GNAT tree node for a defining identifier.
+ Return the ..._DECL node that was associated with it. If there is no tree
+ node associated with GNAT_ENTITY, abort.
+
+ In some cases, such as delayed elaboration or expressions that need to
+ be elaborated only once, GNAT_ENTITY is really not an entity. */
+
+tree
+get_gnu_tree (gnat_entity)
+ Entity_Id gnat_entity;
+{
+ if (! associate_gnat_to_gnu [gnat_entity])
+ gigi_abort (402);
+
+ return associate_gnat_to_gnu [gnat_entity];
+}
+
+/* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
+
+int
+present_gnu_tree (gnat_entity)
+ Entity_Id gnat_entity;
+{
+ return (associate_gnat_to_gnu [gnat_entity] != NULL_TREE);
+}
+
+\f
+/* Return non-zero if we are currently in the global binding level. */
+
+int
+global_bindings_p ()
+{
+ return (force_global != 0 || current_binding_level == global_binding_level
+ ? -1 : 0);
+}
+
+/* Return the list of declarations in the current level. Note that this list
+ is in reverse order (it has to be so for back-end compatibility). */
+
+tree
+getdecls ()
+{
+ return current_binding_level->names;
+}
+
+/* Nonzero if the current level needs to have a BLOCK made. */
+
+int
+kept_level_p ()
+{
+ return (current_binding_level->names != 0);
+}
+
+/* Enter a new binding level. The input parameter is ignored, but has to be
+ specified for back-end compatibility. */
+
+void
+pushlevel (ignore)
+ int ignore ATTRIBUTE_UNUSED;
+{
+ struct binding_level *newlevel = NULL;
+
+ /* Reuse a struct for this binding level, if there is one. */
+ if (free_binding_level)
+ {
+ newlevel = free_binding_level;
+ free_binding_level = free_binding_level->level_chain;
+ }
+ else
+ newlevel
+ = (struct binding_level *) xmalloc (sizeof (struct binding_level));
+
+ *newlevel = clear_binding_level;
+
+ /* Add this level to the front of the chain (stack) of levels that are
+ active. */
+ newlevel->level_chain = current_binding_level;
+ current_binding_level = newlevel;
+}
+
+/* Exit a binding level.
+ Pop the level off, and restore the state of the identifier-decl mappings
+ that were in effect when this level was entered.
+
+ If KEEP is nonzero, this level had explicit declarations, so
+ and create a "block" (a BLOCK node) for the level
+ to record its declarations and subblocks for symbol table output.
+
+ If FUNCTIONBODY is nonzero, this level is the body of a function,
+ so create a block as if KEEP were set and also clear out all
+ label names.
+
+ If REVERSE is nonzero, reverse the order of decls before putting
+ them into the BLOCK. */
+
+tree
+poplevel (keep, reverse, functionbody)
+ int keep;
+ int reverse;
+ int functionbody;
+{
+ /* Points to a GCC BLOCK tree node. This is the BLOCK node construted for the
+ binding level that we are about to exit and which is returned by this
+ routine. */
+ tree block = NULL_TREE;
+ tree decl_chain;
+ tree decl_node;
+ tree subblock_chain = current_binding_level->blocks;
+ tree subblock_node;
+ int block_previously_created;
+
+ /* Reverse the list of XXXX_DECL nodes if desired. Note that the ..._DECL
+ nodes chained through the `names' field of current_binding_level are in
+ reverse order except for PARM_DECL node, which are explicitely stored in
+ the right order. */
+ current_binding_level->names
+ = decl_chain = (reverse) ? nreverse (current_binding_level->names)
+ : current_binding_level->names;
+
+ /* Output any nested inline functions within this block which must be
+ compiled because their address is needed. */
+ for (decl_node = decl_chain; decl_node; decl_node = TREE_CHAIN (decl_node))
+ if (TREE_CODE (decl_node) == FUNCTION_DECL
+ && ! TREE_ASM_WRITTEN (decl_node) && TREE_ADDRESSABLE (decl_node)
+ && DECL_INITIAL (decl_node) != 0)
+ {
+ push_function_context ();
+ output_inline_function (decl_node);
+ pop_function_context ();
+ }
+
+ block = 0;
+ block_previously_created = (current_binding_level->this_block != 0);
+ if (block_previously_created)
+ block = current_binding_level->this_block;
+ else if (keep || functionbody)
+ block = make_node (BLOCK);
+ if (block != 0)
+ {
+ BLOCK_VARS (block) = keep ? decl_chain : 0;
+ BLOCK_SUBBLOCKS (block) = subblock_chain;
+ }
+
+ /* Record the BLOCK node just built as the subblock its enclosing scope. */
+ for (subblock_node = subblock_chain; subblock_node;
+ subblock_node = TREE_CHAIN (subblock_node))
+ BLOCK_SUPERCONTEXT (subblock_node) = block;
+
+ /* Clear out the meanings of the local variables of this level. */
+
+ for (subblock_node = decl_chain; subblock_node;
+ subblock_node = TREE_CHAIN (subblock_node))
+ if (DECL_NAME (subblock_node) != 0)
+ /* If the identifier was used or addressed via a local extern decl,
+ don't forget that fact. */
+ if (DECL_EXTERNAL (subblock_node))
+ {
+ if (TREE_USED (subblock_node))
+ TREE_USED (DECL_NAME (subblock_node)) = 1;
+ if (TREE_ADDRESSABLE (subblock_node))
+ TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
+ }
+
+ {
+ /* Pop the current level, and free the structure for reuse. */
+ struct binding_level *level = current_binding_level;
+ current_binding_level = current_binding_level->level_chain;
+ level->level_chain = free_binding_level;
+ free_binding_level = level;
+ }
+
+ if (functionbody)
+ {
+ /* This is the top level block of a function. The ..._DECL chain stored
+ in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
+ leave them in the BLOCK because they are found in the FUNCTION_DECL
+ instead. */
+ DECL_INITIAL (current_function_decl) = block;
+ BLOCK_VARS (block) = 0;
+ }
+ else if (block)
+ {
+ if (!block_previously_created)
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, block);
+ }
+
+ /* If we did not make a block for the level just exited, any blocks made for
+ inner levels (since they cannot be recorded as subblocks in that level)
+ must be carried forward so they will later become subblocks of something
+ else. */
+ else if (subblock_chain)
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, subblock_chain);
+ if (block)
+ TREE_USED (block) = 1;
+
+ return block;
+}
+\f
+/* Insert BLOCK at the end of the list of subblocks of the
+ current binding level. This is used when a BIND_EXPR is expanded,
+ to handle the BLOCK node inside the BIND_EXPR. */
+
+void
+insert_block (block)
+ tree block;
+{
+ TREE_USED (block) = 1;
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, block);
+}
+
+/* Set the BLOCK node for the innermost scope
+ (the one we are currently in). */
+
+void
+set_block (block)
+ tree block;
+{
+ current_binding_level->this_block = block;
+ current_binding_level->names = chainon (current_binding_level->names,
+ BLOCK_VARS (block));
+ current_binding_level->blocks = chainon (current_binding_level->blocks,
+ BLOCK_SUBBLOCKS (block));
+}
+
+/* Records a ..._DECL node DECL as belonging to the current lexical scope.
+ Returns the ..._DECL node. */
+
+tree
+pushdecl (decl)
+ tree decl;
+{
+ struct binding_level *b;
+
+ /* If at top level, there is no context. But PARM_DECLs always go in the
+ level of its function. */
+ if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL)
+ {
+ b = global_binding_level;
+ DECL_CONTEXT (decl) = 0;
+ }
+ else
+ {
+ b = current_binding_level;
+ DECL_CONTEXT (decl) = current_function_decl;
+ }
+
+ /* Put the declaration on the list. The list of declarations is in reverse
+ order. The list will be reversed later if necessary. This needs to be
+ this way for compatibility with the back-end.
+
+ Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into the list. They
+ will cause trouble with the debugger and aren't needed anyway. */
+ if (TREE_CODE (decl) != TYPE_DECL
+ || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE)
+ {
+ TREE_CHAIN (decl) = b->names;
+ b->names = decl;
+ }
+
+ /* For the declaration of a type, set its name if it either is not already
+ set, was set to an IDENTIFIER_NODE, indicating an internal name,
+ or if the previous type name was not derived from a source name.
+ We'd rather have the type named with a real name and all the pointer
+ types to the same object have the same POINTER_TYPE node. Code in this
+ function in c-decl.c makes a copy of the type node here, but that may
+ cause us trouble with incomplete types, so let's not try it (at least
+ for now). */
+
+ if (TREE_CODE (decl) == TYPE_DECL
+ && DECL_NAME (decl) != 0
+ && (TYPE_NAME (TREE_TYPE (decl)) == 0
+ || TREE_CODE (TYPE_NAME (TREE_TYPE (decl))) == IDENTIFIER_NODE
+ || (TREE_CODE (TYPE_NAME (TREE_TYPE (decl))) == TYPE_DECL
+ && DECL_ARTIFICIAL (TYPE_NAME (TREE_TYPE (decl)))
+ && ! DECL_ARTIFICIAL (decl))))
+ TYPE_NAME (TREE_TYPE (decl)) = decl;
+
+ return decl;
+}
+\f
+/* Do little here. Set up the standard declarations later after the
+ front end has been run. */
+
+void
+init_decl_processing ()
+{
+ /* The structure `tree_identifier' is the GCC tree data structure that holds
+ IDENTIFIER_NODE nodes. We need to call `set_identifier_size' to tell GCC
+ that we have not added any language specific fields to IDENTIFIER_NODE
+ nodes. */
+ set_identifier_size (sizeof (struct tree_identifier));
+
+ lineno = 0;
+
+ /* incomplete_decl_finalize_hook is defined in toplev.c. It needs to be set
+ by each front end to the appropriate routine that handles incomplete
+ VAR_DECL nodes. This routine will be invoked by compile_file when a
+ VAR_DECL node of DECL_SIZE zero is encountered. */
+ incomplete_decl_finalize_hook = finish_incomplete_decl;
+
+ /* Make the binding_level structure for global names. */
+ current_function_decl = 0;
+ current_binding_level = 0;
+ free_binding_level = 0;
+ pushlevel (0);
+ global_binding_level = current_binding_level;
+
+ build_common_tree_nodes (0);
+
+ /* In Ada, we use a signed type for SIZETYPE. Use the signed type
+ corresponding to the size of ptr_mode. Make this here since we need
+ this before we can expand the GNAT types. */
+ set_sizetype (type_for_size (GET_MODE_BITSIZE (ptr_mode), 0));
+ build_common_tree_nodes_2 (0);
+
+ pushdecl (build_decl (TYPE_DECL, get_identifier (SIZE_TYPE), sizetype));
+
+ /* We need to make the integer type before doing anything else.
+ We stitch this in to the appropriate GNAT type later. */
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
+ integer_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
+ char_type_node));
+
+ ptr_void_type_node = build_pointer_type (void_type_node);
+
+}
+
+/* Create the predefined scalar types such as `integer_type_node' needed
+ in the gcc back-end and initialize the global binding level. */
+
+void
+init_gigi_decls (long_long_float_type, exception_type)
+ tree long_long_float_type, exception_type;
+{
+ tree endlink;
+
+ /* Set the types that GCC and Gigi use from the front end. We would like
+ to do this for char_type_node, but it needs to correspond to the C
+ char type. */
+ if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
+ {
+ /* In this case, the builtin floating point types are VAX float,
+ so make up a type for use. */
+ longest_float_type_node = make_node (REAL_TYPE);
+ TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
+ layout_type (longest_float_type_node);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("longest float type"),
+ longest_float_type_node));
+ }
+ else
+ longest_float_type_node = TREE_TYPE (long_long_float_type);
+
+ except_type_node = TREE_TYPE (exception_type);
+
+ unsigned_type_node = type_for_size (INT_TYPE_SIZE, 1);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
+ unsigned_type_node));
+
+ void_type_decl_node
+ = pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
+ void_type_node));
+
+ void_ftype = build_function_type (void_type_node, NULL_TREE);
+ ptr_void_ftype = build_pointer_type (void_ftype);
+
+ /* Now declare runtime functions. */
+ endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
+
+ /* malloc is a function declaration tree for a function to allocate
+ memory. */
+ malloc_decl = create_subprog_decl (get_identifier ("__gnat_malloc"),
+ NULL_TREE,
+ build_function_type (ptr_void_type_node,
+ tree_cons (NULL_TREE,
+ sizetype,
+ endlink)),
+ NULL_TREE, 0, 1, 1, 0);
+
+ /* free is a function declaration tree for a function to free memory. */
+
+ free_decl
+ = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
+ build_function_type (void_type_node,
+ tree_cons (NULL_TREE,
+ ptr_void_type_node,
+ endlink)),
+ NULL_TREE, 0, 1, 1, 0);
+
+ /* Make the types and functions used for exception processing. */
+ jmpbuf_type
+ = build_array_type (type_for_mode (Pmode, 0),
+ build_index_type (build_int_2 (5, 0)));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("JMPBUF_T"), jmpbuf_type));
+ jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
+
+ /* Functions to get and set the jumpbuf pointer for the current thread. */
+ get_jmpbuf_decl
+ = create_subprog_decl
+ (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
+ NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
+ NULL_TREE, 0, 1, 1, 0);
+
+ set_jmpbuf_decl
+ = create_subprog_decl
+ (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
+ NULL_TREE,
+ build_function_type (void_type_node,
+ tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
+ NULL_TREE, 0, 1, 1, 0);
+
+ /* Function to get the current exception. */
+ get_excptr_decl
+ = create_subprog_decl
+ (get_identifier ("system__soft_links__get_gnat_exception"),
+ NULL_TREE,
+ build_function_type (build_pointer_type (except_type_node), NULL_TREE),
+ NULL_TREE, 0, 1, 1, 0);
+
+ /* Function that raise exceptions. */
+ raise_nodefer_decl
+ = create_subprog_decl
+ (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
+ build_function_type (void_type_node,
+ tree_cons (NULL_TREE,
+ build_pointer_type (except_type_node),
+ endlink)),
+ NULL_TREE, 0, 1, 1, 0);
+
+
+ /* __gnat_raise_constraint_error takes a string, an integer and never
+ returns. */
+ raise_constraint_error_decl
+ = create_subprog_decl
+ (get_identifier ("__gnat_raise_constraint_error"), NULL_TREE,
+ build_function_type (void_type_node,
+ tree_cons (NULL_TREE,
+ build_pointer_type (char_type_node),
+ tree_cons (NULL_TREE,
+ integer_type_node,
+ endlink))),
+ NULL_TREE, 0, 1, 1, 0);
+
+ /* Likewise for __gnat_raise_program_error. */
+ raise_program_error_decl
+ = create_subprog_decl
+ (get_identifier ("__gnat_raise_program_error"), NULL_TREE,
+ build_function_type (void_type_node,
+ tree_cons (NULL_TREE,
+ build_pointer_type (char_type_node),
+ tree_cons (NULL_TREE,
+ integer_type_node,
+ endlink))),
+ NULL_TREE, 0, 1, 1, 0);
+
+ /* Likewise for __gnat_raise_storage_error. */
+ raise_storage_error_decl
+ = create_subprog_decl
+ (get_identifier ("__gnat_raise_storage_error"), NULL_TREE,
+ build_function_type (void_type_node,
+ tree_cons (NULL_TREE,
+ build_pointer_type (char_type_node),
+ tree_cons (NULL_TREE,
+ integer_type_node,
+ endlink))),
+ NULL_TREE, 0, 1, 1, 0);
+
+ /* Indicate that these never return. */
+
+ TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
+ TREE_THIS_VOLATILE (raise_constraint_error_decl) = 1;
+ TREE_THIS_VOLATILE (raise_program_error_decl) = 1;
+ TREE_THIS_VOLATILE (raise_storage_error_decl) = 1;
+
+ TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
+ TREE_SIDE_EFFECTS (raise_constraint_error_decl) = 1;
+ TREE_SIDE_EFFECTS (raise_program_error_decl) = 1;
+ TREE_SIDE_EFFECTS (raise_storage_error_decl) = 1;
+
+ TREE_TYPE (raise_nodefer_decl)
+ = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
+ TYPE_QUAL_VOLATILE);
+ TREE_TYPE (raise_constraint_error_decl)
+ = build_qualified_type (TREE_TYPE (raise_constraint_error_decl),
+ TYPE_QUAL_VOLATILE);
+ TREE_TYPE (raise_program_error_decl)
+ = build_qualified_type (TREE_TYPE (raise_program_error_decl),
+ TYPE_QUAL_VOLATILE);
+ TREE_TYPE (raise_storage_error_decl)
+ = build_qualified_type (TREE_TYPE (raise_storage_error_decl),
+ TYPE_QUAL_VOLATILE);
+
+ /* setjmp returns an integer and has one operand, which is a pointer to
+ a jmpbuf. */
+ setjmp_decl
+ = create_subprog_decl
+ (get_identifier ("setjmp"), NULL_TREE,
+ build_function_type (integer_type_node,
+ tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
+ NULL_TREE, 0, 1, 1, 0);
+
+ DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
+ DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
+
+ ggc_add_tree_root (gnat_std_decls,
+ sizeof gnat_std_decls / sizeof gnat_std_decls[0]);
+}
+\f
+/* This routine is called in tree.c to print an error message for invalid use
+ of an incomplete type. */
+
+void
+incomplete_type_error (dont_care_1, dont_care_2)
+ tree dont_care_1 ATTRIBUTE_UNUSED;
+ tree dont_care_2 ATTRIBUTE_UNUSED;
+{
+ gigi_abort (404);
+}
+
+/* This function is called indirectly from toplev.c to handle incomplete
+ declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise,
+ compile_file in toplev.c makes an indirect call through the function pointer
+ incomplete_decl_finalize_hook which is initialized to this routine in
+ init_decl_processing. */
+
+void
+finish_incomplete_decl (dont_care)
+ tree dont_care ATTRIBUTE_UNUSED;
+{
+ gigi_abort (405);
+}
+\f
+/* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL
+ nodes (FIELDLIST), finish constructing the record or union type.
+ If HAS_REP is nonzero, this record has a rep clause; don't call
+ layout_type but merely set the size and alignment ourselves.
+ If DEFER_DEBUG is nonzero, do not call the debugging routines
+ on this type; it will be done later. */
+
+void
+finish_record_type (record_type, fieldlist, has_rep, defer_debug)
+ tree record_type;
+ tree fieldlist;
+ int has_rep;
+ int defer_debug;
+{
+ enum tree_code code = TREE_CODE (record_type);
+ tree ada_size = bitsize_zero_node;
+ tree size = bitsize_zero_node;
+ tree size_unit = size_zero_node;
+ tree field;
+
+ TYPE_FIELDS (record_type) = fieldlist;
+
+ if (TYPE_NAME (record_type) != 0
+ && TREE_CODE (TYPE_NAME (record_type)) == TYPE_DECL)
+ TYPE_STUB_DECL (record_type) = TYPE_NAME (record_type);
+ else
+ TYPE_STUB_DECL (record_type)
+ = pushdecl (build_decl (TYPE_DECL, TYPE_NAME (record_type),
+ record_type));
+
+ /* We don't need both the typedef name and the record name output in
+ the debugging information, since they are the same. */
+ DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type)) = 1;
+
+ /* Globally initialize the record first. If this is a rep'ed record,
+ that just means some initializations; otherwise, layout the record. */
+
+ if (has_rep)
+ {
+ TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type));
+ TYPE_MODE (record_type) = BLKmode;
+ if (TYPE_SIZE (record_type) == 0)
+ {
+ TYPE_SIZE (record_type) = bitsize_zero_node;
+ TYPE_SIZE_UNIT (record_type) = size_zero_node;
+ }
+ }
+ else
+ {
+ /* Ensure there isn't a size already set. There can be in an error
+ case where there is a rep clause but all fields have errors and
+ no longer have a position. */
+ TYPE_SIZE (record_type) = 0;
+ layout_type (record_type);
+ }
+
+ /* At this point, the position and size of each field is known. It was
+ either set before entry by a rep clause, or by laying out the type
+ above. We now make a pass through the fields (in reverse order for
+ QUAL_UNION_TYPEs) to compute the Ada size; the GCC size and alignment
+ (for rep'ed records that are not padding types); and the mode (for
+ rep'ed records). */
+
+ if (code == QUAL_UNION_TYPE)
+ fieldlist = nreverse (fieldlist);
+
+ for (field = fieldlist; field; field = TREE_CHAIN (field))
+ {
+ tree type = TREE_TYPE (field);
+ tree this_size = DECL_SIZE (field);
+ tree this_size_unit = DECL_SIZE_UNIT (field);
+ tree this_ada_size = DECL_SIZE (field);
+
+ if ((TREE_CODE (type) == RECORD_TYPE || TREE_CODE (type) == UNION_TYPE
+ || TREE_CODE (type) == QUAL_UNION_TYPE)
+ && ! TYPE_IS_FAT_POINTER_P (type)
+ && ! TYPE_CONTAINS_TEMPLATE_P (type)
+ && TYPE_ADA_SIZE (type) != 0)
+ this_ada_size = TYPE_ADA_SIZE (type);
+
+ if (has_rep && ! DECL_BIT_FIELD (field))
+ TYPE_ALIGN (record_type)
+ = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field));
+
+ switch (code)
+ {
+ case UNION_TYPE:
+ ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size);
+ size = size_binop (MAX_EXPR, size, this_size);
+ size_unit = size_binop (MAX_EXPR, size_unit, this_size_unit);
+ break;
+
+ case QUAL_UNION_TYPE:
+ ada_size
+ = fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
+ this_ada_size, ada_size));
+ size = fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
+ this_size, size));
+ size_unit = fold (build (COND_EXPR, sizetype, DECL_QUALIFIER (field),
+ this_size_unit, size_unit));
+ break;
+
+ case RECORD_TYPE:
+ /* Since we know here that all fields are sorted in order of
+ increasing bit position, the size of the record is one
+ higher than the ending bit of the last field processed
+ unless we have a rep clause, since in that case we might
+ have a field outside a QUAL_UNION_TYPE that has a higher ending
+ position. So use a MAX in that case. Also, if this field is a
+ QUAL_UNION_TYPE, we need to take into account the previous size in
+ the case of empty variants. */
+ ada_size
+ = merge_sizes (ada_size, bit_position (field), this_ada_size,
+ TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
+ size = merge_sizes (size, bit_position (field), this_size,
+ TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
+ size_unit
+ = merge_sizes (size_unit, byte_position (field), this_size_unit,
+ TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
+ break;
+
+ default:
+ abort ();
+ }
+ }
+
+ if (code == QUAL_UNION_TYPE)
+ nreverse (fieldlist);
+
+ /* If this is a padding record, we never want to make the size smaller than
+ what was specified in it, if any. */
+ if (TREE_CODE (record_type) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type) != 0)
+ {
+ size = TYPE_SIZE (record_type);
+ size_unit = TYPE_SIZE_UNIT (record_type);
+ }
+
+ /* Now set any of the values we've just computed that apply. */
+ if (! TYPE_IS_FAT_POINTER_P (record_type)
+ && ! TYPE_CONTAINS_TEMPLATE_P (record_type))
+ TYPE_ADA_SIZE (record_type) = ada_size;
+
+#ifdef ROUND_TYPE_SIZE
+ size = ROUND_TYPE_SIZE (record_type, size, TYPE_ALIGN (record_type));
+ size_unit = ROUND_TYPE_SIZE_UNIT (record_size, size_unit,
+ TYPE_ALIGN (record_type) / BITS_PER_UNIT);
+#else
+ size = round_up (size, TYPE_ALIGN (record_type));
+ size_unit = round_up (size_unit, TYPE_ALIGN (record_type) / BITS_PER_UNIT);
+#endif
+
+ if (has_rep
+ && ! (TREE_CODE (record_type) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (record_type)
+ && TREE_CODE (size) != INTEGER_CST
+ && contains_placeholder_p (size)))
+ {
+ TYPE_SIZE (record_type) = size;
+ TYPE_SIZE_UNIT (record_type) = size_unit;
+ }
+
+ if (has_rep)
+ compute_record_mode (record_type);
+
+ if (! defer_debug)
+ {
+ /* If this record is of variable size, rename it so that the
+ debugger knows it is and make a new, parallel, record
+ that tells the debugger how the record is laid out. See
+ exp_dbug.ads. */
+ if (TREE_CODE (TYPE_SIZE (record_type)) != INTEGER_CST)
+ {
+ tree new_record_type
+ = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
+ ? UNION_TYPE : TREE_CODE (record_type));
+ tree orig_id = DECL_NAME (TYPE_STUB_DECL (record_type));
+ tree new_id
+ = concat_id_with_name (orig_id,
+ TREE_CODE (record_type) == QUAL_UNION_TYPE
+ ? "XVU" : "XVE");
+ tree last_pos = bitsize_zero_node;
+ tree old_field;
+
+ TYPE_NAME (new_record_type) = new_id;
+ TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
+ TYPE_STUB_DECL (new_record_type)
+ = pushdecl (build_decl (TYPE_DECL, new_id, new_record_type));
+ DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type)) = 1;
+ DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
+ = DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
+ TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type));
+
+ /* Now scan all the fields, replacing each field with a new
+ field corresponding to the new encoding. */
+ for (old_field = TYPE_FIELDS (record_type); old_field != 0;
+ old_field = TREE_CHAIN (old_field))
+ {
+ tree field_type = TREE_TYPE (old_field);
+ tree field_name = DECL_NAME (old_field);
+ tree new_field;
+ tree curpos = bit_position (old_field);
+ int var = 0;
+ unsigned int align = 0;
+ tree pos;
+
+ /* See how the position was modified from the last position.
+
+ There are two basic cases we support: a value was added
+ to the last position or the last position was rounded to
+ a boundary and they something was added. Check for the
+ first case first. If not, see if there is any evidence
+ of rounding. If so, round the last position and try
+ again.
+
+ If this is a union, the position can be taken as zero. */
+
+ if (TREE_CODE (new_record_type) == UNION_TYPE)
+ pos = bitsize_zero_node, align = 0;
+ else
+ pos = compute_related_constant (curpos, last_pos);
+
+ if (pos == 0 && TREE_CODE (curpos) == MULT_EXPR
+ && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST)
+ {
+ align = TREE_INT_CST_LOW (TREE_OPERAND (curpos, 1));
+ pos = compute_related_constant (curpos,
+ round_up (last_pos, align));
+ }
+ else if (pos == 0 && TREE_CODE (curpos) == PLUS_EXPR
+ && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST
+ && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR
+ && host_integerp (TREE_OPERAND
+ (TREE_OPERAND (curpos, 0), 1),
+ 1))
+ {
+ align
+ = tree_low_cst
+ (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1), 1);
+ pos = compute_related_constant (curpos,
+ round_up (last_pos, align));
+ }
+
+ /* If we can't compute a position, set it to zero.
+
+ ??? We really should abort here, but it's too much work
+ to get this correct for all cases. */
+
+ if (pos == 0)
+ pos = bitsize_zero_node;
+
+ /* See if this type is variable-size and make a new type
+ and indicate the indirection if so. */
+ if (TREE_CODE (TYPE_SIZE (field_type)) != INTEGER_CST)
+ {
+ field_type = build_pointer_type (field_type);
+ var = 1;
+ }
+
+ /* Make a new field name, if necessary. */
+ if (var || align != 0)
+ {
+ char suffix[6];
+
+ if (align != 0)
+ sprintf (suffix, "XV%c%u", var ? 'L' : 'A',
+ align / BITS_PER_UNIT);
+ else
+ strcpy (suffix, "XVL");
+
+ field_name = concat_id_with_name (field_name, suffix);
+ }
+
+ new_field = create_field_decl (field_name, field_type,
+ new_record_type, 0,
+ TYPE_SIZE (field_type), pos, 0);
+ TREE_CHAIN (new_field) = TYPE_FIELDS (new_record_type);
+ TYPE_FIELDS (new_record_type) = new_field;
+
+ /* If old_field is a QUAL_UNION_TYPE, take its size as being
+ zero. The only time it's not the last field of the record
+ is when there are other components at fixed positions after
+ it (meaning there was a rep clause for every field) and we
+ want to be able to encode them. */
+ last_pos = size_binop (PLUS_EXPR, bit_position (old_field),
+ (TREE_CODE (TREE_TYPE (old_field))
+ == QUAL_UNION_TYPE)
+ ? bitsize_zero_node
+ : TYPE_SIZE (TREE_TYPE (old_field)));
+ }
+
+ TYPE_FIELDS (new_record_type)
+ = nreverse (TYPE_FIELDS (new_record_type));
+
+ rest_of_type_compilation (new_record_type, global_bindings_p ());
+ }
+
+ rest_of_type_compilation (record_type, global_bindings_p ());
+ }
+}
+
+/* Utility function of above to merge LAST_SIZE, the previous size of a record
+ with FIRST_BIT and SIZE that describe a field. SPECIAL is nonzero
+ if this represents a QUAL_UNION_TYPE in which case we must look for
+ COND_EXPRs and replace a value of zero with the old size. If HAS_REP
+ is nonzero, we must take the MAX of the end position of this field
+ with LAST_SIZE. In all other cases, we use FIRST_BIT plus SIZE.
+
+ We return an expression for the size. */
+
+static tree
+merge_sizes (last_size, first_bit, size, special, has_rep)
+ tree last_size;
+ tree first_bit, size;
+ int special;
+ int has_rep;
+{
+ tree type = TREE_TYPE (last_size);
+
+ if (! special || TREE_CODE (size) != COND_EXPR)
+ {
+ tree new = size_binop (PLUS_EXPR, first_bit, size);
+
+ if (has_rep)
+ new = size_binop (MAX_EXPR, last_size, new);
+
+ return new;
+ }
+
+ return fold (build (COND_EXPR, type, TREE_OPERAND (size, 0),
+ integer_zerop (TREE_OPERAND (size, 1))
+ ? last_size : merge_sizes (last_size, first_bit,
+ TREE_OPERAND (size, 1),
+ 1, has_rep),
+ integer_zerop (TREE_OPERAND (size, 2))
+ ? last_size : merge_sizes (last_size, first_bit,
+ TREE_OPERAND (size, 2),
+ 1, has_rep)));
+}
+
+/* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
+ related by the addition of a constant. Return that constant if so. */
+
+static tree
+compute_related_constant (op0, op1)
+ tree op0, op1;
+{
+ tree op0_var, op1_var;
+ tree op0_con = split_plus (op0, &op0_var);
+ tree op1_con = split_plus (op1, &op1_var);
+ tree result = size_binop (MINUS_EXPR, op0_con, op1_con);
+
+ if (operand_equal_p (op0_var, op1_var, 0))
+ return result;
+ else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0))
+ return result;
+ else
+ return 0;
+}
+
+/* Utility function of above to split a tree OP which may be a sum, into a
+ constant part, which is returned, and a variable part, which is stored
+ in *PVAR. *PVAR may be size_zero_node. All operations must be of
+ sizetype. */
+
+static tree
+split_plus (in, pvar)
+ tree in;
+ tree *pvar;
+{
+ tree result = bitsize_zero_node;
+
+ while (TREE_CODE (in) == NON_LVALUE_EXPR)
+ in = TREE_OPERAND (in, 0);
+
+ *pvar = in;
+ if (TREE_CODE (in) == INTEGER_CST)
+ {
+ *pvar = bitsize_zero_node;
+ return in;
+ }
+ else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR)
+ {
+ tree lhs_var, rhs_var;
+ tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var);
+ tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var);
+
+ result = size_binop (PLUS_EXPR, result, lhs_con);
+ result = size_binop (TREE_CODE (in), result, rhs_con);
+
+ if (lhs_var == TREE_OPERAND (in, 0)
+ && rhs_var == TREE_OPERAND (in, 1))
+ return bitsize_zero_node;
+
+ *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var);
+ return result;
+ }
+ else
+ return bitsize_zero_node;
+}
+\f
+/* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
+ subprogram. If it is void_type_node, then we are dealing with a procedure,
+ otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
+ PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the
+ copy-in/copy-out list to be stored into TYPE_CICO_LIST.
+ RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained
+ object. RETURNS_BY_REF is nonzero if the function returns by reference.
+ RETURNS_WITH_DSP is nonzero if the function is to return with a
+ depressed stack pointer. */
+
+tree
+create_subprog_type (return_type, param_decl_list, cico_list,
+ returns_unconstrained, returns_by_ref, returns_with_dsp)
+ tree return_type;
+ tree param_decl_list;
+ tree cico_list;
+ int returns_unconstrained, returns_by_ref, returns_with_dsp;
+{
+ /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
+ the subprogram formal parameters. This list is generated by traversing the
+ input list of PARM_DECL nodes. */
+ tree param_type_list = NULL;
+ tree param_decl;
+ tree type;
+
+ for (param_decl = param_decl_list; param_decl;
+ param_decl = TREE_CHAIN (param_decl))
+ param_type_list = tree_cons (NULL_TREE, TREE_TYPE (param_decl),
+ param_type_list);
+
+ /* The list of the function parameter types has to be terminated by the void
+ type to signal to the back-end that we are not dealing with a variable
+ parameter subprogram, but that the subprogram has a fixed number of
+ parameters. */
+ param_type_list = tree_cons (NULL_TREE, void_type_node, param_type_list);
+
+ /* The list of argument types has been created in reverse
+ so nreverse it. */
+ param_type_list = nreverse (param_type_list);
+
+ type = build_function_type (return_type, param_type_list);
+
+ /* TYPE may have been shared since GCC hashes types. If it has a CICO_LIST
+ or the new type should, make a copy of TYPE. Likewise for
+ RETURNS_UNCONSTRAINED and RETURNS_BY_REF. */
+ if (TYPE_CI_CO_LIST (type) != 0 || cico_list != 0
+ || TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained
+ || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref)
+ type = copy_type (type);
+
+ TYPE_CI_CO_LIST (type) = cico_list;
+ TYPE_RETURNS_UNCONSTRAINED_P (type) = returns_unconstrained;
+ TYPE_RETURNS_STACK_DEPRESSED (type) = returns_with_dsp;
+ TYPE_RETURNS_BY_REF_P (type) = returns_by_ref;
+ return type;
+}
+\f
+/* Return a copy of TYPE but safe to modify in any way. */
+
+tree
+copy_type (type)
+ tree type;
+{
+ tree new = copy_node (type);
+
+ /* copy_node clears this field instead of copying it, because it is
+ aliased with TREE_CHAIN. */
+ TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type);
+
+ TYPE_POINTER_TO (new) = 0;
+ TYPE_REFERENCE_TO (new) = 0;
+ TYPE_MAIN_VARIANT (new) = new;
+ TYPE_NEXT_VARIANT (new) = 0;
+
+ return new;
+}
+\f
+/* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
+ TYPE_INDEX_TYPE is INDEX. */
+
+tree
+create_index_type (min, max, index)
+ tree min, max;
+ tree index;
+{
+ /* First build a type for the desired range. */
+ tree type = build_index_2_type (min, max);
+
+ /* If this type has the TYPE_INDEX_TYPE we want, return it. Otherwise, if it
+ doesn't have TYPE_INDEX_TYPE set, set it to INDEX. If TYPE_INDEX_TYPE
+ is set, but not to INDEX, make a copy of this type with the requested
+ index type. Note that we have no way of sharing these types, but that's
+ only a small hole. */
+ if (TYPE_INDEX_TYPE (type) == index)
+ return type;
+ else if (TYPE_INDEX_TYPE (type) != 0)
+ type = copy_type (type);
+
+ TYPE_INDEX_TYPE (type) = index;
+ return type;
+}
+\f
+/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
+ string) and TYPE is a ..._TYPE node giving its data type.
+ ARTIFICIAL_P is nonzero if this is a declaration that was generated
+ by the compiler. DEBUG_INFO_P is nonzero if we need to write debugging
+ information about this type. */
+
+tree
+create_type_decl (type_name, type, attr_list, artificial_p, debug_info_p)
+ tree type_name;
+ tree type;
+ struct attrib *attr_list;
+ int artificial_p;
+ int debug_info_p;
+{
+ tree type_decl = build_decl (TYPE_DECL, type_name, type);
+ enum tree_code code = TREE_CODE (type);
+
+ DECL_ARTIFICIAL (type_decl) = artificial_p;
+ pushdecl (type_decl);
+ process_attributes (type_decl, attr_list);
+
+ /* Pass type declaration information to the debugger unless this is an
+ UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
+ and ENUMERAL_TYPE or RECORD_TYPE which is handled separately,
+ a dummy type, which will be completed later, or a type for which
+ debugging information was not requested. */
+ if (code == UNCONSTRAINED_ARRAY_TYPE || TYPE_IS_DUMMY_P (type)
+ || ! debug_info_p)
+ DECL_IGNORED_P (type_decl) = 1;
+ else if (code != ENUMERAL_TYPE && code != RECORD_TYPE
+ && ! ((code == POINTER_TYPE || code == REFERENCE_TYPE)
+ && TYPE_IS_DUMMY_P (TREE_TYPE (type))))
+ rest_of_decl_compilation (type_decl, NULL, global_bindings_p (), 0);
+
+ return type_decl;
+}
+
+/* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
+ ASM_NAME is its assembler name (if provided). TYPE is its data type
+ (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an optional initial
+ expression; NULL_TREE if none.
+
+ CONST_FLAG is nonzero if this variable is constant.
+
+ PUBLIC_FLAG is nonzero if this definition is to be made visible outside of
+ the current compilation unit. This flag should be set when processing the
+ variable definitions in a package specification. EXTERN_FLAG is nonzero
+ when processing an external variable declaration (as opposed to a
+ definition: no storage is to be allocated for the variable here).
+
+ STATIC_FLAG is only relevant when not at top level. In that case
+ it indicates whether to always allocate storage to the variable. */
+
+tree
+create_var_decl (var_name, asm_name, type, var_init, const_flag, public_flag,
+ extern_flag, static_flag, attr_list)
+ tree var_name;
+ tree asm_name;
+ tree type;
+ tree var_init;
+ int const_flag;
+ int public_flag;
+ int extern_flag;
+ int static_flag;
+ struct attrib *attr_list;
+{
+ int init_const
+ = (var_init == 0
+ ? 0
+ : (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (var_init))
+ && (global_bindings_p () || static_flag
+ ? 0 != initializer_constant_valid_p (var_init,
+ TREE_TYPE (var_init))
+ : TREE_CONSTANT (var_init))));
+ tree var_decl
+ = build_decl ((const_flag && init_const
+ /* Only make a CONST_DECL for sufficiently-small objects.
+ We consider complex double "sufficiently-small" */
+ && TYPE_SIZE (type) != 0
+ && host_integerp (TYPE_SIZE_UNIT (type), 1)
+ && 0 >= compare_tree_int (TYPE_SIZE_UNIT (type),
+ GET_MODE_SIZE (DCmode)))
+ ? CONST_DECL : VAR_DECL, var_name, type);
+ tree assign_init = 0;
+
+ /* If this is external, throw away any initializations unless this is a
+ CONST_DECL (meaning we have a constant); they will be done elsewhere. If
+ we are defining a global here, leave a constant initialization and save
+ any variable elaborations for the elaboration routine. Otherwise, if
+ the initializing expression is not the same as TYPE, generate the
+ initialization with an assignment statement, since it knows how
+ to do the required adjustents. */
+
+ if (extern_flag && TREE_CODE (var_decl) != CONST_DECL)
+ var_init = 0;
+
+ if (global_bindings_p () && var_init != 0 && ! init_const)
+ {
+ add_pending_elaborations (var_decl, var_init);
+ var_init = 0;
+ }
+
+ else if (var_init != 0
+ && ((TYPE_MAIN_VARIANT (TREE_TYPE (var_init))
+ != TYPE_MAIN_VARIANT (type))
+ || (static_flag && ! init_const)))
+ assign_init = var_init, var_init = 0;
+
+ DECL_COMMON (var_decl) = !flag_no_common;
+ DECL_INITIAL (var_decl) = var_init;
+ TREE_READONLY (var_decl) = const_flag;
+ DECL_EXTERNAL (var_decl) = extern_flag;
+ TREE_PUBLIC (var_decl) = public_flag || extern_flag;
+ TREE_CONSTANT (var_decl) = TREE_CODE (var_decl) == CONST_DECL;
+ TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
+ = TYPE_VOLATILE (type);
+
+ /* At the global binding level we need to allocate static storage for the
+ variable if and only if its not external. If we are not at the top level
+ we allocate automatic storage unless requested not to. */
+ TREE_STATIC (var_decl) = global_bindings_p () ? !extern_flag : static_flag;
+
+ if (asm_name != 0)
+ SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
+
+ process_attributes (var_decl, attr_list);
+
+ /* Add this decl to the current binding level and generate any
+ needed code and RTL. */
+ var_decl = pushdecl (var_decl);
+ expand_decl (var_decl);
+
+ if (DECL_CONTEXT (var_decl) != 0)
+ expand_decl_init (var_decl);
+
+ /* If this is volatile, force it into memory. */
+ if (TREE_SIDE_EFFECTS (var_decl))
+ mark_addressable (var_decl);
+
+ if (TREE_CODE (var_decl) != CONST_DECL)
+ rest_of_decl_compilation (var_decl, 0, global_bindings_p (), 0);
+
+ if (assign_init != 0)
+ {
+ /* If VAR_DECL has a padded type, convert it to the unpadded
+ type so the assignment is done properly. */
+ tree lhs = var_decl;
+
+ if (TREE_CODE (TREE_TYPE (lhs)) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (lhs)))
+ lhs = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs))), lhs);
+
+ expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, lhs,
+ assign_init));
+ }
+
+ return var_decl;
+}
+\f
+/* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
+ type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
+ this field is in a record type with a "pragma pack". If SIZE is nonzero
+ it is the specified size for this field. If POS is nonzero, it is the bit
+ position. If ADDRESSABLE is nonzero, it means we are allowed to take
+ the address of this field for aliasing purposes. */
+
+tree
+create_field_decl (field_name, field_type, record_type, packed, size, pos,
+ addressable)
+ tree field_name;
+ tree field_type;
+ tree record_type;
+ int packed;
+ tree size, pos;
+ int addressable;
+{
+ tree field_decl = build_decl (FIELD_DECL, field_name, field_type);
+
+ DECL_CONTEXT (field_decl) = record_type;
+ TREE_READONLY (field_decl) = TREE_READONLY (field_type);
+
+ /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
+ byte boundary since GCC cannot handle less-aligned BLKmode bitfields.
+ If it is a padding type where the inner field is of variable size, it
+ must be at its natural alignment. Just handle the packed case here; we
+ will disallow non-aligned rep clauses elsewhere. */
+ if (packed && TYPE_MODE (field_type) == BLKmode)
+ DECL_ALIGN (field_decl)
+ = ((TREE_CODE (field_type) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (field_type)
+ && ! TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (field_type))))
+ ? TYPE_ALIGN (field_type) : BITS_PER_UNIT);
+
+ /* If a size is specified, use it. Otherwise, see if we have a size
+ to use that may differ from the natural size of the object. */
+ if (size != 0)
+ size = convert (bitsizetype, size);
+ else if (packed)
+ {
+ if (packed == 1 && ! operand_equal_p (rm_size (field_type),
+ TYPE_SIZE (field_type), 0))
+ size = rm_size (field_type);
+
+ /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to
+ byte. */
+ if (size != 0 && TREE_CODE (size) == INTEGER_CST
+ && compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0)
+ size = round_up (size, BITS_PER_UNIT);
+ }
+
+ /* Make a bitfield if a size is specified for two reasons: first if the size
+ differs from the natural size. Second, if the alignment is insufficient.
+ There are a number of ways the latter can be true. But never make a
+ bitfield if the type of the field has a nonconstant size. */
+
+ if (size != 0 && TREE_CODE (size) == INTEGER_CST
+ && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
+ && (! operand_equal_p (TYPE_SIZE (field_type), size, 0)
+ || (pos != 0
+ && ! value_zerop (size_binop (TRUNC_MOD_EXPR, pos,
+ bitsize_int (TYPE_ALIGN
+ (field_type)))))
+ || packed
+ || (TYPE_ALIGN (record_type) != 0
+ && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))))
+ {
+ DECL_BIT_FIELD (field_decl) = 1;
+ DECL_SIZE (field_decl) = size;
+ if (! packed && pos == 0)
+ DECL_ALIGN (field_decl)
+ = (TYPE_ALIGN (record_type) != 0
+ ? MIN (TYPE_ALIGN (record_type), TYPE_ALIGN (field_type))
+ : TYPE_ALIGN (field_type));
+ }
+
+ DECL_PACKED (field_decl) = pos != 0 ? DECL_BIT_FIELD (field_decl) : packed;
+ DECL_ALIGN (field_decl)
+ = MAX (DECL_ALIGN (field_decl),
+ DECL_BIT_FIELD (field_decl) ? 1
+ : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT
+ : TYPE_ALIGN (field_type));
+
+ if (pos != 0)
+ {
+ /* We need to pass in the alignment the DECL is known to have.
+ This is the lowest-order bit set in POS, but no more than
+ the alignment of the record, if one is specified. Note
+ that an alignment of 0 is taken as infinite. */
+ unsigned int known_align;
+
+ if (host_integerp (pos, 1))
+ known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1);
+ else
+ known_align = BITS_PER_UNIT;
+
+ if (TYPE_ALIGN (record_type)
+ && (known_align == 0 || known_align > TYPE_ALIGN (record_type)))
+ known_align = TYPE_ALIGN (record_type);
+
+ layout_decl (field_decl, known_align);
+ SET_DECL_OFFSET_ALIGN (field_decl, BIGGEST_ALIGNMENT);
+ pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
+ &DECL_FIELD_BIT_OFFSET (field_decl),
+ BIGGEST_ALIGNMENT, pos);
+
+ DECL_HAS_REP_P (field_decl) = 1;
+ }
+
+ /* Mark the decl as nonaddressable if it either is indicated so semantically
+ or if it is a bit field. */
+ DECL_NONADDRESSABLE_P (field_decl)
+ = ! addressable || DECL_BIT_FIELD (field_decl);
+
+ return field_decl;
+}
+
+/* Subroutine of previous function: return nonzero if EXP, ignoring any side
+ effects, has the value of zero. */
+
+static int
+value_zerop (exp)
+ tree exp;
+{
+ if (TREE_CODE (exp) == COMPOUND_EXPR)
+ return value_zerop (TREE_OPERAND (exp, 1));
+
+ return integer_zerop (exp);
+}
+\f
+/* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
+ PARAM_TYPE is its type. READONLY is nonzero if the parameter is
+ readonly (either an IN parameter or an address of a pass-by-ref
+ parameter). */
+
+tree
+create_param_decl (param_name, param_type, readonly)
+ tree param_name;
+ tree param_type;
+ int readonly;
+{
+ tree param_decl = build_decl (PARM_DECL, param_name, param_type);
+
+ DECL_ARG_TYPE (param_decl) = param_type;
+ DECL_ARG_TYPE_AS_WRITTEN (param_decl) = param_type;
+ TREE_READONLY (param_decl) = readonly;
+ return param_decl;
+}
+\f
+/* Given a DECL and ATTR_LIST, process the listed attributes. */
+
+void
+process_attributes (decl, attr_list)
+ tree decl;
+ struct attrib *attr_list;
+{
+ for (; attr_list; attr_list = attr_list->next)
+ switch (attr_list->type)
+ {
+ case ATTR_MACHINE_ATTRIBUTE:
+ decl_attributes (&decl, tree_cons (attr_list->name, attr_list->arg,
+ NULL_TREE),
+ ATTR_FLAG_TYPE_IN_PLACE);
+ break;
+
+ case ATTR_LINK_ALIAS:
+ TREE_STATIC (decl) = 1;
+ assemble_alias (decl, attr_list->name);
+ break;
+
+ case ATTR_WEAK_EXTERNAL:
+ if (SUPPORTS_WEAK)
+ declare_weak (decl);
+ else
+ post_error ("?weak declarations not supported on this target",
+ attr_list->error_point);
+ break;
+
+ case ATTR_LINK_SECTION:
+#ifdef ASM_OUTPUT_SECTION_NAME
+ DECL_SECTION_NAME (decl)
+ = build_string (IDENTIFIER_LENGTH (attr_list->name),
+ IDENTIFIER_POINTER (attr_list->name));
+ DECL_COMMON (decl) = 0;
+#else
+ post_error ("?section attributes are not supported for this target",
+ attr_list->error_point);
+#endif
+ break;
+ }
+}
+\f
+/* Add some pending elaborations on the list. */
+
+void
+add_pending_elaborations (var_decl, var_init)
+ tree var_decl;
+ tree var_init;
+{
+ if (var_init != 0)
+ Check_Elaboration_Code_Allowed (error_gnat_node);
+
+ pending_elaborations
+ = chainon (pending_elaborations, build_tree_list (var_decl, var_init));
+}
+
+/* Obtain any pending elaborations and clear the old list. */
+
+tree
+get_pending_elaborations ()
+{
+ /* Each thing added to the list went on the end; we want it on the
+ beginning. */
+ tree result = TREE_CHAIN (pending_elaborations);
+
+ TREE_CHAIN (pending_elaborations) = 0;
+ return result;
+}
+
+/* Mark the binding level stack. */
+
+static void
+mark_binding_level (arg)
+ PTR arg;
+{
+ struct binding_level *level = *(struct binding_level **) arg;
+
+ for (; level != 0; level = level->level_chain)
+ {
+ ggc_mark_tree (level->names);
+ ggc_mark_tree (level->blocks);
+ ggc_mark_tree (level->this_block);
+ }
+}
+
+/* Mark the pending elaboration list. */
+
+static void
+mark_e_stack (data)
+ PTR data;
+{
+ struct e_stack *p = *((struct e_stack **) data);
+
+ if (p != 0)
+ {
+ ggc_mark_tree (p->elab_list);
+ mark_e_stack (&p->next);
+ }
+}
+
+/* Return nonzero if there are pending elaborations. */
+
+int
+pending_elaborations_p ()
+{
+ return TREE_CHAIN (pending_elaborations) != 0;
+}
+
+/* Save a copy of the current pending elaboration list and make a new
+ one. */
+
+void
+push_pending_elaborations ()
+{
+ struct e_stack *p = (struct e_stack *) xmalloc (sizeof (struct e_stack));
+
+ p->next = elist_stack;
+ p->elab_list = pending_elaborations;
+ elist_stack = p;
+ pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
+}
+
+/* Pop the stack of pending elaborations. */
+
+void
+pop_pending_elaborations ()
+{
+ struct e_stack *p = elist_stack;
+
+ pending_elaborations = p->elab_list;
+ elist_stack = p->next;
+ free (p);
+}
+
+/* Return the current position in pending_elaborations so we can insert
+ elaborations after that point. */
+
+tree
+get_elaboration_location ()
+{
+ return tree_last (pending_elaborations);
+}
+
+/* Insert the current elaborations after ELAB, which is in some elaboration
+ list. */
+
+void
+insert_elaboration_list (elab)
+ tree elab;
+{
+ tree next = TREE_CHAIN (elab);
+
+ if (TREE_CHAIN (pending_elaborations))
+ {
+ TREE_CHAIN (elab) = TREE_CHAIN (pending_elaborations);
+ TREE_CHAIN (tree_last (pending_elaborations)) = next;
+ TREE_CHAIN (pending_elaborations) = 0;
+ }
+}
+
+/* Returns a LABEL_DECL node for LABEL_NAME. */
+
+tree
+create_label_decl (label_name)
+ tree label_name;
+{
+ tree label_decl = build_decl (LABEL_DECL, label_name, void_type_node);
+
+ DECL_CONTEXT (label_decl) = current_function_decl;
+ DECL_MODE (label_decl) = VOIDmode;
+ DECL_SOURCE_LINE (label_decl) = lineno;
+ DECL_SOURCE_FILE (label_decl) = input_filename;
+
+ return label_decl;
+}
+\f
+/* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram,
+ ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
+ node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
+ PARM_DECL nodes chained through the TREE_CHAIN field).
+
+ INLINE_FLAG, PUBLIC_FLAG, and EXTERN_FLAG are used to set the appropriate
+ fields in the FUNCTION_DECL. */
+
+tree
+create_subprog_decl (subprog_name, asm_name, subprog_type, param_decl_list,
+ inline_flag, public_flag, extern_flag, attr_list)
+ tree subprog_name;
+ tree asm_name;
+ tree subprog_type;
+ tree param_decl_list;
+ int inline_flag;
+ int public_flag;
+ int extern_flag;
+ struct attrib *attr_list;
+{
+ tree return_type = TREE_TYPE (subprog_type);
+ tree subprog_decl = build_decl (FUNCTION_DECL, subprog_name, subprog_type);
+
+ /* If this is a function nested inside an inlined external function, it
+ means we aren't going to compile the outer function unless it is
+ actually inlined, so do the same for us. */
+ if (current_function_decl != 0 && DECL_INLINE (current_function_decl)
+ && DECL_EXTERNAL (current_function_decl))
+ extern_flag = 1;
+
+ DECL_EXTERNAL (subprog_decl) = extern_flag;
+ TREE_PUBLIC (subprog_decl) = public_flag;
+ DECL_INLINE (subprog_decl) = inline_flag;
+ TREE_READONLY (subprog_decl) = TYPE_READONLY (subprog_type);
+ TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type);
+ TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type);
+ DECL_ARGUMENTS (subprog_decl) = param_decl_list;
+ DECL_RESULT (subprog_decl) = build_decl (RESULT_DECL, 0, return_type);
+
+ if (asm_name != 0)
+ DECL_ASSEMBLER_NAME (subprog_decl) = asm_name;
+
+ process_attributes (subprog_decl, attr_list);
+
+ /* Add this decl to the current binding level. */
+ subprog_decl = pushdecl (subprog_decl);
+
+ /* Output the assembler code and/or RTL for the declaration. */
+ rest_of_decl_compilation (subprog_decl, 0, global_bindings_p (), 0);
+
+ return subprog_decl;
+}
+\f
+/* Count how deep we are into nested functions. This is because
+ we shouldn't call the backend function context routines unless we
+ are in a nested function. */
+
+static int function_nesting_depth;
+
+/* Set up the framework for generating code for SUBPROG_DECL, a subprogram
+ body. This routine needs to be invoked before processing the declarations
+ appearing in the subprogram. */
+
+void
+begin_subprog_body (subprog_decl)
+ tree subprog_decl;
+{
+ tree param_decl_list;
+ tree param_decl;
+ tree next_param;
+
+ if (function_nesting_depth++ != 0)
+ push_function_context ();
+
+ announce_function (subprog_decl);
+
+ /* Make this field nonzero so further routines know that this is not
+ tentative. error_mark_node is replaced below (in poplevel) with the
+ adequate BLOCK. */
+ DECL_INITIAL (subprog_decl) = error_mark_node;
+
+ /* This function exists in static storage. This does not mean `static' in
+ the C sense! */
+ TREE_STATIC (subprog_decl) = 1;
+
+ /* Enter a new binding level. */
+ current_function_decl = subprog_decl;
+ pushlevel (0);
+
+ /* Push all the PARM_DECL nodes onto the current scope (i.e. the scope of the
+ subprogram body) so that they can be recognized as local variables in the
+ subprogram.
+
+ The list of PARM_DECL nodes is stored in the right order in
+ DECL_ARGUMENTS. Since ..._DECL nodes get stored in the reverse order in
+ which they are transmitted to `pushdecl' we need to reverse the list of
+ PARM_DECLs if we want it to be stored in the right order. The reason why
+ we want to make sure the PARM_DECLs are stored in the correct order is
+ that this list will be retrieved in a few lines with a call to `getdecl'
+ to store it back into the DECL_ARGUMENTS field. */
+ param_decl_list = nreverse (DECL_ARGUMENTS (subprog_decl));
+
+ for (param_decl = param_decl_list; param_decl; param_decl = next_param)
+ {
+ next_param = TREE_CHAIN (param_decl);
+ TREE_CHAIN (param_decl) = NULL;
+ pushdecl (param_decl);
+ }
+
+ /* Store back the PARM_DECL nodes. They appear in the right order. */
+ DECL_ARGUMENTS (subprog_decl) = getdecls ();
+
+ init_function_start (subprog_decl, input_filename, lineno);
+ expand_function_start (subprog_decl, 0);
+}
+
+
+/* Finish the definition of the current subprogram and compile it all the way
+ to assembler language output. */
+
+void
+end_subprog_body (void)
+{
+ tree decl;
+ tree cico_list;
+
+ poplevel (1, 0, 1);
+ BLOCK_SUPERCONTEXT (DECL_INITIAL (current_function_decl))
+ = current_function_decl;
+
+ /* Mark the RESULT_DECL as being in this subprogram. */
+ DECL_CONTEXT (DECL_RESULT (current_function_decl)) = current_function_decl;
+
+ expand_function_end (input_filename, lineno, 0);
+ rest_of_compilation (current_function_decl);
+
+#if 0
+ /* If we're sure this function is defined in this file then mark it
+ as such */
+ if (TREE_ASM_WRITTEN (current_function_decl))
+ mark_fn_defined_in_this_file (current_function_decl);
+#endif
+
+ /* Throw away any VAR_DECLs we made for OUT parameters; they must
+ not be seen when we call this function and will be in
+ unallocated memory anyway. */
+ for (cico_list = TYPE_CI_CO_LIST (TREE_TYPE (current_function_decl));
+ cico_list != 0; cico_list = TREE_CHAIN (cico_list))
+ TREE_VALUE (cico_list) = 0;
+
+ if (DECL_SAVED_INSNS (current_function_decl) == 0)
+ {
+ /* Throw away DECL_RTL in any PARM_DECLs unless this function
+ was saved for inline, in which case the DECL_RTLs are in
+ preserved memory. */
+ for (decl = DECL_ARGUMENTS (current_function_decl);
+ decl != 0; decl = TREE_CHAIN (decl))
+ {
+ SET_DECL_RTL (decl, 0);
+ DECL_INCOMING_RTL (decl) = 0;
+ }
+
+ /* Similarly, discard DECL_RTL of the return value. */
+ SET_DECL_RTL (DECL_RESULT (current_function_decl), 0);
+
+ /* But DECL_INITIAL must remain nonzero so we know this
+ was an actual function definition unless toplev.c decided not
+ to inline it. */
+ if (DECL_INITIAL (current_function_decl) != 0)
+ DECL_INITIAL (current_function_decl) = error_mark_node;
+
+ DECL_ARGUMENTS (current_function_decl) = 0;
+ }
+
+ /* If we are not at the bottom of the function nesting stack, pop up to
+ the containing function. Otherwise show we aren't in any function. */
+ if (--function_nesting_depth != 0)
+ pop_function_context ();
+ else
+ current_function_decl = 0;
+}
+\f
+/* Return a definition for a builtin function named NAME and whose data type
+ is TYPE. TYPE should be a function type with argument types.
+ FUNCTION_CODE tells later passes how to compile calls to this function.
+ See tree.h for its possible values.
+
+ If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
+ the name to be called if we can't opencode the function. */
+
+tree
+builtin_function (name, type, function_code, class, library_name)
+ const char *name;
+ tree type;
+ int function_code;
+ enum built_in_class class;
+ const char *library_name;
+{
+ tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
+
+ DECL_EXTERNAL (decl) = 1;
+ TREE_PUBLIC (decl) = 1;
+ if (library_name)
+ DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
+
+ pushdecl (decl);
+ DECL_BUILT_IN_CLASS (decl) = class;
+ DECL_FUNCTION_CODE (decl) = function_code;
+ return decl;
+}
+
+/* Return an integer type with the number of bits of precision given by
+ PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
+ it is a signed type. */
+
+tree
+type_for_size (precision, unsignedp)
+ unsigned precision;
+ int unsignedp;
+{
+ tree t;
+ char type_name[20];
+
+ if (precision <= 2 * MAX_BITS_PER_WORD
+ && signed_and_unsigned_types[precision][unsignedp] != 0)
+ return signed_and_unsigned_types[precision][unsignedp];
+
+ if (unsignedp)
+ t = make_unsigned_type (precision);
+ else
+ t = make_signed_type (precision);
+
+ if (precision <= 2 * MAX_BITS_PER_WORD)
+ signed_and_unsigned_types[precision][unsignedp] = t;
+
+ if (TYPE_NAME (t) == 0)
+ {
+ sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision);
+ TYPE_NAME (t) = get_identifier (type_name);
+ }
+
+ return t;
+}
+
+/* Likewise for floating-point types. */
+
+static tree
+float_type_for_size (precision, mode)
+ int precision;
+ enum machine_mode mode;
+{
+ tree t;
+ char type_name[20];
+
+ if (float_types[(int) mode] != 0)
+ return float_types[(int) mode];
+
+ float_types[(int) mode] = t = make_node (REAL_TYPE);
+ TYPE_PRECISION (t) = precision;
+ layout_type (t);
+
+ if (TYPE_MODE (t) != mode)
+ gigi_abort (414);
+
+ if (TYPE_NAME (t) == 0)
+ {
+ sprintf (type_name, "FLOAT_%d", precision);
+ TYPE_NAME (t) = get_identifier (type_name);
+ }
+
+ return t;
+}
+
+/* Return a data type that has machine mode MODE. UNSIGNEDP selects
+ an unsigned type; otherwise a signed type is returned. */
+
+tree
+type_for_mode (mode, unsignedp)
+ enum machine_mode mode;
+ int unsignedp;
+{
+ if (GET_MODE_CLASS (mode) == MODE_FLOAT)
+ return float_type_for_size (GET_MODE_BITSIZE (mode), mode);
+ else
+ return type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
+}
+
+/* Return the unsigned version of a TYPE_NODE, a scalar type. */
+
+tree
+unsigned_type (type_node)
+ tree type_node;
+{
+ tree type = type_for_size (TYPE_PRECISION (type_node), 1);
+
+ if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
+ {
+ type = copy_node (type);
+ TREE_TYPE (type) = type_node;
+ }
+ else if (TREE_TYPE (type_node) != 0
+ && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
+ && TYPE_MODULAR_P (TREE_TYPE (type_node)))
+ {
+ type = copy_node (type);
+ TREE_TYPE (type) = TREE_TYPE (type_node);
+ }
+
+ return type;
+}
+
+/* Return the signed version of a TYPE_NODE, a scalar type. */
+
+tree
+signed_type (type_node)
+ tree type_node;
+{
+ tree type = type_for_size (TYPE_PRECISION (type_node), 0);
+
+ if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
+ {
+ type = copy_node (type);
+ TREE_TYPE (type) = type_node;
+ }
+ else if (TREE_TYPE (type_node) != 0
+ && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
+ && TYPE_MODULAR_P (TREE_TYPE (type_node)))
+ {
+ type = copy_node (type);
+ TREE_TYPE (type) = TREE_TYPE (type_node);
+ }
+
+ return type;
+}
+
+/* Return a type the same as TYPE except unsigned or signed according to
+ UNSIGNEDP. */
+
+tree
+signed_or_unsigned_type (unsignedp, type)
+ int unsignedp;
+ tree type;
+{
+ if (! INTEGRAL_TYPE_P (type) || TREE_UNSIGNED (type) == unsignedp)
+ return type;
+ else
+ return type_for_size (TYPE_PRECISION (type), unsignedp);
+}
+\f
+/* EXP is an expression for the size of an object. If this size contains
+ discriminant references, replace them with the maximum (if MAX_P) or
+ minimum (if ! MAX_P) possible value of the discriminant. */
+
+tree
+max_size (exp, max_p)
+ tree exp;
+ int max_p;
+{
+ enum tree_code code = TREE_CODE (exp);
+ tree type = TREE_TYPE (exp);
+
+ switch (TREE_CODE_CLASS (code))
+ {
+ case 'd':
+ case 'c':
+ return exp;
+
+ case 'x':
+ if (code == TREE_LIST)
+ return tree_cons (TREE_PURPOSE (exp),
+ max_size (TREE_VALUE (exp), max_p),
+ TREE_CHAIN (exp) != 0
+ ? max_size (TREE_CHAIN (exp), max_p) : 0);
+ break;
+
+ case 'r':
+ /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
+ modify. Otherwise, we abort since it is something we can't
+ handle. */
+ if (! contains_placeholder_p (exp))
+ gigi_abort (406);
+
+ type = TREE_TYPE (TREE_OPERAND (exp, 1));
+ return
+ max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), 1);
+
+ case '<':
+ return max_p ? size_one_node : size_zero_node;
+
+ case '1':
+ case '2':
+ case 'e':
+ switch (TREE_CODE_LENGTH (code))
+ {
+ case 1:
+ if (code == NON_LVALUE_EXPR)
+ return max_size (TREE_OPERAND (exp, 0), max_p);
+ else
+ return
+ fold (build1 (code, type,
+ max_size (TREE_OPERAND (exp, 0),
+ code == NEGATE_EXPR ? ! max_p : max_p)));
+
+ case 2:
+ if (code == RTL_EXPR)
+ gigi_abort (407);
+ else if (code == COMPOUND_EXPR)
+ return max_size (TREE_OPERAND (exp, 1), max_p);
+ else if (code == WITH_RECORD_EXPR)
+ return exp;
+
+ {
+ tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
+ tree rhs = max_size (TREE_OPERAND (exp, 1),
+ code == MINUS_EXPR ? ! max_p : max_p);
+
+ /* Special-case wanting the maximum value of a MIN_EXPR.
+ In that case, if one side overflows, return the other.
+ sizetype is signed, but we know sizes are non-negative.
+ Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
+ overflowing or the maximum possible value and the RHS
+ a variable. */
+ if (max_p && code == MIN_EXPR && TREE_OVERFLOW (rhs))
+ return lhs;
+ else if (max_p && code == MIN_EXPR && TREE_OVERFLOW (lhs))
+ return rhs;
+ else if ((code == MINUS_EXPR || code == PLUS_EXPR)
+ && (TREE_OVERFLOW (lhs)
+ || operand_equal_p (lhs, TYPE_MAX_VALUE (type), 0))
+ && ! TREE_CONSTANT (rhs))
+ return lhs;
+ else
+ return fold (build (code, type, lhs, rhs));
+ }
+
+ case 3:
+ if (code == SAVE_EXPR)
+ return exp;
+ else if (code == COND_EXPR)
+ return fold (build (MAX_EXPR, type,
+ max_size (TREE_OPERAND (exp, 1), max_p),
+ max_size (TREE_OPERAND (exp, 2), max_p)));
+ else if (code == CALL_EXPR && TREE_OPERAND (exp, 1) != 0)
+ return build (CALL_EXPR, type, TREE_OPERAND (exp, 0),
+ max_size (TREE_OPERAND (exp, 1), max_p));
+ }
+ }
+
+ gigi_abort (408);
+}
+\f
+/* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
+ EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
+ Return a constructor for the template. */
+
+tree
+build_template (template_type, array_type, expr)
+ tree template_type;
+ tree array_type;
+ tree expr;
+{
+ tree template_elts = NULL_TREE;
+ tree bound_list = NULL_TREE;
+ tree field;
+
+ if (TREE_CODE (array_type) == RECORD_TYPE
+ && (TYPE_IS_PADDING_P (array_type)
+ || TYPE_LEFT_JUSTIFIED_MODULAR_P (array_type)))
+ array_type = TREE_TYPE (TYPE_FIELDS (array_type));
+
+ if (TREE_CODE (array_type) == ARRAY_TYPE
+ || (TREE_CODE (array_type) == INTEGER_TYPE
+ && TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
+ bound_list = TYPE_ACTUAL_BOUNDS (array_type);
+
+ /* First make the list for a CONSTRUCTOR for the template. Go down the
+ field list of the template instead of the type chain because this
+ array might be an Ada array of arrays and we can't tell where the
+ nested arrays stop being the underlying object. */
+
+ for (field = TYPE_FIELDS (template_type); field;
+ (bound_list != 0
+ ? (bound_list = TREE_CHAIN (bound_list))
+ : (array_type = TREE_TYPE (array_type))),
+ field = TREE_CHAIN (TREE_CHAIN (field)))
+ {
+ tree bounds, min, max;
+
+ /* If we have a bound list, get the bounds from there. Likewise
+ for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with
+ DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
+ This will give us a maximum range. */
+ if (bound_list != 0)
+ bounds = TREE_VALUE (bound_list);
+ else if (TREE_CODE (array_type) == ARRAY_TYPE)
+ bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
+ else if (expr != 0 && TREE_CODE (expr) == PARM_DECL
+ && DECL_BY_COMPONENT_PTR_P (expr))
+ bounds = TREE_TYPE (field);
+ else
+ gigi_abort (411);
+
+ min = convert (TREE_TYPE (TREE_CHAIN (field)), TYPE_MIN_VALUE (bounds));
+ max = convert (TREE_TYPE (field), TYPE_MAX_VALUE (bounds));
+
+ /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
+ surround them with a WITH_RECORD_EXPR giving EXPR as the
+ OBJECT. */
+ if (! TREE_CONSTANT (min) && contains_placeholder_p (min))
+ min = build (WITH_RECORD_EXPR, TREE_TYPE (min), min, expr);
+ if (! TREE_CONSTANT (max) && contains_placeholder_p (max))
+ max = build (WITH_RECORD_EXPR, TREE_TYPE (max), max, expr);
+
+ template_elts = tree_cons (TREE_CHAIN (field), max,
+ tree_cons (field, min, template_elts));
+ }
+
+ return build_constructor (template_type, nreverse (template_elts));
+}
+\f
+/* Build a VMS descriptor from a Mechanism_Type, which must specify
+ a descriptor type, and the GCC type of an object. Each FIELD_DECL
+ in the type contains in its DECL_INITIAL the expression to use when
+ a constructor is made for the type. GNAT_ENTITY is a gnat node used
+ to print out an error message if the mechanism cannot be applied to
+ an object of that type and also for the name. */
+
+tree
+build_vms_descriptor (type, mech, gnat_entity)
+ tree type;
+ Mechanism_Type mech;
+ Entity_Id gnat_entity;
+{
+ tree record_type = make_node (RECORD_TYPE);
+ tree field_list = 0;
+ int class;
+ int dtype = 0;
+ tree inner_type;
+ int ndim;
+ int i;
+ tree *idx_arr;
+ tree tem;
+
+ /* If TYPE is an unconstrained array, use the underlying array type. */
+ if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
+ type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
+
+ /* If this is an array, compute the number of dimensions in the array,
+ get the index types, and point to the inner type. */
+ if (TREE_CODE (type) != ARRAY_TYPE)
+ ndim = 0;
+ else
+ for (ndim = 1, inner_type = type;
+ TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
+ ndim++, inner_type = TREE_TYPE (inner_type))
+ ;
+
+ idx_arr = (tree *) alloca (ndim * sizeof (tree));
+
+ if (mech != By_Descriptor_NCA
+ && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
+ for (i = ndim - 1, inner_type = type;
+ i >= 0;
+ i--, inner_type = TREE_TYPE (inner_type))
+ idx_arr[i] = TYPE_DOMAIN (inner_type);
+ else
+ for (i = 0, inner_type = type;
+ i < ndim;
+ i++, inner_type = TREE_TYPE (inner_type))
+ idx_arr[i] = TYPE_DOMAIN (inner_type);
+
+ /* Now get the DTYPE value. */
+ switch (TREE_CODE (type))
+ {
+ case INTEGER_TYPE:
+ case ENUMERAL_TYPE:
+ if (TYPE_VAX_FLOATING_POINT_P (type))
+ switch ((int) TYPE_DIGITS_VALUE (type))
+ {
+ case 6:
+ dtype = 10;
+ break;
+ case 9:
+ dtype = 11;
+ break;
+ case 15:
+ dtype = 27;
+ break;
+ }
+ else
+ switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
+ {
+ case 8:
+ dtype = TREE_UNSIGNED (type) ? 2 : 6;
+ break;
+ case 16:
+ dtype = TREE_UNSIGNED (type) ? 3 : 7;
+ break;
+ case 32:
+ dtype = TREE_UNSIGNED (type) ? 4 : 8;
+ break;
+ case 64:
+ dtype = TREE_UNSIGNED (type) ? 5 : 9;
+ break;
+ case 128:
+ dtype = TREE_UNSIGNED (type) ? 25 : 26;
+ break;
+ }
+ break;
+
+ case REAL_TYPE:
+ dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
+ break;
+
+ case COMPLEX_TYPE:
+ if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
+ && TYPE_VAX_FLOATING_POINT_P (type))
+ switch ((int) TYPE_DIGITS_VALUE (type))
+ {
+ case 6:
+ dtype = 12;
+ break;
+ case 9:
+ dtype = 13;
+ break;
+ case 15:
+ dtype = 29;
+ }
+ else
+ dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
+ break;
+
+ case ARRAY_TYPE:
+ dtype = 14;
+ break;
+
+ default:
+ break;
+ }
+
+ /* Get the CLASS value. */
+ switch (mech)
+ {
+ case By_Descriptor_A:
+ class = 4;
+ break;
+ case By_Descriptor_NCA:
+ class = 10;
+ break;
+ case By_Descriptor_SB:
+ class = 15;
+ break;
+ default:
+ class = 1;
+ }
+
+ /* Make the type for a descriptor for VMS. The first four fields
+ are the same for all types. */
+
+ field_list
+ = chainon (field_list,
+ make_descriptor_field
+ ("LENGTH", type_for_size (16, 1), record_type,
+ size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
+
+ field_list = chainon (field_list,
+ make_descriptor_field ("DTYPE", type_for_size (8, 1),
+ record_type, size_int (dtype)));
+ field_list = chainon (field_list,
+ make_descriptor_field ("CLASS", type_for_size (8, 1),
+ record_type, size_int (class)));
+
+ field_list
+ = chainon (field_list,
+ make_descriptor_field ("POINTER",
+ build_pointer_type (type),
+ record_type,
+ build1 (ADDR_EXPR,
+ build_pointer_type (type),
+ build (PLACEHOLDER_EXPR,
+ type))));
+
+ switch (mech)
+ {
+ case By_Descriptor:
+ case By_Descriptor_S:
+ break;
+
+ case By_Descriptor_SB:
+ field_list
+ = chainon (field_list,
+ make_descriptor_field
+ ("SB_L1", type_for_size (32, 1), record_type,
+ TREE_CODE (type) == ARRAY_TYPE
+ ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
+ field_list
+ = chainon (field_list,
+ make_descriptor_field
+ ("SB_L2", type_for_size (32, 1), record_type,
+ TREE_CODE (type) == ARRAY_TYPE
+ ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
+ break;
+
+ case By_Descriptor_A:
+ case By_Descriptor_NCA:
+ field_list = chainon (field_list,
+ make_descriptor_field ("SCALE",
+ type_for_size (8, 1),
+ record_type,
+ size_zero_node));
+
+ field_list = chainon (field_list,
+ make_descriptor_field ("DIGITS",
+ type_for_size (8, 1),
+ record_type,
+ size_zero_node));
+
+ field_list
+ = chainon (field_list,
+ make_descriptor_field
+ ("AFLAGS", type_for_size (8, 1), record_type,
+ size_int (mech == By_Descriptor_NCA
+ ? 0
+ /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */
+ : (TREE_CODE (type) == ARRAY_TYPE
+ && TYPE_CONVENTION_FORTRAN_P (type)
+ ? 224 : 192))));
+
+ field_list = chainon (field_list,
+ make_descriptor_field ("DIMCT",
+ type_for_size (8, 1),
+ record_type,
+ size_int (ndim)));
+
+ field_list = chainon (field_list,
+ make_descriptor_field ("ARSIZE",
+ type_for_size (32, 1),
+ record_type,
+ size_in_bytes (type)));
+
+ /* Now build a pointer to the 0,0,0... element. */
+ tem = build (PLACEHOLDER_EXPR, type);
+ for (i = 0, inner_type = type; i < ndim;
+ i++, inner_type = TREE_TYPE (inner_type))
+ tem = build (ARRAY_REF, TREE_TYPE (inner_type), tem,
+ convert (TYPE_DOMAIN (inner_type), size_zero_node));
+
+ field_list
+ = chainon (field_list,
+ make_descriptor_field
+ ("A0", build_pointer_type (inner_type), record_type,
+ build1 (ADDR_EXPR, build_pointer_type (inner_type), tem)));
+
+ /* Next come the addressing coefficients. */
+ tem = size_int (1);
+ for (i = 0; i < ndim; i++)
+ {
+ char fname[3];
+ tree idx_length
+ = size_binop (MULT_EXPR, tem,
+ size_binop (PLUS_EXPR,
+ size_binop (MINUS_EXPR,
+ TYPE_MAX_VALUE (idx_arr[i]),
+ TYPE_MIN_VALUE (idx_arr[i])),
+ size_int (1)));
+
+ fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
+ fname[1] = '0' + i, fname[2] = 0;
+ field_list = chainon (field_list,
+ make_descriptor_field (fname,
+ type_for_size (32, 1),
+ record_type,
+ idx_length));
+
+ if (mech == By_Descriptor_NCA)
+ tem = idx_length;
+ }
+
+ /* Finally here are the bounds. */
+ for (i = 0; i < ndim; i++)
+ {
+ char fname[3];
+
+ fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
+ field_list
+ = chainon (field_list,
+ make_descriptor_field
+ (fname, type_for_size (32, 1), record_type,
+ TYPE_MIN_VALUE (idx_arr[i])));
+
+ fname[0] = 'U';
+ field_list
+ = chainon (field_list,
+ make_descriptor_field
+ (fname, type_for_size (32, 1), record_type,
+ TYPE_MAX_VALUE (idx_arr[i])));
+ }
+ break;
+
+ default:
+ post_error ("unsupported descriptor type for &", gnat_entity);
+ }
+
+ finish_record_type (record_type, field_list, 0, 1);
+ pushdecl (build_decl (TYPE_DECL, create_concat_name (gnat_entity, "DESC"),
+ record_type));
+
+ return record_type;
+}
+
+/* Utility routine for above code to make a field. */
+
+static tree
+make_descriptor_field (name, type, rec_type, initial)
+ const char *name;
+ tree type;
+ tree rec_type;
+ tree initial;
+{
+ tree field
+ = create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0);
+
+ DECL_INITIAL (field) = initial;
+ return field;
+}
+\f
+/* Build a type to be used to represent an aliased object whose nominal
+ type is an unconstrained array. This consists of a RECORD_TYPE containing
+ a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
+ ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this
+ is used to represent an arbitrary unconstrained object. Use NAME
+ as the name of the record. */
+
+tree
+build_unc_object_type (template_type, object_type, name)
+ tree template_type;
+ tree object_type;
+ tree name;
+{
+ tree type = make_node (RECORD_TYPE);
+ tree template_field = create_field_decl (get_identifier ("BOUNDS"),
+ template_type, type, 0, 0, 0, 1);
+ tree array_field = create_field_decl (get_identifier ("ARRAY"), object_type,
+ type, 0, 0, 0, 1);
+
+ TYPE_NAME (type) = name;
+ TYPE_CONTAINS_TEMPLATE_P (type) = 1;
+ finish_record_type (type,
+ chainon (chainon (NULL_TREE, template_field),
+ array_field),
+ 0, 0);
+
+ return type;
+}
+\f
+/* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In
+ the normal case this is just two adjustments, but we have more to do
+ if NEW is an UNCONSTRAINED_ARRAY_TYPE. */
+
+void
+update_pointer_to (old_type, new_type)
+ tree old_type;
+ tree new_type;
+{
+ tree ptr = TYPE_POINTER_TO (old_type);
+ tree ref = TYPE_REFERENCE_TO (old_type);
+
+ if ((ptr == 0 && ref == 0) || old_type == new_type)
+ return;
+
+ /* First handle the simple case. */
+ if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
+ {
+ if (ptr != 0)
+ TREE_TYPE (ptr) = new_type;
+ TYPE_POINTER_TO (new_type) = ptr;
+
+ if (ref != 0)
+ TREE_TYPE (ref) = new_type;
+ TYPE_REFERENCE_TO (new_type) = ref;
+
+ if (ptr != 0 && TYPE_NAME (ptr) != 0
+ && TREE_CODE (TYPE_NAME (ptr)) == TYPE_DECL
+ && TREE_CODE (new_type) != ENUMERAL_TYPE)
+ rest_of_decl_compilation (TYPE_NAME (ptr), NULL,
+ global_bindings_p (), 0);
+ if (ref != 0 && TYPE_NAME (ref) != 0
+ && TREE_CODE (TYPE_NAME (ref)) == TYPE_DECL
+ && TREE_CODE (new_type) != ENUMERAL_TYPE)
+ rest_of_decl_compilation (TYPE_NAME (ref), NULL,
+ global_bindings_p (), 0);
+ }
+
+ /* Now deal with the unconstrained array case. In this case the "pointer"
+ is actually a RECORD_TYPE where the types of both fields are
+ pointers to void. In that case, copy the field list from the
+ old type to the new one and update the fields' context. */
+ else if (TREE_CODE (ptr) != RECORD_TYPE || ! TYPE_IS_FAT_POINTER_P (ptr))
+ gigi_abort (412);
+
+ else
+ {
+ tree new_obj_rec = TYPE_OBJECT_RECORD_TYPE (new_type);
+ tree ptr_temp_type;
+ tree new_ref;
+ tree var;
+
+ TYPE_FIELDS (ptr) = TYPE_FIELDS (TYPE_POINTER_TO (new_type));
+ DECL_CONTEXT (TYPE_FIELDS (ptr)) = ptr;
+ DECL_CONTEXT (TREE_CHAIN (TYPE_FIELDS (ptr))) = ptr;
+
+ /* Rework the PLACEHOLDER_EXPR inside the reference to the
+ template bounds.
+
+ ??? This is now the only use of gnat_substitute_in_type, which
+ is now a very "heavy" routine to do this, so it should be replaced
+ at some point. */
+ ptr_temp_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr)));
+ new_ref = build (COMPONENT_REF, ptr_temp_type,
+ build (PLACEHOLDER_EXPR, ptr),
+ TREE_CHAIN (TYPE_FIELDS (ptr)));
+
+ update_pointer_to
+ (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
+ gnat_substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
+ TREE_CHAIN (TYPE_FIELDS (ptr)), new_ref));
+
+ for (var = TYPE_MAIN_VARIANT (ptr); var; var = TYPE_NEXT_VARIANT (var))
+ TYPE_UNCONSTRAINED_ARRAY (var) = new_type;
+
+ TYPE_POINTER_TO (new_type) = TYPE_REFERENCE_TO (new_type)
+ = TREE_TYPE (new_type) = ptr;
+
+ /* Now handle updating the allocation record, what the thin pointer
+ points to. Update all pointers from the old record into the new
+ one, update the types of the fields, and recompute the size. */
+
+ update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), new_obj_rec);
+
+ TREE_TYPE (TYPE_FIELDS (new_obj_rec)) = TREE_TYPE (ptr_temp_type);
+ TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
+ = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr)));
+ DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
+ = TYPE_SIZE (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))));
+ DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
+ = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))));
+
+ TYPE_SIZE (new_obj_rec)
+ = size_binop (PLUS_EXPR,
+ DECL_SIZE (TYPE_FIELDS (new_obj_rec)),
+ DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))));
+ TYPE_SIZE_UNIT (new_obj_rec)
+ = size_binop (PLUS_EXPR,
+ DECL_SIZE_UNIT (TYPE_FIELDS (new_obj_rec)),
+ DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))));
+ rest_of_type_compilation (ptr, global_bindings_p ());
+ }
+}
+\f
+/* Convert a pointer to a constrained array into a pointer to a fat
+ pointer. This involves making or finding a template. */
+
+static tree
+convert_to_fat_pointer (type, expr)
+ tree type;
+ tree expr;
+{
+ tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))));
+ tree template, template_addr;
+ tree etype = TREE_TYPE (expr);
+
+ /* If EXPR is a constant of zero, we make a fat pointer that has a null
+ pointer to the template and array. */
+ if (integer_zerop (expr))
+ return
+ build_constructor
+ (type,
+ tree_cons (TYPE_FIELDS (type),
+ convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
+ tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
+ convert (build_pointer_type (template_type),
+ expr),
+ NULL_TREE)));
+
+ /* If EXPR is a thin pointer, make the template and data from the record. */
+
+ else if (TYPE_THIN_POINTER_P (etype))
+ {
+ tree fields = TYPE_FIELDS (TREE_TYPE (etype));
+
+ expr = save_expr (expr);
+ if (TREE_CODE (expr) == ADDR_EXPR)
+ expr = TREE_OPERAND (expr, 0);
+ else
+ expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
+
+ template = build_component_ref (expr, NULL_TREE, fields);
+ expr = build_unary_op (ADDR_EXPR, NULL_TREE,
+ build_component_ref (expr, NULL_TREE,
+ TREE_CHAIN (fields)));
+ }
+ else
+ /* Otherwise, build the constructor for the template. */
+ template = build_template (template_type, TREE_TYPE (etype), expr);
+
+ template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
+
+ /* The result is a CONSTRUCTOR for the fat pointer. */
+ return
+ build_constructor (type,
+ tree_cons (TYPE_FIELDS (type), expr,
+ tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
+ template_addr, NULL_TREE)));
+}
+\f
+/* Convert to a thin pointer type, TYPE. The only thing we know how to convert
+ is something that is a fat pointer, so convert to it first if it EXPR
+ is not already a fat pointer. */
+
+static tree
+convert_to_thin_pointer (type, expr)
+ tree type;
+ tree expr;
+{
+ if (! TYPE_FAT_POINTER_P (TREE_TYPE (expr)))
+ expr
+ = convert_to_fat_pointer
+ (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr);
+
+ /* We get the pointer to the data and use a NOP_EXPR to make it the
+ proper GCC type. */
+ expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)));
+ expr = build1 (NOP_EXPR, type, expr);
+
+ return expr;
+}
+\f
+/* Create an expression whose value is that of EXPR,
+ converted to type TYPE. The TREE_TYPE of the value
+ is always TYPE. This function implements all reasonable
+ conversions; callers should filter out those that are
+ not permitted by the language being compiled. */
+
+tree
+convert (type, expr)
+ tree type, expr;
+{
+ enum tree_code code = TREE_CODE (type);
+ tree etype = TREE_TYPE (expr);
+ enum tree_code ecode = TREE_CODE (etype);
+ tree tem;
+
+ /* If EXPR is already the right type, we are done. */
+ if (type == etype)
+ return expr;
+
+ /* If EXPR is a WITH_RECORD_EXPR, do the conversion inside and then make a
+ new one. */
+ if (TREE_CODE (expr) == WITH_RECORD_EXPR)
+ return build (WITH_RECORD_EXPR, type,
+ convert (type, TREE_OPERAND (expr, 0)),
+ TREE_OPERAND (expr, 1));
+
+ /* If the input type has padding, remove it by doing a component reference
+ to the field. If the output type has padding, make a constructor
+ to build the record. If both input and output have padding and are
+ of variable size, do this as an unchecked conversion. */
+ if (ecode == RECORD_TYPE && code == RECORD_TYPE
+ && TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype)
+ && (! TREE_CONSTANT (TYPE_SIZE (type))
+ || ! TREE_CONSTANT (TYPE_SIZE (etype))))
+ ;
+ else if (ecode == RECORD_TYPE && TYPE_IS_PADDING_P (etype))
+ {
+ /* If we have just converted to this padded type, just get
+ the inner expression. */
+ if (TREE_CODE (expr) == CONSTRUCTOR
+ && CONSTRUCTOR_ELTS (expr) != 0
+ && TREE_PURPOSE (CONSTRUCTOR_ELTS (expr)) == TYPE_FIELDS (etype))
+ return TREE_VALUE (CONSTRUCTOR_ELTS (expr));
+ else
+ return convert (type, build_component_ref (expr, NULL_TREE,
+ TYPE_FIELDS (etype)));
+ }
+ else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
+ {
+ /* If we previously converted from another type and our type is
+ of variable size, remove the conversion to avoid the need for
+ variable-size temporaries. */
+ if (TREE_CODE (expr) == UNCHECKED_CONVERT_EXPR
+ && ! TREE_CONSTANT (TYPE_SIZE (type)))
+ expr = TREE_OPERAND (expr, 0);
+
+ /* If we are just removing the padding from expr, convert the original
+ object if we have variable size. That will avoid the need
+ for some variable-size temporaries. */
+ if (TREE_CODE (expr) == COMPONENT_REF
+ && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
+ && ! TREE_CONSTANT (TYPE_SIZE (type)))
+ return convert (type, TREE_OPERAND (expr, 0));
+
+ /* If the result type is a padded type with a self-referentially-sized
+ field and the expression type is a record, do this as an
+ unchecked converstion. */
+ else if (TREE_CODE (DECL_SIZE (TYPE_FIELDS (type))) != INTEGER_CST
+ && contains_placeholder_p (DECL_SIZE (TYPE_FIELDS (type)))
+ && TREE_CODE (etype) == RECORD_TYPE)
+ return unchecked_convert (type, expr);
+
+ else
+ return
+ build_constructor (type,
+ tree_cons (TYPE_FIELDS (type),
+ convert (TREE_TYPE
+ (TYPE_FIELDS (type)),
+ expr),
+ NULL_TREE));
+ }
+
+ /* If the input is a biased type, adjust first. */
+ if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
+ return convert (type, fold (build (PLUS_EXPR, TREE_TYPE (etype),
+ fold (build1 (GNAT_NOP_EXPR,
+ TREE_TYPE (etype), expr)),
+ TYPE_MIN_VALUE (etype))));
+
+ /* If the input is a left-justified modular type, we need to extract
+ the actual object before converting it to any other type with the
+ exception of an unconstrained array. */
+ if (ecode == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype)
+ && code != UNCONSTRAINED_ARRAY_TYPE)
+ return convert (type, build_component_ref (expr, NULL_TREE,
+ TYPE_FIELDS (etype)));
+
+ /* If converting a type that does not contain a template into one
+ that does, convert to the data type and then build the template. */
+ if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type)
+ && ! (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype)))
+ {
+ tree obj_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
+
+ return
+ build_constructor
+ (type,
+ tree_cons (TYPE_FIELDS (type),
+ build_template (TREE_TYPE (TYPE_FIELDS (type)),
+ obj_type, NULL_TREE),
+ tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
+ convert (obj_type, expr), NULL_TREE)));
+ }
+
+ /* There are some special cases of expressions that we process
+ specially. */
+ switch (TREE_CODE (expr))
+ {
+ case ERROR_MARK:
+ return expr;
+
+ case TRANSFORM_EXPR:
+ case NULL_EXPR:
+ /* Just set its type here. For TRANSFORM_EXPR, we will do the actual
+ conversion in gnat_expand_expr. NULL_EXPR does not represent
+ and actual value, so no conversion is needed. */
+ TREE_TYPE (expr) = type;
+ return expr;
+
+ case STRING_CST:
+ case CONSTRUCTOR:
+ /* If we are converting a STRING_CST to another constrained array type,
+ just make a new one in the proper type. Likewise for a
+ CONSTRUCTOR. But if the mode of the type is different, we must
+ ensure a new RTL is made for the constant. */
+ if (code == ecode && AGGREGATE_TYPE_P (etype)
+ && ! (TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
+ && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST))
+ {
+ expr = copy_node (expr);
+ TREE_TYPE (expr) = type;
+
+ if (TYPE_MODE (type) != TYPE_MODE (etype))
+ TREE_CST_RTL (expr) = 0;
+
+ return expr;
+ }
+ break;
+
+ case COMPONENT_REF:
+ /* If we are converting between two aggregate types of the same
+ kind, size, mode, and alignment, just make a new COMPONENT_REF.
+ This avoid unneeded conversions which makes reference computations
+ more complex. */
+ if (code == ecode && TYPE_MODE (type) == TYPE_MODE (etype)
+ && AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
+ && TYPE_ALIGN (type) == TYPE_ALIGN (etype)
+ && operand_equal_p (TYPE_SIZE (type), TYPE_SIZE (etype), 0))
+ return build (COMPONENT_REF, type, TREE_OPERAND (expr, 0),
+ TREE_OPERAND (expr, 1));
+
+ break;
+
+ case UNCONSTRAINED_ARRAY_REF:
+ /* Convert this to the type of the inner array by getting the address of
+ the array from the template. */
+ expr = build_unary_op (INDIRECT_REF, NULL_TREE,
+ build_component_ref (TREE_OPERAND (expr, 0),
+ get_identifier ("P_ARRAY"),
+ NULL_TREE));
+ etype = TREE_TYPE (expr);
+ ecode = TREE_CODE (etype);
+ break;
+
+ case UNCHECKED_CONVERT_EXPR:
+ if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
+ && ! TYPE_FAT_POINTER_P (type) && ! TYPE_FAT_POINTER_P (etype))
+ return convert (type, TREE_OPERAND (expr, 0));
+ break;
+
+ case INDIRECT_REF:
+ /* If both types are record types, just convert the pointer and
+ make a new INDIRECT_REF.
+
+ ??? Disable this for now since it causes problems with the
+ code in build_binary_op for MODIFY_EXPR which wants to
+ strip off conversions. But that code really is a mess and
+ we need to do this a much better way some time. */
+ if (0
+ && (TREE_CODE (type) == RECORD_TYPE
+ || TREE_CODE (type) == UNION_TYPE)
+ && (TREE_CODE (etype) == RECORD_TYPE
+ || TREE_CODE (etype) == UNION_TYPE)
+ && ! TYPE_FAT_POINTER_P (type) && ! TYPE_FAT_POINTER_P (etype))
+ return build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert (build_pointer_type (type),
+ TREE_OPERAND (expr, 0)));
+ break;
+
+ default:
+ break;
+ }
+
+ /* Check for converting to a pointer to an unconstrained array. */
+ if (TYPE_FAT_POINTER_P (type) && ! TYPE_FAT_POINTER_P (etype))
+ return convert_to_fat_pointer (type, expr);
+
+ if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)
+ || (code == INTEGER_CST && ecode == INTEGER_CST
+ && (type == TREE_TYPE (etype) || etype == TREE_TYPE (type))))
+ return fold (build1 (NOP_EXPR, type, expr));
+
+ switch (code)
+ {
+ case VOID_TYPE:
+ return build1 (CONVERT_EXPR, type, expr);
+
+ case INTEGER_TYPE:
+ if (TYPE_HAS_ACTUAL_BOUNDS_P (type)
+ && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE))
+ return unchecked_convert (type, expr);
+ else if (TYPE_BIASED_REPRESENTATION_P (type))
+ return fold (build1 (CONVERT_EXPR, type,
+ fold (build (MINUS_EXPR, TREE_TYPE (type),
+ convert (TREE_TYPE (type), expr),
+ TYPE_MIN_VALUE (type)))));
+
+ /* ... fall through ... */
+
+ case ENUMERAL_TYPE:
+ return fold (convert_to_integer (type, expr));
+
+ case POINTER_TYPE:
+ case REFERENCE_TYPE:
+ /* If converting between two pointers to records denoting
+ both a template and type, adjust if needed to account
+ for any differing offsets, since one might be negative. */
+ if (TYPE_THIN_POINTER_P (etype) && TYPE_THIN_POINTER_P (type))
+ {
+ tree bit_diff
+ = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))),
+ bit_position (TYPE_FIELDS (TREE_TYPE (type))));
+ tree byte_diff = size_binop (CEIL_DIV_EXPR, bit_diff,
+ sbitsize_int (BITS_PER_UNIT));
+
+ expr = build1 (NOP_EXPR, type, expr);
+ TREE_CONSTANT (expr) = TREE_CONSTANT (TREE_OPERAND (expr, 0));
+ if (integer_zerop (byte_diff))
+ return expr;
+
+ return build_binary_op (PLUS_EXPR, type, expr,
+ fold (convert_to_pointer (type, byte_diff)));
+ }
+
+ /* If converting to a thin pointer, handle specially. */
+ if (TYPE_THIN_POINTER_P (type)
+ && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)) != 0)
+ return convert_to_thin_pointer (type, expr);
+
+ /* If converting fat pointer to normal pointer, get the pointer to the
+ array and then convert it. */
+ else if (TYPE_FAT_POINTER_P (etype))
+ expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
+ NULL_TREE);
+
+ return fold (convert_to_pointer (type, expr));
+
+ case REAL_TYPE:
+ return fold (convert_to_real (type, expr));
+
+ case RECORD_TYPE:
+ if (TYPE_LEFT_JUSTIFIED_MODULAR_P (type) && ! AGGREGATE_TYPE_P (etype))
+ return
+ build_constructor
+ (type, tree_cons (TYPE_FIELDS (type),
+ convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
+ NULL_TREE));
+
+ /* ... fall through ... */
+
+ case ARRAY_TYPE:
+ /* In these cases, assume the front-end has validated the conversion.
+ If the conversion is valid, it will be a bit-wise conversion, so
+ it can be viewed as an unchecked conversion. */
+ return unchecked_convert (type, expr);
+
+ case UNION_TYPE:
+ /* Just validate that the type is indeed that of a field
+ of the type. Then make the simple conversion. */
+ for (tem = TYPE_FIELDS (type); tem; tem = TREE_CHAIN (tem))
+ if (TREE_TYPE (tem) == etype)
+ return build1 (CONVERT_EXPR, type, expr);
+
+ gigi_abort (413);
+
+ case UNCONSTRAINED_ARRAY_TYPE:
+ /* If EXPR is a constrained array, take its address, convert it to a
+ fat pointer, and then dereference it. Likewise if EXPR is a
+ record containing both a template and a constrained array.
+ Note that a record representing a left justified modular type
+ always represents a packed constrained array. */
+ if (ecode == ARRAY_TYPE
+ || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype))
+ || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))
+ || (ecode == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype)))
+ return
+ build_unary_op
+ (INDIRECT_REF, NULL_TREE,
+ convert_to_fat_pointer (TREE_TYPE (type),
+ build_unary_op (ADDR_EXPR,
+ NULL_TREE, expr)));
+
+ /* Do something very similar for converting one unconstrained
+ array to another. */
+ else if (ecode == UNCONSTRAINED_ARRAY_TYPE)
+ return
+ build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert (TREE_TYPE (type),
+ build_unary_op (ADDR_EXPR,
+ NULL_TREE, expr)));
+ else
+ gigi_abort (409);
+
+ case COMPLEX_TYPE:
+ return fold (convert_to_complex (type, expr));
+
+ default:
+ gigi_abort (410);
+ }
+}
+\f
+/* Remove all conversions that are done in EXP. This includes converting
+ from a padded type or converting to a left-justified modular type. */
+
+tree
+remove_conversions (exp)
+ tree exp;
+{
+ switch (TREE_CODE (exp))
+ {
+ case CONSTRUCTOR:
+ if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (exp)))
+ return remove_conversions (TREE_VALUE (CONSTRUCTOR_ELTS (exp)));
+ break;
+
+ case COMPONENT_REF:
+ if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp, 0))) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
+ return remove_conversions (TREE_OPERAND (exp, 0));
+ break;
+
+ case UNCHECKED_CONVERT_EXPR:
+ case NOP_EXPR: case CONVERT_EXPR:
+ return remove_conversions (TREE_OPERAND (exp, 0));
+
+ default:
+ break;
+ }
+
+ return exp;
+}
+\f
+/* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
+ refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P,
+ likewise return an expression pointing to the underlying array. */
+
+tree
+maybe_unconstrained_array (exp)
+ tree exp;
+{
+ enum tree_code code = TREE_CODE (exp);
+ tree new;
+
+ switch (TREE_CODE (TREE_TYPE (exp)))
+ {
+ case UNCONSTRAINED_ARRAY_TYPE:
+ if (code == UNCONSTRAINED_ARRAY_REF)
+ {
+ new
+ = build_unary_op (INDIRECT_REF, NULL_TREE,
+ build_component_ref (TREE_OPERAND (exp, 0),
+ get_identifier ("P_ARRAY"),
+ NULL_TREE));
+ TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp);
+ return new;
+ }
+
+ else if (code == NULL_EXPR)
+ return build1 (NULL_EXPR,
+ TREE_TYPE (TREE_TYPE (TYPE_FIELDS
+ (TREE_TYPE (TREE_TYPE (exp))))),
+ TREE_OPERAND (exp, 0));
+
+ else if (code == WITH_RECORD_EXPR
+ && (TREE_OPERAND (exp, 0)
+ != (new = maybe_unconstrained_array
+ (TREE_OPERAND (exp, 0)))))
+ return build (WITH_RECORD_EXPR, TREE_TYPE (new), new,
+ TREE_OPERAND (exp, 1));
+
+ case RECORD_TYPE:
+ if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
+ {
+ new
+ = build_component_ref (exp, NULL_TREE,
+ TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))));
+ if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (new)))
+ new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (new))), new);
+
+ return new;
+ }
+ break;
+
+ default:
+ break;
+ }
+
+ return exp;
+}
+\f
+/* Return an expression that does an unchecked converstion of EXPR to TYPE. */
+
+tree
+unchecked_convert (type, expr)
+ tree type;
+ tree expr;
+{
+ tree etype = TREE_TYPE (expr);
+
+ /* If the expression is already the right type, we are done. */
+ if (etype == type)
+ return expr;
+
+ /* If EXPR is a WITH_RECORD_EXPR, do the conversion inside and then make a
+ new one. */
+ if (TREE_CODE (expr) == WITH_RECORD_EXPR)
+ return build (WITH_RECORD_EXPR, type,
+ unchecked_convert (type, TREE_OPERAND (expr, 0)),
+ TREE_OPERAND (expr, 1));
+
+ /* If both types types are integral just do a normal conversion.
+ Likewise for a conversion to an unconstrained array. */
+ if ((((INTEGRAL_TYPE_P (type)
+ && ! (TREE_CODE (type) == INTEGER_TYPE
+ && TYPE_VAX_FLOATING_POINT_P (type)))
+ || (POINTER_TYPE_P (type) && ! TYPE_THIN_POINTER_P (type))
+ || (TREE_CODE (type) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (type)))
+ && ((INTEGRAL_TYPE_P (etype)
+ && ! (TREE_CODE (etype) == INTEGER_TYPE
+ && TYPE_VAX_FLOATING_POINT_P (etype)))
+ || (POINTER_TYPE_P (etype) && ! TYPE_THIN_POINTER_P (etype))
+ || (TREE_CODE (etype) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype))))
+ || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
+ {
+ tree rtype = type;
+
+ if (TREE_CODE (etype) == INTEGER_TYPE
+ && TYPE_BIASED_REPRESENTATION_P (etype))
+ {
+ tree ntype = copy_type (etype);
+
+ TYPE_BIASED_REPRESENTATION_P (ntype) = 0;
+ TYPE_MAIN_VARIANT (ntype) = ntype;
+ expr = build1 (GNAT_NOP_EXPR, ntype, expr);
+ }
+
+ if (TREE_CODE (type) == INTEGER_TYPE
+ && TYPE_BIASED_REPRESENTATION_P (type))
+ {
+ rtype = copy_type (type);
+ TYPE_BIASED_REPRESENTATION_P (rtype) = 0;
+ TYPE_MAIN_VARIANT (rtype) = rtype;
+ }
+
+ expr = convert (rtype, expr);
+ if (type != rtype)
+ expr = build1 (GNAT_NOP_EXPR, type, expr);
+ }
+
+ /* If we are converting TO an integral type whose precision is not the
+ same as its size, first unchecked convert to a record that contains
+ an object of the output type. Then extract the field. */
+ else if (INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) != 0
+ && 0 != compare_tree_int (TYPE_RM_SIZE (type),
+ GET_MODE_BITSIZE (TYPE_MODE (type))))
+ {
+ tree rec_type = make_node (RECORD_TYPE);
+ tree field = create_field_decl (get_identifier ("OBJ"), type,
+ rec_type, 1, 0, 0, 0);
+
+ TYPE_FIELDS (rec_type) = field;
+ layout_type (rec_type);
+
+ expr = unchecked_convert (rec_type, expr);
+ expr = build_component_ref (expr, NULL_TREE, field);
+ }
+
+ /* Similarly for integral input type whose precision is not equal to its
+ size. */
+ else if (INTEGRAL_TYPE_P (etype) && TYPE_RM_SIZE (etype) != 0
+ && 0 != compare_tree_int (TYPE_RM_SIZE (etype),
+ GET_MODE_BITSIZE (TYPE_MODE (etype))))
+ {
+ tree rec_type = make_node (RECORD_TYPE);
+ tree field
+ = create_field_decl (get_identifier ("OBJ"), etype, rec_type,
+ 1, 0, 0, 0);
+
+ TYPE_FIELDS (rec_type) = field;
+ layout_type (rec_type);
+
+ expr = build_constructor (rec_type, build_tree_list (field, expr));
+ expr = unchecked_convert (type, expr);
+ }
+
+ /* We have a special case when we are converting between two
+ unconstrained array types. In that case, take the address,
+ convert the fat pointer types, and dereference. */
+ else if (TREE_CODE (etype) == UNCONSTRAINED_ARRAY_TYPE
+ && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
+ expr = build_unary_op (INDIRECT_REF, NULL_TREE,
+ build1 (UNCHECKED_CONVERT_EXPR, TREE_TYPE (type),
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ expr)));
+
+ /* If both types are aggregates with the same mode and alignment (except
+ if the result is a UNION_TYPE), we can do this as a normal conversion. */
+ else if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
+ && TREE_CODE (type) != UNION_TYPE
+ && TYPE_ALIGN (type) == TYPE_ALIGN (etype)
+ && TYPE_MODE (type) == TYPE_MODE (etype))
+ expr = build1 (CONVERT_EXPR, type, expr);
+
+ else
+ {
+ expr = maybe_unconstrained_array (expr);
+ etype = TREE_TYPE (expr);
+ expr = build1 (UNCHECKED_CONVERT_EXPR, type, expr);
+ }
+
+
+ /* If the result is an integral type whose size is not equal to
+ the size of the underlying machine type, sign- or zero-extend
+ the result. We need not do this in the case where the input is
+ an integral type of the same precision and signedness or if the output
+ is a biased type or if both the input and output are unsigned. */
+ if (INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) != 0
+ && ! (TREE_CODE (type) == INTEGER_TYPE
+ && TYPE_BIASED_REPRESENTATION_P (type))
+ && 0 != compare_tree_int (TYPE_RM_SIZE (type),
+ GET_MODE_BITSIZE (TYPE_MODE (type)))
+ && ! (INTEGRAL_TYPE_P (etype)
+ && TREE_UNSIGNED (type) == TREE_UNSIGNED (etype)
+ && operand_equal_p (TYPE_RM_SIZE (type),
+ (TYPE_RM_SIZE (etype) != 0
+ ? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)),
+ 0))
+ && ! (TREE_UNSIGNED (type) && TREE_UNSIGNED (etype)))
+ {
+ tree base_type = type_for_mode (TYPE_MODE (type), TREE_UNSIGNED (type));
+ tree shift_expr
+ = convert (base_type,
+ size_binop (MINUS_EXPR,
+ bitsize_int
+ (GET_MODE_BITSIZE (TYPE_MODE (type))),
+ TYPE_RM_SIZE (type)));
+ expr
+ = convert (type,
+ build_binary_op (RSHIFT_EXPR, base_type,
+ build_binary_op (LSHIFT_EXPR, base_type,
+ convert (base_type, expr),
+ shift_expr),
+ shift_expr));
+ }
+
+ /* An unchecked conversion should never raise Constraint_Error. The code
+ below assumes that GCC's conversion routines overflow the same
+ way that the underlying hardware does. This is probably true. In
+ the rare case when it isn't, we can rely on the fact that such
+ conversions are erroneous anyway. */
+ if (TREE_CODE (expr) == INTEGER_CST)
+ TREE_OVERFLOW (expr) = TREE_CONSTANT_OVERFLOW (expr) = 0;
+
+ /* If the sizes of the types differ and this is an UNCHECKED_CONVERT_EXPR,
+ show no longer constant. */
+ if (TREE_CODE (expr) == UNCHECKED_CONVERT_EXPR
+ && ! operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype), 1))
+ TREE_CONSTANT (expr) = 0;
+
+ return expr;
+}
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * U T I L S 2 *
+ * *
+ * C Implementation 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). *
+ * *
+ ****************************************************************************/
+
+#include "config.h"
+#include "system.h"
+#include "tree.h"
+#include "flags.h"
+#include "ada.h"
+#include "types.h"
+#include "atree.h"
+#include "stringt.h"
+#include "uintp.h"
+#include "fe.h"
+#include "elists.h"
+#include "nlists.h"
+#include "sinfo.h"
+#include "einfo.h"
+#include "ada-tree.h"
+#include "gigi.h"
+
+static tree find_common_type PARAMS ((tree, tree));
+static int contains_save_expr_p PARAMS ((tree));
+static tree contains_null_expr PARAMS ((tree));
+static tree compare_arrays PARAMS ((tree, tree, tree));
+static tree nonbinary_modular_operation PARAMS ((enum tree_code, tree,
+ tree, tree));
+static tree build_simple_component_ref PARAMS ((tree, tree, tree));
+\f
+/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
+ operation.
+
+ This preparation consists of taking the ordinary representation of
+ an expression expr and producing a valid tree boolean expression
+ describing whether expr is nonzero. We could simply always do
+
+ build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
+
+ but we optimize comparisons, &&, ||, and !.
+
+ The resulting type should always be the same as the input type.
+ This function is simpler than the corresponding C version since
+ the only possible operands will be things of Boolean type. */
+
+tree
+truthvalue_conversion (expr)
+ tree expr;
+{
+ tree type = TREE_TYPE (expr);
+
+ switch (TREE_CODE (expr))
+ {
+ case EQ_EXPR: case NE_EXPR: case LE_EXPR: case GE_EXPR:
+ case LT_EXPR: case GT_EXPR:
+ case TRUTH_ANDIF_EXPR:
+ case TRUTH_ORIF_EXPR:
+ case TRUTH_AND_EXPR:
+ case TRUTH_OR_EXPR:
+ case TRUTH_XOR_EXPR:
+ case ERROR_MARK:
+ return expr;
+
+ case COND_EXPR:
+ /* Distribute the conversion into the arms of a COND_EXPR. */
+ return fold (build (COND_EXPR, type, TREE_OPERAND (expr, 0),
+ truthvalue_conversion (TREE_OPERAND (expr, 1)),
+ truthvalue_conversion (TREE_OPERAND (expr, 2))));
+
+ case WITH_RECORD_EXPR:
+ return build (WITH_RECORD_EXPR, type,
+ truthvalue_conversion (TREE_OPERAND (expr, 0)),
+ TREE_OPERAND (expr, 1));
+
+ default:
+ return build_binary_op (NE_EXPR, type, expr,
+ convert (type, integer_zero_node));
+ }
+}
+\f
+/* Return the base type of TYPE. */
+
+tree
+get_base_type (type)
+ tree type;
+{
+ if (TREE_CODE (type) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (type))
+ type = TREE_TYPE (TYPE_FIELDS (type));
+
+ while (TREE_TYPE (type) != 0
+ && (TREE_CODE (type) == INTEGER_TYPE
+ || TREE_CODE (type) == REAL_TYPE))
+ type = TREE_TYPE (type);
+
+ return type;
+}
+
+/* Likewise, but only return types known to the Ada source. */
+tree
+get_ada_base_type (type)
+ tree type;
+{
+ while (TREE_TYPE (type) != 0
+ && (TREE_CODE (type) == INTEGER_TYPE
+ || TREE_CODE (type) == REAL_TYPE)
+ && ! TYPE_EXTRA_SUBTYPE_P (type))
+ type = TREE_TYPE (type);
+
+ return type;
+}
+\f
+/* EXP is a GCC tree representing an address. See if we can find how
+ strictly the object at that address is aligned. Return that alignment
+ in bits. If we don't know anything about the alignment, return 0.
+ We do not go merely by type information here since the check on
+ N_Validate_Unchecked_Alignment does that. */
+
+unsigned int
+known_alignment (exp)
+ tree exp;
+{
+ unsigned int lhs, rhs;
+
+ switch (TREE_CODE (exp))
+ {
+ case CONVERT_EXPR:
+ case NOP_EXPR:
+ case NON_LVALUE_EXPR:
+ /* Conversions between pointers and integers don't change the alignment
+ of the underlying object. */
+ return known_alignment (TREE_OPERAND (exp, 0));
+
+ case PLUS_EXPR:
+ case MINUS_EXPR:
+ /* If two address are added, the alignment of the result is the
+ minimum of the two aligments. */
+ lhs = known_alignment (TREE_OPERAND (exp, 0));
+ rhs = known_alignment (TREE_OPERAND (exp, 1));
+ return MIN (lhs, rhs);
+
+ case INTEGER_CST:
+ /* The first part of this represents the lowest bit in the constant,
+ but is it in bytes, not bits. */
+ return MIN (BITS_PER_UNIT
+ * (TREE_INT_CST_LOW (exp) & - TREE_INT_CST_LOW (exp)),
+ BIGGEST_ALIGNMENT);
+
+ case MULT_EXPR:
+ /* If we know the alignment of just one side, use it. Otherwise,
+ use the product of the alignments. */
+ lhs = known_alignment (TREE_OPERAND (exp, 0));
+ rhs = known_alignment (TREE_OPERAND (exp, 1));
+ if (lhs == 0 || rhs == 0)
+ return MIN (BIGGEST_ALIGNMENT, MAX (lhs, rhs));
+
+ return MIN (BIGGEST_ALIGNMENT, lhs * rhs);
+
+ case ADDR_EXPR:
+ return expr_align (TREE_OPERAND (exp, 0));
+
+ default:
+ return 0;
+ }
+}
+\f
+/* We have a comparison or assignment operation on two types, T1 and T2,
+ which are both either array types or both record types.
+ Return the type that both operands should be converted to, if any.
+ Otherwise return zero. */
+
+static tree
+find_common_type (t1, t2)
+ tree t1, t2;
+{
+ /* If either type is non-BLKmode, use it. Note that we know that we will
+ not have any alignment problems since if we did the non-BLKmode
+ type could not have been used. */
+ if (TYPE_MODE (t1) != BLKmode)
+ return t1;
+ else if (TYPE_MODE (t2) != BLKmode)
+ return t2;
+
+ /* Otherwise, return the type that has a constant size. */
+ if (TREE_CONSTANT (TYPE_SIZE (t1)))
+ return t1;
+ else if (TREE_CONSTANT (TYPE_SIZE (t2)))
+ return t2;
+
+ /* In this case, both types have variable size. It's probably
+ best to leave the "type mismatch" because changing it could
+ case a bad self-referential reference. */
+ return 0;
+}
+\f
+/* See if EXP contains a SAVE_EXPR in a position where we would
+ normally put it.
+
+ ??? This is a real kludge, but is probably the best approach short
+ of some very general solution. */
+
+static int
+contains_save_expr_p (exp)
+ tree exp;
+{
+ switch (TREE_CODE (exp))
+ {
+ case SAVE_EXPR:
+ return 1;
+
+ case ADDR_EXPR: case INDIRECT_REF:
+ case COMPONENT_REF:
+ case NOP_EXPR: case CONVERT_EXPR: case UNCHECKED_CONVERT_EXPR:
+ return contains_save_expr_p (TREE_OPERAND (exp, 0));
+
+ case CONSTRUCTOR:
+ return (CONSTRUCTOR_ELTS (exp) != 0
+ && contains_save_expr_p (CONSTRUCTOR_ELTS (exp)));
+
+ case TREE_LIST:
+ return (contains_save_expr_p (TREE_VALUE (exp))
+ || (TREE_CHAIN (exp) != 0
+ && contains_save_expr_p (TREE_CHAIN (exp))));
+
+ default:
+ return 0;
+ }
+}
+\f
+/* See if EXP contains a NULL_EXPR in an expression we use for sizes. Return
+ it if so. This is used to detect types whose sizes involve computations
+ that are known to raise Constraint_Error. */
+
+static tree
+contains_null_expr (exp)
+ tree exp;
+{
+ tree tem;
+
+ if (TREE_CODE (exp) == NULL_EXPR)
+ return exp;
+
+ switch (TREE_CODE_CLASS (TREE_CODE (exp)))
+ {
+ case '1':
+ return contains_null_expr (TREE_OPERAND (exp, 0));
+
+ case '<': case '2':
+ tem = contains_null_expr (TREE_OPERAND (exp, 0));
+ if (tem != 0)
+ return tem;
+
+ return contains_null_expr (TREE_OPERAND (exp, 1));
+
+ case 'e':
+ switch (TREE_CODE (exp))
+ {
+ case SAVE_EXPR:
+ return contains_null_expr (TREE_OPERAND (exp, 0));
+
+ case COND_EXPR:
+ tem = contains_null_expr (TREE_OPERAND (exp, 0));
+ if (tem != 0)
+ return tem;
+
+ tem = contains_null_expr (TREE_OPERAND (exp, 1));
+ if (tem != 0)
+ return tem;
+
+ return contains_null_expr (TREE_OPERAND (exp, 2));
+
+ default:
+ return 0;
+ }
+
+ default:
+ return 0;
+ }
+}
+\f
+/* Return an expression tree representing an equality comparison of
+ A1 and A2, two objects of ARRAY_TYPE. The returned expression should
+ be of type RESULT_TYPE
+
+ Two arrays are equal in one of two ways: (1) if both have zero length
+ in some dimension (not necessarily the same dimension) or (2) if the
+ lengths in each dimension are equal and the data is equal. We perform the
+ length tests in as efficient a manner as possible. */
+
+static tree
+compare_arrays (result_type, a1, a2)
+ tree a1, a2;
+ tree result_type;
+{
+ tree t1 = TREE_TYPE (a1);
+ tree t2 = TREE_TYPE (a2);
+ tree result = convert (result_type, integer_one_node);
+ tree a1_is_null = convert (result_type, integer_zero_node);
+ tree a2_is_null = convert (result_type, integer_zero_node);
+ int length_zero_p = 0;
+
+ /* Process each dimension separately and compare the lengths. If any
+ dimension has a size known to be zero, set SIZE_ZERO_P to 1 to
+ suppress the comparison of the data. */
+ while (TREE_CODE (t1) == ARRAY_TYPE && TREE_CODE (t2) == ARRAY_TYPE)
+ {
+ tree lb1 = TYPE_MIN_VALUE (TYPE_DOMAIN (t1));
+ tree ub1 = TYPE_MAX_VALUE (TYPE_DOMAIN (t1));
+ tree lb2 = TYPE_MIN_VALUE (TYPE_DOMAIN (t2));
+ tree ub2 = TYPE_MAX_VALUE (TYPE_DOMAIN (t2));
+ tree bt = get_base_type (TREE_TYPE (lb1));
+ tree length1 = fold (build (MINUS_EXPR, bt, ub1, lb1));
+ tree length2 = fold (build (MINUS_EXPR, bt, ub2, lb2));
+ tree nbt;
+ tree tem;
+ tree comparison, this_a1_is_null, this_a2_is_null;
+
+ /* If the length of the first array is a constant, swap our operands
+ unless the length of the second array is the constant zero.
+ Note that we have set the `length' values to the length - 1. */
+ if (TREE_CODE (length1) == INTEGER_CST
+ && ! integer_zerop (fold (build (PLUS_EXPR, bt, length2,
+ convert (bt, integer_one_node)))))
+ {
+ tem = a1, a1 = a2, a2 = tem;
+ tem = t1, t1 = t2, t2 = tem;
+ tem = lb1, lb1 = lb2, lb2 = tem;
+ tem = ub1, ub1 = ub2, ub2 = tem;
+ tem = length1, length1 = length2, length2 = tem;
+ tem = a1_is_null, a1_is_null = a2_is_null, a2_is_null = tem;
+ }
+
+ /* If the length of this dimension in the second array is the constant
+ zero, we can just go inside the original bounds for the first
+ array and see if last < first. */
+ if (integer_zerop (fold (build (PLUS_EXPR, bt, length2,
+ convert (bt, integer_one_node)))))
+ {
+ tree ub = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
+ tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
+
+ comparison = build_binary_op (LT_EXPR, result_type, ub, lb);
+
+ if (contains_placeholder_p (comparison))
+ comparison = build (WITH_RECORD_EXPR, result_type,
+ comparison, a1);
+ if (contains_placeholder_p (length1))
+ length1 = build (WITH_RECORD_EXPR, bt, length1, a1);
+
+ length_zero_p = 1;
+
+ this_a1_is_null = comparison;
+ this_a2_is_null = convert (result_type, integer_one_node);
+ }
+
+ /* If the length is some other constant value, we know that the
+ this dimension in the first array cannot be superflat, so we
+ can just use its length from the actual stored bounds. */
+ else if (TREE_CODE (length2) == INTEGER_CST)
+ {
+ ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
+ lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
+ ub2 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
+ lb2 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
+ nbt = get_base_type (TREE_TYPE (ub1));
+
+ comparison
+ = build_binary_op (EQ_EXPR, result_type,
+ build_binary_op (MINUS_EXPR, nbt, ub1, lb1),
+ build_binary_op (MINUS_EXPR, nbt, ub2, lb2));
+
+ /* Note that we know that UB2 and LB2 are constant and hence
+ cannot contain a PLACEHOLDER_EXPR. */
+
+ if (contains_placeholder_p (comparison))
+ comparison = build (WITH_RECORD_EXPR, result_type, comparison, a1);
+ if (contains_placeholder_p (length1))
+ length1 = build (WITH_RECORD_EXPR, bt, length1, a1);
+
+ this_a1_is_null = build_binary_op (LT_EXPR, result_type, ub1, lb1);
+ this_a2_is_null = convert (result_type, integer_zero_node);
+ }
+
+ /* Otherwise compare the computed lengths. */
+ else
+ {
+ if (contains_placeholder_p (length1))
+ length1 = build (WITH_RECORD_EXPR, bt, length1, a1);
+ if (contains_placeholder_p (length2))
+ length2 = build (WITH_RECORD_EXPR, bt, length2, a2);
+
+ comparison
+ = build_binary_op (EQ_EXPR, result_type, length1, length2);
+
+ this_a1_is_null
+ = build_binary_op (LT_EXPR, result_type, length1,
+ convert (bt, integer_zero_node));
+ this_a2_is_null
+ = build_binary_op (LT_EXPR, result_type, length2,
+ convert (bt, integer_zero_node));
+ }
+
+ result = build_binary_op (TRUTH_ANDIF_EXPR, result_type,
+ result, comparison);
+
+ a1_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type,
+ this_a1_is_null, a1_is_null);
+ a2_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type,
+ this_a2_is_null, a2_is_null);
+
+ t1 = TREE_TYPE (t1);
+ t2 = TREE_TYPE (t2);
+ }
+
+ /* Unless the size of some bound is known to be zero, compare the
+ data in the array. */
+ if (! length_zero_p)
+ {
+ tree type = find_common_type (TREE_TYPE (a1), TREE_TYPE (a2));
+
+ if (type != 0)
+ a1 = convert (type, a1), a2 = convert (type, a2);
+
+
+ result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result,
+ build (EQ_EXPR, result_type, a1, a2));
+
+ }
+
+ /* The result is also true if both sizes are zero. */
+ result = build_binary_op (TRUTH_ORIF_EXPR, result_type,
+ build_binary_op (TRUTH_ANDIF_EXPR, result_type,
+ a1_is_null, a2_is_null),
+ result);
+
+ /* If either operand contains SAVE_EXPRs, they have to be evaluated before
+ starting the comparison above since the place it would be otherwise
+ evaluated would be wrong. */
+
+ if (contains_save_expr_p (a1))
+ result = build (COMPOUND_EXPR, result_type, a1, result);
+
+ if (contains_save_expr_p (a2))
+ result = build (COMPOUND_EXPR, result_type, a2, result);
+
+ return result;
+}
+\f
+/* Compute the result of applying OP_CODE to LHS and RHS, where both are of
+ type TYPE. We know that TYPE is a modular type with a nonbinary
+ modulus. */
+
+static tree
+nonbinary_modular_operation (op_code, type, lhs, rhs)
+ enum tree_code op_code;
+ tree type;
+ tree lhs, rhs;
+{
+ tree modulus = TYPE_MODULUS (type);
+ unsigned int needed_precision = tree_floor_log2 (modulus) + 1;
+ unsigned int precision;
+ int unsignedp = 1;
+ tree op_type = type;
+ tree result;
+
+ /* If this is an addition of a constant, convert it to a subtraction
+ of a constant since we can do that faster. */
+ if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST)
+ rhs = fold (build (MINUS_EXPR, type, modulus, rhs)), op_code = MINUS_EXPR;
+
+ /* For the logical operations, we only need PRECISION bits. For
+ addition and subraction, we need one more and for multiplication we
+ need twice as many. But we never want to make a size smaller than
+ our size. */
+ if (op_code == PLUS_EXPR || op_code == MINUS_EXPR)
+ needed_precision += 1;
+ else if (op_code == MULT_EXPR)
+ needed_precision *= 2;
+
+ precision = MAX (needed_precision, TYPE_PRECISION (op_type));
+
+ /* Unsigned will do for everything but subtraction. */
+ if (op_code == MINUS_EXPR)
+ unsignedp = 0;
+
+ /* If our type is the wrong signedness or isn't wide enough, make a new
+ type and convert both our operands to it. */
+ if (TYPE_PRECISION (op_type) < precision
+ || TREE_UNSIGNED (op_type) != unsignedp)
+ {
+ /* Copy the node so we ensure it can be modified to make it modular. */
+ op_type = copy_node (type_for_size (precision, unsignedp));
+ modulus = convert (op_type, modulus);
+ TYPE_MODULUS (op_type) = modulus;
+ TYPE_MODULAR_P (op_type) = 1;
+ lhs = convert (op_type, lhs);
+ rhs = convert (op_type, rhs);
+ }
+
+ /* Do the operation, then we'll fix it up. */
+ result = fold (build (op_code, op_type, lhs, rhs));
+
+ /* For multiplication, we have no choice but to do a full modulus
+ operation. However, we want to do this in the narrowest
+ possible size. */
+ if (op_code == MULT_EXPR)
+ {
+ tree div_type = copy_node (type_for_size (needed_precision, 1));
+ modulus = convert (div_type, modulus);
+ TYPE_MODULUS (div_type) = modulus;
+ TYPE_MODULAR_P (div_type) = 1;
+ result = convert (op_type,
+ fold (build (TRUNC_MOD_EXPR, div_type,
+ convert (div_type, result), modulus)));
+ }
+
+ /* For subtraction, add the modulus back if we are negative. */
+ else if (op_code == MINUS_EXPR)
+ {
+ result = save_expr (result);
+ result = fold (build (COND_EXPR, op_type,
+ build (LT_EXPR, integer_type_node, result,
+ convert (op_type, integer_zero_node)),
+ fold (build (PLUS_EXPR, op_type,
+ result, modulus)),
+ result));
+ }
+
+ /* For the other operations, subtract the modulus if we are >= it. */
+ else
+ {
+ result = save_expr (result);
+ result = fold (build (COND_EXPR, op_type,
+ build (GE_EXPR, integer_type_node,
+ result, modulus),
+ fold (build (MINUS_EXPR, op_type,
+ result, modulus)),
+ result));
+ }
+
+ return convert (type, result);
+}
+\f
+/* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type
+ desired for the result. Usually the operation is to be performed
+ in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0
+ in which case the type to be used will be derived from the operands.
+
+ This function is very much unlike the ones for C and C++ since we
+ have already done any type conversion and matching required. All we
+ have to do here is validate the work done by SEM and handle subtypes. */
+
+tree
+build_binary_op (op_code, result_type, left_operand, right_operand)
+ enum tree_code op_code;
+ tree result_type;
+ tree left_operand;
+ tree right_operand;
+{
+ tree left_type = TREE_TYPE (left_operand);
+ tree right_type = TREE_TYPE (right_operand);
+ tree left_base_type = get_base_type (left_type);
+ tree right_base_type = get_base_type (right_type);
+ tree operation_type = result_type;
+ tree best_type = 0;
+ tree modulus;
+ tree result;
+ int has_side_effects = 0;
+
+ /* If one (but not both, unless they have the same object) operands are a
+ WITH_RECORD_EXPR, do the operation and then surround it with the
+ WITH_RECORD_EXPR. Don't do this for assignment, for an ARRAY_REF, or
+ for an ARRAY_RANGE_REF because we need to keep track of the
+ WITH_RECORD_EXPRs on both operands very carefully. */
+ if (op_code != MODIFY_EXPR && op_code != ARRAY_REF
+ && op_code != ARRAY_RANGE_REF
+ && TREE_CODE (left_operand) == WITH_RECORD_EXPR
+ && (TREE_CODE (right_operand) != WITH_RECORD_EXPR
+ || operand_equal_p (TREE_OPERAND (left_operand, 1),
+ TREE_OPERAND (right_operand, 1), 0)))
+ {
+ tree right = right_operand;
+
+ if (TREE_CODE (right) == WITH_RECORD_EXPR)
+ right = TREE_OPERAND (right, 0);
+
+ result = build_binary_op (op_code, result_type,
+ TREE_OPERAND (left_operand, 0), right);
+ return build (WITH_RECORD_EXPR, TREE_TYPE (result), result,
+ TREE_OPERAND (left_operand, 1));
+ }
+ else if (op_code != MODIFY_EXPR && op_code != ARRAY_REF
+ && op_code != ARRAY_RANGE_REF
+ && TREE_CODE (left_operand) != WITH_RECORD_EXPR
+ && TREE_CODE (right_operand) == WITH_RECORD_EXPR)
+ {
+ result = build_binary_op (op_code, result_type, left_operand,
+ TREE_OPERAND (right_operand, 0));
+ return build (WITH_RECORD_EXPR, TREE_TYPE (result), result,
+ TREE_OPERAND (right_operand, 1));
+ }
+
+ if (operation_type != 0
+ && TREE_CODE (operation_type) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (operation_type))
+ operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
+
+ if (operation_type != 0
+ && ! AGGREGATE_TYPE_P (operation_type)
+ && TYPE_EXTRA_SUBTYPE_P (operation_type))
+ operation_type = get_base_type (operation_type);
+
+ modulus = (operation_type != 0 && TREE_CODE (operation_type) == INTEGER_TYPE
+ && TYPE_MODULAR_P (operation_type)
+ ? TYPE_MODULUS (operation_type) : 0);
+
+ switch (op_code)
+ {
+ case MODIFY_EXPR:
+ /* If there were any integral or pointer conversions on LHS, remove
+ them; we'll be putting them back below if needed. Likewise for
+ conversions between array and record types. But don't do this if
+ the right operand is not BLKmode (for packed arrays)
+ unless we are not changing the mode. */
+ while ((TREE_CODE (left_operand) == CONVERT_EXPR
+ || TREE_CODE (left_operand) == NOP_EXPR
+ || TREE_CODE (left_operand) == UNCHECKED_CONVERT_EXPR)
+ && (((INTEGRAL_TYPE_P (left_type)
+ || POINTER_TYPE_P (left_type))
+ && (INTEGRAL_TYPE_P (TREE_TYPE
+ (TREE_OPERAND (left_operand, 0)))
+ || POINTER_TYPE_P (TREE_TYPE
+ (TREE_OPERAND (left_operand, 0)))))
+ || (((TREE_CODE (left_type) == RECORD_TYPE
+ /* Don't remove conversions to left-justified modular
+ types. */
+ && ! TYPE_LEFT_JUSTIFIED_MODULAR_P (left_type))
+ || TREE_CODE (left_type) == ARRAY_TYPE)
+ && ((TREE_CODE (TREE_TYPE
+ (TREE_OPERAND (left_operand, 0)))
+ == RECORD_TYPE)
+ || (TREE_CODE (TREE_TYPE
+ (TREE_OPERAND (left_operand, 0)))
+ == ARRAY_TYPE))
+ && (TYPE_MODE (right_type) == BLKmode
+ || (TYPE_MODE (left_type)
+ == TYPE_MODE (TREE_TYPE
+ (TREE_OPERAND
+ (left_operand, 0))))))))
+ {
+ left_operand = TREE_OPERAND (left_operand, 0);
+ left_type = TREE_TYPE (left_operand);
+ }
+
+ if (operation_type == 0)
+ operation_type = left_type;
+
+ /* If the RHS has a conversion between record and array types and
+ an inner type is no worse, use it. Note we cannot do this for
+ modular types or types with TYPE_ALIGN_OK_P, since the latter
+ might indicate a conversion between a root type and a class-wide
+ type, which we must not remove. */
+ while (TREE_CODE (right_operand) == UNCHECKED_CONVERT_EXPR
+ && ((TREE_CODE (right_type) == RECORD_TYPE
+ && ! TYPE_LEFT_JUSTIFIED_MODULAR_P (right_type)
+ && ! TYPE_ALIGN_OK_P (right_type)
+ && ! TYPE_IS_FAT_POINTER_P (right_type))
+ || TREE_CODE (right_type) == ARRAY_TYPE)
+ && (((TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
+ == RECORD_TYPE)
+ && ! (TYPE_LEFT_JUSTIFIED_MODULAR_P
+ (TREE_TYPE (TREE_OPERAND (right_operand, 0))))
+ && ! (TYPE_ALIGN_OK_P
+ (TREE_TYPE (TREE_OPERAND (right_operand, 0))))
+ && ! (TYPE_IS_FAT_POINTER_P
+ (TREE_TYPE (TREE_OPERAND (right_operand, 0)))))
+ || (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
+ == ARRAY_TYPE))
+ && (0 == (best_type
+ == find_common_type (right_type,
+ TREE_TYPE (TREE_OPERAND
+ (right_operand, 0))))
+ || right_type != best_type))
+ {
+ right_operand = TREE_OPERAND (right_operand, 0);
+ right_type = TREE_TYPE (right_operand);
+ }
+
+ /* If we are copying one array or record to another, find the best type
+ to use. */
+ if (((TREE_CODE (left_type) == ARRAY_TYPE
+ && TREE_CODE (right_type) == ARRAY_TYPE)
+ || (TREE_CODE (left_type) == RECORD_TYPE
+ && TREE_CODE (right_type) == RECORD_TYPE))
+ && (best_type = find_common_type (left_type, right_type)) != 0)
+ operation_type = best_type;
+
+ /* If a class-wide type may be involved, force use of the RHS type. */
+ if (TREE_CODE (right_type) == RECORD_TYPE
+ && TYPE_ALIGN_OK_P (right_type))
+ operation_type = right_type;
+
+ /* After we strip off any COMPONENT_REF, ARRAY_REF, or ARRAY_RANGE_REF
+ from the lhs, we must have either an INDIRECT_REF or a decl. Allow
+ UNCHECKED_CONVERT_EXPRs, but set TREE_ADDRESSABLE to show they are
+ in an LHS. Finally, allow NOP_EXPR if both types are the same tree
+ code and mode because we know these will be nops. */
+ for (result = left_operand;
+ TREE_CODE (result) == COMPONENT_REF
+ || TREE_CODE (result) == ARRAY_REF
+ || TREE_CODE (result) == ARRAY_RANGE_REF
+ || TREE_CODE (result) == REALPART_EXPR
+ || TREE_CODE (result) == IMAGPART_EXPR
+ || TREE_CODE (result) == WITH_RECORD_EXPR
+ || TREE_CODE (result) == UNCHECKED_CONVERT_EXPR
+ || ((TREE_CODE (result) == NOP_EXPR
+ || TREE_CODE (result) == CONVERT_EXPR)
+ && (TREE_CODE (TREE_TYPE (result))
+ == TREE_CODE (TREE_TYPE (TREE_OPERAND (result, 0))))
+ && (TYPE_MODE (TREE_TYPE (TREE_OPERAND (result, 0)))
+ == TYPE_MODE (TREE_TYPE (result))));
+ result = TREE_OPERAND (result, 0))
+ if (TREE_CODE (result) == UNCHECKED_CONVERT_EXPR)
+ TREE_ADDRESSABLE (result) = 1;
+
+ if (TREE_CODE (result) != INDIRECT_REF && TREE_CODE (result) != NULL_EXPR
+ && ! DECL_P (result))
+ gigi_abort (516);
+
+ /* Convert the right operand to the operation type unless
+ it is either already of the correct type or if the type
+ involves a placeholder, since the RHS may not have the same
+ record type. */
+ if (operation_type != right_type
+ && (! (TREE_CODE (TYPE_SIZE (operation_type)) != INTEGER_CST
+ && contains_placeholder_p (TYPE_SIZE (operation_type)))))
+ {
+ /* For a variable-size type, with both BLKmode, convert using
+ CONVERT_EXPR instead of an unchecked conversion since we don't
+ need to make a temporary (and can't anyway). */
+ if (TREE_CODE (TYPE_SIZE (operation_type)) != INTEGER_CST
+ && TYPE_MODE (TREE_TYPE (right_operand)) == BLKmode
+ && TREE_CODE (right_operand) != UNCONSTRAINED_ARRAY_REF)
+ right_operand = build1 (CONVERT_EXPR, operation_type,
+ right_operand);
+ else
+ right_operand = convert (operation_type, right_operand);
+
+ right_type = operation_type;
+ }
+
+ /* If the modes differ, make up a bogus type and convert the RHS to
+ it. This can happen with packed types. */
+ if (TYPE_MODE (left_type) != TYPE_MODE (right_type))
+ {
+ tree new_type = copy_node (left_type);
+
+ TYPE_SIZE (new_type) = TYPE_SIZE (right_type);
+ TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (right_type);
+ TYPE_MAIN_VARIANT (new_type) = new_type;
+ right_operand = convert (new_type, right_operand);
+ }
+
+ has_side_effects = 1;
+ modulus = 0;
+ break;
+
+ case ARRAY_REF:
+ if (operation_type == 0)
+ operation_type = TREE_TYPE (left_type);
+
+ /* ... fall through ... */
+
+ case ARRAY_RANGE_REF:
+
+ /* First convert the right operand to its base type. This will
+ prevent unneed signedness conversions when sizetype is wider than
+ integer. */
+ right_operand = convert (right_base_type, right_operand);
+ right_operand = convert (TYPE_DOMAIN (left_type), right_operand);
+
+ if (! TREE_CONSTANT (right_operand)
+ || ! TREE_CONSTANT (TYPE_MIN_VALUE (right_type))
+ || op_code == ARRAY_RANGE_REF)
+ mark_addressable (left_operand);
+
+ /* If the array is an UNCHECKED_CONVERT_EXPR from and to BLKmode
+ types, convert it to a normal conversion since GCC can deal
+ with any mis-alignment as part of the handling of compponent
+ references. */
+
+ if (TREE_CODE (left_operand) == UNCHECKED_CONVERT_EXPR
+ && TYPE_MODE (TREE_TYPE (left_operand)) == BLKmode
+ && TYPE_MODE (TREE_TYPE (TREE_OPERAND (left_operand, 0))) == BLKmode)
+ left_operand = build1 (CONVERT_EXPR, TREE_TYPE (left_operand),
+ TREE_OPERAND (left_operand, 0));
+
+ modulus = 0;
+ break;
+
+ case GE_EXPR:
+ case LE_EXPR:
+ case GT_EXPR:
+ case LT_EXPR:
+ if (POINTER_TYPE_P (left_type))
+ gigi_abort (501);
+
+ /* ... fall through ... */
+
+ case EQ_EXPR:
+ case NE_EXPR:
+ /* If either operand is a NULL_EXPR, just return a new one. */
+ if (TREE_CODE (left_operand) == NULL_EXPR)
+ return build (op_code, result_type,
+ build1 (NULL_EXPR, integer_type_node,
+ TREE_OPERAND (left_operand, 0)),
+ integer_zero_node);
+
+ else if (TREE_CODE (right_operand) == NULL_EXPR)
+ return build (op_code, result_type,
+ build1 (NULL_EXPR, integer_type_node,
+ TREE_OPERAND (right_operand, 0)),
+ integer_zero_node);
+
+ /* If either object is a left-justified modular types, get the
+ fields from within. */
+ if (TREE_CODE (left_type) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (left_type))
+ {
+ left_operand = convert (TREE_TYPE (TYPE_FIELDS (left_type)),
+ left_operand);
+ left_type = TREE_TYPE (left_operand);
+ left_base_type = get_base_type (left_type);
+ }
+
+ if (TREE_CODE (right_type) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (right_type))
+ {
+ right_operand = convert (TREE_TYPE (TYPE_FIELDS (right_type)),
+ right_operand);
+ right_type = TREE_TYPE (right_operand);
+ right_base_type = get_base_type (right_type);
+ }
+
+ /* If either object if an UNCHECKED_CONVERT_EXPR between two BLKmode
+ objects, change it to a CONVERT_EXPR. */
+ if (TREE_CODE (left_operand) == UNCHECKED_CONVERT_EXPR
+ && TYPE_MODE (left_type) == BLKmode
+ && TYPE_MODE (TREE_TYPE (TREE_OPERAND (left_operand, 0))) == BLKmode)
+ left_operand = build1 (CONVERT_EXPR, left_type,
+ TREE_OPERAND (left_operand, 0));
+ if (TREE_CODE (right_operand) == UNCHECKED_CONVERT_EXPR
+ && TYPE_MODE (right_type) == BLKmode
+ && (TYPE_MODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
+ == BLKmode))
+ right_operand = build1 (CONVERT_EXPR, right_type,
+ TREE_OPERAND (right_operand, 0));
+
+ /* If both objects are arrays, compare them specially. */
+ if ((TREE_CODE (left_type) == ARRAY_TYPE
+ || (TREE_CODE (left_type) == INTEGER_TYPE
+ && TYPE_HAS_ACTUAL_BOUNDS_P (left_type)))
+ && (TREE_CODE (right_type) == ARRAY_TYPE
+ || (TREE_CODE (right_type) == INTEGER_TYPE
+ && TYPE_HAS_ACTUAL_BOUNDS_P (right_type))))
+ {
+ result = compare_arrays (result_type, left_operand, right_operand);
+
+ if (op_code == EQ_EXPR)
+ ;
+ else if (op_code == NE_EXPR)
+ result = invert_truthvalue (result);
+ else
+ gigi_abort (502);
+
+ return result;
+ }
+
+ /* Otherwise, the base types must be the same unless the objects are
+ records. If we have records, use the best type and convert both
+ operands to that type. */
+ if (left_base_type != right_base_type)
+ {
+ if (TREE_CODE (left_base_type) == RECORD_TYPE
+ && TREE_CODE (right_base_type) == RECORD_TYPE)
+ {
+ /* The only way these are permitted to be the same is if both
+ types have the same name. In that case, one of them must
+ not be self-referential. Use that one as the best type.
+ Even better is if one is of fixed size. */
+ best_type = 0;
+
+ if (TYPE_NAME (left_base_type) == 0
+ || TYPE_NAME (left_base_type) != TYPE_NAME (right_base_type))
+ gigi_abort (503);
+
+ if (TREE_CONSTANT (TYPE_SIZE (left_base_type)))
+ best_type = left_base_type;
+ else if (TREE_CONSTANT (TYPE_SIZE (right_base_type)))
+ best_type = right_base_type;
+ else if (! contains_placeholder_p (TYPE_SIZE (left_base_type)))
+ best_type = left_base_type;
+ else if (! contains_placeholder_p (TYPE_SIZE (right_base_type)))
+ best_type = right_base_type;
+ else
+ gigi_abort (504);
+
+ left_operand = convert (best_type, left_operand);
+ right_operand = convert (best_type, right_operand);
+ }
+ else
+ gigi_abort (505);
+ }
+
+ /* If we are comparing a fat pointer against zero, we need to
+ just compare the data pointer. */
+ else if (TYPE_FAT_POINTER_P (left_base_type)
+ && TREE_CODE (right_operand) == CONSTRUCTOR
+ && integer_zerop (TREE_VALUE (TREE_OPERAND (right_operand, 1))))
+ {
+ right_operand = build_component_ref (left_operand, NULL_TREE,
+ TYPE_FIELDS (left_base_type));
+ left_operand = convert (TREE_TYPE (right_operand),
+ integer_zero_node);
+ }
+ else
+ {
+ left_operand = convert (left_base_type, left_operand);
+ right_operand = convert (right_base_type, right_operand);
+ }
+
+ modulus = 0;
+ break;
+
+ case PREINCREMENT_EXPR:
+ case PREDECREMENT_EXPR:
+ case POSTINCREMENT_EXPR:
+ case POSTDECREMENT_EXPR:
+ /* In these, the result type and the left operand type should be the
+ same. Do the operation in the base type of those and convert the
+ right operand (which is an integer) to that type.
+
+ Note that these operations are only used in loop control where
+ we guarantee that no overflow can occur. So nothing special need
+ be done for modular types. */
+
+ if (left_type != result_type)
+ gigi_abort (506);
+
+ operation_type = get_base_type (result_type);
+ left_operand = convert (operation_type, left_operand);
+ right_operand = convert (operation_type, right_operand);
+ has_side_effects = 1;
+ modulus = 0;
+ break;
+
+ case LSHIFT_EXPR:
+ case RSHIFT_EXPR:
+ case LROTATE_EXPR:
+ case RROTATE_EXPR:
+ /* The RHS of a shift can be any type. Also, ignore any modulus
+ (we used to abort, but this is needed for unchecked conversion
+ to modular types). Otherwise, processing is the same as normal. */
+ if (operation_type != left_base_type)
+ gigi_abort (514);
+
+ modulus = 0;
+ left_operand = convert (operation_type, left_operand);
+ break;
+
+ case TRUTH_ANDIF_EXPR:
+ case TRUTH_ORIF_EXPR:
+ case TRUTH_AND_EXPR:
+ case TRUTH_OR_EXPR:
+ case TRUTH_XOR_EXPR:
+ left_operand = truthvalue_conversion (left_operand);
+ right_operand = truthvalue_conversion (right_operand);
+ goto common;
+
+ case BIT_AND_EXPR:
+ case BIT_IOR_EXPR:
+ case BIT_XOR_EXPR:
+ /* For binary modulus, if the inputs are in range, so are the
+ outputs. */
+ if (modulus != 0 && integer_pow2p (modulus))
+ modulus = 0;
+
+ goto common;
+
+ case COMPLEX_EXPR:
+ if (TREE_TYPE (result_type) != left_base_type
+ || TREE_TYPE (result_type) != right_base_type)
+ gigi_abort (515);
+
+ left_operand = convert (left_base_type, left_operand);
+ right_operand = convert (right_base_type, right_operand);
+ break;
+
+ case TRUNC_DIV_EXPR: case TRUNC_MOD_EXPR:
+ case CEIL_DIV_EXPR: case CEIL_MOD_EXPR:
+ case FLOOR_DIV_EXPR: case FLOOR_MOD_EXPR:
+ case ROUND_DIV_EXPR: case ROUND_MOD_EXPR:
+ /* These always produce results lower than either operand. */
+ modulus = 0;
+ goto common;
+
+ default:
+ common:
+ /* The result type should be the same as the base types of the
+ both operands (and they should be the same). Convert
+ everything to the result type. */
+
+ if (operation_type != left_base_type
+ || left_base_type != right_base_type)
+ gigi_abort (507);
+
+ left_operand = convert (operation_type, left_operand);
+ right_operand = convert (operation_type, right_operand);
+ }
+
+ if (modulus != 0 && ! integer_pow2p (modulus))
+ {
+ result = nonbinary_modular_operation (op_code, operation_type,
+ left_operand, right_operand);
+ modulus = 0;
+ }
+ /* If either operand is a NULL_EXPR, just return a new one. */
+ else if (TREE_CODE (left_operand) == NULL_EXPR)
+ return build1 (NULL_EXPR, operation_type, TREE_OPERAND (left_operand, 0));
+ else if (TREE_CODE (right_operand) == NULL_EXPR)
+ return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0));
+ else
+ result = fold (build (op_code, operation_type,
+ left_operand, right_operand));
+
+ TREE_SIDE_EFFECTS (result) |= has_side_effects;
+ TREE_CONSTANT (result)
+ = (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand)
+ && op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF);
+
+ if ((op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
+ && TYPE_VOLATILE (operation_type))
+ TREE_THIS_VOLATILE (result) = 1;
+
+ /* If we are working with modular types, perform the MOD operation
+ if something above hasn't eliminated the need for it. */
+ if (modulus != 0)
+ result = fold (build (FLOOR_MOD_EXPR, operation_type, result,
+ convert (operation_type, modulus)));
+
+ if (result_type != 0 && result_type != operation_type)
+ result = convert (result_type, result);
+
+ return result;
+}
+\f
+/* Similar, but for unary operations. */
+
+tree
+build_unary_op (op_code, result_type, operand)
+ enum tree_code op_code;
+ tree result_type;
+ tree operand;
+{
+ tree type = TREE_TYPE (operand);
+ tree base_type = get_base_type (type);
+ tree operation_type = result_type;
+ tree result;
+ int side_effects = 0;
+
+ /* If we have a WITH_RECORD_EXPR as our operand, do the operation first,
+ then surround it with the WITH_RECORD_EXPR. This allows GCC to do better
+ expression folding. */
+ if (TREE_CODE (operand) == WITH_RECORD_EXPR)
+ {
+ result = build_unary_op (op_code, result_type,
+ TREE_OPERAND (operand, 0));
+ return build (WITH_RECORD_EXPR, TREE_TYPE (result), result,
+ TREE_OPERAND (operand, 1));
+ }
+
+ if (operation_type != 0
+ && TREE_CODE (operation_type) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (operation_type))
+ operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
+
+ if (operation_type != 0
+ && ! AGGREGATE_TYPE_P (operation_type)
+ && TYPE_EXTRA_SUBTYPE_P (operation_type))
+ operation_type = get_base_type (operation_type);
+
+ switch (op_code)
+ {
+ case REALPART_EXPR:
+ case IMAGPART_EXPR:
+ if (operation_type == 0)
+ result_type = operation_type = TREE_TYPE (type);
+ else if (result_type != TREE_TYPE (type))
+ gigi_abort (513);
+
+ result = fold (build1 (op_code, operation_type, operand));
+ break;
+
+ case TRUTH_NOT_EXPR:
+ if (result_type != base_type)
+ gigi_abort (508);
+
+ result = invert_truthvalue (truthvalue_conversion (operand));
+ break;
+
+ case ATTR_ADDR_EXPR:
+ case ADDR_EXPR:
+ switch (TREE_CODE (operand))
+ {
+ case INDIRECT_REF:
+ case UNCONSTRAINED_ARRAY_REF:
+ result = TREE_OPERAND (operand, 0);
+
+ /* Make sure the type here is a pointer, not a reference.
+ GCC wants pointer types for function addresses. */
+ if (result_type == 0)
+ result_type = build_pointer_type (type);
+ break;
+
+ case NULL_EXPR:
+ result = operand;
+ TREE_TYPE (result) = type = build_pointer_type (type);
+ break;
+
+ case ARRAY_REF:
+ case ARRAY_RANGE_REF:
+ case COMPONENT_REF:
+ case BIT_FIELD_REF:
+ /* If this is for 'Address, find the address of the prefix and
+ add the offset to the field. Otherwise, do this the normal
+ way. */
+ if (op_code == ATTR_ADDR_EXPR)
+ {
+ HOST_WIDE_INT bitsize;
+ HOST_WIDE_INT bitpos;
+ tree offset, inner;
+ enum machine_mode mode;
+ int unsignedp, volatilep;
+ unsigned int alignment;
+
+ inner = get_inner_reference (operand, &bitsize, &bitpos, &offset,
+ &mode, &unsignedp, &volatilep,
+ &alignment);
+
+ /* If INNER is a padding type whose field has a self-referential
+ size, convert to that inner type. We know the offset is zero
+ and we need to have that type visible. */
+ if (TREE_CODE (TREE_TYPE (inner)) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (TREE_TYPE (inner))
+ && (contains_placeholder_p
+ (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
+ (TREE_TYPE (inner)))))))
+ inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))),
+ inner);
+
+ /* Compute the offset as a byte offset from INNER. */
+ if (offset == 0)
+ offset = size_zero_node;
+
+ offset = size_binop (PLUS_EXPR, offset,
+ size_int (bitpos / BITS_PER_UNIT));
+
+ /* Take the address of INNER, convert the offset to void *, and
+ add then. It will later be converted to the desired result
+ type, if any. */
+ inner = build_unary_op (ADDR_EXPR, NULL_TREE, inner);
+ inner = convert (ptr_void_type_node, inner);
+ offset = convert (ptr_void_type_node, offset);
+ result = build_binary_op (PLUS_EXPR, ptr_void_type_node,
+ inner, offset);
+ result = convert (build_pointer_type (TREE_TYPE (operand)),
+ result);
+ break;
+ }
+ goto common;
+
+ case CONSTRUCTOR:
+ /* If this is just a constructor for a padded record, we can
+ just take the address of the single field and convert it to
+ a pointer to our type. */
+ if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
+ {
+ result
+ = build_unary_op (ADDR_EXPR, NULL_TREE,
+ TREE_VALUE (CONSTRUCTOR_ELTS (operand)));
+ result = convert (build_pointer_type (TREE_TYPE (operand)),
+ result);
+ break;
+ }
+
+ goto common;
+
+ case NOP_EXPR:
+ if (AGGREGATE_TYPE_P (type)
+ && AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand, 0))))
+ return build_unary_op (ADDR_EXPR, result_type,
+ TREE_OPERAND (operand, 0));
+
+ /* If this NOP_EXPR doesn't change the mode, get the result type
+ from this type and go down. We need to do this in case
+ this is a conversion of a CONST_DECL. */
+ if (TYPE_MODE (type) != BLKmode
+ && (TYPE_MODE (type)
+ == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0)))))
+ return build_unary_op (ADDR_EXPR,
+ (result_type == 0
+ ? build_pointer_type (type)
+ : result_type),
+ TREE_OPERAND (operand, 0));
+ goto common;
+
+ case CONST_DECL:
+ operand = DECL_CONST_CORRESPONDING_VAR (operand);
+
+ /* ... fall through ... */
+
+ default:
+ common:
+
+ if (type != error_mark_node)
+ operation_type = build_pointer_type (type);
+
+ mark_addressable (operand);
+ result = fold (build1 (ADDR_EXPR, operation_type, operand));
+ }
+
+ TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand);
+ break;
+
+ case INDIRECT_REF:
+ /* If we want to refer to an entire unconstrained array,
+ make up an expression to do so. This will never survive to
+ the backend. If TYPE is a thin pointer, first convert the
+ operand to a fat pointer. */
+ if (TYPE_THIN_POINTER_P (type)
+ && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)) != 0)
+ {
+ operand
+ = convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))),
+ operand);
+ type = TREE_TYPE (operand);
+ }
+
+ if (TYPE_FAT_POINTER_P (type))
+ result = build1 (UNCONSTRAINED_ARRAY_REF,
+ TYPE_UNCONSTRAINED_ARRAY (type), operand);
+
+ else if (TREE_CODE (operand) == ADDR_EXPR)
+ result = TREE_OPERAND (operand, 0);
+
+ else
+ {
+ result = fold (build1 (op_code, TREE_TYPE (type), operand));
+ TREE_READONLY (result) = TREE_STATIC (result)
+ = TREE_READONLY (TREE_TYPE (type));
+ }
+
+ side_effects = flag_volatile
+ || (! TYPE_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)));
+ break;
+
+ case NEGATE_EXPR:
+ case BIT_NOT_EXPR:
+ {
+ tree modulus = ((operation_type != 0
+ && TREE_CODE (operation_type) == INTEGER_TYPE
+ && TYPE_MODULAR_P (operation_type))
+ ? TYPE_MODULUS (operation_type) : 0);
+ int mod_pow2 = modulus != 0 && integer_pow2p (modulus);
+
+ /* If this is a modular type, there are various possibilities
+ depending on the operation and whether the modulus is a
+ power of two or not. */
+
+ if (modulus != 0)
+ {
+ if (operation_type != base_type)
+ gigi_abort (509);
+
+ operand = convert (operation_type, operand);
+
+ /* The fastest in the negate case for binary modulus is
+ the straightforward code; the TRUNC_MOD_EXPR below
+ is an AND operation. */
+ if (op_code == NEGATE_EXPR && mod_pow2)
+ result = fold (build (TRUNC_MOD_EXPR, operation_type,
+ fold (build1 (NEGATE_EXPR, operation_type,
+ operand)),
+ modulus));
+
+ /* For nonbinary negate case, return zero for zero operand,
+ else return the modulus minus the operand. If the modulus
+ is a power of two minus one, we can do the subtraction
+ as an XOR since it is equivalent and faster on most machines. */
+ else if (op_code == NEGATE_EXPR && ! mod_pow2)
+ {
+ if (integer_pow2p (fold (build (PLUS_EXPR, operation_type,
+ modulus,
+ convert (operation_type,
+ integer_one_node)))))
+ result = fold (build (BIT_XOR_EXPR, operation_type,
+ operand, modulus));
+ else
+ result = fold (build (MINUS_EXPR, operation_type,
+ modulus, operand));
+
+ result = fold (build (COND_EXPR, operation_type,
+ fold (build (NE_EXPR, integer_type_node,
+ operand,
+ convert (operation_type,
+ integer_zero_node))),
+ result, operand));
+ }
+ else
+ {
+ /* For the NOT cases, we need a constant equal to
+ the modulus minus one. For a binary modulus, we
+ XOR against the constant and subtract the operand from
+ that constant for nonbinary modulus. */
+
+ tree cnst = fold (build (MINUS_EXPR, operation_type, modulus,
+ convert (operation_type,
+ integer_one_node)));
+
+ if (mod_pow2)
+ result = fold (build (BIT_XOR_EXPR, operation_type,
+ operand, cnst));
+ else
+ result = fold (build (MINUS_EXPR, operation_type,
+ cnst, operand));
+ }
+
+ break;
+ }
+ }
+
+ /* ... fall through ... */
+
+ default:
+ if (operation_type != base_type)
+ gigi_abort (509);
+
+ result = fold (build1 (op_code, operation_type, convert (operation_type,
+ operand)));
+ }
+
+ if (side_effects)
+ {
+ TREE_SIDE_EFFECTS (result) = 1;
+ if (TREE_CODE (result) == INDIRECT_REF)
+ TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result));
+ }
+
+ if (result_type != 0 && TREE_TYPE (result) != result_type)
+ result = convert (result_type, result);
+
+ return result;
+}
+\f
+/* Similar, but for COND_EXPR. */
+
+tree
+build_cond_expr (result_type, condition_operand, true_operand, false_operand)
+ tree result_type;
+ tree condition_operand;
+ tree true_operand;
+ tree false_operand;
+{
+ tree result;
+ int addr_p = 0;
+
+ /* Front-end verifies that result, true and false operands have same base
+ type. Convert everything to the result type. */
+
+ true_operand = convert (result_type, true_operand);
+ false_operand = convert (result_type, false_operand);
+
+ /* If the result type is unconstrained, take the address of
+ the operands and then dereference our result. */
+
+ if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE
+ || (TREE_CODE (TYPE_SIZE (result_type)) != INTEGER_CST
+ && contains_placeholder_p (TYPE_SIZE (result_type))))
+ {
+ addr_p = 1;
+ result_type = build_pointer_type (result_type);
+ true_operand = build_unary_op (ADDR_EXPR, result_type, true_operand);
+ false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand);
+ }
+
+ result = fold (build (COND_EXPR, result_type, condition_operand,
+ true_operand, false_operand));
+ if (addr_p)
+ result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
+
+ return result;
+}
+\f
+
+/* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return
+ the CALL_EXPR. */
+
+tree
+build_call_1_expr (fundecl, arg)
+ tree fundecl;
+ tree arg;
+{
+ tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
+ build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
+ chainon (NULL_TREE, build_tree_list (NULL_TREE, arg)),
+ NULL_TREE);
+
+ TREE_SIDE_EFFECTS (call) = 1;
+
+ return call;
+}
+
+/* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2. Return
+ the CALL_EXPR. */
+
+tree
+build_call_2_expr (fundecl, arg1, arg2)
+ tree fundecl;
+ tree arg1, arg2;
+{
+ tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
+ build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
+ chainon (chainon (NULL_TREE,
+ build_tree_list (NULL_TREE, arg1)),
+ build_tree_list (NULL_TREE, arg2)),
+ NULL_TREE);
+
+ TREE_SIDE_EFFECTS (call) = 1;
+
+ return call;
+}
+
+/* Likewise to call FUNDECL with no arguments. */
+
+tree
+build_call_0_expr (fundecl)
+ tree fundecl;
+{
+ tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
+ build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
+ NULL_TREE, NULL_TREE);
+
+ TREE_SIDE_EFFECTS (call) = 1;
+
+ return call;
+}
+\f
+/* Call a function FCN that raises an exception and pass the line
+ number and file name, if requested. */
+
+tree
+build_call_raise (fndecl)
+ tree fndecl;
+{
+ const char *str = discard_file_names ? "" : ref_filename;
+ int len = strlen (str) + 1;
+ tree filename = build_string (len, str);
+
+ TREE_TYPE (filename)
+ = build_array_type (char_type_node,
+ build_index_type (build_int_2 (len, 0)));
+
+ return
+ build_call_2_expr (fndecl,
+ build1 (ADDR_EXPR, build_pointer_type (char_type_node),
+ filename),
+ build_int_2 (lineno, 0));
+}
+\f
+/* Return a CONSTRUCTOR of TYPE whose list is LIST. */
+
+tree
+build_constructor (type, list)
+ tree type;
+ tree list;
+{
+ tree elmt;
+ int allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
+ int side_effects = 0;
+ tree result;
+
+ for (elmt = list; elmt; elmt = TREE_CHAIN (elmt))
+ {
+ if (! TREE_CONSTANT (TREE_VALUE (elmt))
+ || (TREE_CODE (type) == RECORD_TYPE
+ && DECL_BIT_FIELD (TREE_PURPOSE (elmt))
+ && TREE_CODE (TREE_VALUE (elmt)) != INTEGER_CST))
+ allconstant = 0;
+
+ if (TREE_SIDE_EFFECTS (TREE_VALUE (elmt)))
+ side_effects = 1;
+
+ /* Propagate an NULL_EXPR from the size of the type. We won't ever
+ be executing the code we generate here in that case, but handle it
+ specially to avoid the cmpiler blowing up. */
+ if (TREE_CODE (type) == RECORD_TYPE
+ && (0 != (result
+ = contains_null_expr (DECL_SIZE (TREE_PURPOSE (elmt))))))
+ return build1 (NULL_EXPR, type, TREE_OPERAND (result, 0));
+ }
+
+ /* If TYPE is a RECORD_TYPE and the fields are not in the
+ same order as their bit position, don't treat this as constant
+ since varasm.c can't handle it. */
+ if (allconstant && TREE_CODE (type) == RECORD_TYPE)
+ {
+ tree last_pos = bitsize_zero_node;
+ tree field;
+
+ for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
+ {
+ tree this_pos = bit_position (field);
+
+ if (TREE_CODE (this_pos) != INTEGER_CST
+ || tree_int_cst_lt (this_pos, last_pos))
+ {
+ allconstant = 0;
+ break;
+ }
+
+ last_pos = this_pos;
+ }
+ }
+
+ result = build (CONSTRUCTOR, type, NULL_TREE, list);
+ TREE_CONSTANT (result) = allconstant;
+ TREE_STATIC (result) = allconstant;
+ TREE_SIDE_EFFECTS (result) = side_effects;
+ TREE_READONLY (result) = TREE_READONLY (type);
+
+ return result;
+}
+\f
+/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
+ an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
+ for the field.
+
+ We also handle the fact that we might have been passed a pointer to the
+ actual record and know how to look for fields in variant parts. */
+
+static tree
+build_simple_component_ref (record_variable, component, field)
+ tree record_variable;
+ tree component;
+ tree field;
+{
+ tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
+ tree ref;
+
+ if ((TREE_CODE (record_type) != RECORD_TYPE
+ && TREE_CODE (record_type) != UNION_TYPE
+ && TREE_CODE (record_type) != QUAL_UNION_TYPE)
+ || TYPE_SIZE (record_type) == 0)
+ gigi_abort (510);
+
+ /* Either COMPONENT or FIELD must be specified, but not both. */
+ if ((component != 0) == (field != 0))
+ gigi_abort (511);
+
+ /* If no field was specified, look for a field with the specified name
+ in the current record only. */
+ if (field == 0)
+ for (field = TYPE_FIELDS (record_type); field;
+ field = TREE_CHAIN (field))
+ if (DECL_NAME (field) == component)
+ break;
+
+ if (field == 0)
+ return 0;
+
+ /* If this field is not in the specified record, see if we can find
+ something in the record whose original field is the same as this one. */
+ if (DECL_CONTEXT (field) != record_type)
+ /* Check if there is a field with name COMPONENT in the record. */
+ {
+ tree new_field;
+
+ /* First loop thru normal components. */
+
+ for (new_field = TYPE_FIELDS (record_type); new_field != 0;
+ new_field = TREE_CHAIN (new_field))
+ if (DECL_ORIGINAL_FIELD (new_field) == field
+ || new_field == DECL_ORIGINAL_FIELD (field)
+ || (DECL_ORIGINAL_FIELD (field) != 0
+ && (DECL_ORIGINAL_FIELD (field)
+ == DECL_ORIGINAL_FIELD (new_field))))
+ break;
+
+ /* Next, loop thru DECL_INTERNAL_P components if we haven't found
+ the component in the first search. Doing this search in 2 steps
+ is required to avoiding hidden homonymous fields in the
+ _Parent field. */
+
+ if (new_field == 0)
+ for (new_field = TYPE_FIELDS (record_type); new_field != 0;
+ new_field = TREE_CHAIN (new_field))
+ if (DECL_INTERNAL_P (new_field))
+ {
+ tree field_ref
+ = build_simple_component_ref (record_variable,
+ NULL_TREE, new_field);
+ ref = build_simple_component_ref (field_ref, NULL_TREE, field);
+
+ if (ref != 0)
+ return ref;
+ }
+
+ field = new_field;
+ }
+
+ if (field == 0)
+ return 0;
+
+ /* If the record variable is an UNCHECKED_CONVERT_EXPR from and to BLKmode
+ types, convert it to a normal conversion since GCC can deal with any
+ mis-alignment as part of the handling of compponent references. */
+ if (TREE_CODE (record_variable) == UNCHECKED_CONVERT_EXPR
+ && TYPE_MODE (TREE_TYPE (record_variable)) == BLKmode
+ && TYPE_MODE (TREE_TYPE (TREE_OPERAND (record_variable, 0))) == BLKmode)
+ record_variable = build1 (CONVERT_EXPR, TREE_TYPE (record_variable),
+ TREE_OPERAND (record_variable, 0));
+
+ /* It would be nice to call "fold" here, but that can lose a type
+ we need to tag a PLACEHOLDER_EXPR with, so we can't do it. */
+ ref = build (COMPONENT_REF, TREE_TYPE (field), record_variable, field);
+
+ if (TREE_READONLY (record_variable) || TREE_READONLY (field))
+ TREE_READONLY (ref) = 1;
+ if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field)
+ || TYPE_VOLATILE (record_type))
+ TREE_THIS_VOLATILE (ref) = 1;
+
+ return ref;
+}
+\f
+/* Like build_simple_component_ref, except that we give an error if the
+ reference could not be found. */
+
+tree
+build_component_ref (record_variable, component, field)
+ tree record_variable;
+ tree component;
+ tree field;
+{
+ tree ref = build_simple_component_ref (record_variable, component, field);
+
+ if (ref != 0)
+ return ref;
+
+ /* If FIELD was specified, assume this is an invalid user field so
+ raise constraint error. Otherwise, we can't find the type to return, so
+ abort. */
+
+ else if (field != 0)
+ return build1 (NULL_EXPR, TREE_TYPE (field),
+ build_call_raise (raise_constraint_error_decl));
+ else
+ gigi_abort (512);
+}
+\f
+/* Build a GCC tree to call an allocation or deallocation function.
+ If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
+ generate an allocator.
+
+ GNU_SIZE is the size of the object in bytes and ALIGN is the alignment in
+ bits. GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the
+ storage pool to use. If not preset, malloc and free will be used except
+ if GNAT_PROC is the "fake" value of -1, in which case we allocate the
+ object dynamically on the stack frame. */
+
+tree
+build_call_alloc_dealloc (gnu_obj, gnu_size, align, gnat_proc, gnat_pool)
+ tree gnu_obj;
+ tree gnu_size;
+ int align;
+ Entity_Id gnat_proc;
+ Entity_Id gnat_pool;
+{
+ tree gnu_align = size_int (align / BITS_PER_UNIT);
+
+ if (TREE_CODE (gnu_size) != INTEGER_CST && contains_placeholder_p (gnu_size))
+ gnu_size = build (WITH_RECORD_EXPR, sizetype, gnu_size,
+ build_unary_op (INDIRECT_REF, NULL_TREE, gnu_obj));
+
+ if (Present (gnat_proc))
+ {
+ /* The storage pools are obviously always tagged types, but the
+ secondary stack uses the same mechanism and is not tagged */
+ if (Is_Tagged_Type (Etype (gnat_pool)))
+ {
+ /* The size is the third parameter; the alignment is the
+ same type. */
+ Entity_Id gnat_size_type
+ = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
+ tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
+ tree gnu_proc = gnat_to_gnu (gnat_proc);
+ tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
+ tree gnu_pool = gnat_to_gnu (gnat_pool);
+ tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
+ tree gnu_args = NULL_TREE;
+ tree gnu_call;
+
+ /* The first arg is always the address of the storage pool; next
+ comes the address of the object, for a deallocator, then the
+ size and alignment. */
+ gnu_args
+ = chainon (gnu_args, build_tree_list (NULL_TREE, gnu_pool_addr));
+
+ if (gnu_obj)
+ gnu_args
+ = chainon (gnu_args, build_tree_list (NULL_TREE, gnu_obj));
+
+ gnu_args
+ = chainon (gnu_args,
+ build_tree_list (NULL_TREE,
+ convert (gnu_size_type, gnu_size)));
+ gnu_args
+ = chainon (gnu_args,
+ build_tree_list (NULL_TREE,
+ convert (gnu_size_type, gnu_align)));
+
+ gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
+ gnu_proc_addr, gnu_args, NULL_TREE);
+ TREE_SIDE_EFFECTS (gnu_call) = 1;
+ return gnu_call;
+ }
+
+ /* Secondary stack case. */
+ else
+ {
+ /* The size is the second parameter */
+ Entity_Id gnat_size_type
+ = Etype (Next_Formal (First_Formal (gnat_proc)));
+ tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
+ tree gnu_proc = gnat_to_gnu (gnat_proc);
+ tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
+ tree gnu_args = NULL_TREE;
+ tree gnu_call;
+
+ /* The first arg is the address of the object, for a
+ deallocator, then the size */
+ if (gnu_obj)
+ gnu_args
+ = chainon (gnu_args, build_tree_list (NULL_TREE, gnu_obj));
+
+ gnu_args
+ = chainon (gnu_args,
+ build_tree_list (NULL_TREE,
+ convert (gnu_size_type, gnu_size)));
+
+ gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
+ gnu_proc_addr, gnu_args, NULL_TREE);
+ TREE_SIDE_EFFECTS (gnu_call) = 1;
+ return gnu_call;
+ }
+ }
+
+ else if (gnu_obj)
+ return build_call_1_expr (free_decl, gnu_obj);
+ else if (gnat_pool == -1)
+ {
+ /* If the size is a constant, we can put it in the fixed portion of
+ the stack frame to avoid the need to adjust the stack pointer. */
+ if (TREE_CODE (gnu_size) == INTEGER_CST && ! flag_stack_check)
+ {
+ tree gnu_range
+ = build_range_type (NULL_TREE, size_one_node, gnu_size);
+ tree gnu_array_type = build_array_type (char_type_node, gnu_range);
+ tree gnu_decl =
+ create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
+ gnu_array_type, NULL_TREE, 0, 0, 0, 0, 0);
+
+ return convert (ptr_void_type_node,
+ build_unary_op (ADDR_EXPR, NULL_TREE, gnu_decl));
+ }
+ else
+ return build (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align);
+ }
+ else
+ return build_call_1_expr (malloc_decl, gnu_size);
+}
+\f
+/* Build a GCC tree to correspond to allocating an object of TYPE whose
+ initial value is INIT, if INIT is nonzero. Convert the expression to
+ RESULT_TYPE, which must be some type of pointer. Return the tree.
+ GNAT_PROC and GNAT_POOL optionally give the procedure to call and
+ the storage pool to use. */
+
+tree
+build_allocator (type, init, result_type, gnat_proc, gnat_pool)
+ tree type;
+ tree init;
+ tree result_type;
+ Entity_Id gnat_proc;
+ Entity_Id gnat_pool;
+{
+ tree size = TYPE_SIZE_UNIT (type);
+ tree result;
+
+ /* If the initializer, if present, is a NULL_EXPR, just return a new one. */
+ if (init != 0 && TREE_CODE (init) == NULL_EXPR)
+ return build1 (NULL_EXPR, result_type, TREE_OPERAND (init, 0));
+
+ /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the
+ sizes of the object and its template. Allocate the whole thing and
+ fill in the parts that are known. */
+ else if (TYPE_FAT_OR_THIN_POINTER_P (result_type))
+ {
+ tree template_type
+ = (TYPE_FAT_POINTER_P (result_type)
+ ? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (result_type))))
+ : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (result_type))));
+ tree storage_type
+ = build_unc_object_type (template_type, type,
+ get_identifier ("ALLOC"));
+ tree storage_ptr_type = build_pointer_type (storage_type);
+ tree storage;
+ tree template_cons = NULL_TREE;
+
+ size = TYPE_SIZE_UNIT (storage_type);
+
+ if (TREE_CODE (size) != INTEGER_CST
+ && contains_placeholder_p (size))
+ size = build (WITH_RECORD_EXPR, sizetype, size, init);
+
+ storage = build_call_alloc_dealloc (NULL_TREE, size,
+ TYPE_ALIGN (storage_type),
+ gnat_proc, gnat_pool);
+ storage = convert (storage_ptr_type, make_save_expr (storage));
+
+ if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
+ {
+ type = TREE_TYPE (TYPE_FIELDS (type));
+
+ if (init != 0)
+ init = convert (type, init);
+ }
+
+ /* If there is an initializing expression, make a constructor for
+ the entire object including the bounds and copy it into the
+ object. If there is no initializing expression, just set the
+ bounds. */
+ if (init != 0)
+ {
+ template_cons = tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type)),
+ init, NULL_TREE);
+ template_cons = tree_cons (TYPE_FIELDS (storage_type),
+ build_template (template_type, type,
+ init),
+ template_cons);
+
+ return convert
+ (result_type,
+ build (COMPOUND_EXPR, storage_ptr_type,
+ build_binary_op
+ (MODIFY_EXPR, storage_type,
+ build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert (storage_ptr_type, storage)),
+ build_constructor (storage_type, template_cons)),
+ convert (storage_ptr_type, storage)));
+ }
+ else
+ return build
+ (COMPOUND_EXPR, result_type,
+ build_binary_op
+ (MODIFY_EXPR, template_type,
+ build_component_ref
+ (build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert (storage_ptr_type, storage)),
+ NULL_TREE, TYPE_FIELDS (storage_type)),
+ build_template (template_type, type, NULL_TREE)),
+ convert (result_type, convert (storage_ptr_type, storage)));
+ }
+
+ /* If we have an initializing expression, see if its size is simpler
+ than the size from the type. */
+ if (init != 0 && TYPE_SIZE_UNIT (TREE_TYPE (init)) != 0
+ && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST
+ || (TREE_CODE (size) != INTEGER_CST
+ && contains_placeholder_p (size))))
+ size = TYPE_SIZE_UNIT (TREE_TYPE (init));
+
+ /* If the size is still self-referential, reference the initializing
+ expression, if it is present. If not, this must have been a
+ call to allocate a library-level object, in which case we use
+ the maximum size. */
+ if (TREE_CODE (size) != INTEGER_CST && contains_placeholder_p (size))
+ {
+ if (init == 0)
+ size = max_size (size, 1);
+ else
+ size = build (WITH_RECORD_EXPR, sizetype, size, init);
+ }
+
+ /* If the size overflows, pass -1 so the allocator will raise
+ storage error. */
+ if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
+ size = ssize_int (-1);
+
+ /* If this is a type whose alignment is larger than the
+ biggest we support in normal alignment and this is in
+ the default storage pool, make an "aligning type", allocate
+ it, point to the field we need, and return that. */
+ if (TYPE_ALIGN (type) > BIGGEST_ALIGNMENT
+ && No (gnat_proc))
+ {
+ tree new_type = make_aligning_type (type, TYPE_ALIGN (type), size);
+
+ result = build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE (new_type),
+ BIGGEST_ALIGNMENT, Empty, Empty);
+ result = save_expr (result);
+ result = convert (build_pointer_type (new_type), result);
+ result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
+ result = build_component_ref (result, NULL_TREE,
+ TYPE_FIELDS (new_type));
+ result = convert (result_type,
+ build_unary_op (ADDR_EXPR, NULL_TREE, result));
+ }
+ else
+ result = convert (result_type,
+ build_call_alloc_dealloc (NULL_TREE, size,
+ TYPE_ALIGN (type),
+ gnat_proc, gnat_pool));
+
+ /* If we have an initial value, put the new address into a SAVE_EXPR, assign
+ the value, and return the address. Do this with a COMPOUND_EXPR. */
+
+ if (init)
+ {
+ result = save_expr (result);
+ result
+ = build (COMPOUND_EXPR, TREE_TYPE (result),
+ build_binary_op
+ (MODIFY_EXPR, TREE_TYPE (TREE_TYPE (result)),
+ build_unary_op (INDIRECT_REF, TREE_TYPE (TREE_TYPE (result)),
+ result),
+ init),
+ result);
+ }
+
+ return convert (result_type, result);
+}
+\f
+/* Fill in a VMS descriptor for EXPR and return a constructor for it.
+ GNAT_FORMAL is how we find the descriptor record. */
+
+tree
+fill_vms_descriptor (expr, gnat_formal)
+ tree expr;
+ Entity_Id gnat_formal;
+{
+ tree record_type = TREE_TYPE (TREE_TYPE (get_gnu_tree (gnat_formal)));
+ tree field;
+ tree const_list = 0;
+
+ expr = maybe_unconstrained_array (expr);
+ mark_addressable (expr);
+
+ for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
+ {
+ tree init = DECL_INITIAL (field);
+
+ if (TREE_CODE (init) != INTEGER_CST
+ && contains_placeholder_p (init))
+ init = build (WITH_RECORD_EXPR, TREE_TYPE (init), init, expr);
+
+ const_list = tree_cons (field, convert (TREE_TYPE (field), init),
+ const_list);
+ }
+
+ return build_constructor (record_type, nreverse (const_list));
+}
+
+/* Indicate that we need to make the address of EXPR_NODE and it therefore
+ should not be allocated in a register. Return 1 if successful. */
+
+int
+mark_addressable (expr_node)
+ tree expr_node;
+{
+ while (1)
+ switch (TREE_CODE (expr_node))
+ {
+ case ADDR_EXPR:
+ case COMPONENT_REF:
+ case ARRAY_REF:
+ case ARRAY_RANGE_REF:
+ case REALPART_EXPR:
+ case IMAGPART_EXPR:
+ case NOP_EXPR:
+ expr_node = TREE_OPERAND (expr_node, 0);
+ break;
+
+ case CONSTRUCTOR:
+ TREE_ADDRESSABLE (expr_node) = 1;
+ return 1;
+
+ case VAR_DECL:
+ case PARM_DECL:
+ case RESULT_DECL:
+ put_var_into_stack (expr_node);
+ TREE_ADDRESSABLE (expr_node) = 1;
+ return 1;
+
+ case FUNCTION_DECL:
+ TREE_ADDRESSABLE (expr_node) = 1;
+ return 1;
+
+ case CONST_DECL:
+ return (DECL_CONST_CORRESPONDING_VAR (expr_node) != 0
+ && (mark_addressable
+ (DECL_CONST_CORRESPONDING_VAR (expr_node))));
+ default:
+ return 1;
+ }
+}
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- X R _ T A B L S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.36 $
+-- --
+-- Copyright (C) 1998-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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions;
+with Ada.Strings.Fixed;
+with Ada.Strings;
+with Ada.Text_IO;
+with Hostparm;
+with GNAT.IO_Aux;
+with Unchecked_Deallocation;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with Osint;
+
+with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+
+package body Xr_Tabls is
+
+ subtype Line_String is String (1 .. Hostparm.Max_Line_Length);
+ subtype File_Name_String is String (1 .. Hostparm.Max_Name_Length);
+
+ function Base_File_Name (File : String) return String;
+ -- Return the base file name for File (ie not including the directory)
+
+ function Dir_Name (File : String; Base : String := "") return String;
+ -- Return the directory name of File, or "" if there is no directory part
+ -- in File.
+ -- This includes the last separator at the end, and always return an
+ -- absolute path name (directories are relative to Base, or the current
+ -- directory if Base is "")
+
+ Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator;
+
+ Files : File_Table;
+ Entities : Entity_Table;
+ Directories : Project_File_Ptr;
+ Default_Match : Boolean := False;
+
+ ---------------------
+ -- Add_Declaration --
+ ---------------------
+
+ function Add_Declaration
+ (File_Ref : File_Reference;
+ Symbol : String;
+ Line : Natural;
+ Column : Natural;
+ Decl_Type : Character)
+ return Declaration_Reference
+ is
+ The_Entities : Declaration_Reference := Entities.Table;
+ New_Decl : Declaration_Reference;
+ Result : Compare_Result;
+ Prev : Declaration_Reference := null;
+
+ begin
+ -- Check if the identifier already exists in the table
+
+ while The_Entities /= null loop
+ Result := Compare (The_Entities, File_Ref, Line, Column, Symbol);
+ exit when Result = GreaterThan;
+
+ if Result = Equal then
+ return The_Entities;
+ end if;
+
+ Prev := The_Entities;
+ The_Entities := The_Entities.Next;
+ end loop;
+
+ -- Insert the Declaration in the table
+
+ New_Decl := new Declaration_Record'
+ (Symbol_Length => Symbol'Length,
+ Symbol => Symbol,
+ Decl => (File => File_Ref,
+ Line => Line,
+ Column => Column,
+ Source_Line => Null_Unbounded_String,
+ Next => null),
+ Decl_Type => Decl_Type,
+ Body_Ref => null,
+ Ref_Ref => null,
+ Modif_Ref => null,
+ Match => Default_Match or else Match (File_Ref, Line, Column),
+ Par_Symbol => null,
+ Next => null);
+
+ if Prev = null then
+ New_Decl.Next := Entities.Table;
+ Entities.Table := New_Decl;
+ else
+ New_Decl.Next := Prev.Next;
+ Prev.Next := New_Decl;
+ end if;
+
+ if New_Decl.Match then
+ Files.Longest_Name := Natural'Max (File_Ref.File'Length,
+ Files.Longest_Name);
+ end if;
+
+ return New_Decl;
+ end Add_Declaration;
+
+ --------------
+ -- Add_File --
+ --------------
+
+ 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)
+ is
+ The_Files : File_Reference := Files.Table;
+ Base : constant String := Base_File_Name (File_Name);
+ Dir : constant String := Xr_Tabls.Dir_Name (File_Name);
+ Dir_Acc : String_Access := null;
+
+ begin
+ -- Do we have a directory name as well ?
+ if Dir /= "" then
+ Dir_Acc := new String' (Dir);
+ end if;
+
+ -- Check if the file already exists in the table
+
+ while The_Files /= null loop
+
+ if The_Files.File = File_Name then
+ File_Existed := True;
+ Ref := The_Files;
+ return;
+ end if;
+
+ The_Files := The_Files.Next;
+ end loop;
+
+ Ref := new File_Record'
+ (File_Length => Base'Length,
+ File => Base,
+ Dir => Dir_Acc,
+ Lines => null,
+ Visited => Visited,
+ Emit_Warning => Emit_Warning,
+ Gnatchop_File => new String' (Gnatchop_File),
+ Gnatchop_Offset => Gnatchop_Offset,
+ Next => Files.Table);
+ Files.Table := Ref;
+ File_Existed := False;
+ end Add_File;
+
+ --------------
+ -- Add_Line --
+ --------------
+
+ procedure Add_Line
+ (File : File_Reference;
+ Line : Natural;
+ Column : Natural)
+ is
+ begin
+ File.Lines := new Ref_In_File'(Line => Line,
+ Column => Column,
+ Next => File.Lines);
+ end Add_Line;
+
+ ----------------
+ -- Add_Parent --
+ ----------------
+
+ procedure Add_Parent
+ (Declaration : in out Declaration_Reference;
+ Symbol : String;
+ Line : Natural;
+ Column : Natural;
+ File_Ref : File_Reference)
+ is
+ begin
+ Declaration.Par_Symbol := new Declaration_Record'
+ (Symbol_Length => Symbol'Length,
+ Symbol => Symbol,
+ Decl => (File => File_Ref,
+ Line => Line,
+ Column => Column,
+ Source_Line => Null_Unbounded_String,
+ Next => null),
+ Decl_Type => ' ',
+ Body_Ref => null,
+ Ref_Ref => null,
+ Modif_Ref => null,
+ Match => False,
+ Par_Symbol => null,
+ Next => null);
+ end Add_Parent;
+
+ -------------------
+ -- Add_Reference --
+ -------------------
+
+ procedure Add_Reference
+ (Declaration : Declaration_Reference;
+ File_Ref : File_Reference;
+ Line : Natural;
+ Column : Natural;
+ Ref_Type : Character)
+ is
+ procedure Free is new Unchecked_Deallocation
+ (Reference_Record, Reference);
+
+ Ref : Reference;
+ Prev : Reference := null;
+ Result : Compare_Result;
+ New_Ref : Reference := new Reference_Record'
+ (File => File_Ref,
+ Line => Line,
+ Column => Column,
+ Source_Line => Null_Unbounded_String,
+ Next => null);
+
+ begin
+ case Ref_Type is
+ when 'b' | 'c' => Ref := Declaration.Body_Ref;
+ when 'r' | 'i' => Ref := Declaration.Ref_Ref;
+ when 'm' => Ref := Declaration.Modif_Ref;
+ when others => return;
+ end case;
+
+ -- Check if the reference already exists
+
+ while Ref /= null loop
+ Result := Compare (New_Ref, Ref);
+ exit when Result = LessThan;
+
+ if Result = Equal then
+ Free (New_Ref);
+ return;
+ end if;
+
+ Prev := Ref;
+ Ref := Ref.Next;
+ end loop;
+
+ -- Insert it in the list
+
+ if Prev /= null then
+ New_Ref.Next := Prev.Next;
+ Prev.Next := New_Ref;
+
+ else
+ case Ref_Type is
+ when 'b' | 'c' =>
+ New_Ref.Next := Declaration.Body_Ref;
+ Declaration.Body_Ref := New_Ref;
+ when 'r' | 'i' =>
+ New_Ref.Next := Declaration.Ref_Ref;
+ Declaration.Ref_Ref := New_Ref;
+ when 'm' =>
+ New_Ref.Next := Declaration.Modif_Ref;
+ Declaration.Modif_Ref := New_Ref;
+ when others => null;
+ end case;
+ end if;
+
+ if not Declaration.Match then
+ Declaration.Match := Match (File_Ref, Line, Column);
+ end if;
+
+ if Declaration.Match then
+ Files.Longest_Name := Natural'Max (File_Ref.File'Length,
+ Files.Longest_Name);
+ end if;
+ end Add_Reference;
+
+ -------------------
+ -- ALI_File_Name --
+ -------------------
+
+ function ALI_File_Name (Ada_File_Name : String) return String is
+ Index : Natural := Ada.Strings.Fixed.Index
+ (Ada_File_Name, ".", Going => Ada.Strings.Backward);
+
+ begin
+ if Index /= 0 then
+ return Ada_File_Name (Ada_File_Name'First .. Index)
+ & "ali";
+ else
+ return Ada_File_Name & ".ali";
+ end if;
+ end ALI_File_Name;
+
+ --------------------
+ -- Base_File_Name --
+ --------------------
+
+ function Base_File_Name (File : String) return String is
+ begin
+ for J in reverse File'Range loop
+ if File (J) = '/' or else File (J) = Dir_Sep then
+ return File (J + 1 .. File'Last);
+ end if;
+ end loop;
+ return File;
+ end Base_File_Name;
+
+ -------------
+ -- Compare --
+ -------------
+
+ function Compare
+ (Ref1 : Reference;
+ Ref2 : Reference)
+ return Compare_Result
+ is
+ begin
+ if Ref1 = null then
+ return GreaterThan;
+ elsif Ref2 = null then
+ return LessThan;
+ end if;
+
+ if Ref1.File.File < Ref2.File.File then
+ return LessThan;
+
+ elsif Ref1.File.File = Ref2.File.File then
+ if Ref1.Line < Ref2.Line then
+ return LessThan;
+
+ elsif Ref1.Line = Ref2.Line then
+ if Ref1.Column < Ref2.Column then
+ return LessThan;
+ elsif Ref1.Column = Ref2.Column then
+ return Equal;
+ else
+ return GreaterThan;
+ end if;
+
+ else
+ return GreaterThan;
+ end if;
+
+ else
+ return GreaterThan;
+ end if;
+ end Compare;
+
+ -------------
+ -- Compare --
+ -------------
+
+ function Compare
+ (Decl1 : Declaration_Reference;
+ File2 : File_Reference;
+ Line2 : Integer;
+ Col2 : Integer;
+ Symb2 : String)
+ return Compare_Result
+ is
+ begin
+ if Decl1 = null then
+ return GreaterThan;
+ end if;
+
+ if Decl1.Symbol < Symb2 then
+ return LessThan;
+ elsif Decl1.Symbol > Symb2 then
+ return GreaterThan;
+ end if;
+
+ if Decl1.Decl.File.File < Get_File (File2) then
+ return LessThan;
+
+ elsif Decl1.Decl.File.File = Get_File (File2) then
+ if Decl1.Decl.Line < Line2 then
+ return LessThan;
+
+ elsif Decl1.Decl.Line = Line2 then
+ if Decl1.Decl.Column < Col2 then
+ return LessThan;
+
+ elsif Decl1.Decl.Column = Col2 then
+ return Equal;
+
+ else
+ return GreaterThan;
+ end if;
+
+ else
+ return GreaterThan;
+ end if;
+
+ else
+ return GreaterThan;
+ end if;
+ end Compare;
+
+ -------------------------
+ -- Create_Project_File --
+ -------------------------
+
+ procedure Create_Project_File
+ (Name : String)
+ is
+ use Ada.Strings.Unbounded;
+
+ Obj_Dir : Unbounded_String := Null_Unbounded_String;
+ Src_Dir : Unbounded_String := Null_Unbounded_String;
+ Build_Dir : Unbounded_String;
+
+ Gnatls_Src_Cache : Unbounded_String;
+ Gnatls_Obj_Cache : Unbounded_String;
+
+ F : File_Descriptor;
+ Len : Positive;
+ File_Name : aliased String := Name & ASCII.NUL;
+
+ begin
+
+ -- Read the size of the file
+ F := Open_Read (File_Name'Address, Text);
+
+ -- Project file not found
+ if F /= Invalid_FD then
+ Len := Positive (File_Length (F));
+
+ declare
+ Buffer : String (1 .. Len);
+ Index : Positive := Buffer'First;
+ Last : Positive;
+ begin
+ Len := Read (F, Buffer'Address, Len);
+ Close (F);
+
+ -- First, look for Build_Dir, since all the source and object
+ -- path are relative to it.
+
+ while Index <= Buffer'Last loop
+
+ -- find the end of line
+
+ Last := Index;
+ while Last <= Buffer'Last
+ and then Buffer (Last) /= ASCII.LF
+ and then Buffer (Last) /= ASCII.CR
+ loop
+ Last := Last + 1;
+ end loop;
+
+ if Index <= Buffer'Last - 9
+ and then Buffer (Index .. Index + 9) = "build_dir="
+ then
+ Index := Index + 10;
+ while Index <= Last
+ and then (Buffer (Index) = ' '
+ or else Buffer (Index) = ASCII.HT)
+ loop
+ Index := Index + 1;
+ end loop;
+
+ Build_Dir :=
+ To_Unbounded_String (Buffer (Index .. Last - 1));
+ if Buffer (Last - 1) /= Dir_Sep then
+ Append (Build_Dir, Dir_Sep);
+ end if;
+ end if;
+
+ Index := Last + 1;
+
+ -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
+ -- remaining symbol
+
+ if Index <= Buffer'Last
+ and then Buffer (Index) = ASCII.LF
+ then
+ Index := Index + 1;
+ end if;
+ end loop;
+
+ -- Now parse the source and object paths
+
+ Index := Buffer'First;
+ while Index <= Buffer'Last loop
+
+ -- find the end of line
+
+ Last := Index;
+ while Last <= Buffer'Last
+ and then Buffer (Last) /= ASCII.LF
+ and then Buffer (Last) /= ASCII.CR
+ loop
+ Last := Last + 1;
+ end loop;
+
+ if Index <= Buffer'Last - 7
+ and then Buffer (Index .. Index + 7) = "src_dir="
+ then
+ declare
+ S : String := Ada.Strings.Fixed.Trim
+ (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both);
+ begin
+ -- A relative directory ?
+ if S (S'First) /= Dir_Sep then
+ Append (Src_Dir, Build_Dir);
+ end if;
+
+ if S (S'Last) = Dir_Sep then
+ Append (Src_Dir, S & " ");
+ else
+ Append (Src_Dir, S & Dir_Sep & " ");
+ end if;
+ end;
+
+ elsif Index <= Buffer'Last - 7
+ and then Buffer (Index .. Index + 7) = "obj_dir="
+ then
+ declare
+ S : String := Ada.Strings.Fixed.Trim
+ (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both);
+ begin
+ -- A relative directory ?
+ if S (S'First) /= Dir_Sep then
+ Append (Obj_Dir, Build_Dir);
+ end if;
+
+ if S (S'Last) = Dir_Sep then
+ Append (Obj_Dir, S & " ");
+ else
+ Append (Obj_Dir, S & Dir_Sep & " ");
+ end if;
+ end;
+ end if;
+
+ -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
+ -- remaining symbol
+ Index := Last + 1;
+
+ if Index <= Buffer'Last
+ and then Buffer (Index) = ASCII.LF
+ then
+ Index := Index + 1;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ Parse_Gnatls (Gnatls_Src_Cache, Gnatls_Obj_Cache);
+
+ Directories := new Project_File'
+ (Src_Dir_Length => Length (Src_Dir) + Length (Gnatls_Src_Cache),
+ Obj_Dir_Length => Length (Obj_Dir) + Length (Gnatls_Obj_Cache),
+ Src_Dir => To_String (Src_Dir & Gnatls_Src_Cache),
+ Obj_Dir => To_String (Obj_Dir & Gnatls_Obj_Cache),
+ Src_Dir_Index => 1,
+ Obj_Dir_Index => 1,
+ Last_Obj_Dir_Start => 0);
+ end Create_Project_File;
+
+ ---------------------
+ -- Current_Obj_Dir --
+ ---------------------
+
+ function Current_Obj_Dir return String is
+ begin
+ return Directories.Obj_Dir (Directories.Last_Obj_Dir_Start
+ .. Directories.Obj_Dir_Index - 2);
+ end Current_Obj_Dir;
+
+ --------------
+ -- Dir_Name --
+ --------------
+
+ function Dir_Name (File : String; Base : String := "") return String is
+ begin
+ for J in reverse File'Range loop
+ if File (J) = '/' or else File (J) = Dir_Sep then
+
+ -- Is this an absolute directory ?
+ if File (File'First) = '/'
+ or else File (File'First) = Dir_Sep
+ then
+ return File (File'First .. J);
+
+ -- Else do we know the base directory ?
+ elsif Base /= "" then
+ return Base & File (File'First .. J);
+
+ else
+ declare
+ Max_Path : Integer;
+ pragma Import (C, Max_Path, "max_path_len");
+
+ Base2 : Dir_Name_Str (1 .. Max_Path);
+ Last : Natural;
+ begin
+ Get_Current_Dir (Base2, Last);
+ return Base2 (Base2'First .. Last) & File (File'First .. J);
+ end;
+ end if;
+ end if;
+ end loop;
+ return "";
+ end Dir_Name;
+
+ -------------------
+ -- Find_ALI_File --
+ -------------------
+
+ function Find_ALI_File (Short_Name : String) return String is
+ use type Ada.Strings.Unbounded.String_Access;
+ Old_Obj_Dir : constant Integer := Directories.Obj_Dir_Index;
+
+ begin
+ Reset_Obj_Dir;
+
+ loop
+ declare
+ Obj_Dir : String := Next_Obj_Dir;
+ begin
+ exit when Obj_Dir'Length = 0;
+ if GNAT.IO_Aux.File_Exists (Obj_Dir & Short_Name) then
+ Directories.Obj_Dir_Index := Old_Obj_Dir;
+ return Obj_Dir;
+ end if;
+ end;
+ end loop;
+
+ -- Finally look in the standard directories
+
+ Directories.Obj_Dir_Index := Old_Obj_Dir;
+ return "";
+ end Find_ALI_File;
+
+ ----------------------
+ -- Find_Source_File --
+ ----------------------
+
+ function Find_Source_File (Short_Name : String) return String is
+ use type Ada.Strings.Unbounded.String_Access;
+
+ begin
+ Reset_Src_Dir;
+ loop
+ declare
+ Src_Dir : String := Next_Src_Dir;
+ begin
+ exit when Src_Dir'Length = 0;
+
+ if GNAT.IO_Aux.File_Exists (Src_Dir & Short_Name) then
+ return Src_Dir;
+ end if;
+ end;
+ end loop;
+
+ -- Finally look in the standard directories
+
+ return "";
+ end Find_Source_File;
+
+ ----------------
+ -- First_Body --
+ ----------------
+
+ function First_Body (Decl : Declaration_Reference) return Reference is
+ begin
+ return Decl.Body_Ref;
+ end First_Body;
+
+ -----------------------
+ -- First_Declaration --
+ -----------------------
+
+ function First_Declaration return Declaration_Reference is
+ begin
+ return Entities.Table;
+ end First_Declaration;
+
+ -----------------
+ -- First_Modif --
+ -----------------
+
+ function First_Modif (Decl : Declaration_Reference) return Reference is
+ begin
+ return Decl.Modif_Ref;
+ end First_Modif;
+
+ ---------------------
+ -- First_Reference --
+ ---------------------
+
+ function First_Reference (Decl : Declaration_Reference) return Reference is
+ begin
+ return Decl.Ref_Ref;
+ end First_Reference;
+
+ ----------------
+ -- Get_Column --
+ ----------------
+
+ function Get_Column (Decl : Declaration_Reference) return String is
+ begin
+ return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Column),
+ Ada.Strings.Left);
+ end Get_Column;
+
+ function Get_Column (Ref : Reference) return String is
+ begin
+ return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Column),
+ Ada.Strings.Left);
+ end Get_Column;
+
+ ---------------------
+ -- Get_Declaration --
+ ---------------------
+
+ function Get_Declaration
+ (File_Ref : File_Reference;
+ Line : Natural;
+ Column : Natural)
+ return Declaration_Reference
+ is
+ The_Entities : Declaration_Reference := Entities.Table;
+ begin
+ while The_Entities /= null loop
+ if The_Entities.Decl.Line = Line
+ and then The_Entities.Decl.Column = Column
+ and then The_Entities.Decl.File = File_Ref
+ then
+ return The_Entities;
+ else
+ The_Entities := The_Entities.Next;
+ end if;
+ end loop;
+
+ return Empty_Declaration;
+ end Get_Declaration;
+
+ ----------------------
+ -- Get_Emit_Warning --
+ ----------------------
+
+ function Get_Emit_Warning (File : File_Reference) return Boolean is
+ begin
+ return File.Emit_Warning;
+ end Get_Emit_Warning;
+
+ --------------
+ -- Get_File --
+ --------------
+
+ function Get_File
+ (Decl : Declaration_Reference;
+ With_Dir : Boolean := False)
+ return String
+ is
+ begin
+ return Get_File (Decl.Decl.File, With_Dir);
+ end Get_File;
+
+ function Get_File
+ (Ref : Reference;
+ With_Dir : Boolean := False)
+ return String
+ is
+ begin
+ return Get_File (Ref.File, With_Dir);
+ end Get_File;
+
+ function Get_File
+ (File : File_Reference;
+ With_Dir : in Boolean := False;
+ Strip : Natural := 0)
+ return String
+ is
+ function Internal_Strip (Full_Name : String) return String;
+ -- Internal function to process the Strip parameter
+
+ --------------------
+ -- Internal_Strip --
+ --------------------
+
+ function Internal_Strip (Full_Name : String) return String is
+ Unit_End, Extension_Start : Natural;
+ S : Natural := Strip;
+ begin
+ if Strip = 0 then
+ return Full_Name;
+ end if;
+
+ -- Isolate the file extension
+
+ Extension_Start := Full_Name'Last;
+ while Extension_Start >= Full_Name'First
+ and then Full_Name (Extension_Start) /= '.'
+ loop
+ Extension_Start := Extension_Start - 1;
+ end loop;
+
+ -- Strip the right number of subunit_names
+
+ Unit_End := Extension_Start - 1;
+ while Unit_End >= Full_Name'First
+ and then S > 0
+ loop
+ if Full_Name (Unit_End) = '-' then
+ S := S - 1;
+ end if;
+ Unit_End := Unit_End - 1;
+ end loop;
+
+ if Unit_End < Full_Name'First then
+ return "";
+ else
+ return Full_Name (Full_Name'First .. Unit_End)
+ & Full_Name (Extension_Start .. Full_Name'Last);
+ end if;
+ end Internal_Strip;
+
+ begin
+ -- If we do not want the full path name
+
+ if not With_Dir then
+ return Internal_Strip (File.File);
+ end if;
+
+ if File.Dir = null then
+
+ if Ada.Strings.Fixed.Tail (File.File, 3) = "ali" then
+ File.Dir := new String'(Find_ALI_File (File.File));
+ else
+ File.Dir := new String'(Find_Source_File (File.File));
+ end if;
+ end if;
+
+ return Internal_Strip (File.Dir.all & File.File);
+ end Get_File;
+
+ ------------------
+ -- Get_File_Ref --
+ ------------------
+
+ function Get_File_Ref (Ref : Reference) return File_Reference is
+ begin
+ return Ref.File;
+ end Get_File_Ref;
+
+ -----------------------
+ -- Get_Gnatchop_File --
+ -----------------------
+
+ function Get_Gnatchop_File
+ (File : File_Reference; With_Dir : Boolean := False) return String is
+ begin
+ if File.Gnatchop_File.all = "" then
+ return Get_File (File, With_Dir);
+ else
+ return File.Gnatchop_File.all;
+ end if;
+ end Get_Gnatchop_File;
+
+ -----------------------
+ -- Get_Gnatchop_File --
+ -----------------------
+
+ function Get_Gnatchop_File
+ (Ref : Reference; With_Dir : Boolean := False) return String is
+ begin
+ return Get_Gnatchop_File (Ref.File, With_Dir);
+ end Get_Gnatchop_File;
+
+ -----------------------
+ -- Get_Gnatchop_File --
+ -----------------------
+
+ function Get_Gnatchop_File
+ (Decl : Declaration_Reference; With_Dir : Boolean := False) return String
+ is
+ begin
+ return Get_Gnatchop_File (Decl.Decl.File, With_Dir);
+ end Get_Gnatchop_File;
+
+ --------------
+ -- Get_Line --
+ --------------
+
+ function Get_Line (Decl : Declaration_Reference) return String is
+ begin
+ return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Line),
+ Ada.Strings.Left);
+ end Get_Line;
+
+ function Get_Line (Ref : Reference) return String is
+ begin
+ return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Line),
+ Ada.Strings.Left);
+ end Get_Line;
+
+ ----------------
+ -- Get_Parent --
+ ----------------
+
+ function Get_Parent
+ (Decl : Declaration_Reference)
+ return Declaration_Reference is
+ begin
+ return Decl.Par_Symbol;
+ end Get_Parent;
+
+ ---------------------
+ -- Get_Source_Line --
+ ---------------------
+
+ function Get_Source_Line (Ref : Reference) return String is
+ begin
+ return To_String (Ref.Source_Line);
+ end Get_Source_Line;
+
+ function Get_Source_Line (Decl : Declaration_Reference) return String is
+ begin
+ return To_String (Decl.Decl.Source_Line);
+ end Get_Source_Line;
+
+ ----------------
+ -- Get_Symbol --
+ ----------------
+
+ function Get_Symbol (Decl : Declaration_Reference) return String is
+ begin
+ return Decl.Symbol;
+ end Get_Symbol;
+
+ --------------
+ -- Get_Type --
+ --------------
+
+ function Get_Type (Decl : Declaration_Reference) return Character is
+ begin
+ return Decl.Decl_Type;
+ end Get_Type;
+
+ -----------------------
+ -- Grep_Source_Files --
+ -----------------------
+
+ procedure Grep_Source_Files is
+ Decl : Declaration_Reference := First_Declaration;
+
+ type Simple_Ref;
+ type Simple_Ref_Access is access Simple_Ref;
+ type Simple_Ref is
+ record
+ Ref : Reference;
+ Next : Simple_Ref_Access;
+ end record;
+ List : Simple_Ref_Access := null;
+ -- This structure is used to speed up the parsing of Ada sources:
+ -- Every reference found by parsing the .ali files is inserted in this
+ -- list, sorted by filename and line numbers.
+ -- This allows use not to parse a same ada file multiple times
+
+ procedure Free is new Unchecked_Deallocation
+ (Simple_Ref, Simple_Ref_Access);
+ -- Clear an element of the list
+
+ procedure Grep_List;
+ -- For each reference in the list, parse the file and find the
+ -- source line
+
+ procedure Insert_In_Order (Ref : Reference);
+ -- Insert a new reference in the list, ordered by line numbers
+
+ procedure Insert_List_Ref (First_Ref : Reference);
+ -- Process a list of references
+
+ ---------------
+ -- Grep_List --
+ ---------------
+
+ procedure Grep_List is
+ Line : String (1 .. 1024);
+ Last : Natural;
+ File : Ada.Text_IO.File_Type;
+ Line_Number : Natural;
+ Pos : Natural;
+ Save_List : Simple_Ref_Access := List;
+ Current_File : File_Reference;
+
+ begin
+ while List /= null loop
+
+ -- Makes sure we can find and read the file
+
+ Current_File := List.Ref.File;
+ Line_Number := 0;
+
+ begin
+ Ada.Text_IO.Open (File,
+ Ada.Text_IO.In_File,
+ Get_File (List.Ref, True));
+
+ -- Read the file and find every relevant lines
+
+ while List /= null
+ and then List.Ref.File = Current_File
+ and then not Ada.Text_IO.End_Of_File (File)
+ loop
+ Ada.Text_IO.Get_Line (File, Line, Last);
+ Line_Number := Line_Number + 1;
+
+ while List /= null
+ and then Line_Number = List.Ref.Line
+ loop
+
+ -- Skip the leading blanks on the line
+
+ Pos := 1;
+ while Line (Pos) = ' '
+ or else Line (Pos) = ASCII.HT
+ loop
+ Pos := Pos + 1;
+ end loop;
+
+ List.Ref.Source_Line :=
+ To_Unbounded_String (Line (Pos .. Last));
+
+ -- Find the next element in the list
+
+ List := List.Next;
+ end loop;
+
+ end loop;
+
+ Ada.Text_IO.Close (File);
+
+ -- If the Current_File was not found, just skip it
+
+ exception
+ when Ada.IO_Exceptions.Name_Error =>
+ null;
+ end;
+
+ -- If the line or the file were not found
+
+ while List /= null
+ and then List.Ref.File = Current_File
+ loop
+ List := List.Next;
+ end loop;
+
+ end loop;
+
+ -- Clear the list
+
+ while Save_List /= null loop
+ List := Save_List;
+ Save_List := Save_List.Next;
+ Free (List);
+ end loop;
+ end Grep_List;
+
+ ---------------------
+ -- Insert_In_Order --
+ ---------------------
+
+ procedure Insert_In_Order (Ref : Reference) is
+ Iter : Simple_Ref_Access := List;
+ Prev : Simple_Ref_Access := null;
+
+ begin
+ while Iter /= null loop
+
+ -- If we have found the file, sort by lines
+
+ if Iter.Ref.File = Ref.File then
+
+ while Iter /= null
+ and then Iter.Ref.File = Ref.File
+ loop
+ if Iter.Ref.Line > Ref.Line then
+
+ if Iter = List then
+ List := new Simple_Ref'(Ref, List);
+ else
+ Prev.Next := new Simple_Ref'(Ref, Iter);
+ end if;
+ return;
+ end if;
+
+ Prev := Iter;
+ Iter := Iter.Next;
+ end loop;
+
+ if Iter = List then
+ List := new Simple_Ref'(Ref, List);
+ else
+ Prev.Next := new Simple_Ref'(Ref, Iter);
+ end if;
+ return;
+ end if;
+
+ Prev := Iter;
+ Iter := Iter.Next;
+ end loop;
+
+ -- The file was not already in the list, insert it
+
+ List := new Simple_Ref'(Ref, List);
+ end Insert_In_Order;
+
+ ---------------------
+ -- Insert_List_Ref --
+ ---------------------
+
+ procedure Insert_List_Ref (First_Ref : Reference) is
+ Ref : Reference := First_Ref;
+
+ begin
+ while Ref /= Empty_Reference loop
+ Insert_In_Order (Ref);
+ Ref := Next (Ref);
+ end loop;
+ end Insert_List_Ref;
+
+ -- Start of processing for Grep_Source_Files
+
+ begin
+ while Decl /= Empty_Declaration loop
+ Insert_In_Order (Decl.Decl'Access);
+ Insert_List_Ref (First_Body (Decl));
+ Insert_List_Ref (First_Reference (Decl));
+ Insert_List_Ref (First_Modif (Decl));
+ Decl := Next (Decl);
+ end loop;
+
+ Grep_List;
+ end Grep_Source_Files;
+
+ -----------------------
+ -- Longest_File_Name --
+ -----------------------
+
+ function Longest_File_Name return Natural is
+ begin
+ return Files.Longest_Name;
+ end Longest_File_Name;
+
+ -----------
+ -- Match --
+ -----------
+
+ function Match
+ (File : File_Reference;
+ Line : Natural;
+ Column : Natural)
+ return Boolean
+ is
+ Ref : Ref_In_File_Ptr := File.Lines;
+
+ begin
+ while Ref /= null loop
+ if (Ref.Line = 0 or else Ref.Line = Line)
+ and then (Ref.Column = 0 or else Ref.Column = Column)
+ then
+ return True;
+ end if;
+
+ Ref := Ref.Next;
+ end loop;
+
+ return False;
+ end Match;
+
+ -----------
+ -- Match --
+ -----------
+
+ function Match (Decl : Declaration_Reference) return Boolean is
+ begin
+ return Decl.Match;
+ end Match;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Decl : Declaration_Reference) return Declaration_Reference is
+ begin
+ return Decl.Next;
+ end Next;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Ref : Reference) return Reference is
+ begin
+ return Ref.Next;
+ end Next;
+
+ ------------------
+ -- Next_Obj_Dir --
+ ------------------
+
+ function Next_Obj_Dir return String is
+ First : Integer := Directories.Obj_Dir_Index;
+ Last : Integer := Directories.Obj_Dir_Index;
+
+ begin
+ if Last > Directories.Obj_Dir_Length then
+ return String'(1 .. 0 => ' ');
+ end if;
+
+ while Directories.Obj_Dir (Last) /= ' ' loop
+ Last := Last + 1;
+ end loop;
+
+ Directories.Obj_Dir_Index := Last + 1;
+ Directories.Last_Obj_Dir_Start := First;
+ return Directories.Obj_Dir (First .. Last - 1);
+ end Next_Obj_Dir;
+
+ ------------------
+ -- Next_Src_Dir --
+ ------------------
+
+ function Next_Src_Dir return String is
+ First : Integer := Directories.Src_Dir_Index;
+ Last : Integer := Directories.Src_Dir_Index;
+
+ begin
+ if Last > Directories.Src_Dir_Length then
+ return String'(1 .. 0 => ' ');
+ end if;
+
+ while Directories.Src_Dir (Last) /= ' ' loop
+ Last := Last + 1;
+ end loop;
+
+ Directories.Src_Dir_Index := Last + 1;
+ return Directories.Src_Dir (First .. Last - 1);
+ end Next_Src_Dir;
+
+ -------------------------
+ -- Next_Unvisited_File --
+ -------------------------
+
+ function Next_Unvisited_File return File_Reference is
+ The_Files : File_Reference := Files.Table;
+
+ begin
+ while The_Files /= null loop
+ if not The_Files.Visited then
+ The_Files.Visited := True;
+ return The_Files;
+ end if;
+
+ The_Files := The_Files.Next;
+ end loop;
+
+ return Empty_File;
+ end Next_Unvisited_File;
+
+ ------------------
+ -- Parse_Gnatls --
+ ------------------
+
+ procedure Parse_Gnatls
+ (Gnatls_Src_Cache : out Ada.Strings.Unbounded.Unbounded_String;
+ Gnatls_Obj_Cache : out Ada.Strings.Unbounded.Unbounded_String)
+ is
+ begin
+ Osint.Add_Default_Search_Dirs;
+
+ for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
+ if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
+ Ada.Strings.Unbounded.Append (Gnatls_Src_Cache, "./" & ' ');
+ else
+ Ada.Strings.Unbounded.Append
+ (Gnatls_Src_Cache, Osint.Dir_In_Src_Search_Path (J).all & ' ');
+ end if;
+ end loop;
+
+ for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
+ if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
+ Ada.Strings.Unbounded.Append (Gnatls_Obj_Cache, "./" & ' ');
+ else
+ Ada.Strings.Unbounded.Append
+ (Gnatls_Obj_Cache, Osint.Dir_In_Obj_Search_Path (J).all & ' ');
+ end if;
+ end loop;
+ end Parse_Gnatls;
+
+ -------------------
+ -- Reset_Obj_Dir --
+ -------------------
+
+ procedure Reset_Obj_Dir is
+ begin
+ Directories.Obj_Dir_Index := 1;
+ end Reset_Obj_Dir;
+
+ -------------------
+ -- Reset_Src_Dir --
+ -------------------
+
+ procedure Reset_Src_Dir is
+ begin
+ Directories.Src_Dir_Index := 1;
+ end Reset_Src_Dir;
+
+ -----------------------
+ -- Set_Default_Match --
+ -----------------------
+
+ procedure Set_Default_Match (Value : Boolean) is
+ begin
+ Default_Match := Value;
+ end Set_Default_Match;
+
+ -------------------
+ -- Set_Directory --
+ -------------------
+
+ procedure Set_Directory
+ (File : in File_Reference;
+ Dir : in String)
+ is
+ begin
+ File.Dir := new String'(Dir);
+ end Set_Directory;
+
+ -------------------
+ -- Set_Unvisited --
+ -------------------
+
+ procedure Set_Unvisited (File_Ref : in File_Reference) is
+ The_Files : File_Reference := Files.Table;
+
+ begin
+ while The_Files /= null loop
+ if The_Files = File_Ref then
+ The_Files.Visited := False;
+ return;
+ end if;
+
+ The_Files := The_Files.Next;
+ end loop;
+ end Set_Unvisited;
+
+end Xr_Tabls;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- X R E F _ L I B --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.55 $
+-- --
+-- Copyright (C) 1998-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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Fixed; use Ada.Strings.Fixed;
+with GNAT.Command_Line; use GNAT.Command_Line;
+with GNAT.IO_Aux; use GNAT.IO_Aux;
+with Osint;
+with Output; use Output;
+with Types; use Types;
+with Unchecked_Deallocation;
+
+package body Xref_Lib is
+
+ Type_Position : constant := 50;
+ -- Column for label identifying type of entity
+
+ ---------------------
+ -- Local Variables --
+ ---------------------
+
+ D : constant Character := 'D';
+ X : constant Character := 'X';
+ W : constant Character := 'W';
+ Dot : constant Character := '.';
+
+ Pipe : constant Character := '|';
+ -- First character on xref lines in the .ali file
+
+ EOF : constant Character := ASCII.SUB;
+ -- Special character to signal end of file. Not required in input file,
+ -- but should be properly treated if present. See also Read_File.
+
+ No_Xref_Information : exception;
+ -- Exception raised when there is no cross-referencing information in
+ -- the .ali files
+
+ subtype File_Offset is Natural;
+
+ function End_Of_Line_Index (File : ALI_File) return Integer;
+ -- Returns the index of the last character of the current_line
+
+ procedure Read_File
+ (FD : File_Descriptor;
+ Contents : out String_Access;
+ Success : out Boolean);
+ -- Reads file associated with FS into the newly allocated
+ -- string Contents. An EOF character will be added to the
+ -- returned Contents to simplify parsing.
+ -- [VMS] Success is true iff the number of bytes read is less than or
+ -- equal to the file size.
+ -- [Other] Success is true iff the number of bytes read is equal to
+ -- the file size.
+
+ procedure Parse_EOL (Source : access String; Ptr : in out Positive);
+ -- On return Source (Ptr) is the first character of the next line
+ -- or EOF. Source.all must be terminated by EOF.
+
+ procedure Parse_Identifier_Info
+ (Pattern : Search_Pattern;
+ File : in out ALI_File;
+ Local_Symbols : Boolean;
+ Der_Info : Boolean := False;
+ Type_Tree : Boolean := False;
+ Wide_Search : Boolean := True);
+ -- Output the file and the line where the identifier was referenced,
+ -- If Local_Symbols is False then only the publicly visible symbols
+ -- will be processed
+
+ procedure Parse_Token
+ (Source : access String;
+ Ptr : in out Positive;
+ Token_Ptr : out Positive);
+ -- Skips any separators and stores the start of the token in Token_Ptr.
+ -- Then stores the position of the next separator in Ptr.
+ -- On return Source (Token_Ptr .. Ptr - 1) is the token.
+ -- Separators are space and ASCII.HT.
+ -- Parse_Token will never skip to the next line.
+
+ procedure Parse_Number
+ (Source : access String;
+ Ptr : in out Positive;
+ Number : out Natural);
+ -- Skips any separators and parses Source upto the first character that
+ -- is not a decimal digit. Returns value of parsed digits or 0 if none.
+
+ procedure Parse_X_Filename (File : in out ALI_File);
+ -- Reads and processes "X..." lines in the ALI file
+ -- and updates the File.X_File information.
+
+ ----------------
+ -- Add_Entity --
+ ----------------
+
+ procedure Add_Entity
+ (Pattern : in out Search_Pattern;
+ Entity : String;
+ Glob : Boolean := False)
+ is
+ File_Start : Natural;
+ Line_Start : Natural;
+ Col_Start : Natural;
+ Line_Num : Natural := 0;
+ Col_Num : Natural := 0;
+ File_Ref : File_Reference := Empty_File;
+ File_Existed : Boolean;
+ Has_Pattern : Boolean := False;
+
+ begin
+ -- Find the end of the first item in Entity (pattern or file?)
+ -- If there is no ':', we only have a pattern
+
+ File_Start := Index (Entity, ":");
+ if File_Start = 0 then
+
+ -- If the regular expression is invalid, just consider it as a string
+
+ begin
+ Pattern.Entity := Compile (Entity, Glob, False);
+ Pattern.Initialized := True;
+
+ exception
+ when Error_In_Regexp =>
+
+ -- The basic idea is to insert a \ before every character
+
+ declare
+ Tmp_Regexp : String (1 .. 2 * Entity'Length);
+ Index : Positive := 1;
+
+ begin
+ for J in Entity'Range loop
+ Tmp_Regexp (Index) := '\';
+ Tmp_Regexp (Index + 1) := Entity (J);
+ Index := Index + 2;
+ end loop;
+
+ Pattern.Entity := Compile (Tmp_Regexp, True, False);
+ Pattern.Initialized := True;
+ end;
+ end;
+
+ Set_Default_Match (True);
+ return;
+ end if;
+
+ -- If there is a dot in the pattern, then it is a file name
+
+ if (Glob and then
+ Index (Entity (Entity'First .. File_Start - 1), ".") /= 0)
+ or else
+ (not Glob
+ and then Index (Entity (Entity'First .. File_Start - 1),
+ "\.") /= 0)
+ then
+ Pattern.Entity := Compile (".*", False);
+ Pattern.Initialized := True;
+ File_Start := Entity'First;
+
+ else
+ -- If the regular expression is invalid,
+ -- just consider it as a string
+
+ begin
+ Pattern.Entity :=
+ Compile (Entity (Entity'First .. File_Start - 1), Glob, False);
+ Pattern.Initialized := True;
+
+ exception
+ when Error_In_Regexp =>
+
+ -- The basic idea is to insert a \ before every character
+
+ declare
+ Tmp_Regexp : String (1 .. 2 * (File_Start - Entity'First));
+ Index : Positive := 1;
+
+ begin
+ for J in Entity'First .. File_Start - 1 loop
+ Tmp_Regexp (Index) := '\';
+ Tmp_Regexp (Index + 1) := Entity (J);
+ Index := Index + 2;
+ end loop;
+
+ Pattern.Entity := Compile (Tmp_Regexp, True, False);
+ Pattern.Initialized := True;
+ end;
+ end;
+
+ File_Start := File_Start + 1;
+ Has_Pattern := True;
+ end if;
+
+ -- Parse the file name
+
+ Line_Start := Index (Entity (File_Start .. Entity'Last), ":");
+
+ -- Check if it was a disk:\directory item (for NT and OS/2)
+
+ if File_Start = Line_Start - 1
+ and then Line_Start < Entity'Last
+ and then Entity (Line_Start + 1) = '\'
+ then
+ Line_Start := Index (Entity (Line_Start + 1 .. Entity'Last), ":");
+ end if;
+
+ if Line_Start = 0 then
+ Line_Start := Entity'Length + 1;
+
+ elsif Line_Start /= Entity'Last then
+ Col_Start := Index (Entity (Line_Start + 1 .. Entity'Last), ":");
+
+ if Col_Start = 0 then
+ Col_Start := Entity'Last + 1;
+ end if;
+
+ if Col_Start > Line_Start + 1 then
+ begin
+ Line_Num := Natural'Value
+ (Entity (Line_Start + 1 .. Col_Start - 1));
+
+ exception
+ when Constraint_Error =>
+ raise Invalid_Argument;
+ end;
+ end if;
+
+ if Col_Start < Entity'Last then
+ begin
+ Col_Num := Natural'Value (Entity
+ (Col_Start + 1 .. Entity'Last));
+
+ exception
+ when Constraint_Error => raise Invalid_Argument;
+ end;
+ end if;
+ end if;
+
+ Add_File (Entity (File_Start .. Line_Start - 1),
+ File_Existed,
+ File_Ref,
+ Visited => True);
+ Add_Line (File_Ref, Line_Num, Col_Num);
+ Add_File
+ (ALI_File_Name (Entity (File_Start .. Line_Start - 1)),
+ File_Existed, File_Ref,
+ Visited => False,
+ Emit_Warning => True);
+ end Add_Entity;
+
+ --------------
+ -- Add_File --
+ --------------
+
+ procedure Add_File (File : String) is
+ File_Ref : File_Reference := Empty_File;
+ File_Existed : Boolean;
+ Iterator : Expansion_Iterator;
+
+ procedure Add_File_Internal (File : String);
+ -- Do the actual addition of the file
+
+ -----------------------
+ -- Add_File_Internal --
+ -----------------------
+
+ procedure Add_File_Internal (File : String) is
+ begin
+ -- Case where we have an ALI file, accept it even though this is
+ -- not official usage, since the intention is obvious
+
+ if Tail (File, 4) = ".ali" then
+ Add_File
+ (File,
+ File_Existed,
+ File_Ref,
+ Visited => False,
+ Emit_Warning => True);
+
+ -- Normal non-ali file case
+
+ else
+ Add_File
+ (File,
+ File_Existed,
+ File_Ref,
+ Visited => True);
+
+ Add_File
+ (ALI_File_Name (File),
+ File_Existed,
+ File_Ref,
+ Visited => False,
+ Emit_Warning => True);
+ end if;
+ end Add_File_Internal;
+
+ -- Start of processing for Add_File
+
+ begin
+ -- Check if we need to do the expansion
+
+ if Ada.Strings.Fixed.Index (File, "*") /= 0
+ or else Ada.Strings.Fixed.Index (File, "?") /= 0
+ then
+ Start_Expansion (Iterator, File);
+
+ loop
+ declare
+ S : constant String := Expansion (Iterator);
+
+ begin
+ exit when S'Length = 0;
+ Add_File_Internal (S);
+ end;
+ end loop;
+
+ else
+ Add_File_Internal (File);
+ end if;
+ end Add_File;
+
+ -----------------------
+ -- Current_Xref_File --
+ -----------------------
+
+ function Current_Xref_File (File : ALI_File) return File_Reference is
+ begin
+ return File.X_File;
+ end Current_Xref_File;
+
+ --------------------------
+ -- Default_Project_File --
+ --------------------------
+
+ function Default_Project_File
+ (Dir_Name : String)
+ return String
+ is
+ My_Dir : Dir_Type;
+ Dir_Ent : File_Name_String;
+ Last : Natural;
+
+ begin
+ Open (My_Dir, Dir_Name);
+
+ loop
+ Read (My_Dir, Dir_Ent, Last);
+ exit when Last = 0;
+
+ if Tail (Dir_Ent (1 .. Last), 4) = ".adp" then
+
+ -- The first project file found is the good one.
+
+ Close (My_Dir);
+ return Dir_Ent (1 .. Last);
+ end if;
+ end loop;
+
+ Close (My_Dir);
+ return String'(1 .. 0 => ' ');
+
+ exception
+ when Directory_Error => return String'(1 .. 0 => ' ');
+ end Default_Project_File;
+
+ -----------------------
+ -- End_Of_Line_Index --
+ -----------------------
+
+ function End_Of_Line_Index (File : ALI_File) return Integer is
+ Index : Integer := File.Current_Line;
+ begin
+ while Index <= File.Buffer'Last
+ and then File.Buffer (Index) /= ASCII.LF
+ loop
+ Index := Index + 1;
+ end loop;
+
+ return Index;
+ end End_Of_Line_Index;
+
+ ---------------
+ -- File_Name --
+ ---------------
+
+ function File_Name
+ (File : ALI_File;
+ Num : Positive)
+ return File_Reference
+ is
+ begin
+ return File.Dep.Table (Num);
+ end File_Name;
+
+ --------------------
+ -- Find_ALI_Files --
+ --------------------
+
+ procedure Find_ALI_Files is
+ My_Dir : Rec_DIR;
+ Dir_Ent : File_Name_String;
+ Last : Natural;
+ File_Existed : Boolean;
+ File_Ref : File_Reference;
+
+ function Open_Next_Dir return Boolean;
+ -- Tries to open the next object directory, and return False if
+ -- the directory cannot be opened.
+
+ -------------------
+ -- Open_Next_Dir --
+ -------------------
+
+ function Open_Next_Dir return Boolean is
+ begin
+ -- Until we are able to open a new directory
+
+ loop
+ declare
+ Obj_Dir : constant String := Next_Obj_Dir;
+
+ begin
+ -- If there was no more Obj_Dir line
+
+ if Obj_Dir'Length = 0 then
+ return False;
+ end if;
+
+ Open (My_Dir.Dir, Obj_Dir);
+ exit;
+
+ exception
+ -- Could not open the directory
+
+ when Directory_Error => null;
+ end;
+ end loop;
+
+ return True;
+ end Open_Next_Dir;
+
+ -- Start of processing for Find_ALI_Files
+
+ begin
+ if Open_Next_Dir then
+ loop
+ Read (My_Dir.Dir, Dir_Ent, Last);
+
+ if Last = 0 then
+ Close (My_Dir.Dir);
+
+ if not Open_Next_Dir then
+ return;
+ end if;
+
+ elsif Last > 4 and then Dir_Ent (Last - 3 .. Last) = ".ali" then
+ Add_File (Dir_Ent (1 .. Last), File_Existed, File_Ref,
+ Visited => False);
+ Set_Directory (File_Ref, Current_Obj_Dir);
+ end if;
+ end loop;
+ end if;
+ end Find_ALI_Files;
+
+ -------------------
+ -- Get_Full_Type --
+ -------------------
+
+ function Get_Full_Type (Abbrev : Character) return String is
+ begin
+ case Abbrev is
+ when 'A' => return "array type";
+ when 'B' => return "boolean type";
+ when 'C' => return "class-wide type";
+ when 'D' => return "decimal type";
+ when 'E' => return "enumeration type";
+ when 'F' => return "float type";
+ when 'I' => return "integer type";
+ when 'M' => return "modular type";
+ when 'O' => return "fixed type";
+ when 'P' => return "access type";
+ when 'R' => return "record type";
+ when 'S' => return "string type";
+ when 'T' => return "task type";
+ when 'W' => return "protected type";
+
+ when 'a' => return "array type";
+ when 'b' => return "boolean object";
+ when 'c' => return "class-wide object";
+ when 'd' => return "decimal object";
+ when 'e' => return "enumeration object";
+ when 'f' => return "float object";
+ when 'i' => return "integer object";
+ when 'm' => return "modular object";
+ when 'o' => return "fixed object";
+ when 'p' => return "access object";
+ when 'r' => return "record object";
+ when 's' => return "string object";
+ when 't' => return "task object";
+ when 'w' => return "protected object";
+
+ when 'K' => return "package";
+ when 'k' => return "generic package";
+ when 'L' => return "statement label";
+ when 'l' => return "loop label";
+ when 'N' => return "named number";
+ when 'n' => return "enumeration literal";
+ when 'q' => return "block label";
+ when 'U' => return "procedure";
+ when 'u' => return "generic procedure";
+ when 'V' => return "function";
+ when 'v' => return "generic function";
+ when 'X' => return "exception";
+ when 'Y' => return "entry";
+
+ -- The above should be the only possibilities, but for a
+ -- tool like this we don't want to bomb if we find something
+ -- else, so just return ??? when we have an unknown Abbrev value
+
+ when others =>
+ return "???";
+ end case;
+ end Get_Full_Type;
+
+ -----------
+ -- Match --
+ -----------
+
+ function Match
+ (Pattern : Search_Pattern;
+ Symbol : String)
+ return Boolean
+ is
+ begin
+ -- Get the entity name
+
+ return Match (Symbol, Pattern.Entity);
+ end Match;
+
+ ----------
+ -- Open --
+ ----------
+
+ procedure Open
+ (Name : String;
+ File : out ALI_File;
+ Dependencies : Boolean := False)
+ is
+ Name_0 : constant String := Name & ASCII.NUL;
+ Num_Dependencies : Natural := 0;
+ File_Existed : Boolean;
+ File_Ref : File_Reference;
+ FD : File_Descriptor;
+ Success : Boolean := False;
+ Ali : String_Access renames File.Buffer;
+ Token : Positive;
+ Ptr : Positive;
+ File_Start : Positive;
+ File_End : Positive;
+ Gnatchop_Offset : Integer;
+ Gnatchop_Name : Positive;
+
+ begin
+ if File.Buffer /= null then
+ Free (File.Buffer);
+ end if;
+
+ Init (File.Dep);
+
+ FD := Open_Read (Name_0'Address, Binary);
+
+ if FD = Invalid_FD then
+ raise No_Xref_Information;
+ end if;
+
+ Read_File (FD, Ali, Success);
+ Close (FD);
+
+ Ptr := Ali'First;
+
+ -- Read all the lines possibly processing with-clauses and dependency
+ -- information and exit on finding the first Xref line.
+ -- A fall-through of the loop means that there is no xref information
+ -- which is an error condition.
+
+ while Ali (Ptr) /= EOF loop
+
+ if Ali (Ptr) = D then
+ -- Found dependency information. Format looks like:
+ -- D source-name time-stamp checksum [subunit-name] \
+ -- [line:file-name]
+
+ -- Skip the D and parse the filename
+
+ Ptr := Ptr + 1;
+ Parse_Token (Ali, Ptr, Token);
+ File_Start := Token;
+ File_End := Ptr - 1;
+
+ Num_Dependencies := Num_Dependencies + 1;
+ Set_Last (File.Dep, Num_Dependencies);
+
+ Parse_Token (Ali, Ptr, Token); -- Skip time-stamp
+ Parse_Token (Ali, Ptr, Token); -- Skip checksum
+ Parse_Token (Ali, Ptr, Token); -- Read next entity on the line
+
+ if not (Ali (Token) in '0' .. '9') then
+ Parse_Token (Ali, Ptr, Token); -- Was a subunit name
+ end if;
+
+ -- Did we have a gnatchop-ed file with a pragma Source_Reference ?
+ Gnatchop_Offset := 0;
+
+ if Ali (Token) in '0' .. '9' then
+ Gnatchop_Name := Token;
+ while Ali (Gnatchop_Name) /= ':' loop
+ Gnatchop_Name := Gnatchop_Name + 1;
+ end loop;
+ Gnatchop_Offset :=
+ 2 - Natural'Value (Ali (Token .. Gnatchop_Name - 1));
+ Token := Gnatchop_Name + 1;
+ end if;
+
+ Add_File
+ (Ali (File_Start .. File_End),
+ File_Existed,
+ File.Dep.Table (Num_Dependencies),
+ Gnatchop_File => Ali (Token .. Ptr - 1),
+ Gnatchop_Offset => Gnatchop_Offset);
+
+ elsif Dependencies and then Ali (Ptr) = W then
+ -- Found with-clause information. Format looks like:
+ -- "W debug%s debug.adb debug.ali"
+
+ -- Skip the W and parse the .ali filename (3rd token)
+
+ Parse_Token (Ali, Ptr, Token);
+ Parse_Token (Ali, Ptr, Token);
+ Parse_Token (Ali, Ptr, Token);
+
+ Add_File
+ (Ali (Token .. Ptr - 1),
+ File_Existed, File_Ref,
+ Visited => False);
+
+ elsif Ali (Ptr) = X then
+ -- Found a cross-referencing line - stop processing
+
+ File.Current_Line := Ptr;
+ File.Xref_Line := Ptr;
+ return;
+ end if;
+
+ Parse_EOL (Ali, Ptr);
+ end loop;
+
+ raise No_Xref_Information;
+ end Open;
+
+ ---------------
+ -- Parse_EOL --
+ ---------------
+
+ procedure Parse_EOL (Source : access String; Ptr : in out Positive) is
+ begin
+ -- Skip to end of line
+
+ while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
+ and then Source (Ptr) /= EOF
+ loop
+ Ptr := Ptr + 1;
+ end loop;
+
+ if Source (Ptr) /= EOF then
+ Ptr := Ptr + 1; -- skip CR or LF
+ end if;
+
+ -- Skip past CR/LF or LF/CR combination
+
+ if (Source (Ptr) = ASCII.CR or else Source (Ptr) = ASCII.LF)
+ and then Source (Ptr) /= Source (Ptr - 1)
+ then
+ Ptr := Ptr + 1;
+ end if;
+ end Parse_EOL;
+
+ ---------------------------
+ -- Parse_Identifier_Info --
+ ---------------------------
+
+ procedure Parse_Identifier_Info
+ (Pattern : Search_Pattern;
+ File : in out ALI_File;
+ Local_Symbols : Boolean;
+ Der_Info : Boolean := False;
+ Type_Tree : Boolean := False;
+ Wide_Search : Boolean := True)
+ is
+ Ptr : Positive renames File.Current_Line;
+ Ali : String_Access renames File.Buffer;
+
+ E_Line : Natural; -- Line number of current entity
+ E_Col : Natural; -- Column number of current entity
+ E_Type : Character; -- Type of current entity
+ E_Name : Positive; -- Pointer to begin of entity name
+ E_Global : Boolean; -- True iff entity is global
+
+ R_Line : Natural; -- Line number of current reference
+ R_Col : Natural; -- Column number of current reference
+ R_Type : Character; -- Type of current reference
+
+ Decl_Ref : Declaration_Reference;
+ File_Ref : File_Reference := Current_Xref_File (File);
+
+ function Get_Symbol_Name (Eun, Line, Col : Natural) return String;
+ -- Returns the symbol name for the entity defined at the specified
+ -- line and column in the dependent unit number Eun. For this we need
+ -- to parse the ali file again because the parent entity is not in
+ -- the declaration table if it did not match the search pattern.
+
+ ---------------------
+ -- Get_Symbol_Name --
+ ---------------------
+
+ function Get_Symbol_Name (Eun, Line, Col : Natural) return String is
+ Ptr : Positive := 1;
+ E_Eun : Positive; -- Unit number of current entity
+ E_Line : Natural; -- Line number of current entity
+ E_Col : Natural; -- Column number of current entity
+ E_Name : Positive; -- Pointer to begin of entity name
+ E_Type : Character; -- Type of current entity
+
+ procedure Skip_Line;
+ -- skip current line and continuation line
+
+ procedure Skip_Line is
+ begin
+ loop
+ Parse_EOL (Ali, Ptr);
+ exit when Ali (Ptr) /= '.';
+ end loop;
+ end Skip_Line;
+
+ -- Start of processing for Get_Symbol_Name
+
+ begin
+ -- Look for the X lines corresponding to unit Eun
+
+ loop
+ if Ali (Ptr) = 'X' then
+ Ptr := Ptr + 1;
+ Parse_Number (Ali, Ptr, E_Eun);
+ exit when E_Eun = Eun;
+ end if;
+
+ Skip_Line;
+ end loop;
+
+ -- Here we are in the right Ali section, we now look for the entity
+ -- declared at position (Line, Col).
+
+ loop
+ Parse_Number (Ali, Ptr, E_Line);
+ E_Type := Ali (Ptr);
+ Ptr := Ptr + 1;
+ Parse_Number (Ali, Ptr, E_Col);
+ Ptr := Ptr + 1;
+
+ if Line = E_Line and then Col = E_Col then
+ Parse_Token (Ali, Ptr, E_Name);
+ return Ali (E_Name .. Ptr - 1);
+ end if;
+
+ Skip_Line;
+ end loop;
+
+ -- We were not able to find the symbol, this should not happend but
+ -- since we don't want to stop here we return a string of three
+ -- question marks as the symbol name.
+
+ return "???";
+ end Get_Symbol_Name;
+
+ -- Start of processing for Parse_Identifier_Info
+
+ begin
+ -- The identifier info looks like:
+ -- "38U9*Debug 12|36r6 36r19"
+
+ -- Extract the line, column and entity name information
+
+ Parse_Number (Ali, Ptr, E_Line);
+
+ if Ali (Ptr) > ' ' then
+ E_Type := Ali (Ptr);
+ Ptr := Ptr + 1;
+ end if;
+
+ Parse_Number (Ali, Ptr, E_Col);
+
+ E_Global := False;
+ if Ali (Ptr) >= ' ' then
+ E_Global := (Ali (Ptr) = '*');
+ Ptr := Ptr + 1;
+ end if;
+
+ Parse_Token (Ali, Ptr, E_Name);
+
+ -- Exit if the symbol does not match
+ -- or if we have a local symbol and we do not want it
+
+ if (not Local_Symbols and not E_Global)
+ or else (Pattern.Initialized
+ and then not Match (Pattern, Ali (E_Name .. Ptr - 1)))
+ or else (E_Name >= Ptr)
+ then
+ -- Skip rest of this line and all continuation lines
+
+ loop
+ Parse_EOL (Ali, Ptr);
+ exit when Ali (Ptr) /= '.';
+ end loop;
+ return;
+ end if;
+
+ -- Insert the declaration in the table
+
+ Decl_Ref := Add_Declaration
+ (File.X_File, Ali (E_Name .. Ptr - 1), E_Line, E_Col, E_Type);
+
+ if Ali (Ptr) = '<' then
+
+ -- Here we have a type derivation information. The format is
+ -- <3|12I45> which means that the current entity is derived from the
+ -- type defined in unit number 3, line 12 column 45. The pipe and
+ -- unit number is optional. It is specified only if the parent type
+ -- is not defined in the current unit.
+
+ Ptr := Ptr + 1;
+
+ Parse_Derived_Info : declare
+ P_Line : Natural; -- parent entity line
+ P_Column : Natural; -- parent entity column
+ P_Type : Character; -- parent entity type
+ P_Eun : Positive; -- parent entity file number
+
+ begin
+ Parse_Number (Ali, Ptr, P_Line);
+
+ -- If we have a pipe then the first number was the unit number
+
+ if Ali (Ptr) = '|' then
+ P_Eun := P_Line;
+ Ptr := Ptr + 1;
+
+ -- Now we have the line number
+
+ Parse_Number (Ali, Ptr, P_Line);
+
+ else
+ -- We don't have a unit number specified, so we set P_Eun to
+ -- the current unit.
+
+ for K in Dependencies_Tables.First .. Last (File.Dep) loop
+ P_Eun := K;
+ exit when File.Dep.Table (K) = File_Ref;
+ end loop;
+ end if;
+
+ -- Then parse the type and column number
+
+ P_Type := Ali (Ptr);
+ Ptr := Ptr + 1;
+ Parse_Number (Ali, Ptr, P_Column);
+
+ -- Skip '>'
+
+ Ptr := Ptr + 1;
+
+ -- The derived info is needed only is the derived info mode is on
+ -- or if we want to output the type hierarchy
+
+ if Der_Info or else Type_Tree then
+ Add_Parent
+ (Decl_Ref,
+ Get_Symbol_Name (P_Eun, P_Line, P_Column),
+ P_Line,
+ P_Column,
+ File.Dep.Table (P_Eun));
+ end if;
+
+ if Type_Tree then
+ Search_Parent_Tree : declare
+ Pattern : Search_Pattern; -- Parent type pattern
+ File_Pos_Backup : Positive;
+
+ begin
+ Add_Entity
+ (Pattern,
+ Get_Symbol_Name (P_Eun, P_Line, P_Column)
+ & ':' & Get_Gnatchop_File (File.Dep.Table (P_Eun))
+ & ':' & Get_Line (Get_Parent (Decl_Ref))
+ & ':' & Get_Column (Get_Parent (Decl_Ref)),
+ False);
+
+ -- No default match is needed to look for the parent type
+ -- since we are using the fully qualified symbol name:
+ -- symbol:file:line:column
+
+ Set_Default_Match (False);
+
+ -- The parent type is defined in the same unit as the
+ -- derived type. So we want to revisit the unit.
+
+ File_Pos_Backup := File.Current_Line;
+
+ if File.Dep.Table (P_Eun) = File_Ref then
+
+ -- set file pointer at the start of the xref lines
+
+ File.Current_Line := File.Xref_Line;
+
+ Revisit_ALI_File : declare
+ File_Existed : Boolean;
+ File_Ref : File_Reference;
+ begin
+ Add_File
+ (ALI_File_Name (Get_File (File.Dep.Table (P_Eun))),
+ File_Existed,
+ File_Ref,
+ Visited => False);
+ Set_Unvisited (File_Ref);
+ end Revisit_ALI_File;
+ end if;
+
+ Search (Pattern,
+ Local_Symbols, False, False, Der_Info, Type_Tree);
+
+ File.Current_Line := File_Pos_Backup;
+
+ -- in this mode there is no need to parse the remaining of
+ -- the lines.
+
+ return;
+ end Search_Parent_Tree;
+ end if;
+ end Parse_Derived_Info;
+ end if;
+
+ -- To find the body, we will have to parse the file too
+
+ if Wide_Search then
+ declare
+ File_Existed : Boolean;
+ File_Ref : File_Reference;
+ File_Name : constant String :=
+ Get_Gnatchop_File (File.X_File);
+
+ begin
+ Add_File (ALI_File_Name (File_Name),
+ File_Existed, File_Ref, False);
+ end;
+ end if;
+
+ -- Parse references to this entity.
+ -- Ptr points to next reference with leading blanks
+
+ loop
+ -- Process references on current line
+
+ while Ali (Ptr) = ' ' or Ali (Ptr) = ASCII.HT loop
+
+ -- For every reference read the line, type and column,
+ -- optionally preceded by a file number and a pipe symbol.
+
+ Parse_Number (Ali, Ptr, R_Line);
+
+ if Ali (Ptr) = Pipe then
+ Ptr := Ptr + 1;
+ File_Ref := File_Name (File, R_Line);
+
+ Parse_Number (Ali, Ptr, R_Line);
+ end if;
+
+ if Ali (Ptr) > ' ' then
+ R_Type := Ali (Ptr);
+ Ptr := Ptr + 1;
+ end if;
+
+ Parse_Number (Ali, Ptr, R_Col);
+
+ -- Insert the reference or body in the table
+
+ Add_Reference (Decl_Ref, File_Ref, R_Line, R_Col, R_Type);
+
+ end loop;
+
+ Parse_EOL (Ali, Ptr);
+
+ -- Loop until new line is no continuation line
+
+ exit when Ali (Ptr) /= '.';
+ Ptr := Ptr + 1;
+ end loop;
+ end Parse_Identifier_Info;
+
+ ------------------
+ -- Parse_Number --
+ ------------------
+
+ procedure Parse_Number
+ (Source : access String;
+ Ptr : in out Positive;
+ Number : out Natural)
+ is
+ begin
+ -- Skip separators
+
+ while Source (Ptr) = ' ' or else Source (Ptr) = ASCII.HT loop
+ Ptr := Ptr + 1;
+ end loop;
+
+ Number := 0;
+ while Source (Ptr) in '0' .. '9' loop
+ Number := 10 * Number
+ + (Character'Pos (Source (Ptr)) - Character'Pos ('0'));
+ Ptr := Ptr + 1;
+ end loop;
+ end Parse_Number;
+
+ -----------------
+ -- Parse_Token --
+ -----------------
+
+ procedure Parse_Token
+ (Source : access String;
+ Ptr : in out Positive;
+ Token_Ptr : out Positive)
+ is
+ In_Quotes : Boolean := False;
+
+ begin
+ -- Skip separators
+
+ while Source (Ptr) = ' ' or else Source (Ptr) = ASCII.HT loop
+ Ptr := Ptr + 1;
+ end loop;
+
+ Token_Ptr := Ptr;
+
+ -- Find end-of-token
+
+ while (In_Quotes or else
+ not (Source (Ptr) = ' '
+ or else Source (Ptr) = ASCII.HT
+ or else Source (Ptr) = '<'))
+ and then Source (Ptr) >= ' '
+ loop
+ if Source (Ptr) = '"' then
+ In_Quotes := not In_Quotes;
+ end if;
+
+ Ptr := Ptr + 1;
+ end loop;
+ end Parse_Token;
+
+ ----------------------
+ -- Parse_X_Filename --
+ ----------------------
+
+ procedure Parse_X_Filename (File : in out ALI_File) is
+ Ali : String_Access renames File.Buffer;
+ Ptr : Positive renames File.Current_Line;
+ File_Nr : Natural;
+
+ begin
+ while Ali (Ptr) = X loop
+
+ -- The current line is the start of a new Xref file section,
+ -- whose format looks like:
+
+ -- " X 1 debug.ads"
+
+ -- Skip the X and read the file number for the new X_File
+
+ Ptr := Ptr + 1;
+ Parse_Number (Ali, Ptr, File_Nr);
+
+ if File_Nr > 0 then
+ File.X_File := File.Dep.Table (File_Nr);
+ end if;
+
+ Parse_EOL (Ali, Ptr);
+ end loop;
+
+ end Parse_X_Filename;
+
+ --------------------
+ -- Print_Gnatfind --
+ --------------------
+
+ procedure Print_Gnatfind
+ (References : Boolean;
+ Full_Path_Name : Boolean)
+ is
+ Decl : Declaration_Reference := First_Declaration;
+ Ref1 : Reference;
+ Ref2 : Reference;
+
+ procedure Print_Ref
+ (Ref : Reference;
+ Msg : String := " ");
+ -- Print a reference, according to the extended tag of the output
+
+ ---------------
+ -- Print_Ref --
+ ---------------
+
+ procedure Print_Ref
+ (Ref : Reference;
+ Msg : String := " ")
+ is
+ Buffer : constant String :=
+ Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Ref, Full_Path_Name)).all
+ & ":" & Get_Line (Ref)
+ & ":" & Get_Column (Ref)
+ & ": ";
+ Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length;
+
+ begin
+ Num_Blanks := Integer'Max (0, Num_Blanks);
+ Write_Line
+ (Buffer
+ & String'(1 .. Num_Blanks => ' ')
+ & Msg & " " & Get_Symbol (Decl));
+ if Get_Source_Line (Ref)'Length /= 0 then
+ Write_Line (" " & Get_Source_Line (Ref));
+ end if;
+ end Print_Ref;
+
+ -- Start of processing for Print_Gnatfind
+
+ begin
+ while Decl /= Empty_Declaration loop
+ if Match (Decl) then
+
+ -- Output the declaration
+
+ declare
+ Parent : constant Declaration_Reference := Get_Parent (Decl);
+ Buffer : constant String :=
+ Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Decl, Full_Path_Name)).all
+ & ":" & Get_Line (Decl)
+ & ":" & Get_Column (Decl)
+ & ": ";
+ Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length;
+
+ begin
+ Num_Blanks := Integer'Max (0, Num_Blanks);
+ Write_Line
+ (Buffer & String'(1 .. Num_Blanks => ' ')
+ & "(spec) " & Get_Symbol (Decl));
+
+ if Parent /= Empty_Declaration then
+ Write_Line
+ (Buffer & String'(1 .. Num_Blanks => ' ')
+ & " derived from " & Get_Symbol (Parent)
+ & " ("
+ & Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent)).all
+ & ':' & Get_Line (Parent)
+ & ':' & Get_Column (Parent) & ')');
+ end if;
+ end;
+
+ if Get_Source_Line (Decl)'Length /= 0 then
+ Write_Line (" " & Get_Source_Line (Decl));
+ end if;
+
+ -- Output the body (sorted)
+
+ Ref1 := First_Body (Decl);
+ while Ref1 /= Empty_Reference loop
+ Print_Ref (Ref1, "(body)");
+ Ref1 := Next (Ref1);
+ end loop;
+
+ if References then
+ Ref1 := First_Modif (Decl);
+ Ref2 := First_Reference (Decl);
+ while Ref1 /= Empty_Reference
+ or else Ref2 /= Empty_Reference
+ loop
+ if Compare (Ref1, Ref2) = LessThan then
+ Print_Ref (Ref1);
+ Ref1 := Next (Ref1);
+ else
+ Print_Ref (Ref2);
+ Ref2 := Next (Ref2);
+ end if;
+ end loop;
+ end if;
+ end if;
+
+ Decl := Next (Decl);
+ end loop;
+ end Print_Gnatfind;
+
+ ------------------
+ -- Print_Unused --
+ ------------------
+
+ procedure Print_Unused (Full_Path_Name : in Boolean) is
+ Decl : Declaration_Reference := First_Declaration;
+ Ref : Reference;
+
+ begin
+ while Decl /= Empty_Declaration loop
+ if First_Modif (Decl) = Empty_Reference
+ and then First_Reference (Decl) = Empty_Reference
+ then
+ Write_Str (Get_Symbol (Decl)
+ & " "
+ & Get_Type (Decl)
+ & " "
+ & Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Decl, Full_Path_Name)).all
+ & ':'
+ & Get_Line (Decl)
+ & ':'
+ & Get_Column (Decl));
+
+ -- Print the body if any
+
+ Ref := First_Body (Decl);
+
+ if Ref /= Empty_Reference then
+ Write_Line (' '
+ & Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Ref, Full_Path_Name)).all
+ & ':' & Get_Line (Ref)
+ & ':' & Get_Column (Ref));
+ else
+ Write_Eol;
+ end if;
+ end if;
+
+ Decl := Next (Decl);
+ end loop;
+ end Print_Unused;
+
+ --------------
+ -- Print_Vi --
+ --------------
+
+ procedure Print_Vi (Full_Path_Name : in Boolean) is
+ Tab : constant Character := ASCII.HT;
+ Decl : Declaration_Reference := First_Declaration;
+ Ref : Reference;
+
+ begin
+ while Decl /= Empty_Declaration loop
+ Write_Line (Get_Symbol (Decl) & Tab
+ & Get_File (Decl, Full_Path_Name) & Tab
+ & Get_Line (Decl));
+
+ -- Print the body if any
+
+ Ref := First_Body (Decl);
+
+ if Ref /= Empty_Reference then
+ Write_Line (Get_Symbol (Decl) & Tab
+ & Get_File (Ref, Full_Path_Name)
+ & Tab
+ & Get_Line (Ref));
+ end if;
+
+ -- Print the modifications
+
+ Ref := First_Modif (Decl);
+
+ while Ref /= Empty_Reference loop
+ Write_Line (Get_Symbol (Decl) & Tab
+ & Get_File (Ref, Full_Path_Name)
+ & Tab
+ & Get_Line (Ref));
+ Ref := Next (Ref);
+ end loop;
+
+ Decl := Next (Decl);
+ end loop;
+ end Print_Vi;
+
+ ----------------
+ -- Print_Xref --
+ ----------------
+
+ procedure Print_Xref (Full_Path_Name : in Boolean) is
+ Decl : Declaration_Reference := First_Declaration;
+ Ref : Reference;
+ File : File_Reference;
+
+ Margin : constant := 10;
+ -- Column where file names start
+
+ procedure New_Line80;
+ -- Go to start of new line
+
+ procedure Print80 (S : in String);
+ -- Print the text, respecting the 80 columns rule.
+
+ procedure Print_Ref (Line, Column : String);
+ -- The beginning of the output is aligned on a column multiple of 9
+
+ ----------------
+ -- New_Line80 --
+ ----------------
+
+ procedure New_Line80 is
+ begin
+ Write_Eol;
+ Write_Str (String'(1 .. Margin - 1 => ' '));
+ end New_Line80;
+
+ -------------
+ -- Print80 --
+ -------------
+
+ procedure Print80 (S : in String) is
+ Align : Natural := Margin - (Integer (Column) mod Margin);
+ begin
+ if Align = Margin then
+ Align := 0;
+ end if;
+
+ Write_Str (String'(1 .. Align => ' ') & S);
+ end Print80;
+
+ ---------------
+ -- Print_Ref --
+ ---------------
+
+ procedure Print_Ref (Line, Column : String) is
+ Line_Align : constant Integer := 4 - Line'Length;
+
+ S : constant String := String'(1 .. Line_Align => ' ')
+ & Line & ':' & Column;
+
+ Align : Natural := Margin - (Integer (Output.Column) mod Margin);
+
+ begin
+ if Align = Margin then
+ Align := 0;
+ end if;
+
+ if Integer (Output.Column) + Align + S'Length > 79 then
+ New_Line80;
+ Align := 0;
+ end if;
+
+ Write_Str (String'(1 .. Align => ' ') & S);
+ end Print_Ref;
+
+ -- Start of processing for Print_Xref
+
+ begin
+ while Decl /= Empty_Declaration loop
+ Write_Str (Get_Symbol (Decl));
+
+ while Column < Type_Position loop
+ Write_Char (' ');
+ end loop;
+
+ Write_Line (Get_Full_Type (Get_Type (Decl)));
+
+ Write_Parent_Info : declare
+ Parent : constant Declaration_Reference := Get_Parent (Decl);
+ begin
+ if Parent /= Empty_Declaration then
+ Write_Str (" Ptype: ");
+ Print80
+ (Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent)).all);
+ Print_Ref (Get_Line (Parent), Get_Column (Parent));
+ Print80 (" " & Get_Symbol (Parent));
+ Write_Eol;
+ end if;
+ end Write_Parent_Info;
+
+ Write_Str (" Decl: ");
+ Print80
+ (Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Decl, Full_Path_Name)).all & ' ');
+ Print_Ref (Get_Line (Decl), Get_Column (Decl));
+
+ -- Print the body if any
+
+ Ref := First_Body (Decl);
+
+ if Ref /= Empty_Reference then
+ Write_Eol;
+ Write_Str (" Body: ");
+ Print80
+ (Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Ref, Full_Path_Name)).all & ' ');
+ Print_Ref (Get_Line (Ref), Get_Column (Ref));
+ end if;
+
+ -- Print the modifications if any
+
+ Ref := First_Modif (Decl);
+
+ if Ref /= Empty_Reference then
+ Write_Eol;
+ Write_Str (" Modi: ");
+ end if;
+
+ File := Empty_File;
+
+ while Ref /= Empty_Reference loop
+ if Get_File_Ref (Ref) /= File then
+ if File /= Empty_File then
+ New_Line80;
+ end if;
+
+ File := Get_File_Ref (Ref);
+ Write_Str
+ (Get_Gnatchop_File (Ref, Full_Path_Name) & ' ');
+ Print_Ref (Get_Line (Ref), Get_Column (Ref));
+
+ else
+ Print_Ref (Get_Line (Ref), Get_Column (Ref));
+ end if;
+
+ Ref := Next (Ref);
+ end loop;
+
+ -- Print the references
+
+ Ref := First_Reference (Decl);
+
+ if Ref /= Empty_Reference then
+ Write_Eol;
+ Write_Str (" Ref: ");
+ end if;
+
+ File := Empty_File;
+
+ while Ref /= Empty_Reference loop
+ if Get_File_Ref (Ref) /= File then
+ if File /= Empty_File then
+ New_Line80;
+ end if;
+
+ File := Get_File_Ref (Ref);
+ Write_Str
+ (Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Ref, Full_Path_Name)).all & ' ');
+ Print_Ref (Get_Line (Ref), Get_Column (Ref));
+
+ else
+ Print_Ref (Get_Line (Ref), Get_Column (Ref));
+ end if;
+
+ Ref := Next (Ref);
+ end loop;
+
+ Write_Eol;
+ Decl := Next (Decl);
+ end loop;
+ end Print_Xref;
+
+ ---------------
+ -- Read_File --
+ ---------------
+
+ procedure Read_File
+ (FD : File_Descriptor;
+ Contents : out String_Access;
+ Success : out Boolean)
+ is
+ Length : constant File_Offset := File_Offset (File_Length (FD));
+ -- Include room for EOF char
+
+ Buffer : String (1 .. Length + 1);
+
+ This_Read : Integer;
+ Read_Ptr : File_Offset := 1;
+
+ begin
+
+ loop
+ This_Read := Read (FD,
+ A => Buffer (Read_Ptr)'Address,
+ N => Length + 1 - Read_Ptr);
+ Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
+ exit when This_Read <= 0;
+ end loop;
+
+ Buffer (Read_Ptr) := EOF;
+ Contents := new String'(Buffer (1 .. Read_Ptr));
+
+ -- Things aren't simple on VMS due to the plethora of file types
+ -- and organizations. It seems clear that there shouldn't be more
+ -- bytes read than are contained in the file though.
+
+ if Hostparm.OpenVMS then
+ Success := Read_Ptr <= Length + 1;
+ else
+ Success := Read_Ptr = Length + 1;
+ end if;
+ end Read_File;
+
+ ------------
+ -- Search --
+ ------------
+
+ procedure Search
+ (Pattern : Search_Pattern;
+ Local_Symbols : Boolean;
+ Wide_Search : Boolean;
+ Read_Only : Boolean;
+ Der_Info : Boolean;
+ Type_Tree : Boolean)
+ is
+ type String_Access is access String;
+ procedure Free is new Unchecked_Deallocation (String, String_Access);
+
+ ALIfile : ALI_File;
+ File_Ref : File_Reference;
+ Strip_Num : Natural := 0;
+ Ali_Name : String_Access;
+
+ begin
+ -- If we want all the .ali files, then find them
+
+ if Wide_Search then
+ Find_ALI_Files;
+ end if;
+
+ loop
+ -- Get the next unread ali file
+
+ File_Ref := Next_Unvisited_File;
+
+ exit when File_Ref = Empty_File;
+
+ -- Find the ALI file to use. Most of the time, it will be the unit
+ -- name, with a different extension. However, when dealing with
+ -- separates the ALI file is in fact the parent's ALI file (and this
+ -- is recursive, in case the parent itself is a separate).
+
+ Strip_Num := 0;
+ loop
+ Free (Ali_Name);
+ Ali_Name := new String'
+ (Get_File (File_Ref, With_Dir => True, Strip => Strip_Num));
+
+ -- Striped too many things...
+ if Ali_Name.all = "" then
+ if Get_Emit_Warning (File_Ref) then
+ Set_Standard_Error;
+ Write_Line
+ ("warning : file " & Get_File (File_Ref, With_Dir => True)
+ & " not found");
+ Set_Standard_Output;
+ end if;
+ Free (Ali_Name);
+ exit;
+
+ -- If not found, try the parent's ALI file (this is needed for
+ -- separate units and subprograms).
+ elsif not File_Exists (Ali_Name.all) then
+ Strip_Num := Strip_Num + 1;
+
+ -- Else we finally found it
+ else
+ exit;
+ end if;
+ end loop;
+
+ -- Now that we have a file name, parse it to find any reference to
+ -- the entity.
+
+ if Ali_Name /= null
+ and then (Read_Only or else Is_Writable_File (Ali_Name.all))
+ then
+ begin
+ Open (Ali_Name.all, ALIfile);
+ while ALIfile.Buffer (ALIfile.Current_Line) /= EOF loop
+ Parse_X_Filename (ALIfile);
+ Parse_Identifier_Info (Pattern, ALIfile, Local_Symbols,
+ Der_Info, Type_Tree, Wide_Search);
+ end loop;
+
+ exception
+ when No_Xref_Information =>
+ if Get_Emit_Warning (File_Ref) then
+ Set_Standard_Error;
+ Write_Line
+ ("warning : No cross-referencing information in "
+ & Ali_Name.all);
+ Set_Standard_Output;
+ end if;
+ end;
+ end if;
+ end loop;
+
+ Free (Ali_Name);
+ end Search;
+
+ -----------------
+ -- Search_Xref --
+ -----------------
+
+ procedure Search_Xref
+ (Local_Symbols : Boolean;
+ Read_Only : Boolean;
+ Der_Info : Boolean)
+ is
+ ALIfile : ALI_File;
+ File_Ref : File_Reference;
+ Null_Pattern : Search_Pattern;
+ begin
+ loop
+ -- Find the next unvisited file
+
+ File_Ref := Next_Unvisited_File;
+ exit when File_Ref = Empty_File;
+
+ -- Search the object directories for the .ali file
+
+ if Read_Only
+ or else Is_Writable_File (Get_File (File_Ref, With_Dir => True))
+ then
+ begin
+ Open (Get_File (File_Ref, With_Dir => True), ALIfile, True);
+
+ while ALIfile.Buffer (ALIfile.Current_Line) /= EOF loop
+ Parse_X_Filename (ALIfile);
+ Parse_Identifier_Info
+ (Null_Pattern, ALIfile, Local_Symbols, Der_Info);
+ end loop;
+
+ exception
+ when No_Xref_Information => null;
+ end;
+ end if;
+ end loop;
+ end Search_Xref;
+
+end Xref_Lib;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
projects / platform / upstream / linaro-gcc.git / commitdiff