diff options
| author | kenner <kenner@138bc75d-0d04-0410-961f-82ee72b054a4> | 2001-10-02 14:57:59 +0000 |
|---|---|---|
| committer | kenner <kenner@138bc75d-0d04-0410-961f-82ee72b054a4> | 2001-10-02 14:57:59 +0000 |
| commit | 6f1e2b25e3063f24afbd430b2ec17a738b39a6d6 (patch) | |
| tree | 4ef27cb0e7d117a7b5941427f004d4d06fc8675b | |
| parent | d6f39728ae3cc12d4f867eeb4659d01322643264 (diff) | |
| download | gcc-6f1e2b25e3063f24afbd430b2ec17a738b39a6d6.tar.gz | |
New Language: Ada
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45960 138bc75d-0d04-0410-961f-82ee72b054a4
51 files changed, 31793 insertions, 0 deletions
diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb new file mode 100644 index 00000000000..95da3a7e355 --- /dev/null +++ b/gcc/ada/table.adb @@ -0,0 +1,345 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T A B L E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.44 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Opt; +with Output; use Output; +with System; use System; +with Tree_IO; use Tree_IO; + +package body Table is + package body Table is + + Min : constant Int := Int (Table_Low_Bound); + -- Subscript of the minimum entry in the currently allocated table + + Length : Int := 0; + -- Number of entries in currently allocated table. The value of zero + -- ensures that we initially allocate the table. + + procedure free (T : Table_Ptr); + pragma Import (C, free); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Reallocate; + -- Reallocate the existing table according to the current value stored + -- in Max. Works correctly to do an initial allocation if the table + -- is currently null. + + function Tree_Get_Table_Address return Address; + -- Return Null_Address if the table length is zero, + -- Table (First)'Address if not. + + ------------ + -- Append -- + ------------ + + procedure Append (New_Val : Table_Component_Type) is + begin + Increment_Last; + Table (Table_Index_Type (Last_Val)) := New_Val; + end Append; + + -------------------- + -- Decrement_Last -- + -------------------- + + procedure Decrement_Last is + begin + Last_Val := Last_Val - 1; + end Decrement_Last; + + ---------- + -- Free -- + ---------- + + procedure Free is + begin + free (Table); + Table := null; + Length := 0; + end Free; + + -------------------- + -- Increment_Last -- + -------------------- + + procedure Increment_Last is + begin + Last_Val := Last_Val + 1; + + if Last_Val > Max then + Reallocate; + end if; + end Increment_Last; + + ---------- + -- Init -- + ---------- + + procedure Init is + Old_Length : Int := Length; + + begin + Last_Val := Min - 1; + Max := Min + (Table_Initial * Opt.Table_Factor) - 1; + Length := Max - Min + 1; + + -- If table is same size as before (happens when table is never + -- expanded which is a common case), then simply reuse it. Note + -- that this also means that an explicit Init call right after + -- the implicit one in the package body is harmless. + + if Old_Length = Length then + return; + + -- Otherwise we can use Reallocate to get a table of the right size. + -- Note that Reallocate works fine to allocate a table of the right + -- initial size when it is first allocated. + + else + Reallocate; + end if; + end Init; + + ---------- + -- Last -- + ---------- + + function Last return Table_Index_Type is + begin + return Table_Index_Type (Last_Val); + end Last; + + ---------------- + -- Reallocate -- + ---------------- + + procedure Reallocate is + + function realloc + (memblock : Table_Ptr; + size : size_t) + return Table_Ptr; + pragma Import (C, realloc); + + function malloc + (size : size_t) + return Table_Ptr; + pragma Import (C, malloc); + + New_Size : size_t; + + begin + if Max < Last_Val then + pragma Assert (not Locked); + + -- Make sure that we have at least the initial allocation. This + -- is needed in cases where a zero length table is written out. + + Length := Int'Max (Length, Table_Initial); + + -- Now increment table length until it is sufficiently large + + while Max < Last_Val loop + Length := Length * (100 + Table_Increment) / 100; + Max := Min + Length - 1; + end loop; + + if Debug_Flag_D then + Write_Str ("--> Allocating new "); + Write_Str (Table_Name); + Write_Str (" table, size = "); + Write_Int (Max - Min + 1); + Write_Eol; + end if; + end if; + + New_Size := + size_t ((Max - Min + 1) * + (Table_Type'Component_Size / Storage_Unit)); + + if Table = null then + Table := malloc (New_Size); + + elsif New_Size > 0 then + Table := + realloc + (memblock => Table, + size => New_Size); + end if; + + if Length /= 0 and then Table = null then + Set_Standard_Error; + Write_Str ("available memory exhausted"); + Write_Eol; + Set_Standard_Output; + raise Unrecoverable_Error; + end if; + + end Reallocate; + + ------------- + -- Release -- + ------------- + + procedure Release is + begin + Length := Last_Val - Int (Table_Low_Bound) + 1; + Max := Last_Val; + Reallocate; + end Release; + + ------------- + -- Restore -- + ------------- + + procedure Restore (T : Saved_Table) is + begin + free (Table); + Last_Val := T.Last_Val; + Max := T.Max; + Table := T.Table; + Length := Max - Min + 1; + end Restore; + + ---------- + -- Save -- + ---------- + + function Save return Saved_Table is + Res : Saved_Table; + + begin + Res.Last_Val := Last_Val; + Res.Max := Max; + Res.Table := Table; + + Table := null; + Length := 0; + Init; + return Res; + end Save; + + -------------- + -- Set_Item -- + -------------- + + procedure Set_Item + (Index : Table_Index_Type; + Item : Table_Component_Type) + is + begin + if Int (Index) > Max then + Set_Last (Index); + end if; + + Table (Index) := Item; + end Set_Item; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (New_Val : Table_Index_Type) is + begin + if Int (New_Val) < Last_Val then + Last_Val := Int (New_Val); + else + Last_Val := Int (New_Val); + + if Last_Val > Max then + Reallocate; + end if; + end if; + end Set_Last; + + ---------------------------- + -- Tree_Get_Table_Address -- + ---------------------------- + + function Tree_Get_Table_Address return Address is + begin + if Length = 0 then + return Null_Address; + else + return Table (First)'Address; + end if; + end Tree_Get_Table_Address; + + --------------- + -- Tree_Read -- + --------------- + + -- Note: we allocate only the space required to accomodate the data + -- actually written, which means that a Tree_Write/Tree_Read sequence + -- does an implicit Release. + + procedure Tree_Read is + begin + Tree_Read_Int (Max); + Last_Val := Max; + Length := Max - Min + 1; + Reallocate; + + Tree_Read_Data + (Tree_Get_Table_Address, + (Last_Val - Int (First) + 1) * + Table_Type'Component_Size / Storage_Unit); + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + -- Note: we write out only the currently valid data, not the entire + -- contents of the allocated array. See note above on Tree_Read. + + procedure Tree_Write is + begin + Tree_Write_Int (Int (Last)); + Tree_Write_Data + (Tree_Get_Table_Address, + (Last_Val - Int (First) + 1) * + Table_Type'Component_Size / Storage_Unit); + end Tree_Write; + + begin + Init; + end Table; +end Table; diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads new file mode 100644 index 00000000000..4588e4d0e89 --- /dev/null +++ b/gcc/ada/table.ads @@ -0,0 +1,225 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T A B L E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.38 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an implementation of dynamically resizable one +-- dimensional arrays. The idea is to mimic the normal Ada semantics for +-- arrays as closely as possible with the one additional capability of +-- dynamically modifying the value of the Last attribute. + +-- Note that this interface should remain synchronized with those in +-- GNAT.Table and GNAT.Dynamic_Tables to keep coherency between these +-- three related units. + +with Types; use Types; + +package Table is +pragma Elaborate_Body (Table); + + generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type; + Table_Initial : Pos; + Table_Increment : Nat; + Table_Name : String; + + package Table is + + -- Table_Component_Type and Table_Index_Type specify the type of the + -- array, Table_Low_Bound is the lower bound. Index_type must be an + -- integer type. The effect is roughly to declare: + + -- Table : array (Table_Index_Type range Table_Low_Bound .. <>) + -- of Table_Component_Type; + + -- Note: since the upper bound can be one less than the lower + -- bound for an empty array, the table index type must be able + -- to cover this range, e.g. if the lower bound is 1, then the + -- Table_Index_Type should be Natural rather than Positive. + + -- Table_Component_Type may be any Ada type, except that controlled + -- types are not supported. Note however that default initialization + -- will NOT occur for array components. + + -- The Table_Initial values controls the allocation of the table when + -- it is first allocated, either by default, or by an explicit Init + -- call. The value used is Opt.Table_Factor * Table_Initial. + + -- The Table_Increment value controls the amount of increase, if the + -- table has to be increased in size. The value given is a percentage + -- value (e.g. 100 = increase table size by 100%, i.e. double it). + + -- The Table_Name parameter is simply use in debug output messages it + -- has no other usage, and is not referenced in non-debugging mode. + + -- The Last and Set_Last subprograms provide control over the current + -- logical allocation. They are quite efficient, so they can be used + -- freely (expensive reallocation occurs only at major granularity + -- chunks controlled by the allocation parameters). + + -- Note: we do not make the table components aliased, since this would + -- restict the use of table for discriminated types. If it is necessary + -- to take the access of a table element, use Unrestricted_Access. + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + + subtype Big_Table_Type is + Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + -- We work with pointers to a bogus array type that is constrained + -- with the maximum possible range bound. This means that the pointer + -- is a thin pointer, which is more efficient. Since subscript checks + -- in any case must be on the logical, rather than physical bounds, + -- safety is not compromised by this approach. + + type Table_Ptr is access all Big_Table_Type; + -- The table is actually represented as a pointer to allow reallocation + + Table : aliased Table_Ptr := null; + -- The table itself. The lower bound is the value of Low_Bound. + -- Logically the upper bound is the current value of Last (although + -- the actual size of the allocated table may be larger than this). + -- The program may only access and modify Table entries in the range + -- First .. Last. + + Locked : Boolean := False; + -- Table expansion is permitted only if this switch is set to False. A + -- client may set Locked to True, in which case any attempt to expand + -- the table will cause an assertion failure. Note that while a table + -- is locked, its address in memory remains fixed and unchanging. This + -- feature is used to control table expansion during Gigi processing. + -- Gigi assumes that tables other than the Uint and Ureal tables do + -- not move during processing, which means that they cannot be expanded. + -- The Locked flag is used to enforce this restriction. + + procedure Init; + -- This procedure allocates a new table of size Initial (freeing any + -- previously allocated larger table). It is not necessary to call + -- Init when a table is first instantiated (since the instantiation does + -- the same initialization steps). However, it is harmless to do so, and + -- Init is convenient in reestablishing a table for new use. + + function Last return Table_Index_Type; + pragma Inline (Last); + -- Returns the current value of the last used entry in the table, which + -- can then be used as a subscript for Table. Note that the only way to + -- modify Last is to call the Set_Last procedure. Last must always be + -- used to determine the logically last entry. + + procedure Release; + -- Storage is allocated in chunks according to the values given in the + -- Initial and Increment parameters. A call to Release releases all + -- storage that is allocated, but is not logically part of the current + -- array value. Current array values are not affected by this call. + + procedure Free; + -- Free all allocated memory for the table. A call to init is required + -- before any use of this table after calling Free. + + First : constant Table_Index_Type := Table_Low_Bound; + -- Export First as synonym for Low_Bound (parallel with use of Last) + + procedure Set_Last (New_Val : Table_Index_Type); + pragma Inline (Set_Last); + -- This procedure sets Last to the indicated value. If necessary the + -- table is reallocated to accomodate the new value (i.e. on return + -- the allocated table has an upper bound of at least Last). If Set_Last + -- reduces the size of the table, then logically entries are removed + -- from the table. If Set_Last increases the size of the table, then + -- new entries are logically added to the table. + + procedure Increment_Last; + pragma Inline (Increment_Last); + -- Adds 1 to Last (same as Set_Last (Last + 1). + + procedure Decrement_Last; + pragma Inline (Decrement_Last); + -- Subtracts 1 from Last (same as Set_Last (Last - 1). + + procedure Append (New_Val : Table_Component_Type); + pragma Inline (Append); + -- Equivalent to: + -- x.Increment_Last; + -- x.Table (x.Last) := New_Val; + -- i.e. the table size is increased by one, and the given new item + -- stored in the newly created table element. + + procedure Set_Item + (Index : Table_Index_Type; + Item : Table_Component_Type); + pragma Inline (Set_Item); + -- Put Item in the table at position Index. The table is expanded if + -- current table length is less than Index and in that case Last is set + -- to Index. Item will replace any value already present in the table + -- at this position. + + type Saved_Table is private; + -- Type used for Save/Restore subprograms + + function Save return Saved_Table; + -- Resets table to empty, but saves old contents of table in returned + -- value, for possible later restoration by a call to Restore. + + procedure Restore (T : Saved_Table); + -- Given a Saved_Table value returned by a prior call to Save, restores + -- the table to the state it was in at the time of the Save call. + + procedure Tree_Write; + -- Writes out contents of table using Tree_IO + + procedure Tree_Read; + -- Initializes table by reading contents previously written + -- with the Tree_Write call (also using Tree_IO) + + private + + Last_Val : Int; + -- Current value of Last. Note that we declare this in the private part + -- because we don't want the client to modify Last except through one of + -- the official interfaces (since a modification to Last may require a + -- reallocation of the table). + + Max : Int; + -- Subscript of the maximum entry in the currently allocated table + + type Saved_Table is record + Last_Val : Int; + Max : Int; + Table : Table_Ptr; + end record; + + end Table; +end Table; diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb new file mode 100644 index 00000000000..9e823d89971 --- /dev/null +++ b/gcc/ada/targparm.adb @@ -0,0 +1,228 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- T A R G P A R M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.15 $ +-- -- +-- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Namet; use Namet; +with Output; use Output; +with Sinput; use Sinput; +with Sinput.L; use Sinput.L; +with Fname.UF; use Fname.UF; +with Types; use Types; + +package body Targparm is + + type Targparm_Tags is + (AAM, CLA, DEN, DSP, FEL, HIM, LSI, MOV, + MRN, SCD, SCP, SNZ, UAM, VMS, ZCD, ZCG, ZCF); + + Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False); + -- Flag is set True if corresponding parameter is scanned + + AAM_Str : aliased constant Source_Buffer := "AAMP"; + CLA_Str : aliased constant Source_Buffer := "Command_Line_Args"; + DEN_Str : aliased constant Source_Buffer := "Denorm"; + DSP_Str : aliased constant Source_Buffer := "Functions_Return_By_DSP"; + FEL_Str : aliased constant Source_Buffer := "Frontend_Layout"; + HIM_Str : aliased constant Source_Buffer := "High_Integrity_Mode"; + LSI_Str : aliased constant Source_Buffer := "Long_Shifts_Inlined"; + MOV_Str : aliased constant Source_Buffer := "Machine_Overflows"; + MRN_Str : aliased constant Source_Buffer := "Machine_Rounds"; + SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default"; + SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes"; + SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros"; + UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name"; + VMS_Str : aliased constant Source_Buffer := "OpenVMS"; + ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default"; + ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support"; + ZCF_Str : aliased constant Source_Buffer := "Front_End_ZCX_Support"; + + type Buffer_Ptr is access constant Source_Buffer; + Targparm_Str : array (Targparm_Tags) of Buffer_Ptr := + (AAM_Str'Access, + CLA_Str'Access, + DEN_Str'Access, + DSP_Str'Access, + FEL_Str'Access, + HIM_Str'Access, + LSI_Str'Access, + MOV_Str'Access, + MRN_Str'Access, + SCD_Str'Access, + SCP_Str'Access, + SNZ_Str'Access, + UAM_Str'Access, + VMS_Str'Access, + ZCD_Str'Access, + ZCG_Str'Access, + ZCF_Str'Access); + + --------------------------- + -- Get_Target_Parameters -- + --------------------------- + + procedure Get_Target_Parameters is + use ASCII; + + S : Source_File_Index; + N : Name_Id; + T : Source_Buffer_Ptr; + P : Source_Ptr; + Z : Source_Ptr; + + Fatal : Boolean := False; + -- Set True if a fatal error is detected + + Result : Boolean; + -- Records boolean from system line + + begin + Name_Buffer (1 .. 6) := "system"; + Name_Len := 6; + N := File_Name_Of_Spec (Name_Find); + S := Load_Source_File (N); + + if S = No_Source_File then + Write_Line ("fatal error, run-time library not installed correctly"); + Write_Str ("cannot locate file "); + Write_Line (Name_Buffer (1 .. Name_Len)); + raise Unrecoverable_Error; + + -- This must always be the first source file read, and we have defined + -- a constant Types.System_Source_File_Index as 1 to reflect this. + + else + pragma Assert (S = System_Source_File_Index); + null; + end if; + + P := Source_First (S); + Z := Source_Last (S); + T := Source_Text (S); + + while T (P .. P + 10) /= "end System;" loop + + for K in Targparm_Tags loop + if T (P + 3 .. P + 2 + Targparm_Str (K)'Length) = + Targparm_Str (K).all + then + P := P + 3 + Targparm_Str (K)'Length; + + if Targparm_Flags (K) then + Set_Standard_Error; + Write_Line + ("fatal error: system.ads is incorrectly formatted"); + Write_Str ("duplicate line for parameter: "); + + for J in Targparm_Str (K)'Range loop + Write_Char (Targparm_Str (K).all (J)); + end loop; + + Write_Eol; + Set_Standard_Output; + Fatal := True; + + else + Targparm_Flags (K) := True; + end if; + + while T (P) /= ':' or else T (P + 1) /= '=' loop + P := P + 1; + end loop; + + P := P + 2; + + while T (P) = ' ' loop + P := P + 1; + end loop; + + Result := (T (P) = 'T'); + + case K is + when AAM => AAMP_On_Target := Result; + when CLA => Command_Line_Args_On_Target := Result; + when DEN => Denorm_On_Target := Result; + when DSP => Functions_Return_By_DSP_On_Target := Result; + when FEL => Frontend_Layout_On_Target := Result; + when HIM => High_Integrity_Mode_On_Target := Result; + when LSI => Long_Shifts_Inlined_On_Target := Result; + when MOV => Machine_Overflows_On_Target := Result; + when MRN => Machine_Rounds_On_Target := Result; + when SCD => Stack_Check_Default_On_Target := Result; + when SCP => Stack_Check_Probes_On_Target := Result; + when SNZ => Signed_Zeros_On_Target := Result; + when UAM => Use_Ada_Main_Program_Name_On_Target := Result; + when VMS => OpenVMS_On_Target := Result; + when ZCD => ZCX_By_Default_On_Target := Result; + when ZCG => GCC_ZCX_Support_On_Target := Result; + when ZCF => Front_End_ZCX_Support_On_Target := Result; + end case; + + exit; + end if; + end loop; + + while T (P) /= CR and then T (P) /= LF loop + P := P + 1; + exit when P >= Z; + end loop; + + while T (P) = CR or else T (P) = LF loop + P := P + 1; + exit when P >= Z; + end loop; + + if P >= Z then + Set_Standard_Error; + Write_Line ("fatal error, system.ads not formatted correctly"); + Set_Standard_Output; + raise Unrecoverable_Error; + end if; + end loop; + + for K in Targparm_Tags loop + if not Targparm_Flags (K) then + Set_Standard_Error; + Write_Line + ("fatal error: system.ads is incorrectly formatted"); + Write_Str ("missing line for parameter: "); + + for J in Targparm_Str (K)'Range loop + Write_Char (Targparm_Str (K).all (J)); + end loop; + + Write_Eol; + Set_Standard_Output; + Fatal := True; + end if; + end loop; + + if Fatal then + raise Unrecoverable_Error; + end if; + end Get_Target_Parameters; + +end Targparm; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads new file mode 100644 index 00000000000..2346fd209e7 --- /dev/null +++ b/gcc/ada/targparm.ads @@ -0,0 +1,288 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- T A R G P A R M -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.13 $ +-- -- +-- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package obtains parameters from the target runtime version of +-- System, to indicate parameters relevant to the target environment. + +-- Conceptually, these parameters could be obtained using rtsfind, but +-- we do not do this for three reasons: + +-- 1. Compiling System for every compilation wastes time +-- 2. This compilation impedes debugging by adding extra compile steps +-- 3. There are recursion problems coming from compiling System itself +-- or any of its children. + +-- For all these reasons, we read in the source of System, and then scan +-- it at the text level to extract the parameter values. + +-- Note however, that later on, when the ali file is written, we make sure +-- that the System file is at least parsed, so that the checksum is properly +-- computed and set in the ali file. This partially negates points 1 and 2 +-- above although just parsing is quick and does not impact debugging much. + +package Targparm is + + -- The following parameters correspond to the variables defined in the + -- private part of System (without the terminating _On_Target). Note + -- that it is required that all parameters be specified in system.ads. + + ----------------------------------- + -- Control of Exception Handling -- + ----------------------------------- + + -- GNAT provides two methods of implementing exceptions: + + -- Longjmp/Setjmp (-gnatL) + + -- This approach uses longjmp/setjmp to handle exceptions. It + -- uses less storage, and can often propagate exceptions faster, + -- at the expense of (sometimes considerable) overhead in setting + -- up an exception handler. This approach is available on all + -- targets, and is the default where it is the only approach. + + -- Zero Cost (-gnatZ) + + -- This approach uses separate exception tables. These use extra + -- storage, and exception propagation can be quite slow, but there + -- is no overhead in setting up an exception handler (it is to this + -- latter operation that the phrase zero-cost refers). This approach + -- is only available on some targets, and is the default where it is + -- available. + + ZCX_By_Default_On_Target : Boolean; + -- Indicates if zero cost exceptions are active by default. Can be modified + -- by the use of -gnatZ and -gnatL switches. + + GCC_ZCX_Support_On_Target : Boolean; + -- Indicates that when ZCX is active the mechanism to be used is the + -- standard GCC ZCX mechanism (introduced in GCC 3.1) + + Front_End_ZCX_Support_On_Target : Boolean; + -- Indicates that when ZCX is active (and GCC_ZCX_Support is not set) + -- the mechanism to be used is the GNAT front end specific ZCX mechanism + + --------------------------------------- + -- High_Integrity (No Run Time) Mode -- + --------------------------------------- + + -- In High_Integrity mode, there is no system run-time, and the flag + -- Opt.No_Run_Time is set so that the language is appropriately + -- restricted to forbid construct that would generate run-time calls. + + High_Integrity_Mode_On_Target : Boolean; + -- Indicates that this build is for a high integrity mode version of + -- GNAT, so that no run time is permitted. + + ------------------------------- + -- Control of Stack Checking -- + ------------------------------- + + -- GNAT provides two methods of implementing exceptions: + + -- GCC Probing Mechanism + + -- This approach uses the standard GCC mechanism for + -- stack checking. The method assumes that accessing + -- storage immediately beyond the end of the stack + -- will result in a trap that is converted to a storage + -- error by the runtime system. This mechanism has + -- minimal overhead, but requires complex hardware, + -- operating system and run-time support. Probing is + -- the default method where it is available. The stack + -- size for the environment task depends on the operating + -- system and cannot be set in a system-independent way. + + -- GNAT Stack-limit Checking + + -- This method relies on comparing the stack pointer + -- with per-task stack limits. If the check fails, an + -- exception is explicitly raised. The advantage is + -- that the method requires no extra system dependent + -- runtime support and can be used on systems without + -- memory protection as well, but at the cost of more + -- overhead for doing the check. This method is the + -- default on systems that lack complete support for + -- probing. + + Stack_Check_Probes_On_Target : Boolean; + -- Indicates if stack check probes are used, as opposed to the standard + -- target independent comparison method. + + Stack_Check_Default_On_Target : Boolean; + -- Indicates if stack checking is on by default + + ---------------------------- + -- Command Line Arguments -- + ---------------------------- + + -- For most ports of GNAT, command line arguments are supported. The + -- following flag is set to False for targets that do not support + -- command line arguments (notably VxWorks). + + Command_Line_Args_On_Target : Boolean; + -- Set False if no command line arguments on target + + -- Note: this is prepared for future use, but not yet used, since we + -- do not yet have a way of propagating Targparm params to the binder + + ----------------------- + -- Main Program Name -- + ----------------------- + + -- When the binder generates the main program to be used to create the + -- executable, the main program name is main by default (to match the + -- usual Unix practice). If this parameter is set to True, then the + -- name is instead by default taken from the actual Ada main program + -- name (just the name of the child if the main program is a child unit). + -- In either case, this value can be overridden using -M name. + + Use_Ada_Main_Program_Name_On_Target : Boolean; + -- Set True to use the Ada main program name as the main name + + -- Note: this is prepared for future use, but not yet used, since we + -- do not yet have a way of propagating Targparm params to the binder + + ---------------------------- + -- Support of Long Shifts -- + ---------------------------- + + -- In GNORT mode, we cannot call library routines, and in particular + -- we cannot call routines for long (64-bit) shifts if such routines + -- are required on the target. This comes up in the context of support + -- of packed arrays. We can only represent packed arrays whose length + -- is in the range 33- to 64-bits as modular types if long shifts are + -- done with inline code. + + -- For the default version, for now we set long shifts inlined as True + -- This may not be quite accurate, but until we get proper separate + -- System's for each target, it is a safer choice. + + Long_Shifts_Inlined_On_Target : Boolean; + -- Indicates if long (double word) shifts are generated using inlined + -- code (and thus are permissible in No_Run_Time mode). + + ---------------------------------------------- + -- Boolean-Valued Floating-Point Attributes -- + ---------------------------------------------- + + -- The constants below give the values for representation oriented + -- floating-point attributes that are the same for all float types + -- on the target. These are all boolean values. + + -- A value is only True if the target reliably supports the corresponding + -- feature. Reliably here means that support is guaranteed for all + -- possible settings of the relevant compiler switches (like -mieee), + -- since we cannot control the user setting of those switches. + + -- The attributes cannot dependent on the current setting of compiler + -- switches, since the values must be static and consistent throughout + -- the partition. We probably should add such consistency checks in future, + -- but for now we don't do this. + + AAMP_On_Target : Boolean; + -- Set to True if target is AAMP. + + Denorm_On_Target : Boolean; + -- Set to False on targets that do not reliably support denormals. + -- Reliably here means for all settings of the relevant -m flag, so + -- for example, this is False on the Alpha where denormals are not + -- supported unless -mieee is used. + + Machine_Rounds_On_Target : Boolean; + -- Set to False for targets where S'Machine_Rounds is False + + Machine_Overflows_On_Target : Boolean; + -- Set to True for targets where S'Machine_Overflows is True + + Signed_Zeros_On_Target : Boolean; + -- Set to False on targets that do not reliably support signed zeros. + + OpenVMS_On_Target : Boolean; + -- Set to True if target is OpenVMS. + + -------------------------------------------------------------- + -- Handling of Unconstrained Values Returned from Functions -- + -------------------------------------------------------------- + + -- Functions that return variable length objects, notably unconstrained + -- arrays are a special case, because there is no simple obvious way of + -- implementing this feature. Furthermore, this capability is not present + -- in C++ or C, so typically the system ABI does not handle this case. + + -- GNAT uses two different approaches + + -- The Secondary Stack + + -- The secondary stack is a special storage pool that is used for + -- this purpose. The called function places the result on the + -- secondary stack, and the caller uses or copies the value from + -- the secondary stack, and pops the secondary stack after the + -- value is consumed. The secondary stack is outside the system + -- ABI, and the important point is that although generally it is + -- handled in a stack like manner corresponding to the subprogram + -- call structure, a return from a function does NOT pop the stack. + + -- DSP (Depressed Stack Pointer) + + -- Some targets permit the implementation of a function call/return + -- protocol in which the function does not pop the main stack pointer + -- on return, but rather returns with the stack pointer depressed. + -- This is not generally permitted by any ABI, but for at least some + -- targets, the implementation of alloca provides a model for this + -- approach. If return-with-DSP is implemented, then functions that + -- return variable length objects do it by returning with the stack + -- pointer depressed, and the returned object is a pointer to the + -- area within the stack frame of the called procedure that contains + -- the returned value. The caller must then pop the main stack when + -- this value is consumed. + + Functions_Return_By_DSP_On_Target : Boolean; + -- Set to True if target permits functions to return with using the + -- DSP (depressed stack pointer) approach. + + ----------------- + -- Data Layout -- + ----------------- + + -- Normally when using the GCC backend, Gigi and GCC perform much of the + -- data layout using the standard layout capabilities of GCC. If the + -- parameter Backend_Layout is set to False, then the front end must + -- perform all data layout. For further details see the package Layout. + + Frontend_Layout_On_Target : Boolean; + -- Set True if front end does layout + + ----------------- + -- Subprograms -- + ----------------- + + procedure Get_Target_Parameters; + -- Called at the start of execution to read the source of System and + -- obtain and set the values of the above parameters. + +end Targparm; diff --git a/gcc/ada/targtyps.c b/gcc/ada/targtyps.c new file mode 100644 index 00000000000..900762b2e1e --- /dev/null +++ b/gcc/ada/targtyps.c @@ -0,0 +1,226 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T A R G T Y P S * + * * + * Body * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-2001 Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 2, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* Functions for retrieving target types. See Ada package Get_Targ */ + +#include "config.h" +#include "system.h" +#include "tree.h" +#include "real.h" +#include "rtl.h" +#include "ada.h" +#include "types.h" +#include "atree.h" +#include "elists.h" +#include "namet.h" +#include "nlists.h" +#include "snames.h" +#include "stringt.h" +#include "uintp.h" +#include "urealp.h" +#include "fe.h" +#include "sinfo.h" +#include "einfo.h" +#include "ada-tree.h" +#include "gigi.h" + +#define MIN(X,Y) ((X) < (Y) ? (X) : (Y)) + +/* Standard data type sizes. Most of these are not used. */ + +#ifndef CHAR_TYPE_SIZE +#define CHAR_TYPE_SIZE BITS_PER_UNIT +#endif + +#ifndef SHORT_TYPE_SIZE +#define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2)) +#endif + +#ifndef INT_TYPE_SIZE +#define INT_TYPE_SIZE BITS_PER_WORD +#endif + +#ifdef OPEN_VMS /* A target macro defined in vms.h */ +#define LONG_TYPE_SIZE 64 +#else +#ifndef LONG_TYPE_SIZE +#define LONG_TYPE_SIZE BITS_PER_WORD +#endif +#endif + +#ifndef LONG_LONG_TYPE_SIZE +#define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2) +#endif + +#ifndef FLOAT_TYPE_SIZE +#define FLOAT_TYPE_SIZE BITS_PER_WORD +#endif + +#ifndef DOUBLE_TYPE_SIZE +#define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) +#endif + +#ifndef LONG_DOUBLE_TYPE_SIZE +#define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) +#endif + +#ifndef WIDEST_HARDWARE_FP_SIZE +#define WIDEST_HARDWARE_FP_SIZE LONG_DOUBLE_TYPE_SIZE +#endif + +/* The following provide a functional interface for the front end Ada code + to determine the sizes that are used for various C types. */ + +Pos +get_target_bits_per_unit () +{ + return BITS_PER_UNIT; +} + +Pos +get_target_bits_per_word () +{ + return BITS_PER_WORD; +} + +Pos +get_target_char_size () +{ + return CHAR_TYPE_SIZE; +} + +Pos +get_target_wchar_t_size () +{ + /* We never want wide chacters less than "short" in Ada. */ + return MAX (SHORT_TYPE_SIZE, WCHAR_TYPE_SIZE); +} + +Pos +get_target_short_size () +{ + return SHORT_TYPE_SIZE; +} + +Pos +get_target_int_size () +{ + return INT_TYPE_SIZE; +} + +Pos +get_target_long_size () +{ + return LONG_TYPE_SIZE; +} + +Pos +get_target_long_long_size () +{ + return LONG_LONG_TYPE_SIZE; +} + +Pos +get_target_float_size () +{ + return FLOAT_TYPE_SIZE; +} + +Pos +get_target_double_size () +{ + return DOUBLE_TYPE_SIZE; +} + +Pos +get_target_long_double_size () +{ + return WIDEST_HARDWARE_FP_SIZE; +} + +Pos +get_target_pointer_size () +{ + return POINTER_SIZE; +} + +Pos +get_target_maximum_alignment () +{ + return BIGGEST_ALIGNMENT / BITS_PER_UNIT; +} + +Boolean +get_target_no_dollar_in_label () +{ +#ifdef NO_DOLLAR_IN_LABEL + return 1; +#else + return 0; +#endif +} + +#ifndef FLOAT_WORDS_BIG_ENDIAN +#define FLOAT_WORDS_BIG_ENDIAN WORDS_BIG_ENDIAN +#endif + +Nat +get_float_words_be () +{ + return FLOAT_WORDS_BIG_ENDIAN; +} + +Nat +get_words_be () +{ + return WORDS_BIG_ENDIAN; +} + +Nat +get_bytes_be () +{ + return BYTES_BIG_ENDIAN; +} + +Nat +get_bits_be () +{ + return BITS_BIG_ENDIAN; +} + +Nat +get_strict_alignment () +{ + return STRICT_ALIGNMENT; +} diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb new file mode 100644 index 00000000000..3ccd7a7472e --- /dev/null +++ b/gcc/ada/tbuild.adb @@ -0,0 +1,522 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T B U I L D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.98 $ +-- -- +-- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Restrict; use Restrict; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Uintp; use Uintp; + +package body Tbuild is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Unique_Serial_Number; + -- Add a unique serialization to the string in the Name_Buffer. This + -- consists of a unit specific serial number, and b/s for body/spec. + + ------------------------------ + -- Add_Unique_Serial_Number -- + ------------------------------ + + procedure Add_Unique_Serial_Number is + Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit)); + + begin + Add_Nat_To_Name_Buffer (Increment_Serial_Number); + + -- Add either b or s, depending on whether current unit is a spec + -- or a body. This is needed because we may generate the same name + -- in a spec and a body otherwise. + + Name_Len := Name_Len + 1; + + if Nkind (Unit_Node) = N_Package_Declaration + or else Nkind (Unit_Node) = N_Subprogram_Declaration + or else Nkind (Unit_Node) in N_Generic_Declaration + then + Name_Buffer (Name_Len) := 's'; + else + Name_Buffer (Name_Len) := 'b'; + end if; + end Add_Unique_Serial_Number; + + ---------------- + -- Checks_Off -- + ---------------- + + function Checks_Off (N : Node_Id) return Node_Id is + begin + return + Make_Unchecked_Expression (Sloc (N), + Expression => N); + end Checks_Off; + + ---------------- + -- Convert_To -- + ---------------- + + function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is + Result : Node_Id; + + begin + if Present (Etype (Expr)) + and then (Etype (Expr)) = Typ + then + return Relocate_Node (Expr); + else + Result := + Make_Type_Conversion (Sloc (Expr), + Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)), + Expression => Relocate_Node (Expr)); + + Set_Etype (Result, Typ); + return Result; + end if; + end Convert_To; + + -------------------- + -- Make_DT_Access -- + -------------------- + + function Make_DT_Access + (Loc : Source_Ptr; + Rec : Node_Id; + Typ : Entity_Id) + return Node_Id + is + Full_Type : Entity_Id := Typ; + + begin + if Is_Private_Type (Typ) then + Full_Type := Underlying_Type (Typ); + end if; + + return + Unchecked_Convert_To ( + New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc), + Make_Selected_Component (Loc, + Prefix => New_Copy (Rec), + Selector_Name => + New_Reference_To (Tag_Component (Full_Type), Loc))); + end Make_DT_Access; + + ----------------------- + -- Make_DT_Component -- + ----------------------- + + function Make_DT_Component + (Loc : Source_Ptr; + Typ : Entity_Id; + I : Positive) + return Node_Id + is + X : Node_Id; + Full_Type : Entity_Id := Typ; + + begin + if Is_Private_Type (Typ) then + Full_Type := Underlying_Type (Typ); + end if; + + X := First_Component ( + Designated_Type (Etype (Access_Disp_Table (Full_Type)))); + + for J in 2 .. I loop + X := Next_Component (X); + end loop; + + return New_Reference_To (X, Loc); + end Make_DT_Component; + + -------------------------------- + -- Make_Implicit_If_Statement -- + -------------------------------- + + function Make_Implicit_If_Statement + (Node : Node_Id; + Condition : Node_Id; + Then_Statements : List_Id; + Elsif_Parts : List_Id := No_List; + Else_Statements : List_Id := No_List) + return Node_Id + is + begin + Check_Restriction (No_Implicit_Conditionals, Node); + return Make_If_Statement (Sloc (Node), + Condition, + Then_Statements, + Elsif_Parts, + Else_Statements); + end Make_Implicit_If_Statement; + + ------------------------------------- + -- Make_Implicit_Label_Declaration -- + ------------------------------------- + + function Make_Implicit_Label_Declaration + (Loc : Source_Ptr; + Defining_Identifier : Node_Id; + Label_Construct : Node_Id) + return Node_Id + is + N : constant Node_Id := + Make_Implicit_Label_Declaration (Loc, Defining_Identifier); + + begin + Set_Label_Construct (N, Label_Construct); + return N; + end Make_Implicit_Label_Declaration; + + ---------------------------------- + -- Make_Implicit_Loop_Statement -- + ---------------------------------- + + function Make_Implicit_Loop_Statement + (Node : Node_Id; + Statements : List_Id; + Identifier : Node_Id := Empty; + Iteration_Scheme : Node_Id := Empty; + Has_Created_Identifier : Boolean := False; + End_Label : Node_Id := Empty) + return Node_Id + is + begin + Check_Restriction (No_Implicit_Loops, Node); + + if Present (Iteration_Scheme) + and then Present (Condition (Iteration_Scheme)) + then + Check_Restriction (No_Implicit_Conditionals, Node); + end if; + + return Make_Loop_Statement (Sloc (Node), + Identifier => Identifier, + Iteration_Scheme => Iteration_Scheme, + Statements => Statements, + Has_Created_Identifier => Has_Created_Identifier, + End_Label => End_Label); + end Make_Implicit_Loop_Statement; + + -------------------------- + -- Make_Integer_Literal -- + --------------------------- + + function Make_Integer_Literal + (Loc : Source_Ptr; + Intval : Int) + return Node_Id + is + begin + return Make_Integer_Literal (Loc, UI_From_Int (Intval)); + end Make_Integer_Literal; + + --------------------------- + -- Make_Unsuppress_Block -- + --------------------------- + + -- Generates the following expansion: + + -- declare + -- pragma Suppress (<check>); + -- begin + -- <stmts> + -- end; + + function Make_Unsuppress_Block + (Loc : Source_Ptr; + Check : Name_Id; + Stmts : List_Id) + return Node_Id + is + begin + return + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Pragma (Loc, + Chars => Name_Suppress, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Check))))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Make_Unsuppress_Block; + + -------------------------- + -- New_Constraint_Error -- + -------------------------- + + function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is + Ident_Node : Node_Id; + Raise_Node : Node_Id; + + begin + Ident_Node := New_Node (N_Identifier, Loc); + Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error))); + Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error)); + Raise_Node := New_Node (N_Raise_Statement, Loc); + Set_Name (Raise_Node, Ident_Node); + return Raise_Node; + end New_Constraint_Error; + + ----------------------- + -- New_External_Name -- + ----------------------- + + function New_External_Name + (Related_Id : Name_Id; + Suffix : Character := ' '; + Suffix_Index : Int := 0; + Prefix : Character := ' ') + return Name_Id + is + begin + Get_Name_String (Related_Id); + + if Prefix /= ' ' then + pragma Assert (Is_OK_Internal_Letter (Prefix)); + + for J in reverse 1 .. Name_Len loop + Name_Buffer (J + 1) := Name_Buffer (J); + end loop; + + Name_Len := Name_Len + 1; + Name_Buffer (1) := Prefix; + end if; + + if Suffix /= ' ' then + pragma Assert (Is_OK_Internal_Letter (Suffix)); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Suffix; + end if; + + if Suffix_Index /= 0 then + if Suffix_Index < 0 then + Add_Unique_Serial_Number; + else + Add_Nat_To_Name_Buffer (Suffix_Index); + end if; + end if; + + return Name_Find; + end New_External_Name; + + function New_External_Name + (Related_Id : Name_Id; + Suffix : String; + Suffix_Index : Int := 0; + Prefix : Character := ' ') + return Name_Id + is + begin + Get_Name_String (Related_Id); + + if Prefix /= ' ' then + pragma Assert (Is_OK_Internal_Letter (Prefix)); + + for J in reverse 1 .. Name_Len loop + Name_Buffer (J + 1) := Name_Buffer (J); + end loop; + + Name_Len := Name_Len + 1; + Name_Buffer (1) := Prefix; + end if; + + if Suffix /= "" then + Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; + Name_Len := Name_Len + Suffix'Length; + end if; + + if Suffix_Index /= 0 then + if Suffix_Index < 0 then + Add_Unique_Serial_Number; + else + Add_Nat_To_Name_Buffer (Suffix_Index); + end if; + end if; + + return Name_Find; + end New_External_Name; + + function New_External_Name + (Suffix : Character; + Suffix_Index : Nat) + return Name_Id + is + begin + Name_Buffer (1) := Suffix; + Name_Len := 1; + Add_Nat_To_Name_Buffer (Suffix_Index); + return Name_Find; + end New_External_Name; + + ----------------------- + -- New_Internal_Name -- + ----------------------- + + function New_Internal_Name (Id_Char : Character) return Name_Id is + begin + pragma Assert (Is_OK_Internal_Letter (Id_Char)); + Name_Buffer (1) := Id_Char; + Name_Len := 1; + Add_Unique_Serial_Number; + return Name_Enter; + end New_Internal_Name; + + ----------------------- + -- New_Occurrence_Of -- + ----------------------- + + function New_Occurrence_Of + (Def_Id : Entity_Id; + Loc : Source_Ptr) + return Node_Id + is + Occurrence : Node_Id; + + begin + Occurrence := New_Node (N_Identifier, Loc); + Set_Chars (Occurrence, Chars (Def_Id)); + Set_Entity (Occurrence, Def_Id); + + if Is_Type (Def_Id) then + Set_Etype (Occurrence, Def_Id); + else + Set_Etype (Occurrence, Etype (Def_Id)); + end if; + + return Occurrence; + end New_Occurrence_Of; + + ---------------------- + -- New_Reference_To -- + ---------------------- + + function New_Reference_To + (Def_Id : Entity_Id; + Loc : Source_Ptr) + return Node_Id + is + Occurrence : Node_Id; + + begin + Occurrence := New_Node (N_Identifier, Loc); + Set_Chars (Occurrence, Chars (Def_Id)); + Set_Entity (Occurrence, Def_Id); + return Occurrence; + end New_Reference_To; + + ----------------------- + -- New_Suffixed_Name -- + ----------------------- + + function New_Suffixed_Name + (Related_Id : Name_Id; + Suffix : String) + return Name_Id + is + begin + Get_Name_String (Related_Id); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := '_'; + Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; + Name_Len := Name_Len + Suffix'Length; + return Name_Find; + end New_Suffixed_Name; + + ------------------- + -- OK_Convert_To -- + ------------------- + + function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is + Result : Node_Id; + + begin + Result := + Make_Type_Conversion (Sloc (Expr), + Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)), + Expression => Relocate_Node (Expr)); + Set_Conversion_OK (Result, True); + Set_Etype (Result, Typ); + return Result; + end OK_Convert_To; + + -------------------------- + -- Unchecked_Convert_To -- + -------------------------- + + function Unchecked_Convert_To + (Typ : Entity_Id; + Expr : Node_Id) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Expr); + Result : Node_Id; + + begin + -- If the expression is already of the correct type, then nothing + -- to do, except for relocating the node in case this is required. + + if Present (Etype (Expr)) + and then (Base_Type (Etype (Expr)) = Typ + or else Etype (Expr) = Typ) + then + return Relocate_Node (Expr); + + -- Cases where the inner expression is itself an unchecked conversion + -- to the same type, and we can thus eliminate the outer conversion. + + elsif Nkind (Expr) = N_Unchecked_Type_Conversion + and then Entity (Subtype_Mark (Expr)) = Typ + then + Result := Relocate_Node (Expr); + + -- All other cases + + else + Result := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Expr)); + end if; + + Set_Etype (Result, Typ); + return Result; + end Unchecked_Convert_To; + +end Tbuild; diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads new file mode 100644 index 00000000000..51d539b523b --- /dev/null +++ b/gcc/ada/tbuild.ads @@ -0,0 +1,241 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T B U I L D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.69 $ +-- -- +-- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains various utility procedures to assist in +-- building specific types of tree nodes. + +with Types; use Types; + +package Tbuild is + + function Make_DT_Component + (Loc : Source_Ptr; + Typ : Entity_Id; + I : Positive) + return Node_Id; + -- Gives a reference to the Ith component of the Dispatch Table of + -- a given Tagged Type. + -- + -- I = 1 --> Inheritance_Depth + -- I = 2 --> Tags (array of ancestors) + -- I = 3, 4 --> predefined primitive + -- function _Size (X : Typ) return Long_Long_Integer; + -- function _Equality (X : Typ; Y : Typ'Class) return Boolean; + -- I >= 5 --> User-Defined Primitive Operations + + function Make_DT_Access + (Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id; + -- Create an access to the Dispatch Table by using the Tag field + -- of a tagged record : Acc_Dt (Rec.tag).all + + function Make_Implicit_If_Statement + (Node : Node_Id; + Condition : Node_Id; + Then_Statements : List_Id; + Elsif_Parts : List_Id := No_List; + Else_Statements : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Implicit_If_Statement); + -- This function makes an N_If_Statement node whose fields are filled + -- in with the indicated values (see Sinfo), and whose Sloc field is + -- is set to Sloc (Node). The effect is identical to calling function + -- Nmake.Make_If_Statement except that there is a check for restriction + -- No_Implicit_Conditionals, and if this restriction is being violated, + -- an error message is posted on Node. + + function Make_Implicit_Label_Declaration + (Loc : Source_Ptr; + Defining_Identifier : Node_Id; + Label_Construct : Node_Id) + return Node_Id; + -- Used to contruct an implicit label declaration node, including setting + -- the proper Label_Construct field (since Label_Construct is a semantic + -- field, the normal call to Make_Implicit_Label_Declaration does not + -- set this field). + + function Make_Implicit_Loop_Statement + (Node : Node_Id; + Statements : List_Id; + Identifier : Node_Id := Empty; + Iteration_Scheme : Node_Id := Empty; + Has_Created_Identifier : Boolean := False; + End_Label : Node_Id := Empty) + return Node_Id; + -- This function makes an N_Loop_Statement node whose fields are filled + -- in with the indicated values (see Sinfo), and whose Sloc field is + -- is set to Sloc (Node). The effect is identical to calling function + -- Nmake.Make_Loop_Statement except that there is a check for restrictions + -- No_Implicit_Loops and No_Implicit_Conditionals (the first applying in + -- all cases, and the second only for while loops), and if one of these + -- restrictions is being violated, an error message is posted on Node. + + function Make_Integer_Literal + (Loc : Source_Ptr; + Intval : Int) + return Node_Id; + pragma Inline (Make_Integer_Literal); + -- A convenient form of Make_Integer_Literal taking Int instead of Uint + + function Make_Unsuppress_Block + (Loc : Source_Ptr; + Check : Name_Id; + Stmts : List_Id) + return Node_Id; + -- Build a block with a pragma Suppress on 'Check'. Stmts is the + -- statements list that needs protection against the check + + function New_Constraint_Error (Loc : Source_Ptr) return Node_Id; + -- This function builds a tree corresponding to the Ada statement + -- "raise Constraint_Error" and returns the root of this tree, + -- the N_Raise_Statement node. + + function New_External_Name + (Related_Id : Name_Id; + Suffix : Character := ' '; + Suffix_Index : Int := 0; + Prefix : Character := ' ') + return Name_Id; + function New_External_Name + (Related_Id : Name_Id; + Suffix : String; + Suffix_Index : Int := 0; + Prefix : Character := ' ') + return Name_Id; + -- Builds a new entry in the names table of the form: + -- + -- [Prefix &] Related_Id [& Suffix] [& Suffix_Index] + -- + -- Prefix is prepended only if Prefix is non-blank (in which case it + -- must be an upper case letter other than O,Q,U,W (which are used for + -- identifier encoding, see Namet), and T is reserved for use by implicit + -- types. and X is reserved for use by debug type encoding (see package + -- Exp_Dbug). Note: the reason that Prefix is last is that it is almost + -- always omitted. The notable case of Prefix being non-null is when + -- it is 'T' for an implicit type. + + -- Suffix_Index'Image is appended only if the value of Suffix_Index is + -- positive, or if Suffix_Index is negative 1, then a unique serialized + -- suffix is added. If Suffix_Index is zero, then no index is appended. + + -- Suffix is also a single upper case letter other than O,Q,U,W,X and is a + -- required parameter (T is permitted). The constructed name is stored + -- using Find_Name so that it can be located using a subsequent Find_Name + -- operation (i.e. it is properly hashed into the names table). The upper + -- case letter given as the Suffix argument ensures that the name does + -- not clash with any Ada identifier name. These generated names are + -- permitted, but not required, to be made public by setting the flag + -- Is_Public in the associated entity. + + function New_External_Name + (Suffix : Character; + Suffix_Index : Nat) + return Name_Id; + -- Builds a new entry in the names table of the form + -- Suffix & Suffix_Index'Image + -- where Suffix is a single upper case letter other than O,Q,U,W,X and is + -- a required parameter (T is permitted). The constructed name is stored + -- using Find_Name so that it can be located using a subsequent Find_Name + -- operation (i.e. it is properly hashed into the names table). The upper + -- case letter given as the Suffix argument ensures that the name does + -- not clash with any Ada identifier name. These generated names are + -- permitted, but not required, to be made public by setting the flag + -- Is_Public in the associated entity. + + function New_Internal_Name (Id_Char : Character) return Name_Id; + -- Id_Char is an upper case letter other than O,Q,U,W (which are reserved + -- for identifier encoding (see Namet package for details) and X which is + -- used for debug encoding (see Exp_Dbug). The letter T is permitted, but + -- is reserved by convention for the case of internally generated types. + -- The result of the call is a new generated unique name of the form XyyyU + -- where X is Id_Char, yyy is a unique serial number, and U is either a + -- lower case s or b indicating if the current unit is a spec or a body. + -- + -- The name is entered into the names table using Name_Enter rather than + -- Name_Find, because there can never be a need to locate the entry using + -- the Name_Find procedure later on. Names created by New_Internal_Name + -- are guaranteed to be consistent from one compilation to another (i.e. + -- if the identical unit is compiled with a semantically consistent set + -- of sources, the numbers will be consistent. This means that it is fine + -- to use these as public symbols. + + function New_Suffixed_Name + (Related_Id : Name_Id; + Suffix : String) + return Name_Id; + -- This function is used to create special suffixed names used by the + -- debugger. Suffix is a string of upper case letters, used to construct + -- the required name. For instance, the special type used to record the + -- fixed-point small is called typ_SMALL where typ is the name of the + -- fixed-point type (as passed in Related_Id), and Suffix is "SMALL". + + function New_Occurrence_Of + (Def_Id : Entity_Id; + Loc : Source_Ptr) + return Node_Id; + -- New_Occurrence_Of creates an N_Identifier node which is an + -- occurrence of the defining identifier which is passed as its + -- argument. The Entity and Etype of the result are set from + -- the given defining identifier as follows: Entity is simply + -- a copy of Def_Id. Etype is a copy of Def_Id for types, and + -- a copy of the Etype of Def_Id for other entities. + + function New_Reference_To + (Def_Id : Entity_Id; + Loc : Source_Ptr) + return Node_Id; + -- This is like New_Occurrence_Of, but it does not set the Etype field. + -- It is used from the expander, where Etype fields are generally not set, + -- since they are set when the expanded tree is reanalyzed. + + function Checks_Off (N : Node_Id) return Node_Id; + pragma Inline (Checks_Off); + -- Returns an N_Unchecked_Expression node whose expression is the given + -- argument. The results is a subexpression identical to the argument, + -- except that it will be analyzed and resolved with checks off. + + function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; + -- Returns an expression that represents the result of a checked convert + -- of expression Exp to type T. If the base type of Exp is T, then no + -- conversion is required, and Exp is returned unchanged. Otherwise an + -- N_Type_Conversion node is constructed to convert the expression. + -- If an N_Type_Conversion node is required, Relocate_Node is used on + -- Exp. This means that it is safe to replace a node by a Convert_To + -- of itself to some other type. + + function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; + -- Like Convert_To, except that a conversion node is always generated, + -- and the Conversion_OK flag is set on this conversion node. + + function Unchecked_Convert_To + (Typ : Entity_Id; + Expr : Node_Id) + return Node_Id; + -- Like Convert_To, but if a conversion is actually needed, constructs + -- an N_Unchecked_Type_Conversion node to do the required conversion. + +end Tbuild; diff --git a/gcc/ada/text_io.ads b/gcc/ada/text_io.ads new file mode 100644 index 00000000000..7715464f826 --- /dev/null +++ b/gcc/ada/text_io.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_95; +with Ada.Text_IO; + +package Text_IO renames Ada.Text_IO; diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c new file mode 100644 index 00000000000..1ea4b8025ea --- /dev/null +++ b/gcc/ada/tracebak.c @@ -0,0 +1,1177 @@ +/**************************************************************************** + * * + * 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 diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c new file mode 100644 index 00000000000..572dff2645c --- /dev/null +++ b/gcc/ada/trans.c @@ -0,0 +1,5428 @@ +/**************************************************************************** + * * + * 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; + +/* 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); +} + + +/* 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; +} + +/* 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; +} + +/* 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)); +} + +/* 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)); + } +} + +/* 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); + } + } +} + +/* 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); + } +} + +/* 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))); +} + +/* 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); +} + +/* 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); +} + +/* 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)))); +} + +/* 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); +} + +/* 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; + } +} + +/* 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)); + } +} + +/* 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)); +} + +/* 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)); +} + +/* 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; +} + +/* 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); +} + +/* 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; +} + +/* 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; +} + +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); +} + +/* 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); +} + +/* 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; +} + +/* 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); +} + +/* 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; +} diff --git a/gcc/ada/tree_gen.adb b/gcc/ada/tree_gen.adb new file mode 100644 index 00000000000..fc54b0e45c2 --- /dev/null +++ b/gcc/ada/tree_gen.adb @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E _ G E N -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- Copyright (C) 1992-1999, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; +with Elists; +with Fname; +with Lib; +with Namet; +with Nlists; +with Opt; +with Osint; +with Repinfo; +with Sinput; +with Stand; +with Stringt; +with Uintp; +with Urealp; + +procedure Tree_Gen is +begin + if Opt.Tree_Output then + Osint.Tree_Create; + Opt.Tree_Write; + Atree.Tree_Write; + Elists.Tree_Write; + Fname.Tree_Write; + Lib.Tree_Write; + Namet.Tree_Write; + Nlists.Tree_Write; + Sinput.Tree_Write; + Stand.Tree_Write; + Stringt.Tree_Write; + Uintp.Tree_Write; + Urealp.Tree_Write; + Repinfo.Tree_Write; + Osint.Tree_Close; + end if; +end Tree_Gen; diff --git a/gcc/ada/tree_gen.ads b/gcc/ada/tree_gen.ads new file mode 100644 index 00000000000..0d3afe08380 --- /dev/null +++ b/gcc/ada/tree_gen.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E _ G E N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This procedure is used to write out the tree if the option is set + +procedure Tree_Gen; diff --git a/gcc/ada/tree_in.adb b/gcc/ada/tree_in.adb new file mode 100644 index 00000000000..368cf5a2f48 --- /dev/null +++ b/gcc/ada/tree_in.adb @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E _ I N -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- Copyright (C) 1992-1999, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; +with Csets; +with Elists; +with Fname; +with Lib; +with Namet; +with Nlists; +with Opt; +with Repinfo; +with Sinput; +with Stand; +with Stringt; +with Tree_IO; +with Uintp; +with Urealp; + +procedure Tree_In (Desc : File_Descriptor) is +begin + Tree_IO.Tree_Read_Initialize (Desc); + Opt.Tree_Read; + Atree.Tree_Read; + Elists.Tree_Read; + Fname.Tree_Read; + Lib.Tree_Read; + Namet.Tree_Read; + Nlists.Tree_Read; + Sinput.Tree_Read; + Stand.Tree_Read; + Stringt.Tree_Read; + Uintp.Tree_Read; + Urealp.Tree_Read; + Repinfo.Tree_Read; + Csets.Initialize; +end Tree_In; diff --git a/gcc/ada/tree_in.ads b/gcc/ada/tree_in.ads new file mode 100644 index 00000000000..932794ce42f --- /dev/null +++ b/gcc/ada/tree_in.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E _ I N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This procedure is used to read in a tree if the option is set. Note that +-- it is not part of the compiler proper, but rather the interface from +-- tools that need to read the tree to the tree reading routines, and is +-- thus bound as part of such tools. + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +procedure Tree_In (Desc : File_Descriptor); +-- Desc is the file descriptor for the file containing the tree, as written +-- by the compiler in a previous compilation using Tree_Gen. On return the +-- global data structures are appropriately initialized. diff --git a/gcc/ada/tree_io.adb b/gcc/ada/tree_io.adb new file mode 100644 index 00000000000..5f4c30fae77 --- /dev/null +++ b/gcc/ada/tree_io.adb @@ -0,0 +1,661 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E _ I O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.13 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Output; use Output; +with Unchecked_Conversion; + +package body Tree_IO is + Debug_Flag_Tree : Boolean := False; + -- Debug flag for debug output from tree read/write + + ------------------------------------------- + -- Compression Scheme Used for Tree File -- + ------------------------------------------- + + -- We don't just write the data directly, but instead do a mild form + -- of compression, since we expect lots of compressible zeroes and + -- blanks. The compression scheme is as follows: + + -- 00nnnnnn followed by nnnnnn bytes (non compressed data) + -- 01nnnnnn indicates nnnnnn binary zero bytes + -- 10nnnnnn indicates nnnnnn ASCII space bytes + -- 11nnnnnn bbbbbbbb indicates nnnnnnnn occurrences of byte bbbbbbbb + + -- Since we expect many zeroes in trees, and many spaces in sources, + -- this compression should be reasonably efficient. We can put in + -- something better later on. + + -- Note that this compression applies to the Write_Tree_Data and + -- Read_Tree_Data calls, not to the calls to read and write single + -- scalar values, which are written in memory format without any + -- compression. + + C_Noncomp : constant := 2#00_000000#; + C_Zeros : constant := 2#01_000000#; + C_Spaces : constant := 2#10_000000#; + C_Repeat : constant := 2#11_000000#; + -- Codes for compression sequences + + Max_Count : constant := 63; + -- Maximum data length for one compression sequence + + Max_Comp : constant := Max_Count + 1; + -- Maximum length of one compression sequence + + -- The above compression scheme applies only to data written with the + -- Tree_Write routine and read with Tree_Read. Data written using the + -- Tree_Write_Char or Tree_Write_Int routines and read using the + -- corresponding input routines is not compressed. + + type Int_Bytes is array (1 .. 4) of Byte; + for Int_Bytes'Size use 32; + + function To_Int_Bytes is new Unchecked_Conversion (Int, Int_Bytes); + function To_Int is new Unchecked_Conversion (Int_Bytes, Int); + + ---------------------- + -- Global Variables -- + ---------------------- + + Tree_FD : File_Descriptor; + -- File descriptor for tree + + Buflen : constant Int := 8_192; + -- Length of buffer for read and write file data + + Buf : array (Pos range 1 .. Buflen) of Byte; + -- Read/write file data buffer + + Bufn : Nat; + -- Number of bytes read/written from/to buffer + + Buft : Nat; + -- Total number of bytes in input buffer containing valid data. Used only + -- for input operations. There is data left to be processed in the buffer + -- if Buft > Bufn. A value of zero for Buft means that the buffer is empty. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Read_Buffer; + -- Reads data into buffer, setting Bufe appropriately + + function Read_Byte return Byte; + pragma Inline (Read_Byte); + -- Returns next byte from input file, raises Tree_Format_Error if none left + + procedure Write_Buffer; + -- Writes out current buffer contents + + procedure Write_Byte (B : Byte); + pragma Inline (Write_Byte); + -- Write one byte to output buffer, checking for buffer-full condition + + ----------------- + -- Read_Buffer -- + ----------------- + + procedure Read_Buffer is + begin + Buft := Int (Read (Tree_FD, Buf (1)'Address, Integer (Buflen))); + + if Buft = 0 then + raise Tree_Format_Error; + else + Bufn := 0; + end if; + end Read_Buffer; + + --------------- + -- Read_Byte -- + --------------- + + function Read_Byte return Byte is + begin + if Bufn = Buft then + Read_Buffer; + end if; + + Bufn := Bufn + 1; + return Buf (Bufn); + end Read_Byte; + + -------------------- + -- Tree_Read_Bool -- + -------------------- + + procedure Tree_Read_Bool (B : out Boolean) is + begin + B := Boolean'Val (Read_Byte); + + if Debug_Flag_Tree then + if B then + Write_Str ("True"); + else + Write_Str ("False"); + end if; + + Write_Eol; + end if; + end Tree_Read_Bool; + + -------------------- + -- Tree_Read_Char -- + -------------------- + + procedure Tree_Read_Char (C : out Character) is + begin + C := Character'Val (Read_Byte); + + if Debug_Flag_Tree then + Write_Str ("==> transmitting Character = "); + Write_Char (C); + Write_Eol; + end if; + end Tree_Read_Char; + + -------------------- + -- Tree_Read_Data -- + -------------------- + + procedure Tree_Read_Data (Addr : Address; Length : Int) is + + type S is array (Pos) of Byte; + -- This is a big array, for which we have to suppress the warning + + type SP is access all S; + + function To_SP is new Unchecked_Conversion (Address, SP); + + Data : constant SP := To_SP (Addr); + -- Data buffer to be read as an indexable array of bytes + + OP : Pos := 1; + -- Pointer to next byte of data buffer to be read into + + B : Byte; + C : Byte; + L : Int; + + begin + if Debug_Flag_Tree then + Write_Str ("==> transmitting "); + Write_Int (Length); + Write_Str (" data bytes"); + Write_Eol; + end if; + + -- Verify data length + + Tree_Read_Int (L); + + if L /= Length then + Write_Str ("==> transmitting, expected "); + Write_Int (Length); + Write_Str (" bytes, found length = "); + Write_Int (L); + Write_Eol; + raise Tree_Format_Error; + end if; + + -- Loop to read data + + while OP <= Length loop + + -- Get compression control character + + B := Read_Byte; + C := B and 2#00_111111#; + B := B and 2#11_000000#; + + -- Non-repeat case + + if B = C_Noncomp then + if Debug_Flag_Tree then + Write_Str ("==> uncompressed: "); + Write_Int (Int (C)); + Write_Str (", starting at "); + Write_Int (OP); + Write_Eol; + end if; + + for J in 1 .. C loop + Data (OP) := Read_Byte; + OP := OP + 1; + end loop; + + -- Repeated zeroes + + elsif B = C_Zeros then + if Debug_Flag_Tree then + Write_Str ("==> zeroes: "); + Write_Int (Int (C)); + Write_Str (", starting at "); + Write_Int (OP); + Write_Eol; + end if; + + for J in 1 .. C loop + Data (OP) := 0; + OP := OP + 1; + end loop; + + -- Repeated spaces + + elsif B = C_Spaces then + if Debug_Flag_Tree then + Write_Str ("==> spaces: "); + Write_Int (Int (C)); + Write_Str (", starting at "); + Write_Int (OP); + Write_Eol; + end if; + + for J in 1 .. C loop + Data (OP) := Character'Pos (' '); + OP := OP + 1; + end loop; + + -- Specified repeated character + + else -- B = C_Repeat + B := Read_Byte; + + if Debug_Flag_Tree then + Write_Str ("==> other char: "); + Write_Int (Int (C)); + Write_Str (" ("); + Write_Int (Int (B)); + Write_Char (')'); + Write_Str (", starting at "); + Write_Int (OP); + Write_Eol; + end if; + + for J in 1 .. C loop + Data (OP) := B; + OP := OP + 1; + end loop; + end if; + end loop; + + -- At end of loop, data item must be exactly filled + + if OP /= Length + 1 then + raise Tree_Format_Error; + end if; + + end Tree_Read_Data; + + -------------------------- + -- Tree_Read_Initialize -- + -------------------------- + + procedure Tree_Read_Initialize (Desc : File_Descriptor) is + begin + Buft := 0; + Bufn := 0; + Tree_FD := Desc; + Debug_Flag_Tree := Debug_Flag_5; + end Tree_Read_Initialize; + + ------------------- + -- Tree_Read_Int -- + ------------------- + + procedure Tree_Read_Int (N : out Int) is + N_Bytes : Int_Bytes; + + begin + for J in 1 .. 4 loop + N_Bytes (J) := Read_Byte; + end loop; + + N := To_Int (N_Bytes); + + if Debug_Flag_Tree then + Write_Str ("==> transmitting Int = "); + Write_Int (N); + Write_Eol; + end if; + end Tree_Read_Int; + + ------------------- + -- Tree_Read_Str -- + ------------------- + + procedure Tree_Read_Str (S : out String_Ptr) is + N : Nat; + + begin + Tree_Read_Int (N); + S := new String (1 .. Natural (N)); + Tree_Read_Data (S.all (1)'Address, N); + end Tree_Read_Str; + + ------------------------- + -- Tree_Read_Terminate -- + ------------------------- + + procedure Tree_Read_Terminate is + begin + -- Must be at end of input buffer, so we should get Tree_Format_Error + -- if we try to read one more byte, if not, we have a format error. + + declare + B : Byte; + begin + B := Read_Byte; + exception + when Tree_Format_Error => return; + end; + + raise Tree_Format_Error; + end Tree_Read_Terminate; + + --------------------- + -- Tree_Write_Bool -- + --------------------- + + procedure Tree_Write_Bool (B : Boolean) is + begin + if Debug_Flag_Tree then + Write_Str ("==> transmitting Boolean = "); + + if B then + Write_Str ("True"); + else + Write_Str ("False"); + end if; + + Write_Eol; + end if; + + Write_Byte (Boolean'Pos (B)); + end Tree_Write_Bool; + + --------------------- + -- Tree_Write_Char -- + --------------------- + + procedure Tree_Write_Char (C : Character) is + begin + if Debug_Flag_Tree then + Write_Str ("==> transmitting Character = "); + Write_Char (C); + Write_Eol; + end if; + + Write_Byte (Character'Pos (C)); + end Tree_Write_Char; + + --------------------- + -- Tree_Write_Data -- + --------------------- + + procedure Tree_Write_Data (Addr : Address; Length : Int) is + + type S is array (Pos) of Byte; + -- This is a big array, for which we have to suppress the warning + + type SP is access all S; + + function To_SP is new Unchecked_Conversion (Address, SP); + + Data : constant SP := To_SP (Addr); + -- Pointer to data to be written, converted to array type + + IP : Pos := 1; + -- Input buffer pointer, next byte to be processed + + NC : Nat range 0 .. Max_Count := 0; + -- Number of bytes of non-compressible sequence + + C : Byte; + + procedure Write_Non_Compressed_Sequence; + -- Output currently collected sequence of non-compressible data + + procedure Write_Non_Compressed_Sequence is + begin + if NC > 0 then + Write_Byte (C_Noncomp + Byte (NC)); + + if Debug_Flag_Tree then + Write_Str ("==> uncompressed: "); + Write_Int (NC); + Write_Str (", starting at "); + Write_Int (IP - NC); + Write_Eol; + end if; + + for J in reverse 1 .. NC loop + Write_Byte (Data (IP - J)); + end loop; + + NC := 0; + end if; + end Write_Non_Compressed_Sequence; + + -- Start of processing for Tree_Write_Data + + begin + if Debug_Flag_Tree then + Write_Str ("==> transmitting "); + Write_Int (Length); + Write_Str (" data bytes"); + Write_Eol; + end if; + + -- We write the count at the start, so that we can check it on + -- the corresponding read to make sure that reads and writes match + + Tree_Write_Int (Length); + + -- Conversion loop + -- IP is index of next input character + -- NC is number of non-compressible bytes saved up + + loop + -- If input is completely processed, then we are all done + + if IP > Length then + Write_Non_Compressed_Sequence; + return; + end if; + + -- Test for compressible sequence, must be at least three identical + -- bytes in a row to be worthwhile compressing. + + if IP + 2 <= Length + and then Data (IP) = Data (IP + 1) + and then Data (IP) = Data (IP + 2) + then + Write_Non_Compressed_Sequence; + + -- Count length of new compression sequence + + C := 3; + IP := IP + 3; + + while IP < Length + and then Data (IP) = Data (IP - 1) + and then C < Max_Count + loop + C := C + 1; + IP := IP + 1; + end loop; + + -- Output compression sequence + + if Data (IP - 1) = 0 then + if Debug_Flag_Tree then + Write_Str ("==> zeroes: "); + Write_Int (Int (C)); + Write_Str (", starting at "); + Write_Int (IP - Int (C)); + Write_Eol; + end if; + + Write_Byte (C_Zeros + C); + + elsif Data (IP - 1) = Character'Pos (' ') then + if Debug_Flag_Tree then + Write_Str ("==> spaces: "); + Write_Int (Int (C)); + Write_Str (", starting at "); + Write_Int (IP - Int (C)); + Write_Eol; + end if; + + Write_Byte (C_Spaces + C); + + else + if Debug_Flag_Tree then + Write_Str ("==> other char: "); + Write_Int (Int (C)); + Write_Str (" ("); + Write_Int (Int (Data (IP - 1))); + Write_Char (')'); + Write_Str (", starting at "); + Write_Int (IP - Int (C)); + Write_Eol; + end if; + + Write_Byte (C_Repeat + C); + Write_Byte (Data (IP - 1)); + end if; + + -- No compression possible here + + else + -- Output non-compressed sequence if at maximum length + + if NC = Max_Count then + Write_Non_Compressed_Sequence; + end if; + + NC := NC + 1; + IP := IP + 1; + end if; + end loop; + + end Tree_Write_Data; + + --------------------------- + -- Tree_Write_Initialize -- + --------------------------- + + procedure Tree_Write_Initialize (Desc : File_Descriptor) is + begin + Bufn := 0; + Tree_FD := Desc; + Set_Standard_Error; + Debug_Flag_Tree := Debug_Flag_5; + end Tree_Write_Initialize; + + -------------------- + -- Tree_Write_Int -- + -------------------- + + procedure Tree_Write_Int (N : Int) is + N_Bytes : constant Int_Bytes := To_Int_Bytes (N); + + begin + if Debug_Flag_Tree then + Write_Str ("==> transmitting Int = "); + Write_Int (N); + Write_Eol; + end if; + + for J in 1 .. 4 loop + Write_Byte (N_Bytes (J)); + end loop; + end Tree_Write_Int; + + -------------------- + -- Tree_Write_Str -- + -------------------- + + procedure Tree_Write_Str (S : String_Ptr) is + begin + Tree_Write_Int (S'Length); + Tree_Write_Data (S (1)'Address, S'Length); + end Tree_Write_Str; + + -------------------------- + -- Tree_Write_Terminate -- + -------------------------- + + procedure Tree_Write_Terminate is + begin + if Bufn > 0 then + Write_Buffer; + end if; + end Tree_Write_Terminate; + + ------------------ + -- Write_Buffer -- + ------------------ + + procedure Write_Buffer is + begin + if Integer (Bufn) = Write (Tree_FD, Buf'Address, Integer (Bufn)) then + Bufn := 0; + + else + Set_Standard_Error; + Write_Str ("fatal error: disk full"); + OS_Exit (2); + end if; + end Write_Buffer; + + ---------------- + -- Write_Byte -- + ---------------- + + procedure Write_Byte (B : Byte) is + begin + Bufn := Bufn + 1; + Buf (Bufn) := B; + + if Bufn = Buflen then + Write_Buffer; + end if; + end Write_Byte; + +end Tree_IO; diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads new file mode 100644 index 00000000000..28fd07aefef --- /dev/null +++ b/gcc/ada/tree_io.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines used to read and write the tree files +-- used by ASIS. Only the actual read and write routines are here. The open, +-- create and close routines are elsewhere (in Osint in the compiler, and in +-- the tree read driver for the tree read interface). + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with System; use System; +with Types; use Types; + +package Tree_IO is + + Tree_Format_Error : exception; + -- Raised if a format error is detected in the input file + + procedure Tree_Read_Initialize (Desc : File_Descriptor); + -- Called to initialize reading of a tree file. This call must be made + -- before calls to Tree_Read_xx. No calls to Tree_Write_xx are permitted + -- after this call. + + procedure Tree_Read_Data (Addr : Address; Length : Int); + -- Checks that the Length provided is the same as what has been provided + -- to the corresponding Tree_Write_Data from the current tree file, + -- Tree_Format_Error is raised if it is not the case. If Length is + -- correct and non zero, reads Length bytes of information into memory + -- starting at Addr from the current tree file. + + procedure Tree_Read_Bool (B : out Boolean); + -- Reads a single boolean value. The boolean value must have been written + -- with a call to the Tree_Write_Bool procedure. + + procedure Tree_Read_Char (C : out Character); + -- Reads a single character. The character must have been written with a + -- call to the Tree_Write_Char procedure. + + procedure Tree_Read_Int (N : out Int); + -- Reads a single integer value. The integer must have been written with + -- a call to the Tree_Write_Int procedure. + + procedure Tree_Read_Str (S : out String_Ptr); + -- Read string, allocate on heap, and return pointer to allocated string + -- which always has a lower bound of 1. + + procedure Tree_Read_Terminate; + -- Called after reading all data, checks that the buffer pointers is at + -- the end of file, raising Tree_Format_Error if not. + + procedure Tree_Write_Initialize (Desc : File_Descriptor); + -- Called to initialize writing of a tree file. This call must be made + -- before calls to Tree_Write_xx. No calls to Tree_Read_xx are permitted + -- after this call. + + procedure Tree_Write_Data (Addr : Address; Length : Int); + -- Writes Length then, if Length is not null, Length bytes of data + -- starting at Addr to current tree file + + procedure Tree_Write_Bool (B : Boolean); + -- Writes a single boolean value to the current tree file + + procedure Tree_Write_Char (C : Character); + -- Writes a single character to the current tree file + + procedure Tree_Write_Int (N : Int); + -- Writes a single integer value to the current tree file + + procedure Tree_Write_Str (S : String_Ptr); + -- Write out string value referenced by S. Low bound must be 1. + + procedure Tree_Write_Terminate; + -- Terminates writing of the file (flushing the buffer), but does not + -- close the file (the caller is responsible for closing the file). + +end Tree_IO; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb new file mode 100644 index 00000000000..80954c9e660 --- /dev/null +++ b/gcc/ada/treepr.adb @@ -0,0 +1,1873 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads new file mode 100644 index 00000000000..b2a8c6fdd9c --- /dev/null +++ b/gcc/ada/treepr.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E P R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.14 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; +package Treepr is + +-- This package provides printing routines for the abstract syntax tree +-- These routines are intended only for debugging use. + + procedure Tree_Dump; + -- This routine is called from the GNAT main program to dump trees as + -- requested by debug options (including tree of Standard if requested). + + procedure Print_Tree_Node (N : Node_Id; Label : String := ""); + -- Prints a single tree node, without printing descendants. The Label + -- string is used to preface each line of the printed output. + + procedure Print_Tree_List (L : List_Id); + -- Prints a single node list, without printing the descendants of any + -- of the nodes in the list + + procedure Print_Tree_Elist (E : Elist_Id); + -- Prints a single node list, without printing the descendants of any + -- of the nodes in the list + + procedure Print_Node_Subtree (N : Node_Id); + -- Prints the subtree routed at a specified tree node, including all + -- referenced descendants. + + procedure Print_List_Subtree (L : List_Id); + -- Prints the subtree consisting of the given node list and all its + -- referenced descendants. + + procedure Print_Elist_Subtree (E : Elist_Id); + -- Prints the subtree consisting of the given element list and all its + -- referenced descendants. + + procedure PE (E : Elist_Id); + -- Debugging procedure (to be called within gdb) + -- same as Print_Tree_Elist + + procedure PL (L : List_Id); + -- Debugging procedure (to be called within gdb) + -- same as Print_Tree_List + + procedure PN (N : Node_Id); + -- Debugging procedure (to be called within gdb) + -- same as Print_Tree_Node with Label = "" + + procedure PT (N : Node_Id); + -- Debugging procedure (to be called within gdb) + -- same as Print_Node_Subtree + +end Treepr; diff --git a/gcc/ada/treeprs.ads b/gcc/ada/treeprs.ads new file mode 100644 index 00000000000..1afdb8782a6 --- /dev/null +++ b/gcc/ada/treeprs.ads @@ -0,0 +1,795 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E P R S -- +-- -- +-- S p e c -- +-- -- +-- Generated by xtreeprs revision 1.31 using -- +-- sinfo.ads revision 1.430 -- +-- treeprs.adt revision 1.17 -- +-- -- +-- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + + +-- This package contains the declaration of the string used by the Tree_Print +-- package. It must be updated whenever the arrangements of the field names +-- in package Sinfo is changed. The utility program XTREEPRS is used to +-- do this update correctly using the template treeprs.adt as input. + +with Sinfo; use Sinfo; + +package Treeprs is + + -------------------------------- + -- String Data for Node Print -- + -------------------------------- + + -- String data for print out. The Pchars array is a long string with the + -- the entry for each node type consisting of a single blank, followed by + -- a series of entries, one for each Op or Flag field used for the node. + -- Each entry has a single character which identifies the field, followed + -- by the synonym name. The starting location for a given node type is + -- found from the corresponding entry in the Pchars_Pos_Array. + + -- The following characters identify the field. These are characters + -- which could never occur in a field name, so they also mark the + -- end of the previous name. + + subtype Fchar is Character range '#' .. '9'; + + F_Field1 : constant Fchar := '#'; -- Character'Val (16#23#) + F_Field2 : constant Fchar := '$'; -- Character'Val (16#24#) + F_Field3 : constant Fchar := '%'; -- Character'Val (16#25#) + F_Field4 : constant Fchar := '&'; -- Character'Val (16#26#) + F_Field5 : constant Fchar := '''; -- Character'Val (16#27#) + F_Flag1 : constant Fchar := '('; -- Character'Val (16#28#) + F_Flag2 : constant Fchar := ')'; -- Character'Val (16#29#) + F_Flag3 : constant Fchar := '*'; -- Character'Val (16#2A#) + F_Flag4 : constant Fchar := '+'; -- Character'Val (16#2B#) + F_Flag5 : constant Fchar := ','; -- Character'Val (16#2C#) + F_Flag6 : constant Fchar := '-'; -- Character'Val (16#2D#) + F_Flag7 : constant Fchar := '.'; -- Character'Val (16#2E#) + F_Flag8 : constant Fchar := '/'; -- Character'Val (16#2F#) + F_Flag9 : constant Fchar := '0'; -- Character'Val (16#30#) + F_Flag10 : constant Fchar := '1'; -- Character'Val (16#31#) + F_Flag11 : constant Fchar := '2'; -- Character'Val (16#32#) + F_Flag12 : constant Fchar := '3'; -- Character'Val (16#33#) + F_Flag13 : constant Fchar := '4'; -- Character'Val (16#34#) + F_Flag14 : constant Fchar := '5'; -- Character'Val (16#35#) + F_Flag15 : constant Fchar := '6'; -- Character'Val (16#36#) + F_Flag16 : constant Fchar := '7'; -- Character'Val (16#37#) + F_Flag17 : constant Fchar := '8'; -- Character'Val (16#38#) + F_Flag18 : constant Fchar := '9'; -- Character'Val (16#39#) + + -- Note this table does not include entity field and flags whose access + -- functions are in Einfo (these are handled by the Print_Entity_Info + -- procedure in Treepr, which uses the routines in Einfo to get the + -- proper symbolic information). In addition, the following fields are + -- handled by Treepr, and do not appear in the Pchars array: + + -- Analyzed + -- Cannot_Be_Constant + -- Chars + -- Comes_From_Source + -- Error_Posted + -- Etype + -- Is_Controlling_Actual + -- Is_Overloaded + -- Is_Static_Expression + -- Left_Opnd + -- Must_Check_Expr + -- Must_Not_Freeze + -- No_Overflow_Expr + -- Paren_Count + -- Raises_Constraint_Error + -- Right_Opnd + + Pchars : constant String := + -- Unused_At_Start + "" & + -- At_Clause + "#Identifier%Expression" & + -- Component_Clause + "#Component_Name$Position%First_Bit&Last_Bit" & + -- Enumeration_Representation_Clause + "#Identifier%Array_Aggregate&Next_Rep_Item" & + -- Mod_Clause + "%Expression&Pragmas_Before" & + -- Record_Representation_Clause + "#Identifier$Mod_Clause%Component_Clauses&Next_Rep_Item" & + -- Attribute_Definition_Clause + "$Name%Expression&Next_Rep_Item+From_At_Mod" & + -- Empty + "" & + -- Error + "" & + -- Pragma + "$Pragma_Argument_Associations%Debug_Statement&Next_Rep_Item" & + -- Pragma_Argument_Association + "%Expression" & + -- Defining_Character_Literal + "$Next_Entity%Scope" & + -- Defining_Identifier + "$Next_Entity%Scope" & + -- Defining_Operator_Symbol + "$Next_Entity%Scope" & + -- Expanded_Name + "%Prefix$Selector_Name&Entity4Redundant_Use2Has_Private_View" & + -- Identifier + "&Entity$Original_Discriminant4Redundant_Use2Has_Private_View" & + -- Operator_Symbol + "%Strval&Entity2Has_Private_View" & + -- Character_Literal + "$Char_Literal_Value&Entity2Has_Private_View" & + -- Op_Add + "" & + -- Op_Concat + "4Is_Component_Left_Opnd5Is_Component_Right_Opnd" & + -- Op_Divide + "5Treat_Fixed_As_Integer4Do_Division_Check9Rounded_Result" & + -- Op_Expon + "4Is_Power_Of_2_For_Shift" & + -- Op_Mod + "5Treat_Fixed_As_Integer4Do_Division_Check" & + -- Op_Multiply + "5Treat_Fixed_As_Integer9Rounded_Result" & + -- Op_Rem + "5Treat_Fixed_As_Integer4Do_Division_Check" & + -- Op_Subtract + "" & + -- Op_And + "+Do_Length_Check" & + -- Op_Eq + "" & + -- Op_Ge + "" & + -- Op_Gt + "" & + -- Op_Le + "" & + -- Op_Lt + "" & + -- Op_Ne + "" & + -- Op_Or + "+Do_Length_Check" & + -- Op_Xor + "+Do_Length_Check" & + -- Op_Rotate_Left + "+Shift_Count_OK" & + -- Op_Rotate_Right + "+Shift_Count_OK" & + -- Op_Shift_Left + "+Shift_Count_OK" & + -- Op_Shift_Right + "+Shift_Count_OK" & + -- Op_Shift_Right_Arithmetic + "+Shift_Count_OK" & + -- Op_Abs + "" & + -- Op_Minus + "" & + -- Op_Not + "" & + -- Op_Plus + "" & + -- Attribute_Reference + "%Prefix$Attribute_Name#Expressions&Entity2Do_Access_Check8Do_Overflow" & + "_Check4Redundant_Use+OK_For_Stream" & + -- And_Then + "#Actions" & + -- Conditional_Expression + "#Expressions$Then_Actions%Else_Actions" & + -- Explicit_Dereference + "%Prefix2Do_Access_Check" & + -- Function_Call + "$Name%Parameter_Associations&First_Named_Actual#Controlling_Argument4" & + "Do_Tag_Check8Parameter_List_Truncated9ABE_Is_Certain" & + -- In + "" & + -- Indexed_Component + "%Prefix#Expressions2Do_Access_Check" & + -- Integer_Literal + "%Intval4Print_In_Hex" & + -- Not_In + "" & + -- Null + "" & + -- Or_Else + "#Actions" & + -- Procedure_Call_Statement + "$Name%Parameter_Associations&First_Named_Actual#Controlling_Argument4" & + "Do_Tag_Check8Parameter_List_Truncated9ABE_Is_Certain" & + -- Qualified_Expression + "&Subtype_Mark%Expression" & + -- Raise_Constraint_Error + "#Condition" & + -- Raise_Program_Error + "#Condition" & + -- Raise_Storage_Error + "#Condition" & + -- Aggregate + "#Expressions$Component_Associations8Null_Record_Present%Aggregate_Bou" & + "nds+Static_Processing_OK9Compile_Time_Known_Aggregate2Expansion_De" & + "layed" & + -- Allocator + "%Expression#Storage_Pool&Procedure_To_Call4No_Initialization8Do_Stora" & + "ge_Check" & + -- Extension_Aggregate + "%Ancestor_Part#Expressions$Component_Associations8Null_Record_Present" & + "2Expansion_Delayed" & + -- Range + "#Low_Bound$High_Bound2Includes_Infinities" & + -- Real_Literal + "%Realval&Corresponding_Integer_Value2Is_Machine_Number" & + -- Reference + "%Prefix" & + -- Selected_Component + "%Prefix$Selector_Name2Do_Access_Check4Do_Discriminant_Check" & + -- Slice + "%Prefix&Discrete_Range2Do_Access_Check" & + -- String_Literal + "%Strval2Has_Wide_Character" & + -- Subprogram_Info + "#Identifier" & + -- Type_Conversion + "&Subtype_Mark%Expression8Do_Overflow_Check4Do_Tag_Check+Do_Length_Che" & + "ck2Float_Truncate9Rounded_Result5Conversion_OK" & + -- Unchecked_Expression + "%Expression" & + -- Unchecked_Type_Conversion + "&Subtype_Mark%Expression2Kill_Range_Check" & + -- Subtype_Indication + "&Subtype_Mark%Constraint/Must_Not_Freeze" & + -- Component_Declaration + "#Defining_Identifier+Aliased_Present'Subtype_Indication%Expression,Mo" & + "re_Ids-Prev_Ids" & + -- Entry_Declaration + "#Defining_Identifier&Discrete_Subtype_Definition%Parameter_Specificat" & + "ions" & + -- Formal_Object_Declaration + "#Defining_Identifier6In_Present8Out_Present&Subtype_Mark%Expression,M" & + "ore_Ids-Prev_Ids" & + -- Formal_Type_Declaration + "#Defining_Identifier%Formal_Type_Definition&Discriminant_Specificatio" & + "ns4Unknown_Discriminants_Present" & + -- Full_Type_Declaration + "#Defining_Identifier&Discriminant_Specifications%Type_Definition2Disc" & + "r_Check_Funcs_Built" & + -- Incomplete_Type_Declaration + "#Defining_Identifier&Discriminant_Specifications4Unknown_Discriminant" & + "s_Present" & + -- Loop_Parameter_Specification + "#Defining_Identifier6Reverse_Present&Discrete_Subtype_Definition" & + -- Object_Declaration + "#Defining_Identifier+Aliased_Present8Constant_Present&Object_Definiti" & + "on%Expression$Handler_List_Entry'Corresponding_Generic_Association" & + ",More_Ids-Prev_Ids4No_Initialization6Assignment_OK2Exception_Junk5" & + "Delay_Finalize_Attach7Is_Subprogram_Descriptor" & + -- Protected_Type_Declaration + "#Defining_Identifier&Discriminant_Specifications%Protected_Definition" & + "'Corresponding_Body" & + -- Private_Extension_Declaration + "#Defining_Identifier&Discriminant_Specifications4Unknown_Discriminant" & + "s_Present+Abstract_Present'Subtype_Indication" & + -- Private_Type_Declaration + "#Defining_Identifier&Discriminant_Specifications4Unknown_Discriminant" & + "s_Present+Abstract_Present6Tagged_Present8Limited_Present" & + -- Subtype_Declaration + "#Defining_Identifier'Subtype_Indication&Generic_Parent_Type2Exception" & + "_Junk" & + -- Function_Specification + "#Defining_Unit_Name$Elaboration_Boolean%Parameter_Specifications&Subt" & + "ype_Mark'Generic_Parent" & + -- Procedure_Specification + "#Defining_Unit_Name$Elaboration_Boolean%Parameter_Specifications'Gene" & + "ric_Parent" & + -- Entry_Index_Specification + "#Defining_Identifier&Discrete_Subtype_Definition" & + -- Freeze_Entity + "&Entity$Access_Types_To_Process%TSS_Elist#Actions'First_Subtype_Link" & + -- Access_Function_Definition + "6Protected_Present%Parameter_Specifications&Subtype_Mark" & + -- Access_Procedure_Definition + "6Protected_Present%Parameter_Specifications" & + -- Task_Type_Declaration + "#Defining_Identifier$Task_Body_Procedure&Discriminant_Specifications%" & + "Task_Definition'Corresponding_Body" & + -- Package_Body_Stub + "#Defining_Identifier&Library_Unit'Corresponding_Body" & + -- Protected_Body_Stub + "#Defining_Identifier&Library_Unit'Corresponding_Body" & + -- Subprogram_Body_Stub + "#Specification&Library_Unit'Corresponding_Body" & + -- Task_Body_Stub + "#Defining_Identifier&Library_Unit'Corresponding_Body" & + -- Function_Instantiation + "#Defining_Unit_Name$Name%Generic_Associations&Parent_Spec'Instance_Sp" & + "ec9ABE_Is_Certain" & + -- Package_Instantiation + "#Defining_Unit_Name$Name%Generic_Associations&Parent_Spec'Instance_Sp" & + "ec9ABE_Is_Certain" & + -- Procedure_Instantiation + "#Defining_Unit_Name$Name&Parent_Spec%Generic_Associations'Instance_Sp" & + "ec9ABE_Is_Certain" & + -- Package_Body + "#Defining_Unit_Name$Declarations&Handled_Statement_Sequence'Correspon" & + "ding_Spec4Was_Originally_Stub" & + -- Subprogram_Body + "#Specification$Declarations&Handled_Statement_Sequence%Activation_Cha" & + "in_Entity'Corresponding_Spec+Acts_As_Spec6Bad_Is_Detected8Do_Stora" & + "ge_Check-Has_Priority_Pragma.Is_Protected_Subprogram_Body,Is_Task_" & + "Master4Was_Originally_Stub" & + -- Protected_Body + "#Defining_Identifier$Declarations&End_Label'Corresponding_Spec4Was_Or" & + "iginally_Stub" & + -- Task_Body + "#Defining_Identifier$Declarations&Handled_Statement_Sequence,Is_Task_" & + "Master%Activation_Chain_Entity'Corresponding_Spec4Was_Originally_S" & + "tub" & + -- Implicit_Label_Declaration + "#Defining_Identifier$Label_Construct" & + -- Package_Declaration + "#Specification'Corresponding_Body&Parent_Spec%Activation_Chain_Entity" & + -- Single_Task_Declaration + "#Defining_Identifier%Task_Definition" & + -- Subprogram_Declaration + "#Specification%Body_To_Inline'Corresponding_Body&Parent_Spec" & + -- Use_Package_Clause + "$Names%Next_Use_Clause&Hidden_By_Use_Clause" & + -- Generic_Package_Declaration + "#Specification'Corresponding_Body$Generic_Formal_Declarations&Parent_" & + "Spec%Activation_Chain_Entity" & + -- Generic_Subprogram_Declaration + "#Specification'Corresponding_Body$Generic_Formal_Declarations&Parent_" & + "Spec" & + -- Constrained_Array_Definition + "$Discrete_Subtype_Definitions+Aliased_Present'Subtype_Indication" & + -- Unconstrained_Array_Definition + "$Subtype_Marks+Aliased_Present'Subtype_Indication" & + -- Exception_Renaming_Declaration + "#Defining_Identifier$Name" & + -- Object_Renaming_Declaration + "#Defining_Identifier&Subtype_Mark$Name'Corresponding_Generic_Associat" & + "ion" & + -- Package_Renaming_Declaration + "#Defining_Unit_Name$Name&Parent_Spec" & + -- Subprogram_Renaming_Declaration + "#Specification$Name&Parent_Spec'Corresponding_Spec" & + -- Generic_Function_Renaming_Declaration + "#Defining_Unit_Name$Name&Parent_Spec" & + -- Generic_Package_Renaming_Declaration + "#Defining_Unit_Name$Name&Parent_Spec" & + -- Generic_Procedure_Renaming_Declaration + "#Defining_Unit_Name$Name&Parent_Spec" & + -- Abort_Statement + "$Names" & + -- Accept_Statement + "#Entry_Direct_Name'Entry_Index%Parameter_Specifications&Handled_State" & + "ment_Sequence$Declarations" & + -- Assignment_Statement + "$Name%Expression4Do_Tag_Check+Do_Length_Check,Forwards_OK-Backwards_O" & + "K.No_Ctrl_Actions" & + -- Asynchronous_Select + "#Triggering_Alternative$Abortable_Part" & + -- Block_Statement + "#Identifier$Declarations&Handled_Statement_Sequence,Is_Task_Master%Ac" & + "tivation_Chain_Entity6Has_Created_Identifier-Is_Task_Allocation_Bl" & + "ock.Is_Asynchronous_Call_Block" & + -- Case_Statement + "%Expression&Alternatives'End_Span" & + -- Code_Statement + "%Expression" & + -- Conditional_Entry_Call + "#Entry_Call_Alternative&Else_Statements" & + -- Delay_Relative_Statement + "%Expression" & + -- Delay_Until_Statement + "%Expression" & + -- Entry_Call_Statement + "$Name%Parameter_Associations&First_Named_Actual" & + -- Free_Statement + "%Expression#Storage_Pool&Procedure_To_Call" & + -- Goto_Statement + "$Name2Exception_Junk" & + -- Loop_Statement + "#Identifier$Iteration_Scheme%Statements&End_Label6Has_Created_Identif" & + "ier" & + -- Null_Statement + "" & + -- Raise_Statement + "$Name" & + -- Requeue_Statement + "$Name6Abort_Present" & + -- Return_Statement + "%Expression#Storage_Pool&Procedure_To_Call4Do_Tag_Check$Return_Type,B" & + "y_Ref" & + -- Selective_Accept + "#Select_Alternatives&Else_Statements" & + -- Timed_Entry_Call + "#Entry_Call_Alternative&Delay_Alternative" & + -- Exit_Statement + "$Name#Condition" & + -- If_Statement + "#Condition$Then_Statements%Elsif_Parts&Else_Statements'End_Span" & + -- Accept_Alternative + "$Accept_Statement#Condition%Statements&Pragmas_Before'Accept_Handler_" & + "Records" & + -- Delay_Alternative + "$Delay_Statement#Condition%Statements&Pragmas_Before" & + -- Elsif_Part + "#Condition$Then_Statements%Condition_Actions" & + -- Entry_Body_Formal_Part + "&Entry_Index_Specification%Parameter_Specifications#Condition" & + -- Iteration_Scheme + "#Condition%Condition_Actions&Loop_Parameter_Specification" & + -- Terminate_Alternative + "#Condition&Pragmas_Before'Pragmas_After" & + -- Abortable_Part + "%Statements" & + -- Abstract_Subprogram_Declaration + "#Specification" & + -- Access_Definition + "&Subtype_Mark" & + -- Access_To_Object_Definition + "6All_Present'Subtype_Indication8Constant_Present" & + -- Case_Statement_Alternative + "&Discrete_Choices%Statements" & + -- Compilation_Unit + "&Library_Unit#Context_Items6Private_Present$Unit'Aux_Decls_Node8Has_N" & + "o_Elaboration_Code4Body_Required+Acts_As_Spec%First_Inlined_Subpro" & + "gram" & + -- Compilation_Unit_Aux + "$Declarations#Actions'Pragmas_After" & + -- Component_Association + "#Choices$Loop_Actions%Expression" & + -- Component_List + "%Component_Items&Variant_Part4Null_Present" & + -- Derived_Type_Definition + "+Abstract_Present'Subtype_Indication%Record_Extension_Part" & + -- Decimal_Fixed_Point_Definition + "%Delta_Expression$Digits_Expression&Real_Range_Specification" & + -- Defining_Program_Unit_Name + "$Name#Defining_Identifier" & + -- Delta_Constraint + "%Delta_Expression&Range_Constraint" & + -- Designator + "$Name#Identifier" & + -- Digits_Constraint + "$Digits_Expression&Range_Constraint" & + -- Discriminant_Association + "#Selector_Names%Expression" & + -- Discriminant_Specification + "#Defining_Identifier'Discriminant_Type%Expression,More_Ids-Prev_Ids" & + -- Enumeration_Type_Definition + "#Literals" & + -- Entry_Body + "#Defining_Identifier'Entry_Body_Formal_Part$Declarations&Handled_Stat" & + "ement_Sequence%Activation_Chain_Entity" & + -- Entry_Call_Alternative + "#Entry_Call_Statement%Statements&Pragmas_Before" & + -- Exception_Declaration + "#Defining_Identifier%Expression,More_Ids-Prev_Ids" & + -- Exception_Handler + "$Choice_Parameter&Exception_Choices%Statements,Zero_Cost_Handling" & + -- Floating_Point_Definition + "$Digits_Expression&Real_Range_Specification" & + -- Formal_Decimal_Fixed_Point_Definition + "" & + -- Formal_Derived_Type_Definition + "&Subtype_Mark6Private_Present+Abstract_Present" & + -- Formal_Discrete_Type_Definition + "" & + -- Formal_Floating_Point_Definition + "" & + -- Formal_Modular_Type_Definition + "" & + -- Formal_Ordinary_Fixed_Point_Definition + "" & + -- Formal_Package_Declaration + "#Defining_Identifier$Name%Generic_Associations6Box_Present'Instance_S" & + "pec9ABE_Is_Certain" & + -- Formal_Private_Type_Definition + "+Abstract_Present6Tagged_Present8Limited_Present" & + -- Formal_Signed_Integer_Type_Definition + "" & + -- Formal_Subprogram_Declaration + "#Specification$Default_Name6Box_Present" & + -- Generic_Association + "$Selector_Name#Explicit_Generic_Actual_Parameter" & + -- Handled_Sequence_Of_Statements + "%Statements&End_Label'Exception_Handlers#At_End_Proc$First_Real_State" & + "ment,Zero_Cost_Handling" & + -- Index_Or_Discriminant_Constraint + "#Constraints" & + -- Itype_Reference + "#Itype" & + -- Label + "#Identifier2Exception_Junk" & + -- Modular_Type_Definition + "%Expression" & + -- Number_Declaration + "#Defining_Identifier%Expression,More_Ids-Prev_Ids" & + -- Ordinary_Fixed_Point_Definition + "%Delta_Expression&Real_Range_Specification" & + -- Others_Choice + "#Others_Discrete_Choices2All_Others" & + -- Package_Specification + "#Defining_Unit_Name$Visible_Declarations%Private_Declarations&End_Lab" & + "el'Generic_Parent" & + -- Parameter_Association + "$Selector_Name%Explicit_Actual_Parameter&Next_Named_Actual" & + -- Parameter_Specification + "#Defining_Identifier6In_Present8Out_Present$Parameter_Type%Expression" & + "4Do_Accessibility_Check,More_Ids-Prev_Ids'Default_Expression" & + -- Protected_Definition + "$Visible_Declarations%Private_Declarations&End_Label-Has_Priority_Pra" & + "gma" & + -- Range_Constraint + "&Range_Expression" & + -- Real_Range_Specification + "#Low_Bound$High_Bound" & + -- Record_Definition + "&End_Label+Abstract_Present6Tagged_Present8Limited_Present#Component_" & + "List4Null_Present" & + -- Signed_Integer_Type_Definition + "#Low_Bound$High_Bound" & + -- Single_Protected_Declaration + "#Defining_Identifier%Protected_Definition" & + -- Subunit + "$Name#Proper_Body%Corresponding_Stub" & + -- Task_Definition + "$Visible_Declarations%Private_Declarations&End_Label-Has_Priority_Pra" & + "gma,Has_Storage_Size_Pragma.Has_Task_Info_Pragma/Has_Task_Name_Pra" & + "gma" & + -- Triggering_Alternative + "#Triggering_Statement%Statements&Pragmas_Before" & + -- Use_Type_Clause + "$Subtype_Marks%Next_Use_Clause&Hidden_By_Use_Clause" & + -- Validate_Unchecked_Conversion + "#Source_Type$Target_Type" & + -- Variant + "&Discrete_Choices#Component_List$Enclosing_Variant%Present_Expr'Dchec" & + "k_Function" & + -- Variant_Part + "$Name#Variants" & + -- With_Clause + "$Name&Library_Unit'Corresponding_Spec,First_Name-Last_Name4Context_In" & + "stalled+Elaborate_Present6Elaborate_All_Present8Implicit_With.Unre" & + "ferenced_In_Spec/No_Entities_Ref_In_Spec" & + -- With_Type_Clause + "$Name6Tagged_Present" & + -- Unused_At_End + ""; + + type Pchar_Pos_Array is array (Node_Kind) of Positive; + Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'( + N_Unused_At_Start => 1, + N_At_Clause => 1, + N_Component_Clause => 23, + N_Enumeration_Representation_Clause => 66, + N_Mod_Clause => 107, + N_Record_Representation_Clause => 133, + N_Attribute_Definition_Clause => 187, + N_Empty => 229, + N_Error => 229, + N_Pragma => 229, + N_Pragma_Argument_Association => 288, + N_Defining_Character_Literal => 299, + N_Defining_Identifier => 317, + N_Defining_Operator_Symbol => 335, + N_Expanded_Name => 353, + N_Identifier => 412, + N_Operator_Symbol => 472, + N_Character_Literal => 503, + N_Op_Add => 546, + N_Op_Concat => 546, + N_Op_Divide => 593, + N_Op_Expon => 649, + N_Op_Mod => 673, + N_Op_Multiply => 714, + N_Op_Rem => 752, + N_Op_Subtract => 793, + N_Op_And => 793, + N_Op_Eq => 809, + N_Op_Ge => 809, + N_Op_Gt => 809, + N_Op_Le => 809, + N_Op_Lt => 809, + N_Op_Ne => 809, + N_Op_Or => 809, + N_Op_Xor => 825, + N_Op_Rotate_Left => 841, + N_Op_Rotate_Right => 856, + N_Op_Shift_Left => 871, + N_Op_Shift_Right => 886, + N_Op_Shift_Right_Arithmetic => 901, + N_Op_Abs => 916, + N_Op_Minus => 916, + N_Op_Not => 916, + N_Op_Plus => 916, + N_Attribute_Reference => 916, + N_And_Then => 1019, + N_Conditional_Expression => 1027, + N_Explicit_Dereference => 1065, + N_Function_Call => 1088, + N_In => 1209, + N_Indexed_Component => 1209, + N_Integer_Literal => 1244, + N_Not_In => 1264, + N_Null => 1264, + N_Or_Else => 1264, + N_Procedure_Call_Statement => 1272, + N_Qualified_Expression => 1393, + N_Raise_Constraint_Error => 1417, + N_Raise_Program_Error => 1427, + N_Raise_Storage_Error => 1437, + N_Aggregate => 1447, + N_Allocator => 1587, + N_Extension_Aggregate => 1664, + N_Range => 1751, + N_Real_Literal => 1792, + N_Reference => 1846, + N_Selected_Component => 1853, + N_Slice => 1912, + N_String_Literal => 1950, + N_Subprogram_Info => 1976, + N_Type_Conversion => 1987, + N_Unchecked_Expression => 2102, + N_Unchecked_Type_Conversion => 2113, + N_Subtype_Indication => 2154, + N_Component_Declaration => 2194, + N_Entry_Declaration => 2278, + N_Formal_Object_Declaration => 2351, + N_Formal_Type_Declaration => 2436, + N_Full_Type_Declaration => 2537, + N_Incomplete_Type_Declaration => 2625, + N_Loop_Parameter_Specification => 2703, + N_Object_Declaration => 2767, + N_Protected_Type_Declaration => 3014, + N_Private_Extension_Declaration => 3102, + N_Private_Type_Declaration => 3216, + N_Subtype_Declaration => 3342, + N_Function_Specification => 3416, + N_Procedure_Specification => 3508, + N_Entry_Index_Specification => 3587, + N_Freeze_Entity => 3635, + N_Access_Function_Definition => 3703, + N_Access_Procedure_Definition => 3759, + N_Task_Type_Declaration => 3802, + N_Package_Body_Stub => 3905, + N_Protected_Body_Stub => 3957, + N_Subprogram_Body_Stub => 4009, + N_Task_Body_Stub => 4055, + N_Function_Instantiation => 4107, + N_Package_Instantiation => 4193, + N_Procedure_Instantiation => 4279, + N_Package_Body => 4365, + N_Subprogram_Body => 4463, + N_Protected_Body => 4690, + N_Task_Body => 4772, + N_Implicit_Label_Declaration => 4910, + N_Package_Declaration => 4946, + N_Single_Task_Declaration => 5015, + N_Subprogram_Declaration => 5051, + N_Use_Package_Clause => 5111, + N_Generic_Package_Declaration => 5154, + N_Generic_Subprogram_Declaration => 5251, + N_Constrained_Array_Definition => 5324, + N_Unconstrained_Array_Definition => 5388, + N_Exception_Renaming_Declaration => 5437, + N_Object_Renaming_Declaration => 5462, + N_Package_Renaming_Declaration => 5534, + N_Subprogram_Renaming_Declaration => 5570, + N_Generic_Function_Renaming_Declaration => 5620, + N_Generic_Package_Renaming_Declaration => 5656, + N_Generic_Procedure_Renaming_Declaration => 5692, + N_Abort_Statement => 5728, + N_Accept_Statement => 5734, + N_Assignment_Statement => 5829, + N_Asynchronous_Select => 5915, + N_Block_Statement => 5953, + N_Case_Statement => 6118, + N_Code_Statement => 6151, + N_Conditional_Entry_Call => 6162, + N_Delay_Relative_Statement => 6201, + N_Delay_Until_Statement => 6212, + N_Entry_Call_Statement => 6223, + N_Free_Statement => 6270, + N_Goto_Statement => 6312, + N_Loop_Statement => 6332, + N_Null_Statement => 6404, + N_Raise_Statement => 6404, + N_Requeue_Statement => 6409, + N_Return_Statement => 6428, + N_Selective_Accept => 6502, + N_Timed_Entry_Call => 6538, + N_Exit_Statement => 6579, + N_If_Statement => 6594, + N_Accept_Alternative => 6657, + N_Delay_Alternative => 6733, + N_Elsif_Part => 6785, + N_Entry_Body_Formal_Part => 6829, + N_Iteration_Scheme => 6890, + N_Terminate_Alternative => 6947, + N_Abortable_Part => 6986, + N_Abstract_Subprogram_Declaration => 6997, + N_Access_Definition => 7011, + N_Access_To_Object_Definition => 7024, + N_Case_Statement_Alternative => 7072, + N_Compilation_Unit => 7100, + N_Compilation_Unit_Aux => 7239, + N_Component_Association => 7274, + N_Component_List => 7306, + N_Derived_Type_Definition => 7348, + N_Decimal_Fixed_Point_Definition => 7406, + N_Defining_Program_Unit_Name => 7466, + N_Delta_Constraint => 7491, + N_Designator => 7525, + N_Digits_Constraint => 7541, + N_Discriminant_Association => 7576, + N_Discriminant_Specification => 7602, + N_Enumeration_Type_Definition => 7669, + N_Entry_Body => 7678, + N_Entry_Call_Alternative => 7785, + N_Exception_Declaration => 7832, + N_Exception_Handler => 7881, + N_Floating_Point_Definition => 7946, + N_Formal_Decimal_Fixed_Point_Definition => 7989, + N_Formal_Derived_Type_Definition => 7989, + N_Formal_Discrete_Type_Definition => 8035, + N_Formal_Floating_Point_Definition => 8035, + N_Formal_Modular_Type_Definition => 8035, + N_Formal_Ordinary_Fixed_Point_Definition => 8035, + N_Formal_Package_Declaration => 8035, + N_Formal_Private_Type_Definition => 8122, + N_Formal_Signed_Integer_Type_Definition => 8170, + N_Formal_Subprogram_Declaration => 8170, + N_Generic_Association => 8209, + N_Handled_Sequence_Of_Statements => 8257, + N_Index_Or_Discriminant_Constraint => 8349, + N_Itype_Reference => 8361, + N_Label => 8367, + N_Modular_Type_Definition => 8393, + N_Number_Declaration => 8404, + N_Ordinary_Fixed_Point_Definition => 8453, + N_Others_Choice => 8495, + N_Package_Specification => 8530, + N_Parameter_Association => 8616, + N_Parameter_Specification => 8674, + N_Protected_Definition => 8803, + N_Range_Constraint => 8875, + N_Real_Range_Specification => 8892, + N_Record_Definition => 8913, + N_Signed_Integer_Type_Definition => 8999, + N_Single_Protected_Declaration => 9020, + N_Subunit => 9061, + N_Task_Definition => 9097, + N_Triggering_Alternative => 9235, + N_Use_Type_Clause => 9282, + N_Validate_Unchecked_Conversion => 9333, + N_Variant => 9357, + N_Variant_Part => 9436, + N_With_Clause => 9450, + N_With_Type_Clause => 9625, + N_Unused_At_End => 9645); + +end Treeprs; diff --git a/gcc/ada/treeprs.adt b/gcc/ada/treeprs.adt new file mode 100644 index 00000000000..5cf69890ee7 --- /dev/null +++ b/gcc/ada/treeprs.adt @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E P R S -- +-- -- +-- T e m p l a t e -- +-- -- +-- $Revision: 1.17 $ -- +-- -- +-- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This file is a template used as input to the utility program XTreeprs, +-- which reads this template, and the spec of Sinfo (sinfo.ads) and generates +-- the spec for the Treeprs package (file treeprs.ads) + +-- This package contains the declaration of the string used by the Tree_Print +-- package. It must be updated whenever the arrangements of the field names +-- in package Sinfo is changed. The utility program XTREEPRS is used to +-- do this update correctly using the template treeprs.adt as input. + +with Sinfo; use Sinfo; + +package Treeprs is + + -------------------------------- + -- String Data for Node Print -- + -------------------------------- + + -- String data for print out. The Pchars array is a long string with the + -- the entry for each node type consisting of a single blank, followed by + -- a series of entries, one for each Op or Flag field used for the node. + -- Each entry has a single character which identifies the field, followed + -- by the synonym name. The starting location for a given node type is + -- found from the corresponding entry in the Pchars_Pos_Array. + + -- The following characters identify the field. These are characters + -- which could never occur in a field name, so they also mark the + -- end of the previous name. + + subtype Fchar is Character range '#' .. '9'; + + F_Field1 : constant Fchar := '#'; -- Character'Val (16#23#) + F_Field2 : constant Fchar := '$'; -- Character'Val (16#24#) + F_Field3 : constant Fchar := '%'; -- Character'Val (16#25#) + F_Field4 : constant Fchar := '&'; -- Character'Val (16#26#) + F_Field5 : constant Fchar := '''; -- Character'Val (16#27#) + F_Flag1 : constant Fchar := '('; -- Character'Val (16#28#) + F_Flag2 : constant Fchar := ')'; -- Character'Val (16#29#) + F_Flag3 : constant Fchar := '*'; -- Character'Val (16#2A#) + F_Flag4 : constant Fchar := '+'; -- Character'Val (16#2B#) + F_Flag5 : constant Fchar := ','; -- Character'Val (16#2C#) + F_Flag6 : constant Fchar := '-'; -- Character'Val (16#2D#) + F_Flag7 : constant Fchar := '.'; -- Character'Val (16#2E#) + F_Flag8 : constant Fchar := '/'; -- Character'Val (16#2F#) + F_Flag9 : constant Fchar := '0'; -- Character'Val (16#30#) + F_Flag10 : constant Fchar := '1'; -- Character'Val (16#31#) + F_Flag11 : constant Fchar := '2'; -- Character'Val (16#32#) + F_Flag12 : constant Fchar := '3'; -- Character'Val (16#33#) + F_Flag13 : constant Fchar := '4'; -- Character'Val (16#34#) + F_Flag14 : constant Fchar := '5'; -- Character'Val (16#35#) + F_Flag15 : constant Fchar := '6'; -- Character'Val (16#36#) + F_Flag16 : constant Fchar := '7'; -- Character'Val (16#37#) + F_Flag17 : constant Fchar := '8'; -- Character'Val (16#38#) + F_Flag18 : constant Fchar := '9'; -- Character'Val (16#39#) + + -- Note this table does not include entity field and flags whose access + -- functions are in Einfo (these are handled by the Print_Entity_Info + -- procedure in Treepr, which uses the routines in Einfo to get the + -- proper symbolic information). In addition, the following fields are + -- handled by Treepr, and do not appear in the Pchars array: + + -- Analyzed + -- Cannot_Be_Constant + -- Chars + -- Comes_From_Source + -- Error_Posted + -- Etype + -- Is_Controlling_Actual + -- Is_Overloaded + -- Is_Static_Expression + -- Left_Opnd + -- Must_Check_Expr + -- Must_Not_Freeze + -- No_Overflow_Expr + -- Paren_Count + -- Raises_Constraint_Error + -- Right_Opnd + +!!TEMPLATE INSERTION POINT + +end Treeprs; diff --git a/gcc/ada/ttypef.ads b/gcc/ada/ttypef.ads new file mode 100644 index 00000000000..e9ac596266a --- /dev/null +++ b/gcc/ada/ttypef.ads @@ -0,0 +1,207 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T T Y P E F -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.21 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This module contains values for the predefined floating-point attributes. +-- All references to these attribute values in a program being compiled must +-- use the values in this package, not the values returned by referencing +-- the corresponding attributes (since that would give host machine values). +-- Boolean-valued attributes are defined in System.Parameters, because they +-- need a finer control than what is provided by the formats described below. + +-- The codes for the eight floating-point formats supported are: + +-- IEEES - IEEE Single Float +-- IEEEL - IEEE Double Float +-- IEEEX - IEEE Double Extended Float +-- VAXFF - VAX F Float +-- VAXDF - VAX D Float +-- VAXGF - VAX G Float +-- AAMPS - AAMP 32-bit Float +-- AAMPL - AAMP 48-bit Float + +package Ttypef is + + ---------------------------------- + -- Universal Integer Attributes -- + ---------------------------------- + + -- Note that the constant declarations below specify values + -- using the Ada model, so IEEES_Machine_Emax does not specify + -- the IEEE definition of the single precision float type, + -- but the value of the Ada attribute which is one higher + -- as the binary point is at a different location. + + IEEES_Digits : constant := 6; + IEEEL_Digits : constant := 15; + IEEEX_Digits : constant := 18; + VAXFF_Digits : constant := 6; + VAXDF_Digits : constant := 9; + VAXGF_Digits : constant := 15; + AAMPS_Digits : constant := 6; + AAMPL_Digits : constant := 9; + + IEEES_Machine_Emax : constant := 128; + IEEEL_Machine_Emax : constant := 1024; + IEEEX_Machine_Emax : constant := 16384; + VAXFF_Machine_Emax : constant := 127; + VAXDF_Machine_Emax : constant := 127; + VAXGF_Machine_Emax : constant := 1023; + AAMPS_Machine_Emax : constant := 127; + AAMPL_Machine_Emax : constant := 127; + + IEEES_Machine_Emin : constant := -125; + IEEEL_Machine_Emin : constant := -1021; + IEEEX_Machine_Emin : constant := -16381; + VAXFF_Machine_Emin : constant := -127; + VAXDF_Machine_Emin : constant := -127; + VAXGF_Machine_Emin : constant := -1023; + AAMPS_Machine_Emin : constant := -127; + AAMPL_Machine_Emin : constant := -127; + + IEEES_Machine_Mantissa : constant := 24; + IEEEL_Machine_Mantissa : constant := 53; + IEEEX_Machine_Mantissa : constant := 64; + VAXFF_Machine_Mantissa : constant := 24; + VAXDF_Machine_Mantissa : constant := 56; + VAXGF_Machine_Mantissa : constant := 53; + AAMPS_Machine_Mantissa : constant := 24; + AAMPL_Machine_Mantissa : constant := 40; + + IEEES_Model_Emin : constant := -125; + IEEEL_Model_Emin : constant := -1021; + IEEEX_Model_Emin : constant := -16381; + VAXFF_Model_Emin : constant := -127; + VAXDF_Model_Emin : constant := -127; + VAXGF_Model_Emin : constant := -1023; + AAMPS_Model_Emin : constant := -127; + AAMPL_Model_Emin : constant := -127; + + IEEES_Model_Mantissa : constant := 24; + IEEEL_Model_Mantissa : constant := 53; + IEEEX_Model_Mantissa : constant := 64; + VAXFF_Model_Mantissa : constant := 24; + VAXDF_Model_Mantissa : constant := 56; + VAXGF_Model_Mantissa : constant := 53; + AAMPS_Model_Mantissa : constant := 24; + AAMPL_Model_Mantissa : constant := 40; + + IEEES_Safe_Emax : constant := 128; + IEEEL_Safe_Emax : constant := 1024; + IEEEX_Safe_Emax : constant := 16384; + VAXFF_Safe_Emax : constant := 127; + VAXDF_Safe_Emax : constant := 127; + VAXGF_Safe_Emax : constant := 1023; + AAMPS_Safe_Emax : constant := 127; + AAMPL_Safe_Emax : constant := 127; + + ------------------------------- + -- Universal Real Attributes -- + ------------------------------- + + IEEES_Model_Epsilon : constant := 2#1.0#E-23; + IEEEL_Model_Epsilon : constant := 2#1.0#E-52; + IEEEX_Model_Epsilon : constant := 2#1.0#E-63; + VAXFF_Model_Epsilon : constant := 16#0.1000_000#E-4; + VAXDF_Model_Epsilon : constant := 16#0.4000_0000_0000_000#E-7; + VAXGF_Model_Epsilon : constant := 16#0.4000_0000_0000_00#E-12; + AAMPS_Model_Epsilon : constant := 2#1.0#E-23; + AAMPL_Model_Epsilon : constant := 2#1.0#E-39; + + IEEES_Model_Small : constant := 2#1.0#E-126; + IEEEL_Model_Small : constant := 2#1.0#E-1022; + IEEEX_Model_Small : constant := 2#1.0#E-16381; + VAXFF_Model_Small : constant := 16#0.8000_000#E-21; + VAXDF_Model_Small : constant := 16#0.8000_0000_0000_000#E-31; + VAXGF_Model_Small : constant := 16#0.8000_0000_0000_00#E-51; + AAMPS_Model_Small : constant := 16#0.8000_000#E-21; + AAMPL_Model_Small : constant := 16#0.8000_0000_000#E-31; + + IEEES_Safe_First : constant := -16#0.FFFF_FF#E+32; + IEEEL_Safe_First : constant := -16#0.FFFF_FFFF_FFFF_F8#E+256; + IEEEX_Safe_First : constant := -16#0.FFFF_FFFF_FFFF_FFFF#E+4096; + VAXFF_Safe_First : constant := -16#0.7FFF_FF8#E+32; + VAXDF_Safe_First : constant := -16#0.7FFF_FFFF_FFFF_FF8#E-38; + VAXGF_Safe_First : constant := -16#0.7FFF_FFFF_FFFF_FC#E-256; + AAMPS_Safe_First : constant := -16#0.7FFF_FF8#E+32; + AAMPL_Safe_First : constant := -16#0.7FFF_FFFF_FF8#E+32; + + IEEES_Safe_Large : constant := 16#0.FFFF_FF#E+32; + IEEEL_Safe_Large : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256; + IEEEX_Safe_Large : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096; + VAXFF_Safe_Large : constant := 16#0.7FFF_FC0#E+32; + VAXDF_Safe_Large : constant := 16#0.7FFF_FFFF_0000_000#E+32; + VAXGF_Safe_Large : constant := 16#0.7FFF_FFFF_FFFF_F0#E+256; + AAMPS_Safe_Large : constant := 16#0.7FFF_FC0#E+32; + AAMPL_Safe_Large : constant := 16#0.7FFF_FFFF#E+32; + + IEEES_Safe_Last : constant := 16#0.FFFF_FF#E+32; + IEEEL_Safe_Last : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256; + IEEEX_Safe_Last : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096; + VAXFF_Safe_Last : constant := 16#0.7FFF_FF8#E+32; + VAXDF_Safe_Last : constant := 16#0.7FFF_FFFF_FFFF_FC0#E+32; + VAXGF_Safe_Last : constant := 16#0.7FFF_FFFF_FFFF_FC#E+256; + AAMPS_Safe_Last : constant := 16#0.7FFF_FF8#E+32; + AAMPL_Safe_Last : constant := 16#0.7FFF_FFFF_FF8#E+32; + + IEEES_Safe_Small : constant := 2#1.0#E-126; + IEEEL_Safe_Small : constant := 2#1.0#E-1022; + IEEEX_Safe_Small : constant := 2#1.0#E-16381; + VAXFF_Safe_Small : constant := 16#0.1000_000#E-31; + VAXDF_Safe_Small : constant := 16#0.1000_0000_0000_000#E-31; + VAXGF_Safe_Small : constant := 16#0.1000_0000_0000_00#E-255; + AAMPS_Safe_Small : constant := 16#0.1000_000#E-31; + AAMPL_Safe_Small : constant := 16#0.1000_0000_000#E-31; + + ---------------------- + -- Typed Attributes -- + ---------------------- + + -- The attributes First and Last are typed attributes in Ada, and yield + -- values of the appropriate float type. However we still describe them + -- as universal real values in this file, since we are talking about the + -- target floating-point types, not the host floating-point types. + + IEEES_First : constant := -16#0.FFFF_FF#E+32; + IEEEL_First : constant := -16#0.FFFF_FFFF_FFFF_F8#E+256; + IEEEX_First : constant := -16#0.FFFF_FFFF_FFFF_FFFF#E+4096; + VAXFF_First : constant := -16#0.7FFF_FF8#E+32; + VAXDF_First : constant := -16#0.7FFF_FFFF_FFFF_FF8#E+32; + VAXGF_First : constant := -16#0.7FFF_FFFF_FFFF_FC#E+256; + AAMPS_First : constant := -16#0.7FFF_FF8#E+32; + AAMPL_First : constant := -16#0.7FFF_FFFF_FF8#E+32; + + IEEES_Last : constant := 16#0.FFFF_FF#E+32; + IEEEL_Last : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256; + IEEEX_Last : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096; + VAXFF_Last : constant := 16#0.7FFF_FF8#E+32; + VAXDF_Last : constant := 16#0.7FFF_FFFF_FFFF_FC0#E+32; + VAXGF_Last : constant := 16#0.7FFF_FFFF_FFFF_FC#E+256; + AAMPS_Last : constant := 16#0.7FFF_FF8#E+32; + AAMPL_Last : constant := 16#0.7FFF_FFFF_FF8#E+32; + +end Ttypef; diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads new file mode 100644 index 00000000000..6ac1af4395e --- /dev/null +++ b/gcc/ada/ttypes.ads @@ -0,0 +1,211 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.25 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains constants describing target properties + +with Types; use Types; +with Get_Targ; use Get_Targ; + +package Ttypes is + + ------------------------------ + -- Host/Target Dependencies -- + ------------------------------ + + -- It is vital to maintain a clear distinction between properties of + -- types on the host and types on the target, since in the general + -- case of a cross-compiler these will be different. + + -- This package and its companion Ttypef provide definitions of values + -- that describe the properties of the target types. All instances of + -- target dependencies, including the definitions of such packages as + -- Standard and System depend directly or indirectly on the definitions + -- in the Ttypes and Ttypef packages. + + -- In the source of the compiler, references to attributes such as + -- Integer'Size will give information regarding the host types (i.e. + -- the types within the compiler itself). Such references are therefore + -- almost always suspicious (it is hard for example to see that the + -- code in the compiler should even be using type Integer very much, + -- and certainly this code should not depend on the size of Integer). + + -- On the other hand, it is perfectly reasonable for the compiler to + -- require access to the size of type Integer for the target machine, + -- e.g. in constructing the internal representation of package Standard. + -- For this purpose, instead of referencing the attribute Integer'Size, + -- a reference to Ttypes.Standard_Integer_Size will provide the needed + -- value for the target type. + + -- Two approaches are used for handling target dependent values in the + -- standard library packages. Package Standard is handled specially, + -- being constructed internally (by package Stand). Target dependent + -- values needed in Stand are obtained by direct reference to Ttypes + -- and Ttypef. + + -- For package System, the required constant values are obtained by + -- referencing appropriate attributes. Ada 95 already defines most of + -- the required attributes, and GNAT specific attributes have been + -- defined to cover the remaining cases (such as Storage_Unit). The + -- evaluation of these attributes obtains the required target dependent + -- values from Ttypes and Ttypef. The additional attributes that have + -- been added to GNAT (Address_Size, Storage_Unit, Word_Size, Max_Priority, + -- and Max_Interrupt_Priority) are for almost all purposes redundant with + -- respect to the corresponding references to System constants. For example + -- in a program, System.Address_Size and Standard'Address_Size yield the + -- same value. The critical use of the attribute is in writing the System + -- declaration of Address_Size which of course cannot refer to itself. By + -- this means we achieve complete target independence in the source code + -- of package System, i.e. there is only one copy of the source of System + -- for all targets. + + -- Note that during compilation there are two versions of package System + -- around. The version that is directly WITH'ed by compiler packages + -- contains host-dependent definitions, which is what is needed in that + -- case (for example, System.Storage_Unit referenced in the source of the + -- compiler refers to the storage unit of the host, not the target. This + -- means that, like attribute references, any references to constants in + -- package System in the compiler code are suspicious, since it is strange + -- for the compiler to have such host dependencies. If the compiler needs + -- to access the target dependent values of such quantities as Storage_Unit + -- then it should reference the constants in this package (Ttypes), rather + -- than referencing System.Storage_Unit, or Standard'Storage_Unit, both of + -- which would yield the host value. + + --------------------------------------------------- + -- Target-Dependent Values for Types in Standard -- + --------------------------------------------------- + + -- Note: GNAT always supplies all the following integer and float types, + -- but depending on the machine, some of the types may be identical. For + -- example, on some machines, Short_Float may be the same as Float, and + -- Long_Long_Float may be the same as Long_Float. + + Standard_Short_Short_Integer_Size : constant Pos := Get_Char_Size; + Standard_Short_Short_Integer_Width : constant Pos := + Width_From_Size (Standard_Short_Short_Integer_Size); + + Standard_Short_Integer_Size : constant Pos := Get_Short_Size; + Standard_Short_Integer_Width : constant Pos := + Width_From_Size (Standard_Short_Integer_Size); + + Standard_Integer_Size : constant Pos := Get_Int_Size; + Standard_Integer_Width : constant Pos := + Width_From_Size (Standard_Integer_Size); + + Standard_Long_Integer_Size : constant Pos := Get_Long_Size; + Standard_Long_Integer_Width : constant Pos := + Width_From_Size (Standard_Long_Integer_Size); + + Standard_Long_Long_Integer_Size : constant Pos := Get_Long_Long_Size; + Standard_Long_Long_Integer_Width : constant Pos := + Width_From_Size (Standard_Long_Long_Integer_Size); + + Standard_Short_Float_Size : constant Pos := Get_Float_Size; + Standard_Short_Float_Digits : constant Pos := + Digits_From_Size (Standard_Short_Float_Size); + + Standard_Float_Size : constant Pos := Get_Float_Size; + Standard_Float_Digits : constant Pos := + Digits_From_Size (Standard_Float_Size); + + Standard_Long_Float_Size : constant Pos := Get_Double_Size; + Standard_Long_Float_Digits : constant Pos := + Digits_From_Size (Standard_Long_Float_Size); + + Standard_Long_Long_Float_Size : constant Pos := Get_Long_Double_Size; + Standard_Long_Long_Float_Digits : constant Pos := + Digits_From_Size (Standard_Long_Long_Float_Size); + + Standard_Character_Size : constant Pos := Get_Char_Size; + + Standard_Wide_Character_Size : constant Pos := 2 * Get_Char_Size; + -- The Standard.Wide_Character type is special in the sense that + -- it is not defined in terms of its corresponding C type (wchar_t). + -- Unfortunately this makes the representation of Wide_Character + -- incompatible with the C wchar_t type. + -- ??? This is required by the RM or backward compatibility + + -- Note: there is no specific control over the representation of + -- enumeration types. The convention used is that if an enumeration + -- type has fewer than 2**(Character'Size) elements, then the size + -- used is Character'Size, otherwise Integer'Size is used. + + -- Similarly, the size of fixed-point types depends on the size of the + -- corresponding integer type, which is the smallest predefined integer + -- type capable of representing the required range of values. + + ------------------------------------------------- + -- Target-Dependent Values for Types in System -- + ------------------------------------------------- + + System_Address_Size : constant Pos := Get_Pointer_Size; + -- System.Address'Size (also size of all thin pointers) + + System_Max_Binary_Modulus_Power : constant Pos := + Standard_Long_Long_Integer_Size; + + System_Max_Nonbinary_Modulus_Power : constant Pos := + Standard_Integer_Size - 1; + + System_Storage_Unit : constant Pos := Get_Bits_Per_Unit; + System_Word_Size : constant Pos := Get_Bits_Per_Word; + + System_Tick_Nanoseconds : constant Pos := 1_000_000_000; + -- Value of System.Tick in nanoseconds. At the moment, this is a fixed + -- constant (with value of 1.0 seconds), but later we should add this + -- value to the GCC configuration file so that its value can be made + -- configuration dependent. + + ----------------------------------------------------- + -- Target-Dependent Values for Types in Interfaces -- + ----------------------------------------------------- + + Interfaces_Wchar_T_Size : constant Pos := Get_Wchar_T_Size; + + ---------------------------------------- + -- Other Target-Dependent Definitions -- + ---------------------------------------- + + Maximum_Alignment : constant Pos := Get_Maximum_Alignment; + -- The maximum alignment, in storage units, that an object or + -- type may require on the target machine. + + Bytes_Big_Endian : Boolean := Get_Bytes_BE /= 0; + -- Important note: for Ada purposes, the important setting is the bytes + -- endianness (Bytes_Big_Endian), not the bits value (Bits_Big_Endian). + -- This is because Ada bit addressing must be compatible with the byte + -- ordering (otherwise we would end up with non-contiguous fields). It + -- is rare for the two to be different, but if they are, Bits_Big_Endian + -- is relevant only for the generation of instructions with bit numbers, + -- and thus relevant only to the back end. Note that this is a variable + -- rather than a constant, since it can be modified (flipped) by -gnatd8. + + Target_Strict_Alignment : Boolean := Get_Strict_Alignment /= 0; + -- True if instructions will fail if data is misaligned + +end Ttypes; diff --git a/gcc/ada/types.adb b/gcc/ada/types.adb new file mode 100644 index 00000000000..0c668a5bd2d --- /dev/null +++ b/gcc/ada/types.adb @@ -0,0 +1,235 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T Y P E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.20 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body Types is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat; + -- Extract two decimal digit value from time stamp + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left = Right) and then String (Left) < String (Right); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left > Right); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Time_Stamp_Type) return Boolean is + Sleft : Nat; + Sright : Nat; + + begin + if String (Left) = String (Right) then + return True; + + elsif Left (1) = ' ' or else Right (1) = ' ' then + return False; + end if; + + -- In the following code we check for a difference of 2 seconds or less + + -- Recall that the time stamp format is: + + -- Y Y Y Y M M D D H H M M S S + -- 01 02 03 04 05 06 07 08 09 10 11 12 13 14 + + -- Note that we do not bother to worry about shifts in the day. + -- It seems unlikely that such shifts could ever occur in practice + -- and even if they do we err on the safe side, ie we say that the time + -- stamps are different. + + Sright := V (Right, 13) + 60 * (V (Right, 11) + 60 * V (Right, 09)); + Sleft := V (Left, 13) + 60 * (V (Left, 11) + 60 * V (Left, 09)); + + -- So the check is: dates must be the same, times differ 2 sec at most + + return abs (Sleft - Sright) <= 2 + and then String (Left (1 .. 8)) = String (Right (1 .. 8)); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left = Right) and then String (Left) > String (Right); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left < Right); + end ">="; + + ------------------- + -- Get_Char_Code -- + ------------------- + + function Get_Char_Code (C : Character) return Char_Code is + begin + return Char_Code'Val (Character'Pos (C)); + end Get_Char_Code; + + ------------------- + -- Get_Character -- + ------------------- + + -- Note: raises Constraint_Error if checks on and C out of range + + function Get_Character (C : Char_Code) return Character is + begin + return Character'Val (C); + end Get_Character; + + -------------------- + -- Get_Hex_String -- + -------------------- + + subtype Wordh is Word range 0 .. 15; + Hex : constant array (Wordh) of Character := "0123456789ABCDEF"; + + function Get_Hex_String (W : Word) return Word_Hex_String is + X : Word := W; + WS : Word_Hex_String; + + begin + for J in reverse 1 .. 8 loop + WS (J) := Hex (X mod 16); + X := X / 16; + end loop; + + return WS; + end Get_Hex_String; + + ------------------------ + -- In_Character_Range -- + ------------------------ + + function In_Character_Range (C : Char_Code) return Boolean is + begin + return (C <= 255); + end In_Character_Range; + + --------------------- + -- Make_Time_Stamp -- + --------------------- + + procedure Make_Time_Stamp + (Year : Nat; + Month : Nat; + Day : Nat; + Hour : Nat; + Minutes : Nat; + Seconds : Nat; + TS : out Time_Stamp_Type) + is + Z : constant := Character'Pos ('0'); + + begin + TS (01) := Character'Val (Z + Year / 1000); + TS (02) := Character'Val (Z + (Year / 100) mod 10); + TS (03) := Character'Val (Z + (Year / 10) mod 10); + TS (04) := Character'Val (Z + Year mod 10); + TS (05) := Character'Val (Z + Month / 10); + TS (06) := Character'Val (Z + Month mod 10); + TS (07) := Character'Val (Z + Day / 10); + TS (08) := Character'Val (Z + Day mod 10); + TS (09) := Character'Val (Z + Hour / 10); + TS (10) := Character'Val (Z + Hour mod 10); + TS (11) := Character'Val (Z + Minutes / 10); + TS (12) := Character'Val (Z + Minutes mod 10); + TS (13) := Character'Val (Z + Seconds / 10); + TS (14) := Character'Val (Z + Seconds mod 10); + end Make_Time_Stamp; + + ---------------------- + -- Split_Time_Stamp -- + ---------------------- + + procedure Split_Time_Stamp + (TS : Time_Stamp_Type; + Year : out Nat; + Month : out Nat; + Day : out Nat; + Hour : out Nat; + Minutes : out Nat; + Seconds : out Nat) + is + + begin + -- Y Y Y Y M M D D H H M M S S + -- 01 02 03 04 05 06 07 08 09 10 11 12 13 14 + + Year := 100 * V (TS, 01) + V (TS, 03); + Month := V (TS, 05); + Day := V (TS, 07); + Hour := V (TS, 09); + Minutes := V (TS, 11); + Seconds := V (TS, 13); + end Split_Time_Stamp; + + ------- + -- V -- + ------- + + function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat is + begin + return 10 * (Character'Pos (T (X)) - Character'Pos ('0')) + + Character'Pos (T (X + 1)) - Character'Pos ('0'); + end V; + +end Types; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads new file mode 100644 index 00000000000..1cbf57d2672 --- /dev/null +++ b/gcc/ada/types.ads @@ -0,0 +1,720 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.87 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Unchecked_Deallocation; + +package Types is +pragma Preelaborate (Types); + +-- This package contains host independent type definitions which are used +-- in more than one unit in the compiler. They are gathered here for easy +-- reference, though in some cases the full description is found in the +-- relevant module which implements the definition. The main reason that +-- they are not in their "natural" specs is that this would cause a lot of +-- inter-spec dependencies, and in particular some awkward circular +-- dependencies would have to be dealt with. + +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file a-types.h + +-- Note: the declarations in this package reflect an expectation that the +-- host machine has an efficient integer base type with a range at least +-- 32 bits 2s-complement. If there are any machines for which this is not +-- a correct assumption, a significant number of changes will be required! + + ------------------------------- + -- General Use Integer Types -- + ------------------------------- + + type Int is range -2 ** 31 .. +2 ** 31 - 1; + -- Signed 32-bit integer + + type Dint is range -2 ** 63 .. +2 ** 63 - 1; + -- Double length (64-bit) integer + + subtype Nat is Int range 0 .. Int'Last; + -- Non-negative Int values + + subtype Pos is Int range 1 .. Int'Last; + -- Positive Int values + + type Word is mod 2 ** 32; + -- Unsigned 32-bit integer + + type Short is range -32768 .. +32767; + for Short'Size use 16; + -- 16-bit signed integer + + type Byte is mod 2 ** 8; + for Byte'Size use 8; + -- 8-bit unsigned integer + + type size_t is mod 2 ** Standard'Address_Size; + -- Memory size value, for use in calls to C routines + + -------------------------------------- + -- 8-Bit Character and String Types -- + -------------------------------------- + + -- We use Standard.Character and Standard.String freely, since we are + -- compiling ourselves, and we properly implement the required 8-bit + -- character code as required in Ada 95. This section defines a few + -- general use constants and subtypes. + + EOF : constant Character := ASCII.SUB; + -- The character SUB (16#1A#) is used in DOS and other systems derived + -- from DOS (OS/2, NT etc) to signal the end of a text file. Internally + -- all source files are ended by an EOF character, even on Unix systems. + -- An EOF character acts as the end of file only as the last character + -- of a source buffer, in any other position, it is treated as a blank + -- if it appears between tokens, and as an illegal character otherwise. + -- This makes life easier dealing with files that originated from DOS, + -- including concatenated files with interspersed EOF characters. + + subtype Graphic_Character is Character range ' ' .. '~'; + -- Graphic characters, as defined in ARM + + subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR; + -- Line terminator characters (LF, VT, FF, CR) + + subtype Upper_Half_Character is + Character range Character'Val (16#80#) .. Character'Val (16#FF#); + -- Characters with the upper bit set + + type Character_Ptr is access all Character; + type String_Ptr is access all String; + -- Standard character and string pointers + + procedure Free is new Unchecked_Deallocation (String, String_Ptr); + -- Procedure for freeing dynamically allocated String values + + subtype Word_Hex_String is String (1 .. 8); + -- Type used to represent Word value as 8 hex digits, with upper case + -- letters for the alphabetic cases. + + function Get_Hex_String (W : Word) return Word_Hex_String; + -- Convert word value to 8-character hex string + + ----------------------------------------- + -- Types Used for Text Buffer Handling -- + ----------------------------------------- + + -- We can't use type String for text buffers, since we must use the + -- standard 32-bit integer as an index value, since we count on all + -- index values being the same size. + + type Text_Ptr is new Int; + -- Type used for subscripts in text buffer + + type Text_Buffer is array (Text_Ptr range <>) of Character; + -- Text buffer used to hold source file or library information file + + type Text_Buffer_Ptr is access all Text_Buffer; + -- Text buffers for input files are allocated dynamically and this type + -- is used to reference these text buffers. + + procedure Free is new Unchecked_Deallocation (Text_Buffer, Text_Buffer_Ptr); + -- Procedure for freeing dynamically allocated text buffers + + ------------------------------------------ + -- Types Used for Source Input Handling -- + ------------------------------------------ + + type Logical_Line_Number is range 0 .. Int'Last; + for Logical_Line_Number'Size use 32; + -- Line number type, used for storing logical line numbers (i.e. line + -- numbers that include effects of any Source_Reference pragmas in the + -- source file). The value zero indicates a line containing a source + -- reference pragma. + + No_Line_Number : constant Logical_Line_Number := 0; + -- Special value used to indicate no line number + + type Physical_Line_Number is range 1 .. Int'Last; + for Physical_Line_Number'Size use 32; + -- Line number type, used for storing physical line numbers (i.e. + -- line numbers in the physical file being compiled, unaffected by + -- the presence of source reference pragmas. + + type Column_Number is range 0 .. 32767; + for Column_Number'Size use 16; + -- Column number (assume that 2**15 is large enough, see declaration + -- of Hostparm.Max_Line_Length) + + No_Column_Number : constant Column_Number := 0; + -- Special value used to indicate no column number + + subtype Source_Buffer is Text_Buffer; + -- Type used to store text of a source file . The buffer for the main + -- source (the source specified on the command line) has a lower bound + -- starting at zero. Subsequent subsidiary sources have lower bounds + -- which are one greater than the previous upper bound. + + subtype Big_Source_Buffer is Text_Buffer (0 .. Text_Ptr'Last); + -- This is a virtual type used as the designated type of the access + -- type Source_Buffer_Ptr, see Osint.Read_Source_File for details. + + type Source_Buffer_Ptr is access all Big_Source_Buffer; + -- Pointer to source buffer. We use virtual origin addressing for + -- source buffers, with thin pointers. The pointer points to a virtual + -- instance of type Big_Source_Buffer, where the actual type is in fact + -- of type Source_Buffer. The address is adjusted so that the virtual + -- origin addressing works correctly. See Osint.Read_Source_Buffer for + -- further details. + + subtype Source_Ptr is Text_Ptr; + -- Type used to represent a source location, which is a subscript of a + -- character in the source buffer. As noted above, diffferent source + -- buffers have different ranges, so it is possible to tell from a + -- Source_Ptr value which source it refers to. Note that negative numbers + -- are allowed to accomodate the following special values. + + No_Location : constant Source_Ptr := -1; + -- Value used to indicate no source position set in a node + + Standard_Location : constant Source_Ptr := -2; + -- Used for all nodes in the representation of package Standard other + -- than nodes representing the contents of Standard.ASCII. Note that + -- testing for <= Standard_Location tests for both Standard_Location + -- and for Standard_ASCII_Location. + + Standard_ASCII_Location : constant Source_Ptr := -3; + -- Used for all nodes in the presentation of package Standard.ASCII + + First_Source_Ptr : constant Source_Ptr := 0; + -- Starting source pointer index value for first source program + + ------------------------------------- + -- Range Definitions for Tree Data -- + ------------------------------------- + + -- The tree has fields that can hold any of the following types: + + -- Pointers to other tree nodes (type Node_Id) + -- List pointers (type List_Id) + -- Element list pointers (type Elist_Id) + -- Names (type Name_Id) + -- Strings (type String_Id) + -- Universal integers (type Uint) + -- Universal reals (type Ureal) + -- Character codes (type Char_Code stored with a bias) + + -- In most contexts, the strongly typed interface determines which of + -- these types is present. However, there are some situations (involving + -- untyped traversals of the tree), where it is convenient to be easily + -- able to distinguish these values. The underlying representation in all + -- cases is an integer type Union_Id, and we ensure that the range of + -- the various possible values for each of the above types is disjoint + -- so that this distinction is possible. + + type Union_Id is new Int; + -- The type in the tree for a union of possible ID values + + -- Note: it is also helpful for debugging purposes to make these ranges + -- distinct. If a bug leads to misidentification of a value, then it will + -- typically result in an out of range value and a Constraint_Error. + + List_Low_Bound : constant := -100_000_000; + -- The List_Id values are subscripts into an array of list headers which + -- has List_Low_Bound as its lower bound. This value is chosen so that all + -- List_Id values are negative, and the value zero is in the range of both + -- List_Id and Node_Id values (see further description below). + + List_High_Bound : constant := 0; + -- Maximum List_Id subscript value. This allows up to 100 million list + -- Id values, which is in practice infinite, and there is no need to + -- check the range. The range overlaps the node range by one element + -- (with value zero), which is used both for the Empty node, and for + -- indicating no list. The fact that the same value is used is convenient + -- because it means that the default value of Empty applies to both nodes + -- and lists, and also is more efficient to test for. + + Node_Low_Bound : constant := 0; + -- The tree Id values start at zero, because we use zero for Empty (to + -- allow a zero test for Empty). Actual tree node subscripts start at 0 + -- since Empty is a legitimate node value. + + Node_High_Bound : constant := 099_999_999; + -- Maximum number of nodes that can be allocated is 100 million, which + -- is in practice infinite, and there is no need to check the range. + + Elist_Low_Bound : constant := 100_000_000; + -- The Elist_Id values are subscripts into an array of elist headers which + -- has Elist_Low_Bound as its lower bound. + + Elist_High_Bound : constant := 199_999_999; + -- Maximum Elist_Id subscript value. This allows up to 100 million Elists, + -- which is in practice infinite and there is no need to check the range. + + Elmt_Low_Bound : constant := 200_000_000; + -- Low bound of element Id values. The use of these values is internal to + -- the Elists package, but the definition of the range is included here + -- since it must be disjoint from other Id values. The Elmt_Id values are + -- subscripts into an array of list elements which has this as lower bound. + + Elmt_High_Bound : constant := 299_999_999; + -- Upper bound of Elmt_Id values. This allows up to 100 million element + -- list members, which is in practice infinite (no range check needed). + + Names_Low_Bound : constant := 300_000_000; + -- Low bound for name Id values + + Names_High_Bound : constant := 399_999_999; + -- Maximum number of names that can be allocated is 100 million, which is + -- in practice infinite and there is no need to check the range. + + Strings_Low_Bound : constant := 400_000_000; + -- Low bound for string Id values + + Strings_High_Bound : constant := 499_999_999; + -- Maximum number of strings that can be allocated is 100 million, which + -- is in practice infinite and there is no need to check the range. + + Ureal_Low_Bound : constant := 500_000_000; + -- Low bound for Ureal values. + + Ureal_High_Bound : constant := 599_999_999; + -- Maximum number of Ureal values stored is 100_000_000 which is in + -- practice infinite so that no check is required. + + Uint_Low_Bound : constant := 600_000_000; + -- Low bound for Uint values. + + Uint_Table_Start : constant := 2_000_000_000; + -- Location where table entries for universal integers start (see + -- Uintp spec for details of the representation of Uint values). + + Uint_High_Bound : constant := 2_099_999_999; + -- The range of Uint values is very large, since a substantial part + -- of this range is used to store direct values, see Uintp for details. + + Char_Code_Bias : constant := 2_100_000_000; + -- A bias value added to character code values stored in the tree which + -- ensures that they have different values from any of the above types. + + -- The following subtype definitions are used to provide convenient names + -- for membership tests on Int values to see what data type range they + -- lie in. Such tests appear only in the lowest level packages. + + subtype List_Range is Union_Id + range List_Low_Bound .. List_High_Bound; + + subtype Node_Range is Union_Id + range Node_Low_Bound .. Node_High_Bound; + + subtype Elist_Range is Union_Id + range Elist_Low_Bound .. Elist_High_Bound; + + subtype Elmt_Range is Union_Id + range Elmt_Low_Bound .. Elmt_High_Bound; + + subtype Names_Range is Union_Id + range Names_Low_Bound .. Names_High_Bound; + + subtype Strings_Range is Union_Id + range Strings_Low_Bound .. Strings_High_Bound; + + subtype Uint_Range is Union_Id + range Uint_Low_Bound .. Uint_High_Bound; + + subtype Ureal_Range is Union_Id + range Ureal_Low_Bound .. Ureal_High_Bound; + + subtype Char_Code_Range is Union_Id + range Char_Code_Bias .. Char_Code_Bias + 2**16 - 1; + + ----------------------------- + -- Types for Namet Package -- + ----------------------------- + + -- Name_Id values are used to identify entries in the names table. Except + -- for the special values No_Name, and Error_Name, they are subscript + -- values for the Names table defined in package Namet. + + -- Note that with only a few exceptions, which are clearly documented, the + -- type Name_Id should be regarded as a private type. In particular it is + -- never appropriate to perform arithmetic operations using this type. + + type Name_Id is range Names_Low_Bound .. Names_High_Bound; + for Name_Id'Size use 32; + -- Type used to identify entries in the names table + + No_Name : constant Name_Id := Names_Low_Bound; + -- The special Name_Id value No_Name is used in the parser to indicate + -- a situation where no name is present (e.g. on a loop or block). + + Error_Name : constant Name_Id := Names_Low_Bound + 1; + -- The special Name_Id value Error_Name is used in the parser to + -- indicate that some kind of error was encountered in scanning out + -- the relevant name, so it does not have a representable label. + + First_Name_Id : constant Name_Id := Names_Low_Bound + 2; + -- Subscript of first entry in names table + + ---------------------------- + -- Types for Atree Package -- + ---------------------------- + + -- Node_Id values are used to identify nodes in the tree. They are + -- subscripts into the Node table declared in package Tree. Note that + -- the special values Empty and Error are subscripts into this table, + -- See package Atree for further details. + + type Node_Id is range Node_Low_Bound .. Node_High_Bound; + -- Type used to identify nodes in the tree + + subtype Entity_Id is Node_Id; + -- A synonym for node types, used in the entity package to refer to + -- nodes that are entities (i.e. nodes with an Nkind of N_Defining_xxx) + -- All such nodes are extended nodes and these are the only extended + -- nodes, so that in practice entity and extended nodes are synonymous. + + subtype Node_Or_Entity_Id is Node_Id; + -- A synonym for node types, used in cases where a given value may be used + -- to represent either a node or an entity. We like to minimize such uses + -- for obvious reasons of logical type consistency, but where such uses + -- occur, they should be documented by use of this type. + + Empty : constant Node_Id := Node_Low_Bound; + -- Used to indicate null node. A node is actually allocated with this + -- Id value, so that Nkind (Empty) = N_Empty. Note that Node_Low_Bound + -- is zero, so Empty = No_List = zero. + + Empty_List_Or_Node : constant := 0; + -- This constant is used in situations (e.g. initializing empty fields) + -- where the value set will be used to represent either an empty node + -- or a non-existent list, depending on the context. + + Error : constant Node_Id := Node_Low_Bound + 1; + -- Used to indicate that there was an error in the source program. A node + -- is actually allocated at this address, so that Nkind (Error) = N_Error. + + Empty_Or_Error : constant Node_Id := Error; + -- Since Empty and Error are the first two Node_Id values, the test for + -- N <= Empty_Or_Error tests to see if N is Empty or Error. This definition + -- provides convenient self-documentation for such tests. + + First_Node_Id : constant Node_Id := Node_Low_Bound; + -- Subscript of first allocated node. Note that Empty and Error are both + -- allocated nodes, whose Nkind fields can be accessed without error. + + ------------------------------ + -- Types for Nlists Package -- + ------------------------------ + + -- List_Id values are used to identify node lists in the tree. They are + -- subscripts into the Lists table declared in package Tree. Note that + -- the special value Error_List is a subscript in this table, but the + -- value No_List is *not* a valid subscript, and any attempt to apply + -- list operations to No_List will cause a (detected) error. + + type List_Id is range List_Low_Bound .. List_High_Bound; + -- Type used to identify a node list + + No_List : constant List_Id := List_High_Bound; + -- Used to indicate absence of a list. Note that the value is zero, which + -- is the same as Empty, which is helpful in intializing nodes where a + -- value of zero can represent either an empty node or an empty list. + + Error_List : constant List_Id := List_Low_Bound; + -- Used to indicate that there was an error in the source program in a + -- context which would normally require a list. This node appears to be + -- an empty list to the list operations (a null list is actually allocated + -- which has this Id value). + + First_List_Id : constant List_Id := Error_List; + -- Subscript of first allocated list header + + ------------------------------ + -- Types for Elists Package -- + ------------------------------ + + -- Element list Id values are used to identify element lists stored in + -- the tree (see package Tree for further details). They are formed by + -- adding a bias (Element_List_Bias) to subscript values in the same + -- array that is used for node list headers. + + type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound; + -- Type used to identify an element list (Elist header table subscript) + + No_Elist : constant Elist_Id := Elist_Low_Bound; + -- Used to indicate absense of an element list. Note that this is not + -- an actual Elist header, so element list operations on this value + -- are not valid. + + First_Elist_Id : constant Elist_Id := No_Elist + 1; + -- Subscript of first allocated Elist header. + + -- Element Id values are used to identify individual elements of an + -- element list (see package Elists for further details). + + type Elmt_Id is range Elmt_Low_Bound .. Elmt_High_Bound; + -- Type used to identify an element list + + No_Elmt : constant Elmt_Id := Elmt_Low_Bound; + -- Used to represent empty element + + First_Elmt_Id : constant Elmt_Id := No_Elmt + 1; + -- Subscript of first allocated Elmt table entry + + ------------------------------- + -- Types for Stringt Package -- + ------------------------------- + + -- String_Id values are used to identify entries in the strings table. + -- They are subscripts into the strings table defined in package Strings. + + -- Note that with only a few exceptions, which are clearly documented, the + -- type String_Id should be regarded as a private type. In particular it is + -- never appropriate to perform arithmetic operations using this type. + + type String_Id is range Strings_Low_Bound .. Strings_High_Bound; + -- Type used to identify entries in the strings table + + No_String : constant String_Id := Strings_Low_Bound; + -- Used to indicate missing string Id. Note that the value zero is used + -- to indicate a missing data value for all the Int types in this section. + + First_String_Id : constant String_Id := No_String + 1; + -- First subscript allocated in string table + + ------------------------- + -- Character Code Type -- + ------------------------- + + -- The type Char is used for character data internally in the compiler, + -- but character codes in the source are represented by the Char_Code + -- type. Each character literal in the source is interpreted as being one + -- of the 2**16 possible Wide_Character codes, and a unique integer value + -- is assigned, corresponding to the POS value in the Wide_Character type. + -- String literals are similarly interpreted as a sequence of such codes. + + -- Note: when character code values are stored in the tree, they are stored + -- by adding a bias value (Char_Code_Bias) that results in values that can + -- be distinguished from other types of values stored in the tree. + + type Char_Code is mod 2 ** 16; + for Char_Code'Size use 16; + + function Get_Char_Code (C : Character) return Char_Code; + pragma Inline (Get_Char_Code); + -- Function to obtain internal character code from source character. For + -- the moment, the internal character code is simply the Pos value of the + -- input source character, but we provide this interface for possible + -- later support of alternative character sets. + + function In_Character_Range (C : Char_Code) return Boolean; + pragma Inline (In_Character_Range); + -- Determines if the given character code is in range of type Character, + -- and if so, returns True. If not, returns False. + + function Get_Character (C : Char_Code) return Character; + pragma Inline (Get_Character); + -- For a character C that is in character range (see above function), this + -- function returns the corresponding Character value. It is an error to + -- call Get_Character if C is not in character range + + --------------------------------------- + -- Types used for Library Management -- + --------------------------------------- + + type Unit_Number_Type is new Int; + -- Unit number. The main source is unit 0, and subsidiary sources have + -- non-zero numbers starting with 1. Unit numbers are used to index the + -- file table in Lib. + + Main_Unit : constant Unit_Number_Type := 0; + -- Unit number value for main unit + + No_Unit : constant Unit_Number_Type := -1; + -- Special value used to signal no unit + + type Source_File_Index is new Nat; + -- Type used to index the source file table (see package Sinput) + + No_Source_File : constant Source_File_Index := 0; + -- Value used to indicate no source file present + + System_Source_File_Index : constant Source_File_Index := 1; + -- Value used for source file table entry for system.ads, which is + -- always the first source file read (see unit Targparm for details). + + subtype File_Name_Type is Name_Id; + -- File names are stored in the names table and this synonym is used to + -- indicate that a Name_Id value is being used to hold a simple file + -- name (which does not include any directory information). + + No_File : constant File_Name_Type := File_Name_Type (No_Name); + -- Constant used to indicate no file found + + subtype Unit_Name_Type is Name_Id; + -- Unit names are stored in the names table and this synonym is used to + -- indicate that a Name_Id value is being used to hold a unit name. + + ----------------------------------- + -- Representation of Time Stamps -- + ----------------------------------- + + -- All compiled units are marked with a time stamp which is derived from + -- the source file (we assume that the host system has the concept of a + -- file time stamp which is modified when a file is modified). These + -- time stamps are used to ensure consistency of the set of units that + -- constitutes a library. Time stamps are 12 character strings with + -- with the following format: + + -- YYYYMMDDHHMMSS + + -- YYYY year + -- MM month (2 digits 01-12) + -- DD day (2 digits 01-31) + -- HH hour (2 digits 00-23) + -- MM minutes (2 digits 00-59) + -- SS seconds (2 digits 00-59) + + -- In the case of Unix systems (and other systems which keep the time in + -- GMT), the time stamp is the GMT time of the file, not the local time. + -- This solves problems in using libraries across networks with clients + -- spread across multiple time-zones. + + Time_Stamp_Length : constant := 14; + -- Length of time stamp value + + subtype Time_Stamp_Index is Natural range 1 .. Time_Stamp_Length; + type Time_Stamp_Type is new String (Time_Stamp_Index); + -- Type used to represent time stamp + + Empty_Time_Stamp : constant Time_Stamp_Type := (others => ' '); + -- Type used to represent an empty or missing time stamp. Looks less + -- than any real time stamp if two time stamps are compared. Note that + -- although this is not a private type, clients should not rely on the + -- exact way in which this string is represented, and instead should + -- use the subprograms below. + + function "=" (Left, Right : Time_Stamp_Type) return Boolean; + function "<=" (Left, Right : Time_Stamp_Type) return Boolean; + function ">=" (Left, Right : Time_Stamp_Type) return Boolean; + function "<" (Left, Right : Time_Stamp_Type) return Boolean; + function ">" (Left, Right : Time_Stamp_Type) return Boolean; + -- Comparison functions on time stamps. Note that two time stamps + -- are defined as being equal if they have the same day/month/year + -- and the hour/minutes/seconds values are within 2 seconds of one + -- another. This deals with rounding effects in library file time + -- stamps caused by copying operations during installation. We have + -- particularly noticed that WinNT seems susceptible to such changes. + -- Note: the Empty_Time_Stamp value looks equal to itself, and less + -- than any non-empty time stamp value. + + procedure Split_Time_Stamp + (TS : Time_Stamp_Type; + Year : out Nat; + Month : out Nat; + Day : out Nat; + Hour : out Nat; + Minutes : out Nat; + Seconds : out Nat); + -- Given a time stamp, decompose it into its components + + procedure Make_Time_Stamp + (Year : Nat; + Month : Nat; + Day : Nat; + Hour : Nat; + Minutes : Nat; + Seconds : Nat; + TS : out Time_Stamp_Type); + -- Given the components of a time stamp, initialize the value + + ----------------------------------------------- + -- Types used for Pragma Suppress Management -- + ----------------------------------------------- + + -- The following record contains an entry for each recognized check name + -- for pragma Suppress. It is used to represent current settings of scope + -- based suppress actions from pragma Suppress or command line settings. + + type Suppress_Record is record + Access_Checks : Boolean; + Accessibility_Checks : Boolean; + Discriminant_Checks : Boolean; + Division_Checks : Boolean; + Elaboration_Checks : Boolean; + Index_Checks : Boolean; + Length_Checks : Boolean; + Overflow_Checks : Boolean; + Range_Checks : Boolean; + Storage_Checks : Boolean; + Tag_Checks : Boolean; + end record; + + -- To add a new check type to GNAT, the following steps are required: + + -- 1. Add an appropriate entry to the above record type + -- 2. Add an entry to Snames spec and body for the new name + -- 3. Add an entry to the definition of Check_Id in the Snames spec + -- 4. Add a new entity flag definition in Einfo for the check + -- 5. Add a new function to Sem.Util to handle the new check test + -- 6. Add appropriate processing for pragma Suppress in Sem.Prag + -- 7. Add a branch to the case statement in Sem.Ch8.Pop_Scope + -- 8. Add a new Do_xxx_Check flag to Sinfo (if required) + -- 9. Add appropriate checks for the new test + + ----------------------------------- + -- Global Exception Declarations -- + ----------------------------------- + + -- This section contains declarations of exceptions that are used + -- throughout the compiler. + + Unrecoverable_Error : exception; + -- This exception is raised to immediately terminate the compilation + -- of the current source program. Used in situations where things are + -- bad enough that it doesn't seem worth continuing (e.g. max errors + -- reached, or a required file is not found). Also raised when the + -- compiler finds itself in trouble after an error (see Comperr). + + --------------------------------- + -- Parameter Mechanism Control -- + --------------------------------- + + -- Function and parameter entities have a field that records the + -- passing mechanism. See specification of Sem_Mech for full details. + -- The following subtype is used to represent values of this type: + + subtype Mechanism_Type is Int range -10 .. Int'Last; + -- Type used to represent a mechanism value. This is a subtype rather + -- than a type to avoid some annoying processing problems with certain + -- routines in Einfo (processing them to create the corresponding C). + +end Types; diff --git a/gcc/ada/types.h b/gcc/ada/types.h new file mode 100644 index 00000000000..e993bdbea6a --- /dev/null +++ b/gcc/ada/types.h @@ -0,0 +1,335 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T Y P E S * + * * + * C Header File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-2001, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 2, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* This is the C file that corresponds to the Ada package spec Types. It was + created manually from the files types.ads and types.adb. + + This package contains host independent type definitions which are used + throughout the compiler modules. The comments in the C version are brief + reminders of the purpose of each declaration. For complete documentation, + see the Ada version of these definitions. */ + +/* Boolean Types: */ + +/* Boolean type (cannot use enum, because of bit field restriction on some + compilers). */ +typedef unsigned char Boolean; +#define False 0 +#define True 1 + +/* General Use Integer Types */ + +/* Signed 32/bit integer */ +typedef int Int; + +/* Signed 16 bit integer */ +typedef short Short; + +/* Non/negative Int values */ +typedef Int Nat; + +/* Positive Int values */ +typedef Int Pos; + +/* 8/bit unsigned integer */ +typedef char Byte; + +/* 8/Bit Character and String Types: */ + +/* 8/bit character type */ +typedef char Char; + +/* Graphic characters, as defined in ARM */ +typedef Char Graphic_Character; + +/* Line terminator characters (LF, VT, FF, CR) */ +typedef Char Line_Terminator; + +/* Characters with the upper bit set */ +typedef Char Upper_Half_Character; + +/* String type built on Char (note that zero is an OK index) */ +typedef Char *Str; + +/* Pointer to string of Chars */ +typedef Char *Str_Ptr; + +/* Types for the fat pointer used for strings and the template it + points to. */ +typedef struct {int Low_Bound, High_Bound; } String_Template; +typedef struct {const char *Array; String_Template *Bounds; } + __attribute ((aligned (sizeof (char *) * 2))) Fat_Pointer; + +/* Types for Node/Entity Kinds: */ + +/* The reason that these are defined here in the C version, rather than in the + corresponding packages is that the requirement for putting bodies of + inlined stuff IN the C header changes the dependencies. Both a-sinfo.h + and a-einfo.h now reference routines defined in tree.h. + + Note: these types would more naturally be defined as unsigned char, but + once again, the annoying restriction on bit fields for some compilers + bites us! */ + +typedef unsigned int Node_Kind; +typedef unsigned int Entity_Kind; + +/* Types used for Text Buffer Handling: */ + +/* Type used for subscripts in text buffer. */ +typedef Int Text_Ptr; + +/* Text buffer used to hold source file or library information file. */ +typedef Char *Text_Buffer; + +/* Pointer to text buffer. */ +typedef Char *Text_Buffer_Ptr; + +/* Types used for Source Input Handling: */ + +/* Line number type, used for storing all line numbers. */ +typedef Int Line_Number_Type; + +/* Column number type, used for storing all column numbers. */ +typedef Int Column_Number_Type; + +/* Type used to store text of a source file. */ +typedef Text_Buffer Source_Buffer; + +/* Pointer to source buffer. */ +typedef Text_Buffer_Ptr Source_Buffer_Ptr; + +/* Type used for source location. */ +typedef Text_Ptr Source_Ptr; + +/* Value used to indicate no source position set. */ +#define No_Location -1 + +/* Used for Sloc in all nodes in the representation of package Standard. */ +#define Standard_Location -2 + +/* Type used for union of all possible ID values covering all ranges */ +typedef int Union_Id; + +/* Range definitions for Tree Data: */ + +#define List_Low_Bound -100000000 +#define List_High_Bound 0 + +#define Node_Low_Bound 0 +#define Node_High_Bound 99999999 + +#define Elist_Low_Bound 100000000 +#define Elist_High_Bound 199999999 + +#define Elmt_Low_Bound 200000000 +#define Elmt_High_Bound 299999999 + +#define Names_Low_Bound 300000000 +#define Names_High_Bound 399999999 + +#define Strings_Low_Bound 400000000 +#define Strings_High_Bound 499999999 + +#define Ureal_Low_Bound 500000000 +#define Ureal_High_Bound 599999999 + +#define Uint_Low_Bound 600000000 +#define Uint_Table_Start 2000000000 +#define Uint_High_Bound 2099999999 + +#define Char_Code_Bias 2100000000 + +SUBTYPE (List_Range, Int, List_Low_Bound, List_High_Bound) +SUBTYPE (Node_Range, Int, Node_Low_Bound, Node_High_Bound) +SUBTYPE (Elist_Range, Int, Elist_Low_Bound, Elist_High_Bound) +SUBTYPE (Elmt_Range, Int, Elmt_Low_Bound, Elmt_High_Bound) +SUBTYPE (Names_Range, Int, Names_Low_Bound, Names_High_Bound) +SUBTYPE (Strings_Range, Int, Strings_Low_Bound, Strings_High_Bound) +SUBTYPE (Uint_Range, Int, Uint_Low_Bound, Uint_High_Bound) +SUBTYPE (Ureal_Range, Int, Ureal_Low_Bound, Ureal_High_Bound) +SUBTYPE (Char_Code_Range, Int, Char_Code_Bias, (Char_Code_Bias + 65535)) + +/* Types for Names_Table Package: */ + +typedef Int Name_Id; + +/* Name_Id value for no name present. */ +#define No_Name Names_Low_Bound + +/* Name_Id value for bad name. */ +#define Error_Name (Names_Low_Bound + 1) + +/* First subscript of names table. */ +#define First_Name_Id (Names_Low_Bound + 2) + +/* Types for Tree Package: */ + +/* Subscript of nodes table entry. */ +typedef Int Node_Id; + +/* Used in semantics for Node_Id value referencing an entity. */ +typedef Node_Id Entity_Id; + +/* Null node. */ +#define Empty 0 + +/* Error node. */ +#define Error 1 + +/* Subscript of first allocated node. */ +#define First_Node_Id Empty + +/* Subscript of entry in lists table. */ +typedef Int List_Id; + +/* Indicates absence of a list. */ +#define No_List 0 + +/* Error list. */ +#define Error_List List_Low_Bound + +/* Subscript of first allocated list header. */ +#define First_List_Id Error_List + +/* Element list Id, subscript value of entry in lists table. */ +typedef Int Elist_Id; + +/* Used to indicate absence of an element list. */ +#define No_Elist Elist_Low_Bound + +/* Subscript of first allocated elist header */ +#define First_Elist_Id (No_Elist + 1) + +/* Element Id, subscript value of entry in elements table. */ +typedef Int Elmt_Id; + +/* Used to indicate absence of a list element. */ +#define No_Elmt Elmt_Low_Bound + +/* Subscript of first allocated element */ +#define First_Elmt_Id (No_Elmt + 1) + +/* Types for String_Table Package: */ + +/* Subscript of strings table entry. */ +typedef Int String_Id; + +/* Used to indicate missing string Id. */ +#define No_String Strings_Low_Bound + +/* Subscript of first entry in strings table. */ +#define First_String_Id (No_String + 1) + +/* Types for Uint_Support Package: */ + +/* Type used for representation of universal integers. */ +typedef Int Uint; + +/* Used to indicate missing Uint value. */ +#define No_Uint Uint_Low_Bound + +/* Base value used to represent Uint values. */ +#define Base 32768 + +/* Minimum and maximum integers directly representable as Uint values */ +#define Min_Direct (-(Base - 1)) +#define Max_Direct ((Base - 1) * (Base - 1)) + +#define Uint_Direct_Bias (Uint_Low_Bound + Base) +#define Uint_Direct_First (Uint_Direct_Bias + Min_Direct) +#define Uint_Direct_Last (Uint_Direct_Bias + Max_Direct) + +/* Define range of direct biased values */ +SUBTYPE (Uint_Direct, Uint, Uint_Direct_First, Uint_Direct_Last) + +/* Constants in Uint format. */ +#define Uint_0 (Uint_Direct_Bias + 0) +#define Uint_1 (Uint_Direct_Bias + 1) +#define Uint_2 (Uint_Direct_Bias + 2) +#define Uint_10 (Uint_Direct_Bias + 10) +#define Uint_16 (Uint_Direct_Bias + 16) + +/* Types for Ureal_Support Package: */ + +/* Type used for representation of universal reals. */ +typedef Int Ureal; + +/* Used to indicate missing Uint value. */ +#define No_Ureal Ureal_Low_Bound + +/* Subscript of first entry in Ureal table. */ +#define Ureal_First_Entry (No_Ureal + 1) + +/* Character Code Type: */ + +/* Character code value, intended to be 16 bits. */ +typedef short Char_Code; + +/* Types Used for Library Management: */ + +/* Unit number. */ +typedef Int Unit_Number_Type; + +/* Unit number value for main unit. */ +#define Main_Unit 0 + +/* Type used for lines table. */ +typedef Source_Ptr *Lines_Table_Type; + +/* Type used for pointer to lines table. */ +typedef Source_Ptr *Lines_Table_Ptr; + +/* Length of time stamp value. */ +#define Time_Stamp_Length 22 + +/* Type used to represent time stamp. */ +typedef Char *Time_Stamp_Type; + +/* Name_Id synonym used for file names. */ +typedef Name_Id File_Name_Type; + +/* Constant used to indicate no file found. */ +#define No_File No_Name + +/* Name_Id synonym used for unit names. */ +typedef Name_Id Unit_Name_Type; + +/* Definitions for mechanism type and values */ +typedef Int Mechanism_Type; +#define Default 0 +#define By_Copy (-1) +#define By_Reference (-2) +#define By_Descriptor (-3) +#define By_Descriptor_UBS (-4) +#define By_Descriptor_UBSB (-5) +#define By_Descriptor_UBA (-6) +#define By_Descriptor_S (-7) +#define By_Descriptor_SB (-8) +#define By_Descriptor_A (-9) +#define By_Descriptor_NCA (-10) diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb new file mode 100644 index 00000000000..d60986b07d0 --- /dev/null +++ b/gcc/ada/uintp.adb @@ -0,0 +1,2472 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads new file mode 100644 index 00000000000..1cfb79ae17b --- /dev/null +++ b/gcc/ada/uintp.ads @@ -0,0 +1,505 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U I N T P -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.58 $ +-- -- +-- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Support for universal integer arithmetic + +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file sinfo.h + +with Alloc; +with Table; +with Types; use Types; + +package Uintp is + + ------------------------------------------------- + -- Basic Types and Constants for Uintp Package -- + ------------------------------------------------- + + type Uint is private; + -- The basic universal integer type + + No_Uint : constant Uint; + -- A constant value indicating a missing or unset Uint value + + Uint_0 : constant Uint; + Uint_1 : constant Uint; + Uint_2 : constant Uint; + Uint_3 : constant Uint; + Uint_4 : constant Uint; + Uint_5 : constant Uint; + Uint_6 : constant Uint; + Uint_7 : constant Uint; + Uint_8 : constant Uint; + Uint_9 : constant Uint; + Uint_10 : constant Uint; + Uint_12 : constant Uint; + Uint_15 : constant Uint; + Uint_16 : constant Uint; + Uint_24 : constant Uint; + Uint_32 : constant Uint; + Uint_63 : constant Uint; + Uint_64 : constant Uint; + Uint_128 : constant Uint; + + Uint_Minus_1 : constant Uint; + Uint_Minus_2 : constant Uint; + Uint_Minus_3 : constant Uint; + Uint_Minus_4 : constant Uint; + Uint_Minus_5 : constant Uint; + Uint_Minus_6 : constant Uint; + Uint_Minus_7 : constant Uint; + Uint_Minus_8 : constant Uint; + Uint_Minus_9 : constant Uint; + Uint_Minus_12 : constant Uint; + Uint_Minus_128 : constant Uint; + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Initialize Uint tables. Note that Initialize must not be called if + -- Tree_Read is used. Note also that there is no lock routine in this + -- unit, these are among the few tables that can be expanded during + -- gigi processing. + + procedure Tree_Read; + -- Initializes internal tables from current tree file using Tree_Read. + -- Note that Initialize should not be called if Tree_Read is used. + -- Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using Tree_Write. + + function UI_Abs (Right : Uint) return Uint; + pragma Inline (UI_Abs); + -- Returns abs function of universal integer. + + function UI_Add (Left : Uint; Right : Uint) return Uint; + function UI_Add (Left : Int; Right : Uint) return Uint; + function UI_Add (Left : Uint; Right : Int) return Uint; + -- Returns sum of two integer values. + + function UI_Decimal_Digits_Hi (U : Uint) return Nat; + -- Returns an estimate of the number of decimal digits required to + -- represent the absolute value of U. This estimate is correct or high, + -- i.e. it never returns a value that is too low. The accuracy of the + -- estimate affects only the effectiveness of comparison optimizations + -- in Urealp. + + function UI_Decimal_Digits_Lo (U : Uint) return Nat; + -- Returns an estimate of the number of decimal digits required to + -- represent the absolute value of U. This estimate is correct or low, + -- i.e. it never returns a value that is too high. The accuracy of the + -- estimate affects only the effectiveness of comparison optimizations + -- in Urealp. + + function UI_Div (Left : Uint; Right : Uint) return Uint; + function UI_Div (Left : Int; Right : Uint) return Uint; + function UI_Div (Left : Uint; Right : Int) return Uint; + -- Returns quotient of two integer values. Fatal error if Right = 0 + + function UI_Eq (Left : Uint; Right : Uint) return Boolean; + function UI_Eq (Left : Int; Right : Uint) return Boolean; + function UI_Eq (Left : Uint; Right : Int) return Boolean; + pragma Inline (UI_Eq); + -- Compares integer values for equality. + + function UI_Expon (Left : Uint; Right : Uint) return Uint; + function UI_Expon (Left : Int; Right : Uint) return Uint; + function UI_Expon (Left : Uint; Right : Int) return Uint; + function UI_Expon (Left : Int; Right : Int) return Uint; + -- Returns result of exponentiating two integer values + -- Fatal error if Right is negative. + + function UI_GCD (Uin, Vin : Uint) return Uint; + -- Computes GCD of input values. Assumes Uin >= Vin >= 0. + + function UI_Ge (Left : Uint; Right : Uint) return Boolean; + function UI_Ge (Left : Int; Right : Uint) return Boolean; + function UI_Ge (Left : Uint; Right : Int) return Boolean; + pragma Inline (UI_Ge); + -- Compares integer values for greater than or equal. + + function UI_Gt (Left : Uint; Right : Uint) return Boolean; + function UI_Gt (Left : Int; Right : Uint) return Boolean; + function UI_Gt (Left : Uint; Right : Int) return Boolean; + pragma Inline (UI_Gt); + -- Compares integer values for greater than. + + function UI_Is_In_Int_Range (Input : Uint) return Boolean; + pragma Inline (UI_Is_In_Int_Range); + -- Determines if universal integer is in Int range. + + function UI_Le (Left : Uint; Right : Uint) return Boolean; + function UI_Le (Left : Int; Right : Uint) return Boolean; + function UI_Le (Left : Uint; Right : Int) return Boolean; + pragma Inline (UI_Le); + -- Compares integer values for less than or equal. + + function UI_Lt (Left : Uint; Right : Uint) return Boolean; + function UI_Lt (Left : Int; Right : Uint) return Boolean; + function UI_Lt (Left : Uint; Right : Int) return Boolean; + -- Compares integer values for less than. + + function UI_Max (Left : Uint; Right : Uint) return Uint; + function UI_Max (Left : Int; Right : Uint) return Uint; + function UI_Max (Left : Uint; Right : Int) return Uint; + -- Returns maximum of two integer values + + function UI_Min (Left : Uint; Right : Uint) return Uint; + function UI_Min (Left : Int; Right : Uint) return Uint; + function UI_Min (Left : Uint; Right : Int) return Uint; + -- Returns minimum of two integer values. + + function UI_Mod (Left : Uint; Right : Uint) return Uint; + function UI_Mod (Left : Int; Right : Uint) return Uint; + function UI_Mod (Left : Uint; Right : Int) return Uint; + pragma Inline (UI_Mod); + -- Returns mod function of two integer values. + + function UI_Mul (Left : Uint; Right : Uint) return Uint; + function UI_Mul (Left : Int; Right : Uint) return Uint; + function UI_Mul (Left : Uint; Right : Int) return Uint; + -- Returns product of two integer values + + function UI_Ne (Left : Uint; Right : Uint) return Boolean; + function UI_Ne (Left : Int; Right : Uint) return Boolean; + function UI_Ne (Left : Uint; Right : Int) return Boolean; + pragma Inline (UI_Ne); + -- Compares integer values for inequality. + + function UI_Negate (Right : Uint) return Uint; + pragma Inline (UI_Negate); + -- Returns negative of universal integer. + + function UI_Rem (Left : Uint; Right : Uint) return Uint; + function UI_Rem (Left : Int; Right : Uint) return Uint; + function UI_Rem (Left : Uint; Right : Int) return Uint; + -- Returns rem of two integer values. + + function UI_Sub (Left : Uint; Right : Uint) return Uint; + function UI_Sub (Left : Int; Right : Uint) return Uint; + function UI_Sub (Left : Uint; Right : Int) return Uint; + pragma Inline (UI_Sub); + -- Returns difference of two integer values + + function UI_From_Dint (Input : Dint) return Uint; + -- Converts Dint value to universal integer form. + + function UI_From_Int (Input : Int) return Uint; + -- Converts Int value to universal integer form. + + function UI_To_Int (Input : Uint) return Int; + -- Converts universal integer value to Int. Fatal error + -- if value is not in appropriate range. + + function Num_Bits (Input : Uint) return Nat; + -- Approximate number of binary bits in given universal integer. + -- This function is used for capacity checks, and it can be one + -- bit off without affecting its usage. + + --------------------- + -- Output Routines -- + --------------------- + + type UI_Format is (Hex, Decimal, Auto); + -- Used to determine whether UI_Image/UI_Write output is in hexadecimal + -- or decimal format. Auto, the default setting, lets the routine make + -- a decision based on the value. + + UI_Image_Max : constant := 32; + UI_Image_Buffer : String (1 .. UI_Image_Max); + UI_Image_Length : Natural; + -- Buffer used for UI_Image as described below + + procedure UI_Image (Input : Uint; Format : UI_Format := Auto); + -- Places a representation of Uint, consisting of a possible minus sign, + -- followed by the value in UI_Image_Buffer. The form of the value is an + -- integer literal in either decimal (no base) or hexadecimal (base 16) + -- format. If Hex is True on entry, then hex mode is forced, otherwise + -- UI_Image makes a guess at which output format is more convenient. The + -- value must fit in UI_Image_Buffer. If necessary, the result is an + -- approximation of the proper value, using an exponential format. The + -- image of No_Uint is output as a single question mark. + + procedure UI_Write (Input : Uint; Format : UI_Format := Auto); + -- Writes a representation of Uint, consisting of a possible minus sign, + -- followed by the value to the output file. The form of the value is an + -- integer literal in either decimal (no base) or hexadecimal (base 16) + -- format as appropriate. UI_Format shows which format to use. Auto, + -- the default, asks UI_Write to make a guess at which output format + -- will be more convenient to read. + + procedure pid (Input : Uint); + -- Writes representation of Uint in decimal with a terminating line + -- return. This is intended for use from the debugger. + + procedure pih (Input : Uint); + -- Writes representation of Uint in hex with a terminating line return. + -- This is intended for use from the debugger. + + ------------------------ + -- Operator Renamings -- + ------------------------ + + function "+" (Left : Uint; Right : Uint) return Uint renames UI_Add; + function "+" (Left : Int; Right : Uint) return Uint renames UI_Add; + function "+" (Left : Uint; Right : Int) return Uint renames UI_Add; + + function "/" (Left : Uint; Right : Uint) return Uint renames UI_Div; + function "/" (Left : Int; Right : Uint) return Uint renames UI_Div; + function "/" (Left : Uint; Right : Int) return Uint renames UI_Div; + + function "*" (Left : Uint; Right : Uint) return Uint renames UI_Mul; + function "*" (Left : Int; Right : Uint) return Uint renames UI_Mul; + function "*" (Left : Uint; Right : Int) return Uint renames UI_Mul; + + function "-" (Left : Uint; Right : Uint) return Uint renames UI_Sub; + function "-" (Left : Int; Right : Uint) return Uint renames UI_Sub; + function "-" (Left : Uint; Right : Int) return Uint renames UI_Sub; + + function "**" (Left : Uint; Right : Uint) return Uint renames UI_Expon; + function "**" (Left : Uint; Right : Int) return Uint renames UI_Expon; + function "**" (Left : Int; Right : Uint) return Uint renames UI_Expon; + function "**" (Left : Int; Right : Int) return Uint renames UI_Expon; + + function "abs" (Real : Uint) return Uint renames UI_Abs; + + function "mod" (Left : Uint; Right : Uint) return Uint renames UI_Mod; + function "mod" (Left : Int; Right : Uint) return Uint renames UI_Mod; + function "mod" (Left : Uint; Right : Int) return Uint renames UI_Mod; + + function "rem" (Left : Uint; Right : Uint) return Uint renames UI_Rem; + function "rem" (Left : Int; Right : Uint) return Uint renames UI_Rem; + function "rem" (Left : Uint; Right : Int) return Uint renames UI_Rem; + + function "-" (Real : Uint) return Uint renames UI_Negate; + + function "=" (Left : Uint; Right : Uint) return Boolean renames UI_Eq; + function "=" (Left : Int; Right : Uint) return Boolean renames UI_Eq; + function "=" (Left : Uint; Right : Int) return Boolean renames UI_Eq; + + function ">=" (Left : Uint; Right : Uint) return Boolean renames UI_Ge; + function ">=" (Left : Int; Right : Uint) return Boolean renames UI_Ge; + function ">=" (Left : Uint; Right : Int) return Boolean renames UI_Ge; + + function ">" (Left : Uint; Right : Uint) return Boolean renames UI_Gt; + function ">" (Left : Int; Right : Uint) return Boolean renames UI_Gt; + function ">" (Left : Uint; Right : Int) return Boolean renames UI_Gt; + + function "<=" (Left : Uint; Right : Uint) return Boolean renames UI_Le; + function "<=" (Left : Int; Right : Uint) return Boolean renames UI_Le; + function "<=" (Left : Uint; Right : Int) return Boolean renames UI_Le; + + function "<" (Left : Uint; Right : Uint) return Boolean renames UI_Lt; + function "<" (Left : Int; Right : Uint) return Boolean renames UI_Lt; + function "<" (Left : Uint; Right : Int) return Boolean renames UI_Lt; + + ----------------------------- + -- Mark/Release Processing -- + ----------------------------- + + -- The space used by Uint data is not automatically reclaimed. However, + -- a mark-release regime is implemented which allows storage to be + -- released back to a previously noted mark. This is used for example + -- when doing comparisons, where only intermediate results get stored + -- that do not need to be saved for future use. + + type Save_Mark is private; + + function Mark return Save_Mark; + -- Note mark point for future release + + procedure Release (M : Save_Mark); + -- Release storage allocated since mark was noted + + procedure Release_And_Save (M : Save_Mark; UI : in out Uint); + -- Like Release, except that the given Uint value (which is typically + -- among the data being released) is recopied after the release, so + -- that it is the most recent item, and UI is updated to point to + -- its copied location. + + procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Uint); + -- Like Release, except that the given Uint values (which are typically + -- among the data being released) are recopied after the release, so + -- that they are the most recent items, and UI1 and UI2 are updated if + -- necessary to point to the copied locations. This routine is careful + -- to do things in the right order, so that the values do not clobber + -- one another. + + ----------------------------------- + -- Representation of Uint Values -- + ----------------------------------- + +private + + type Uint is new Int range Uint_Low_Bound .. Uint_High_Bound; + for Uint'Size use 32; + + No_Uint : constant Uint := Uint (Uint_Low_Bound); + + -- Uint values are represented as multiple precision integers stored in + -- a multi-digit format using Base as the base. This value is chosen so + -- that the product Base*Base is within the range of allowed Int values. + + -- Base is defined to allow efficient execution of the primitive + -- operations (a0, b0, c0) defined in the section "The Classical + -- Algorithms" (sec. 4.3.1) of Donald Knuth's "The Art of Computer + -- Programming", Vol. 2. These algorithms are used in this package. + + Base_Bits : constant := 15; + -- Number of bits in base value + + Base : constant Int := 2 ** Base_Bits; + + -- Values in the range -(Base+1) .. maxdirect are encoded directly as + -- Uint values by adding a bias value. The value of maxdirect is chosen + -- so that a directly represented number always fits in two digits when + -- represented in base format. + + Min_Direct : constant Int := -(Base - 1); + Max_Direct : constant Int := (Base - 1) * (Base - 1); + + -- The following values define the bias used to store Uint values which + -- are in this range, as well as the biased values for the first and + -- last values in this range. We use a new derived type for these + -- constants to avoid accidental use of Uint arithmetic on these + -- values, which is never correct. + + type Ctrl is range Int'First .. Int'Last; + + Uint_Direct_Bias : constant Ctrl := Ctrl (Uint_Low_Bound) + Ctrl (Base); + Uint_Direct_First : constant Ctrl := Uint_Direct_Bias + Ctrl (Min_Direct); + Uint_Direct_Last : constant Ctrl := Uint_Direct_Bias + Ctrl (Max_Direct); + + Uint_0 : constant Uint := Uint (Uint_Direct_Bias); + Uint_1 : constant Uint := Uint (Uint_Direct_Bias + 1); + Uint_2 : constant Uint := Uint (Uint_Direct_Bias + 2); + Uint_3 : constant Uint := Uint (Uint_Direct_Bias + 3); + Uint_4 : constant Uint := Uint (Uint_Direct_Bias + 4); + Uint_5 : constant Uint := Uint (Uint_Direct_Bias + 5); + Uint_6 : constant Uint := Uint (Uint_Direct_Bias + 6); + Uint_7 : constant Uint := Uint (Uint_Direct_Bias + 7); + Uint_8 : constant Uint := Uint (Uint_Direct_Bias + 8); + Uint_9 : constant Uint := Uint (Uint_Direct_Bias + 9); + Uint_10 : constant Uint := Uint (Uint_Direct_Bias + 10); + Uint_12 : constant Uint := Uint (Uint_Direct_Bias + 12); + Uint_15 : constant Uint := Uint (Uint_Direct_Bias + 15); + Uint_16 : constant Uint := Uint (Uint_Direct_Bias + 16); + Uint_24 : constant Uint := Uint (Uint_Direct_Bias + 24); + Uint_32 : constant Uint := Uint (Uint_Direct_Bias + 32); + Uint_63 : constant Uint := Uint (Uint_Direct_Bias + 63); + Uint_64 : constant Uint := Uint (Uint_Direct_Bias + 64); + Uint_128 : constant Uint := Uint (Uint_Direct_Bias + 128); + + Uint_Minus_1 : constant Uint := Uint (Uint_Direct_Bias - 1); + Uint_Minus_2 : constant Uint := Uint (Uint_Direct_Bias - 2); + Uint_Minus_3 : constant Uint := Uint (Uint_Direct_Bias - 3); + Uint_Minus_4 : constant Uint := Uint (Uint_Direct_Bias - 4); + Uint_Minus_5 : constant Uint := Uint (Uint_Direct_Bias - 5); + Uint_Minus_6 : constant Uint := Uint (Uint_Direct_Bias - 6); + Uint_Minus_7 : constant Uint := Uint (Uint_Direct_Bias - 7); + Uint_Minus_8 : constant Uint := Uint (Uint_Direct_Bias - 8); + Uint_Minus_9 : constant Uint := Uint (Uint_Direct_Bias - 9); + Uint_Minus_12 : constant Uint := Uint (Uint_Direct_Bias - 12); + Uint_Minus_128 : constant Uint := Uint (Uint_Direct_Bias - 128); + + type Save_Mark is record + Save_Uint : Uint; + Save_Udigit : Int; + end record; + + -- Values outside the range that is represented directly are stored + -- using two tables. The secondary table Udigits contains sequences of + -- Int values consisting of the digits of the number in a radix Base + -- system. The digits are stored from most significant to least + -- significant with the first digit only carrying the sign. + + -- There is one entry in the primary Uints table for each distinct Uint + -- value. This table entry contains the length (number of digits) and + -- a starting offset of the value in the Udigits table. + + Uint_First_Entry : constant Uint := Uint (Uint_Table_Start); + + -- Some subprograms defined in this package manipulate the Udigits + -- table directly, while for others it is more convenient to work with + -- locally defined arrays of the digits of the Universal Integers. + -- The type UI_Vector is defined for this purpose and some internal + -- subprograms used for converting from one to the other are defined. + + type UI_Vector is array (Pos range <>) of Int; + -- Vector containing the integer values of a Uint value + + -- Note: An earlier version of this package used pointers of arrays + -- of Ints (dynamically allocated) for the Uint type. The change + -- leads to a few less natural idioms used throughout this code, but + -- eliminates all uses of the heap except for the table package itself. + -- For example, Uint parameters are often converted to UI_Vectors for + -- internal manipulation. This is done by creating the local UI_Vector + -- using the function N_Digits on the Uint to find the size needed for + -- the vector, and then calling Init_Operand to copy the values out + -- of the table into the vector. + + type Uint_Entry is record + Length : Pos; + -- Length of entry in Udigits table in digits (i.e. in words) + + Loc : Int; + -- Starting location in Udigits table of this Uint value + end record; + + package Uints is new Table.Table ( + Table_Component_Type => Uint_Entry, + Table_Index_Type => Uint, + Table_Low_Bound => Uint_First_Entry, + Table_Initial => Alloc.Uints_Initial, + Table_Increment => Alloc.Uints_Increment, + Table_Name => "Uints"); + + package Udigits is new Table.Table ( + Table_Component_Type => Int, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Udigits_Initial, + Table_Increment => Alloc.Udigits_Increment, + Table_Name => "Udigits"); + + -- Note: the reason these tables are defined here in the private part of + -- the spec, rather than in the body, is that they are refrerenced + -- directly by gigi. + +end Uintp; diff --git a/gcc/ada/uintp.h b/gcc/ada/uintp.h new file mode 100644 index 00000000000..365dba0d60f --- /dev/null +++ b/gcc/ada/uintp.h @@ -0,0 +1,75 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * U I N T P * + * * + * C Header File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-2001, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 2, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* This file corresponds to the Ada package specification Uintp. It was + created manually from the files uintp.ads and uintp.adb */ + +/* Support for universal integer arithmetic */ + +struct Uint_Entry +{ + Pos Length; + Int Loc; +}; + +/* See if a Uint is within the range of an integer. */ +#define UI_Is_In_Int_Range uintp__ui_is_in_int_range +extern Boolean UI_Is_In_Int_Range PARAMS((Uint)); + +/* Obtain Int value from Uint input. This will abort if the result is + out of range. */ +#define UI_To_Int uintp__ui_to_int +extern Int UI_To_Int PARAMS((Uint)); + +/* Convert an Int into a Uint. */ +#define UI_From_Int uintp__ui_from_int +extern Uint UI_From_Int PARAMS((int)); + +/* Similarly, but return a GCC INTEGER_CST. Overflow is tested by the + constant-folding used to build the node. TYPE is the GCC type of the + resulting node. */ +extern tree UI_To_gnu PARAMS((Uint, tree)); + +/* Universal integers are represented by the Uint type which is an index into + the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an + index and length for getting the "digits" of the universal integer from the + Udigits_Ptr table. + + For efficiency, this method is used only for integer values larger than the + constant Uint_Bias. If a Uint is less than this constant, then it contains + the integer value itself. The origin of the Uints_Ptr table is adjusted so + that a Uint value of Uint_Bias indexes the first element. */ + +#define Uints_Ptr (uintp__uints__table - Uint_Table_Start) +extern struct Uint_Entry *uintp__uints__table; + +#define Udigits_Ptr uintp__udigits__table +extern int *uintp__udigits__table; + +#define Uint_0 (Uint_Direct_Bias + 0) +#define Uint_1 (Uint_Direct_Bias + 1) diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb new file mode 100644 index 00000000000..b6e0f6bd5e3 --- /dev/null +++ b/gcc/ada/uname.adb @@ -0,0 +1,653 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U N A M E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.56 $ +-- -- +-- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Einfo; use Einfo; +with Hostparm; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Output; use Output; +with Sinfo; use Sinfo; +with Sinput; use Sinput; + +package body Uname is + + ------------------- + -- Get_Body_Name -- + ------------------- + + function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is + begin + Get_Name_String (N); + + pragma Assert (Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + and then Name_Buffer (Name_Len) = 's'); + + Name_Buffer (Name_Len) := 'b'; + return Name_Find; + end Get_Body_Name; + + ----------------------------------- + -- Get_External_Unit_Name_String -- + ----------------------------------- + + procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is + Pcount : Natural; + Newlen : Natural; + + begin + -- Get unit name and eliminate trailing %s or %b + + Get_Name_String (N); + Name_Len := Name_Len - 2; + + -- Find number of components + + Pcount := 0; + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Pcount := Pcount + 1; + end if; + end loop; + + -- If simple name, nothing to do + + if Pcount = 0 then + return; + end if; + + -- If name has multiple components, replace dots by double underscore + + Newlen := Name_Len + Pcount; + + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Name_Buffer (Newlen) := '_'; + Name_Buffer (Newlen - 1) := '_'; + Newlen := Newlen - 2; + + else + Name_Buffer (Newlen) := Name_Buffer (J); + Newlen := Newlen - 1; + end if; + end loop; + + Name_Len := Name_Len + Pcount; + end Get_External_Unit_Name_String; + + -------------------------- + -- Get_Parent_Body_Name -- + -------------------------- + + function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is + begin + Get_Name_String (N); + + while Name_Buffer (Name_Len) /= '.' loop + pragma Assert (Name_Len > 1); -- not a child or subunit name + Name_Len := Name_Len - 1; + end loop; + + Name_Buffer (Name_Len) := '%'; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := 'b'; + return Name_Find; + + end Get_Parent_Body_Name; + + -------------------------- + -- Get_Parent_Spec_Name -- + -------------------------- + + function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is + begin + Get_Name_String (N); + + while Name_Buffer (Name_Len) /= '.' loop + if Name_Len = 1 then + return No_Name; -- not a child or subunit name + else + Name_Len := Name_Len - 1; + end if; + end loop; + + Name_Buffer (Name_Len) := '%'; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := 's'; + return Name_Find; + + end Get_Parent_Spec_Name; + + ------------------- + -- Get_Spec_Name -- + ------------------- + + function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is + begin + Get_Name_String (N); + + pragma Assert (Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + and then Name_Buffer (Name_Len) = 'b'); + + Name_Buffer (Name_Len) := 's'; + return Name_Find; + end Get_Spec_Name; + + ------------------- + -- Get_Unit_Name -- + ------------------- + + function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is + + Unit_Name_Buffer : String (1 .. Hostparm.Max_Name_Length); + -- Buffer used to build name of unit. Note that we cannot use the + -- Name_Buffer in package Name_Table because we use it to read + -- component names. + + Unit_Name_Length : Natural := 0; + -- Length of name stored in Unit_Name_Buffer + + Node : Node_Id; + -- Program unit node + + procedure Add_Char (C : Character); + -- Add a single character to stored unit name + + procedure Add_Name (Name : Name_Id); + -- Add the characters of a names table entry to stored unit name + + procedure Add_Node_Name (Node : Node_Id); + -- Recursive procedure adds characters associated with Node + + function Get_Parent (Node : Node_Id) return Node_Id; + -- Get parent compilation unit of a stub + + -------------- + -- Add_Char -- + -------------- + + procedure Add_Char (C : Character) is + begin + -- Should really check for max length exceeded here??? + Unit_Name_Length := Unit_Name_Length + 1; + Unit_Name_Buffer (Unit_Name_Length) := C; + end Add_Char; + + -------------- + -- Add_Name -- + -------------- + + procedure Add_Name (Name : Name_Id) is + begin + Get_Name_String (Name); + + for J in 1 .. Name_Len loop + Add_Char (Name_Buffer (J)); + end loop; + end Add_Name; + + ------------------- + -- Add_Node_Name -- + ------------------- + + procedure Add_Node_Name (Node : Node_Id) is + Kind : Node_Kind := Nkind (Node); + + begin + -- Just ignore an error node (someone else will give a message) + + if Node = Error then + return; + + -- Otherwise see what kind of node we have + + else + case Kind is + + when N_Identifier | + N_Defining_Identifier | + N_Defining_Operator_Symbol => + + -- Note: it is of course an error to have a defining + -- operator symbol at this point, but this is not where + -- the error is signalled, so we handle it nicely here! + + Add_Name (Chars (Node)); + + when N_Defining_Program_Unit_Name => + Add_Node_Name (Name (Node)); + Add_Char ('.'); + Add_Node_Name (Defining_Identifier (Node)); + + when N_Selected_Component | + N_Expanded_Name => + Add_Node_Name (Prefix (Node)); + Add_Char ('.'); + Add_Node_Name (Selector_Name (Node)); + + when N_Subprogram_Specification | + N_Package_Specification => + Add_Node_Name (Defining_Unit_Name (Node)); + + when N_Subprogram_Body | + N_Subprogram_Declaration | + N_Package_Declaration | + N_Generic_Declaration => + Add_Node_Name (Specification (Node)); + + when N_Generic_Instantiation => + Add_Node_Name (Defining_Unit_Name (Node)); + + when N_Package_Body => + Add_Node_Name (Defining_Unit_Name (Node)); + + when N_Task_Body | + N_Protected_Body => + Add_Node_Name (Defining_Identifier (Node)); + + when N_Package_Renaming_Declaration => + Add_Node_Name (Defining_Unit_Name (Node)); + + when N_Subprogram_Renaming_Declaration => + Add_Node_Name (Specification (Node)); + + when N_Generic_Renaming_Declaration => + Add_Node_Name (Defining_Unit_Name (Node)); + + when N_Subprogram_Body_Stub => + Add_Node_Name (Get_Parent (Node)); + Add_Char ('.'); + Add_Node_Name (Specification (Node)); + + when N_Compilation_Unit => + Add_Node_Name (Unit (Node)); + + when N_Package_Body_Stub => + Add_Node_Name (Get_Parent (Node)); + Add_Char ('.'); + Add_Node_Name (Defining_Identifier (Node)); + + when N_Task_Body_Stub | + N_Protected_Body_Stub => + Add_Node_Name (Get_Parent (Node)); + Add_Char ('.'); + Add_Node_Name (Defining_Identifier (Node)); + + when N_Subunit => + Add_Node_Name (Name (Node)); + Add_Char ('.'); + Add_Node_Name (Proper_Body (Node)); + + when N_With_Clause => + Add_Node_Name (Name (Node)); + + when N_Pragma => + Add_Node_Name (Expression (First + (Pragma_Argument_Associations (Node)))); + + -- Tasks and protected stuff appear only in an error context, + -- but the error has been posted elsewhere, so we deal nicely + -- with these error situations here, and produce a reasonable + -- unit name using the defining identifier. + + when N_Task_Type_Declaration | + N_Single_Task_Declaration | + N_Protected_Type_Declaration | + N_Single_Protected_Declaration => + Add_Node_Name (Defining_Identifier (Node)); + + when others => + raise Program_Error; + + end case; + end if; + end Add_Node_Name; + + ---------------- + -- Get_Parent -- + ---------------- + + function Get_Parent (Node : Node_Id) return Node_Id is + N : Node_Id := Node; + + begin + while Nkind (N) /= N_Compilation_Unit loop + N := Parent (N); + end loop; + + return N; + end Get_Parent; + + -------------------------------------------- + -- Start of Processing for Get_Unit_Name -- + -------------------------------------------- + + begin + Node := N; + + -- If we have Defining_Identifier, find the associated unit node + + if Nkind (Node) = N_Defining_Identifier then + Node := Declaration_Node (Node); + + -- If an expanded name, it is an already analyzed child unit, find + -- unit node. + + elsif Nkind (Node) = N_Expanded_Name then + Node := Declaration_Node (Entity (Node)); + end if; + + if Nkind (Node) = N_Package_Specification + or else Nkind (Node) in N_Subprogram_Specification + then + Node := Parent (Node); + end if; + + -- Node points to the unit, so get its name and add proper suffix + + Add_Node_Name (Node); + Add_Char ('%'); + + case Nkind (Node) is + when N_Generic_Declaration | + N_Subprogram_Declaration | + N_Package_Declaration | + N_With_Clause | + N_Pragma | + N_Generic_Instantiation | + N_Package_Renaming_Declaration | + N_Subprogram_Renaming_Declaration | + N_Generic_Renaming_Declaration | + N_Single_Task_Declaration | + N_Single_Protected_Declaration | + N_Task_Type_Declaration | + N_Protected_Type_Declaration => + + Add_Char ('s'); + + when N_Subprogram_Body | + N_Package_Body | + N_Subunit | + N_Body_Stub | + N_Task_Body | + N_Protected_Body | + N_Identifier | + N_Selected_Component => + + Add_Char ('b'); + + when others => + raise Program_Error; + end case; + + Name_Buffer (1 .. Unit_Name_Length) := + Unit_Name_Buffer (1 .. Unit_Name_Length); + Name_Len := Unit_Name_Length; + return Name_Find; + + end Get_Unit_Name; + + -------------------------- + -- Get_Unit_Name_String -- + -------------------------- + + procedure Get_Unit_Name_String (N : Unit_Name_Type) is + Unit_Is_Body : Boolean; + + begin + Get_Decoded_Name_String (N); + Unit_Is_Body := Name_Buffer (Name_Len) = 'b'; + Set_Casing (Identifier_Casing (Source_Index (Main_Unit)), Mixed_Case); + + -- A special fudge, normally we don't have operator symbols present, + -- since it is always an error to do so. However, if we do, at this + -- stage it has the form: + + -- "and" + + -- and the %s or %b has already been eliminated so put 2 chars back + + if Name_Buffer (1) = '"' then + Name_Len := Name_Len + 2; + end if; + + -- Now adjust the %s or %b to (spec) or (body) + + if Unit_Is_Body then + Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)"; + else + Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)"; + end if; + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '-' then + Name_Buffer (J) := '.'; + end if; + end loop; + + Name_Len := Name_Len + (7 - 2); + end Get_Unit_Name_String; + + ------------------ + -- Is_Body_Name -- + ------------------ + + function Is_Body_Name (N : Unit_Name_Type) return Boolean is + begin + Get_Name_String (N); + return Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + and then Name_Buffer (Name_Len) = 'b'; + end Is_Body_Name; + + ------------------- + -- Is_Child_Name -- + ------------------- + + function Is_Child_Name (N : Unit_Name_Type) return Boolean is + J : Natural; + + begin + Get_Name_String (N); + J := Name_Len; + + while Name_Buffer (J) /= '.' loop + if J = 1 then + return False; -- not a child or subunit name + else + J := J - 1; + end if; + end loop; + + return True; + end Is_Child_Name; + + ------------------ + -- Is_Spec_Name -- + ------------------ + + function Is_Spec_Name (N : Unit_Name_Type) return Boolean is + begin + Get_Name_String (N); + return Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + and then Name_Buffer (Name_Len) = 's'; + end Is_Spec_Name; + + ----------------------- + -- Name_To_Unit_Name -- + ----------------------- + + function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is + begin + Get_Name_String (N); + Name_Buffer (Name_Len + 1) := '%'; + Name_Buffer (Name_Len + 2) := 's'; + Name_Len := Name_Len + 2; + return Name_Find; + end Name_To_Unit_Name; + + --------------- + -- New_Child -- + --------------- + + function New_Child + (Old : Unit_Name_Type; + Newp : Unit_Name_Type) + return Unit_Name_Type + is + P : Natural; + + begin + Get_Name_String (Old); + + declare + Child : String := Name_Buffer (1 .. Name_Len); + + begin + Get_Name_String (Newp); + Name_Len := Name_Len - 2; + + P := Child'Last; + while Child (P) /= '.' loop + P := P - 1; + end loop; + + while P <= Child'Last loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Child (P); + P := P + 1; + end loop; + + return Name_Find; + end; + end New_Child; + + -------------- + -- Uname_Ge -- + -------------- + + function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is + begin + return Left = Right or else Uname_Gt (Left, Right); + end Uname_Ge; + + -------------- + -- Uname_Gt -- + -------------- + + function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is + begin + return Left /= Right and then not Uname_Lt (Left, Right); + end Uname_Gt; + + -------------- + -- Uname_Le -- + -------------- + + function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is + begin + return Left = Right or else Uname_Lt (Left, Right); + end Uname_Le; + + -------------- + -- Uname_Lt -- + -------------- + + function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is + Left_Name : String (1 .. Hostparm.Max_Name_Length); + Left_Length : Natural; + Right_Name : String renames Name_Buffer; + Right_Length : Natural renames Name_Len; + J : Natural; + + begin + pragma Warnings (Off, Right_Length); + -- Suppress warnings on Right_Length, used in pragma Assert + + if Left = Right then + return False; + end if; + + Get_Name_String (Left); + Left_Name (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1); + Left_Length := Name_Len; + Get_Name_String (Right); + J := 1; + + loop + exit when Left_Name (J) = '%'; + + if Right_Name (J) = '%' then + return False; -- left name is longer + end if; + + pragma Assert (J <= Left_Length and then J <= Right_Length); + + if Left_Name (J) /= Right_Name (J) then + return Left_Name (J) < Right_Name (J); -- parent names different + end if; + + J := J + 1; + end loop; + + -- Come here pointing to % in left name + + if Right_Name (J) /= '%' then + return True; -- right name is longer + end if; + + -- Here the parent names are the same and specs sort low. If neither is + -- a spec, then we are comparing the same name and we want a result of + -- False in any case. + + return Left_Name (J + 1) = 's'; + end Uname_Lt; + + --------------------- + -- Write_Unit_Name -- + --------------------- + + procedure Write_Unit_Name (N : Unit_Name_Type) is + begin + Get_Unit_Name_String (N); + Write_Str (Name_Buffer (1 .. Name_Len)); + end Write_Unit_Name; + +end Uname; diff --git a/gcc/ada/uname.ads b/gcc/ada/uname.ads new file mode 100644 index 00000000000..c5fc2097396 --- /dev/null +++ b/gcc/ada/uname.ads @@ -0,0 +1,176 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U N A M E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.23 $ -- +-- -- +-- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; +package Uname is + + --------------------------- + -- Unit Name Conventions -- + --------------------------- + + -- Units are associated with a unique ASCII name as follows. First we + -- have the fully expanded name of the unit, with lower case letters + -- (except for the use of upper case letters for encoding upper half + -- and wide characters, as described in Namet), and periods. Following + -- this is one of the following suffixes: + + -- %s for package/subprogram/generic declarations (specs) + -- %b for package/subprogram/generic bodies and subunits + + -- Unit names are stored in the names table, and referred to by the + -- corresponding Name_Id values. The subtype Unit_Name, which is a + -- synonym for Name_Id, is used to indicate that a Name_Id value that + -- holds a unit name (as defined above) is expected. + + -- Note: as far as possible the conventions for unit names are encapsulated + -- in this package. The one exception is that package Fname, which provides + -- conversion routines from unit names to file names must be aware of the + -- precise conventions that are used. + + ------------------- + -- Display Names -- + ------------------- + + -- For display purposes, unit names are printed out with the suffix + -- " (body)" for a body and " (spec)" for a spec. These formats are + -- used for the Write_Unit_Name and Get_Unit_Name_String subprograms. + + ----------------- + -- Subprograms -- + ----------------- + + function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type; + -- Given the name of a spec, this function returns the name of the + -- corresponding body, i.e. characters %s replaced by %b + + function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type; + -- Given the name of a subunit, returns the name of the parent body. + + function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type; + -- Given the name of a child unit spec or body, returns the unit name + -- of the parent spec. Returns No_Name if the given name is not the name + -- of a child unit. + + procedure Get_External_Unit_Name_String (N : Unit_Name_Type); + -- Given the name of a body or spec unit, this procedure places in + -- Name_Buffer the name of the unit with periods replaced by double + -- underscores. The spec/body indication is eliminated. The length + -- of the stored name is placed in Name_Len. All letters are lower + -- case, corresponding to the string used in external names. + + function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type; + -- Given the name of a body, this function returns the name of the + -- corresponding spec, i.e. characters %b replaced by %s + + function Get_Unit_Name (N : Node_Id) return Unit_Name_Type; + -- This procedure returns the unit name that corresponds to the given node, + -- which is one of the following: + -- + -- N_Subprogram_Declaration (spec) cases + -- N_Package_Declaration + -- N_Generic_Declaration + -- N_With_Clause + -- N_Function_Instantiation + -- N_Package_Instantiation + -- N_Procedure_Instantiation + -- N_Pragma (Elaborate case) + -- + -- N_Package_Body (body) cases + -- N_Subprogram_Body + -- N_Identifier + -- N_Selected_Component + -- + -- N_Subprogram_Body_Stub (subunit) cases + -- N_Package_Body_Stub + -- N_Task_Body_Stub + -- N_Protected_Body_Stub + -- N_Subunit + + procedure Get_Unit_Name_String (N : Unit_Name_Type); + -- Places the display name of the unit in Name_Buffer and sets Name_Len + -- to the length of the stored name, i.e. it uses the same interface as + -- the Get_Name_String routine in the Namet package. The name contains + -- an indication of spec or body, and is decoded. + + function Is_Body_Name (N : Unit_Name_Type) return Boolean; + -- Returns True iff the given name is the unit name of a body (i.e. if + -- it ends with the characters %b). + + function Is_Child_Name (N : Unit_Name_Type) return Boolean; + -- Returns True iff the given name is a child unit name (of either a + -- body or a spec). + + function Is_Spec_Name (N : Unit_Name_Type) return Boolean; + -- Returns True iff the given name is the unit name of a specification + -- (i.e. if it ends with the characters %s). + + function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type; + -- Given the Id of the Ada name of a unit, this function returns the + -- corresponding unit name of the spec (by appending %s to the name). + + function New_Child + (Old : Unit_Name_Type; + Newp : Unit_Name_Type) + return Unit_Name_Type; + -- Old is a child unit name (for either a body or spec). Newp is the + -- unit name of the actual parent (this may be different from the + -- parent in old). The returned unit name is formed by taking the + -- parent name from Newp and the child unit name from Old, with the + -- result being a body or spec depending on Old. For example: + -- + -- Old = A.B.C (body) + -- Newp = A.R (spec) + -- result = A.R.C (body) + -- + -- See spec of Load_Unit for extensive discussion of why this routine + -- needs to be used (the call in the body of Load_Unit is the only one). + + function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean; + function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean; + function Uname_Le (Left, Right : Unit_Name_Type) return Boolean; + function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean; + -- These functions perform lexicographic ordering of unit names. The + -- ordering is suitable for printing, and is not quite a straightforward + -- comparison of the names, since the convention is that specs appear + -- before bodies. Note that the standard = and /= operators work fine + -- because all unit names are hashed into the name table, so if two names + -- are the same, they always have the same Name_Id value. + + procedure Write_Unit_Name (N : Unit_Name_Type); + -- Given a unit name, this procedure writes the display name to the + -- standard output file. Name_Buffer and Name_Len are set as described + -- above for the Get_Unit_Name_String call on return. + +end Uname; diff --git a/gcc/ada/unchconv.ads b/gcc/ada/unchconv.ads new file mode 100644 index 00000000000..f501af5e22a --- /dev/null +++ b/gcc/ada/unchconv.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U N C H E C K E D _ C O N V E R S I O N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.15 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Source (<>) is limited private; + type Target (<>) is limited private; + +function Unchecked_Conversion (S : Source) return Target; +pragma Import (Intrinsic, Unchecked_Conversion); +pragma Pure (Unchecked_Conversion); diff --git a/gcc/ada/unchdeal.ads b/gcc/ada/unchdeal.ads new file mode 100644 index 00000000000..2a24ca05627 --- /dev/null +++ b/gcc/ada/unchdeal.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U N C H E C K E D _ D E A L L O C A T I O N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.15 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Object (<>) is limited private; + type Name is access Object; + +procedure Unchecked_Deallocation (X : in out Name); +pragma Import (Intrinsic, Unchecked_Deallocation); diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb new file mode 100644 index 00000000000..941af169647 --- /dev/null +++ b/gcc/ada/urealp.adb @@ -0,0 +1,1472 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads new file mode 100644 index 00000000000..9896e0d9968 --- /dev/null +++ b/gcc/ada/urealp.ads @@ -0,0 +1,355 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U R E A L P -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.35 $ -- +-- -- +-- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Support for universal real arithmetic + +with Types; use Types; +with Uintp; use Uintp; + +package Urealp is + + --------------------------------------- + -- Representation of Universal Reals -- + --------------------------------------- + + -- A universal real value is represented by a single value (which is + -- an index into an internal table). These values are not hashed, so + -- the equality operator should not be used on Ureal values (instead + -- use the UR_Eq function). + + -- A Ureal value represents an arbitrary precision universal real value, + -- stored internally using four components + + -- the numerator (Uint, always non-negative) + -- the denominator (Uint, always non-zero, always positive if base = 0) + -- a real base (Nat, either zero, or in the range 2 .. 16) + -- a sign flag (Boolean), set if negative + + -- If the base is zero, then the absolute value of the Ureal is simply + -- numerator/denominator. If the base is non-zero, then the absolute + -- value is num / (rbase ** den). + + -- Negative numbers are represented by the sign of the numerator being + -- negative. The denominator is always positive. + + -- A normalized Ureal value has base = 0, and numerator/denominator + -- reduced to lowest terms, with zero itself being represented as 0/1. + -- This is a canonical format, so that for normalized Ureal values it + -- is the case that two equal values always have the same denominator + -- and numerator values. + + -- Note: a value of minus zero is legitimate, and the operations in + -- Urealp preserve the handling of signed zeroes in accordance with + -- the rules of IEEE P754 ("IEEE floating point"). + + ------------------------------ + -- Types for Urealp Package -- + ------------------------------ + + type Ureal is private; + -- Type used for representation of universal reals + + No_Ureal : constant Ureal; + -- Constant used to indicate missing or unset Ureal value + + --------------------- + -- Ureal Constants -- + --------------------- + + function Ureal_0 return Ureal; + -- Returns value 0.0 + + function Ureal_M_0 return Ureal; + -- Returns value -0.0 + + function Ureal_Tenth return Ureal; + -- Returns value 0.1 + + function Ureal_Half return Ureal; + -- Returns value 0.5 + + function Ureal_1 return Ureal; + -- Returns value 1.0 + + function Ureal_2 return Ureal; + -- Returns value 2.0 + + function Ureal_10 return Ureal; + -- Returns value 10.0 + + function Ureal_100 return Ureal; + -- Returns value 100.0 + + function Ureal_2_128 return Ureal; + -- Returns value 2.0 ** 128 + + function Ureal_2_M_128 return Ureal; + -- Returns value 2.0 ** (-128) + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Initialize Ureal tables. Note that Initialize must not be called if + -- Tree_Read is used. Note also that there is no Lock routine in this + -- unit. These tables are among the few tables that can be expanded + -- during Gigi processing. + + procedure Tree_Read; + -- Initializes internal tables from current tree file using Tree_Read. + -- Note that Initialize should not be called if Tree_Read is used. + -- Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using Tree_Write + + function Rbase (Real : Ureal) return Nat; + -- Return the base of the universal real. + + function Denominator (Real : Ureal) return Uint; + -- Return the denominator of the universal real. + + function Numerator (Real : Ureal) return Uint; + -- Return the numerator of the universal real. + + function Norm_Den (Real : Ureal) return Uint; + -- Return the denominator of the universal real after a normalization. + + function Norm_Num (Real : Ureal) return Uint; + -- Return the numerator of the universal real after a normalization. + + function UR_From_Uint (UI : Uint) return Ureal; + -- Returns real corresponding to universal integer value + + function UR_To_Uint (Real : Ureal) return Uint; + -- Return integer value obtained by accurate rounding of real value. + -- The rounding of values half way between two integers is away from + -- zero, as required by normal Ada 95 rounding semantics. + + function UR_Trunc (Real : Ureal) return Uint; + -- Return integer value obtained by a truncation of real towards zero + + function UR_Ceiling (Real : Ureal) return Uint; + -- Return value of smallest integer not less than the given value + + function UR_Floor (Real : Ureal) return Uint; + -- Return value of smallest integer not greater than the given value + + -- Conversion table for above four functions + + -- Input To_Uint Trunc Ceiling Floor + -- 1.0 1 1 1 1 + -- 1.2 1 1 2 1 + -- 1.5 2 1 2 1 + -- 1.7 2 1 2 1 + -- 2.0 2 2 2 2 + -- -1.0 -1 -1 -1 -1 + -- -1.2 -1 -1 -1 -2 + -- -1.5 -2 -1 -1 -2 + -- -1.7 -2 -1 -1 -2 + -- -2.0 -2 -2 -2 -2 + + function UR_From_Components + (Num : Uint; + Den : Uint; + Rbase : Nat := 0; + Negative : Boolean := False) + return Ureal; + -- Builds real value from given numerator, denominator and base. The + -- value is negative if Negative is set to true, and otherwise is + -- non-negative. + + function UR_Add (Left : Ureal; Right : Ureal) return Ureal; + function UR_Add (Left : Ureal; Right : Uint) return Ureal; + function UR_Add (Left : Uint; Right : Ureal) return Ureal; + -- Returns real sum of operands + + function UR_Div (Left : Ureal; Right : Ureal) return Ureal; + function UR_Div (Left : Uint; Right : Ureal) return Ureal; + function UR_Div (Left : Ureal; Right : Uint) return Ureal; + -- Returns real quotient of operands. Fatal error if Right is zero + + function UR_Mul (Left : Ureal; Right : Ureal) return Ureal; + function UR_Mul (Left : Uint; Right : Ureal) return Ureal; + function UR_Mul (Left : Ureal; Right : Uint) return Ureal; + -- Returns real product of operands + + function UR_Sub (Left : Ureal; Right : Ureal) return Ureal; + function UR_Sub (Left : Uint; Right : Ureal) return Ureal; + function UR_Sub (Left : Ureal; Right : Uint) return Ureal; + -- Returns real difference of operands + + function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal; + -- Returns result of raising Ureal to Uint power. + -- Fatal error if Left is 0 and Right is negative. + + function UR_Abs (Real : Ureal) return Ureal; + -- Returns abs function of real + + function UR_Negate (Real : Ureal) return Ureal; + -- Returns negative of real + + function UR_Eq (Left, Right : Ureal) return Boolean; + -- Compares reals for equality. + + function UR_Max (Left, Right : Ureal) return Ureal; + -- Returns the maximum of two reals + + function UR_Min (Left, Right : Ureal) return Ureal; + -- Returns the minimum of two reals + + function UR_Ne (Left, Right : Ureal) return Boolean; + -- Compares reals for inequality. + + function UR_Lt (Left, Right : Ureal) return Boolean; + -- Compares reals for less than. + + function UR_Le (Left, Right : Ureal) return Boolean; + -- Compares reals for less than or equal. + + function UR_Gt (Left, Right : Ureal) return Boolean; + -- Compares reals for greater than. + + function UR_Ge (Left, Right : Ureal) return Boolean; + -- Compares reals for greater than or equal. + + function UR_Is_Zero (Real : Ureal) return Boolean; + -- Tests if real value is zero + + function UR_Is_Negative (Real : Ureal) return Boolean; + -- Tests if real value is negative, note that negative zero gives true + + function UR_Is_Positive (Real : Ureal) return Boolean; + -- Test if real value is greater than zero + + procedure UR_Write (Real : Ureal); + -- Writes value of Real to standard output. Used only for debugging and + -- tree/source output. If the result is easily representable as a standard + -- Ada literal, it will be given that way, but as a result of evaluation + -- of static expressions, it is possible to generate constants (e.g. 1/13) + -- which have no such representation. In such cases (and in cases where it + -- is too much work to figure out the Ada literal), the string that is + -- output is of the form [numerator/denominator]. + + procedure pr (Real : Ureal); + -- Writes value of Real to standard output with a terminating line return, + -- using UR_Write as described above. This is for use from the debugger. + + ------------------------ + -- Operator Renamings -- + ------------------------ + + function "+" (Left : Ureal; Right : Ureal) return Ureal renames UR_Add; + function "+" (Left : Uint; Right : Ureal) return Ureal renames UR_Add; + function "+" (Left : Ureal; Right : Uint) return Ureal renames UR_Add; + + function "/" (Left : Ureal; Right : Ureal) return Ureal renames UR_Div; + function "/" (Left : Uint; Right : Ureal) return Ureal renames UR_Div; + function "/" (Left : Ureal; Right : Uint) return Ureal renames UR_Div; + + function "*" (Left : Ureal; Right : Ureal) return Ureal renames UR_Mul; + function "*" (Left : Uint; Right : Ureal) return Ureal renames UR_Mul; + function "*" (Left : Ureal; Right : Uint) return Ureal renames UR_Mul; + + function "-" (Left : Ureal; Right : Ureal) return Ureal renames UR_Sub; + function "-" (Left : Uint; Right : Ureal) return Ureal renames UR_Sub; + function "-" (Left : Ureal; Right : Uint) return Ureal renames UR_Sub; + + function "**" (Real : Ureal; N : Uint) return Ureal + renames UR_Exponentiate; + + function "abs" (Real : Ureal) return Ureal renames UR_Abs; + + function "-" (Real : Ureal) return Ureal renames UR_Negate; + + function "=" (Left, Right : Ureal) return Boolean renames UR_Eq; + + function "<" (Left, Right : Ureal) return Boolean renames UR_Lt; + + function "<=" (Left, Right : Ureal) return Boolean renames UR_Le; + + function ">=" (Left, Right : Ureal) return Boolean renames UR_Ge; + + function ">" (Left, Right : Ureal) return Boolean renames UR_Gt; + + ----------------------------- + -- Mark/Release Processing -- + ----------------------------- + + -- The space used by Ureal data is not automatically reclaimed. However, + -- a mark-release regime is implemented which allows storage to be + -- released back to a previously noted mark. This is used for example + -- when doing comparisons, where only intermediate results get stored + -- that do not need to be saved for future use. + + type Save_Mark is private; + + function Mark return Save_Mark; + -- Note mark point for future release + + procedure Release (M : Save_Mark); + -- Release storage allocated since mark was noted + + ------------------------------------ + -- Representation of Ureal Values -- + ------------------------------------ + +private + + type Ureal is new Int range Ureal_Low_Bound .. Ureal_High_Bound; + for Ureal'Size use 32; + + No_Ureal : constant Ureal := Ureal'First; + + type Save_Mark is new Int; + + pragma Inline (Denominator); + pragma Inline (Mark); + pragma Inline (Norm_Num); + pragma Inline (Norm_Den); + pragma Inline (Numerator); + pragma Inline (Rbase); + pragma Inline (Release); + pragma Inline (Ureal_0); + pragma Inline (Ureal_M_0); + pragma Inline (Ureal_Tenth); + pragma Inline (Ureal_Half); + pragma Inline (Ureal_1); + pragma Inline (Ureal_2); + pragma Inline (Ureal_10); + pragma Inline (UR_From_Components); + +end Urealp; diff --git a/gcc/ada/urealp.h b/gcc/ada/urealp.h new file mode 100644 index 00000000000..24afb55b598 --- /dev/null +++ b/gcc/ada/urealp.h @@ -0,0 +1,50 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * U R E A L P * + * * + * C Header File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-2001 Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 2, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* This file corresponds to the Ada package specification Urealp. It was + created manually from the files urealp.ads and urealp.adb */ + +/* Support for universal real arithmetic. */ + +#define Numerator urealp__numerator +extern Uint Numerator PARAMS ((Ureal)); + +#define Denominator urealp__denominator +extern Uint Denominator PARAMS ((Ureal)); + +#define Rbase urealp__rbase +extern Nat Rbase PARAMS ((Ureal)); + +#define UR_Is_Negative urealp__ur_is_negative +extern Boolean UR_Is_Negative PARAMS ((Ureal)); + +#define UR_Is_Zero urealp__ur_is_zero +extern Boolean UR_Is_Zero PARAMS ((Ureal)); + +#define Machine eval_fat__machine +extern Ureal Machine PARAMS ((Entity_Id, Ureal)); diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb new file mode 100644 index 00000000000..f6fffeaedc2 --- /dev/null +++ b/gcc/ada/usage.adb @@ -0,0 +1,390 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U S A G E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.116 $ +-- -- +-- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; +with System.WCh_Con; use System.WCh_Con; + +procedure Usage is + + procedure Write_Switch_Char (Sw : String; Prefix : String := "gnat"); + -- Output two spaces followed by default switch character followed + -- Prefix, followed by the string given as the argument, and then + -- enough blanks to tab to column 13, i.e. assuming Sw is not longer + -- than 5 characters, the maximum allowed, Write_Switch_Char will + -- always output exactly 12 characters. + + procedure Write_Switch_Char (Sw : String; Prefix : String := "gnat") is + begin + Write_Str (" "); + Write_Char (Switch_Character); + Write_Str (Prefix); + Write_Str (Sw); + + for J in 1 .. 12 - 3 - Prefix'Length - Sw'Length loop + Write_Char (' '); + end loop; + end Write_Switch_Char; + +-- Start of processing for Usage + +begin + Find_Program_Name; + + -- For gnatmake, we are appending this information to the end of + -- the normal gnatmake output, so generate appropriate header + + if Name_Len >= 8 + and then (Name_Buffer (Name_Len - 7 .. Name_Len) = "gnatmake" + or else + Name_Buffer (Name_Len - 7 .. Name_Len) = "GNATMAKE") + then + Write_Eol; + Write_Line ("Compiler switches (passed to the compiler by gnatmake):"); + + else + -- Usage line + + Write_Str ("Usage: "); + Write_Program_Name; + Write_Char (' '); + Write_Str ("switches sfile"); + Write_Eol; + Write_Eol; + + -- Line for sfile + + Write_Line (" sfile Source file name"); + end if; + + Write_Eol; + + -- Common GCC switches not available in JGNAT + + if not Hostparm.Java_VM then + Write_Switch_Char ("fstack-check ", ""); + Write_Line ("Generate stack checking code"); + + Write_Switch_Char ("fno-inline ", ""); + Write_Line ("Inhibit all inlining (makes executable smaller)"); + end if; + + -- Common switches available to both GCC and JGNAT + + Write_Switch_Char ("g ", ""); + Write_Line ("Generate debugging information"); + + Write_Switch_Char ("Idir ", ""); + Write_Line ("Specify source files search path"); + + Write_Switch_Char ("I- ", ""); + Write_Line ("Do not look for sources in current directory"); + + Write_Switch_Char ("O[0123] ", ""); + Write_Line ("Control the optimization level"); + + Write_Eol; + + -- Individual lines for switches. Write_Switch_Char outputs fourteen + -- characters, so the remaining message is allowed to be a maximum + -- of 65 characters to be comfortable on an 80 character device. + -- If the Write_Str fits on one line, it is short enough! + + -- Line for -gnata switch + + Write_Switch_Char ("a"); + Write_Line ("Assertions enabled. Pragma Assert/Debug to be activated"); + + -- Line for -gnatA switch + + Write_Switch_Char ("A"); + Write_Line ("Avoid processing gnat.adc, if present file will be ignored"); + + -- Line for -gnatb switch + + Write_Switch_Char ("b"); + Write_Line ("Generate brief messages to stderr even if verbose mode set"); + + -- Line for -gnatc switch + + Write_Switch_Char ("c"); + Write_Line ("Check syntax and semantics only (no code generation)"); + + Write_Switch_Char ("C"); + Write_Line ("Compress names in external names and debug info tables"); + + -- Line for -gnatd switch + + Write_Switch_Char ("d?"); + Write_Line ("Compiler debug option ? (a-z,A-Z,0-9), see debug.adb"); + + -- Line for -gnatD switch + + Write_Switch_Char ("D"); + Write_Line ("Debug expanded generated code rather than source code"); + + -- Line for -gnatec switch + + Write_Switch_Char ("ec?"); + Write_Line ("Specify configuration pragmas file, e.g. -gnatec/x/f.adc"); + + -- Line for -gnatE switch + + Write_Switch_Char ("E"); + Write_Line ("Dynamic elaboration checking mode enabled"); + + -- Line for -gnatf switch + + Write_Switch_Char ("f"); + Write_Line ("Full errors. Verbose details, all undefined references"); + + -- Line for -gnatF switch + + Write_Switch_Char ("F"); + Write_Line ("Force all import/export external names to all uppercase"); + + -- Line for -gnatg switch + + Write_Switch_Char ("g"); + Write_Line ("GNAT implementation mode (used for compiling GNAT units)"); + + -- Line for -gnatG switch + + Write_Switch_Char ("G"); + Write_Line ("Output generated expanded code in source form"); + + -- Line for -gnath switch + + Write_Switch_Char ("h"); + Write_Line ("Output this usage (help) information"); + + -- Line for -gnati switch + + Write_Switch_Char ("i?"); + Write_Line ("Identifier char set (?=1/2/3/4/8/p/f/n/w)"); + + -- Line for -gnatk switch + + Write_Switch_Char ("k"); + Write_Line ("Limit file names to nnn characters (k = krunch)"); + + -- Line for -gnatl switch + + Write_Switch_Char ("l"); + Write_Line ("Output full source listing with embedded error messages"); + + -- Line for -gnatL switch + + Write_Switch_Char ("L"); + Write_Line ("Use longjmp/setjmp for exception handling"); + + -- Line for -gnatm switch + + Write_Switch_Char ("mnnn"); + Write_Line ("Limit number of detected errors to nnn (1-999)"); + + -- Line for -gnatn switch + + Write_Switch_Char ("n"); + Write_Line ("Inlining of subprograms (apply pragma Inline across units)"); + + -- Line for -gnatN switch + + Write_Switch_Char ("N"); + Write_Line ("Full (frontend) inlining of subprograqms"); + + -- Line for -gnato switch + + Write_Switch_Char ("o"); + Write_Line ("Enable overflow checking (off by default)"); + + -- Line for -gnatO switch + + Write_Switch_Char ("O nm "); + Write_Line ("Set name of output ali file (internal switch)"); + + -- Line for -gnatp switch + + Write_Switch_Char ("p"); + Write_Line ("Suppress all checks"); + + -- Line for -gnatP switch + + Write_Switch_Char ("P"); + Write_Line ("Generate periodic calls to System.Polling.Poll"); + + -- Line for -gnatq switch + + Write_Switch_Char ("q"); + Write_Line ("Don't quit, try semantics, even if parse errors"); + + -- Line for -gnatQ switch + + Write_Switch_Char ("Q"); + Write_Line ("Don't quit, write ali/tree file even if compile errors"); + + -- Line for -gnatR switch + + Write_Switch_Char ("R?"); + Write_Line ("List rep inf (?=0/1/2/3 for none/types/all/variable)"); + + -- Lines for -gnats switch + + Write_Switch_Char ("s"); + Write_Line ("Syntax check only"); + + -- Lines for -gnatt switch + + Write_Switch_Char ("t"); + Write_Line ("Tree output file to be generated"); + + -- Line for -gnatT switch + + Write_Switch_Char ("Tnnn"); + Write_Line ("All compiler tables start at nnn times usual starting size"); + + -- Line for -gnatu switch + + Write_Switch_Char ("u"); + Write_Line ("List units for this compilation"); + + -- Line for -gnatU switch + + Write_Switch_Char ("U"); + Write_Line ("Enable unique tag for error messages"); + + -- Line for -gnatv switch + + Write_Switch_Char ("v"); + Write_Line ("Verbose mode. Full error output with source lines to stdout"); + + -- Line for -gnatV switch + + Write_Switch_Char ("V?"); + Write_Line + ("Validity checking (?=ndcte or 0-4 None/Default/Copy/Test/Exprs)"); + + -- Lines for -gnatw switch + + Write_Switch_Char ("wxx"); + Write_Line ("Enable selected warning modes, xx = list of parameters:"); + Write_Line (" a turn on all optional warnings (except b,h)"); + Write_Line (" A turn off all optional warnings"); + Write_Line (" b turn on biased rounding warnings"); + Write_Line (" B turn off biased rounding warnings"); + Write_Line (" c turn on constant conditional warnings"); + Write_Line (" C* turn off constant conditional warnings"); + Write_Line (" e treat all warnings as errors"); + Write_Line (" h turn on warnings for hiding variables"); + Write_Line (" H* turn off warnings for hiding variables"); + Write_Line (" i* turn on warnings for implementation units"); + Write_Line (" I turn off warnings for implementation units"); + Write_Line (" l turn on elaboration warnings"); + Write_Line (" L* turn off elaboration warnings"); + Write_Line (" o* turn on address clause overlay warnings"); + Write_Line (" O turn off address clause overlay warnings"); + Write_Line (" p turn on warnings for ineffective pragma inline"); + Write_Line (" P* turn off warnings for ineffective pragma inline"); + Write_Line (" r turn on redundant construct warnings"); + Write_Line (" R* turn off redundant construct warnings"); + Write_Line (" s suppress all warnings"); + Write_Line (" u turn on warnings for unused entities"); + Write_Line (" U* turn off warnings for unused entities"); + Write_Line (" * indicates default in above list"); + + -- Line for -gnatW switch + + Write_Switch_Char ("W"); + Write_Str ("Wide character encoding method ("); + + for J in WC_Encoding_Method loop + Write_Char (WC_Encoding_Letters (J)); + + if J = WC_Encoding_Method'Last then + Write_Char (')'); + else + Write_Char ('/'); + end if; + end loop; + + Write_Eol; + + -- Line for -gnatx switch + + Write_Switch_Char ("x"); + Write_Line ("Suppress output of cross-reference information"); + + -- Line for -gnatX switch + + Write_Switch_Char ("X"); + Write_Line ("Language extensions permitted"); + + -- Lines for -gnaty switch + + Write_Switch_Char ("y"); + Write_Line ("Enable all style checks"); + + Write_Switch_Char ("yxx"); + Write_Line ("Enable selected style checks xx = list of parameters:"); + Write_Line (" 1-9 check indentation"); + Write_Line (" a check attribute casing"); + Write_Line (" b check no blanks at end of lines"); + Write_Line (" c check comment format"); + Write_Line (" e check end/exit labels present"); + Write_Line (" f check no form feeds/vertical tabs in source"); + Write_Line (" h check no horizontal tabs in source"); + Write_Line (" i check if-then layout"); + Write_Line (" k check casing rules for keywords, identifiers"); + Write_Line (" l check reference manual layout"); + Write_Line (" m check line length <= 79 characters"); + Write_Line (" n check casing of package Standard identifiers"); + Write_Line (" Mnnn check line length <= nnn characters"); + Write_Line (" o check subprogram bodies in alphabetical order"); + Write_Line (" p check pragma casing"); + Write_Line (" r check RM column layout"); + Write_Line (" s check separate subprogram specs present"); + Write_Line (" t check token separation rules"); + + -- Lines for -gnatz switch + + Write_Switch_Char ("z"); + Write_Line ("Distribution stub generation (r/s for receiver/sender stubs)"); + + -- Line for -gnatZ switch + + Write_Switch_Char ("Z"); + Write_Line ("Use zero cost exception handling"); + + -- Line for -gnat83 switch + + Write_Switch_Char ("83"); + Write_Line ("Enforce Ada 83 restrictions"); + +end Usage; diff --git a/gcc/ada/usage.ads b/gcc/ada/usage.ads new file mode 100644 index 00000000000..af0c35c29bf --- /dev/null +++ b/gcc/ada/usage.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U S A G E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Procedure to generate screen of usage information if no file name present + +procedure Usage; diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c new file mode 100644 index 00000000000..b23bbe9f0c6 --- /dev/null +++ b/gcc/ada/utils.c @@ -0,0 +1,3350 @@ +/**************************************************************************** + * * + * 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)); + +/* 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); +} + + +/* 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; +} + +/* 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; +} + +/* 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]); +} + +/* 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); +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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); +} + +/* 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; +} + +/* 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; + } +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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); +} + +/* 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); +} + +/* 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)); +} + +/* 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; +} + +/* 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; +} + +/* 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 ()); + } +} + +/* 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))); +} + +/* 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; +} + +/* 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); + } +} + +/* 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; +} + +/* 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; +} + +/* 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; +} diff --git a/gcc/ada/utils2.c b/gcc/ada/utils2.c new file mode 100644 index 00000000000..424673ba103 --- /dev/null +++ b/gcc/ada/utils2.c @@ -0,0 +1,2049 @@ +/**************************************************************************** + * * + * 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)); + +/* 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)); + } +} + +/* 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; +} + +/* 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; + } +} + +/* 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; +} + +/* 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; + } +} + +/* 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; + } +} + +/* 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; +} + +/* 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); +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + + +/* 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; +} + +/* 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)); +} + +/* 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; +} + +/* 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; +} + +/* 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); +} + +/* 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); +} + +/* 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); +} + +/* 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; + } +} diff --git a/gcc/ada/validsw.adb b/gcc/ada/validsw.adb new file mode 100644 index 00000000000..923c913ea4d --- /dev/null +++ b/gcc/ada/validsw.adb @@ -0,0 +1,222 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V A L I D S W -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Opt; use Opt; + +package body Validsw is + + ---------------------------------- + -- Reset_Validity_Check_Options -- + ---------------------------------- + + procedure Reset_Validity_Check_Options is + begin + Validity_Check_Copies := False; + Validity_Check_Default := True; + Validity_Check_Floating_Point := False; + Validity_Check_In_Out_Params := False; + Validity_Check_In_Params := False; + Validity_Check_Operands := False; + Validity_Check_Returns := False; + Validity_Check_Subscripts := False; + Validity_Check_Tests := False; + end Reset_Validity_Check_Options; + + --------------------------------- + -- Save_Validity_Check_Options -- + --------------------------------- + + procedure Save_Validity_Check_Options + (Options : out Validity_Check_Options) + is + P : Natural := 0; + + procedure Add (C : Character; S : Boolean); + -- Add given character C to string if switch S is true + + procedure Add (C : Character; S : Boolean) is + begin + if S then + P := P + 1; + Options (P) := C; + end if; + end Add; + + -- Start of processing for Save_Validity_Check_Options + + begin + for K in Options'Range loop + Options (K) := ' '; + end loop; + + Add ('c', Validity_Check_Copies); + Add ('d', Validity_Check_Default); + Add ('f', Validity_Check_Floating_Point); + Add ('i', Validity_Check_In_Params); + Add ('m', Validity_Check_In_Out_Params); + Add ('o', Validity_Check_Operands); + Add ('r', Validity_Check_Returns); + Add ('s', Validity_Check_Subscripts); + Add ('t', Validity_Check_Tests); + end Save_Validity_Check_Options; + + ---------------------------------------- + -- Set_Default_Validity_Check_Options -- + ---------------------------------------- + + procedure Set_Default_Validity_Check_Options is + begin + Reset_Validity_Check_Options; + Set_Validity_Check_Options ("d"); + end Set_Default_Validity_Check_Options; + + -------------------------------- + -- Set_Validity_Check_Options -- + -------------------------------- + + -- Version used when no error checking is required + + procedure Set_Validity_Check_Options (Options : String) is + OK : Boolean; + EC : Natural; + + begin + Set_Validity_Check_Options (Options, OK, EC); + end Set_Validity_Check_Options; + + -- Normal version with error checking + + procedure Set_Validity_Check_Options + (Options : String; + OK : out Boolean; + Err_Col : out Natural) + is + J : Natural; + C : Character; + + begin + Reset_Validity_Check_Options; + + J := Options'First; + while J <= Options'Last loop + C := Options (J); + J := J + 1; + + case C is + when 'c' => + Validity_Check_Copies := True; + + when 'd' => + Validity_Check_Default := True; + + when 'f' => + Validity_Check_Floating_Point := True; + + when 'i' => + Validity_Check_In_Params := True; + + when 'm' => + Validity_Check_In_Out_Params := True; + + when 'o' => + Validity_Check_Operands := True; + + when 'r' => + Validity_Check_Returns := True; + + when 's' => + Validity_Check_Subscripts := True; + + when 't' => + Validity_Check_Tests := True; + + when 'C' => + Validity_Check_Copies := False; + + when 'D' => + Validity_Check_Default := False; + + when 'I' => + Validity_Check_In_Params := False; + + when 'F' => + Validity_Check_Floating_Point := False; + + when 'M' => + Validity_Check_In_Out_Params := False; + + when 'O' => + Validity_Check_Operands := False; + + when 'R' => + Validity_Check_Returns := False; + + when 'S' => + Validity_Check_Subscripts := False; + + when 'T' => + Validity_Check_Tests := False; + + when 'a' => + Validity_Check_Copies := True; + Validity_Check_Default := True; + Validity_Check_Floating_Point := True; + Validity_Check_In_Out_Params := True; + Validity_Check_In_Params := True; + Validity_Check_Operands := True; + Validity_Check_Returns := True; + Validity_Check_Subscripts := True; + Validity_Check_Tests := True; + + when 'n' => + Validity_Check_Copies := False; + Validity_Check_Default := False; + Validity_Check_Floating_Point := False; + Validity_Check_In_Out_Params := False; + Validity_Check_In_Params := False; + Validity_Check_Operands := False; + Validity_Check_Returns := False; + Validity_Check_Subscripts := False; + Validity_Check_Tests := False; + + when ' ' => + null; + + when others => + OK := False; + Err_Col := J - 1; + return; + end case; + end loop; + + Validity_Checks_On := True; + OK := True; + Err_Col := Options'Last + 1; + end Set_Validity_Check_Options; + +end Validsw; diff --git a/gcc/ada/validsw.ads b/gcc/ada/validsw.ads new file mode 100644 index 00000000000..881fca4fd88 --- /dev/null +++ b/gcc/ada/validsw.ads @@ -0,0 +1,146 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V A L I D S W -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This unit contains the routines used to handle setting of validity +-- checking options. + +package Validsw is + + ----------------------------- + -- Validity Check Switches -- + ----------------------------- + + -- The following flags determine the specific set of validity checks + -- to be made if validity checking is active (Validity_Checks_On = True) + + -- See GNAT users guide for an exact description of each option. The letter + -- given in the comment is the letter used in the -gnatV compiler switch + -- or in the argument of a Validity_Checks pragma to activate the option. + -- The corresponding upper case letter deactivates the option. + + Validity_Check_Copies : Boolean := False; + -- Controls the validity checking of copies. If this switch is set to + -- true using -gnatVc, or a 'c' in the argument of a Validity_Checks + -- pragma, then the right side of assignments and also initializing + -- expressions in object declarations are checked for validity. + + Validity_Check_Default : Boolean := True; + -- Controls default (reference manual) validity checking. If this switch + -- is set to True using -gnatVd or a 'd' in the argument of a Validity_ + -- Checks pragma then left side subscripts and case statement arguments + -- are checked for validity. This switch is also set by default if no + -- -gnatV switch is used and no Validity_Checks pragma is processed. + + Validity_Check_Floating_Point : Boolean := False; + -- Normally validity checking applies only to discrete values (integer + -- and enumeration types). If this switch is set to True using -gnatVf + -- or an 'f' in the argument of a Validity_Checks pragma, then floating- + -- point values are also checked. The context in which such checks + -- occur depends on other flags, e.g. if Validity_Check_Copies is also + -- set then floating-point values on the right side of an assignment + -- will be validity checked. + + Validity_Check_In_Out_Params : Boolean := False; + -- Controls the validity checking of IN OUT parameters. If this switch + -- is set to True using -gnatVm or a 'm' in the argument of a pragma + -- Validity_Checks, then the initial value of all IN OUT parameters + -- will be checked at the point of call of a procecure. Note that the + -- character 'm' here stands for modified (parameters). + + Validity_Check_In_Params : Boolean := False; + -- Controls the validity checking of IN parameters. If this switch is + -- set to True using -gnatVm or an 'i' in the argument of a pragma + -- Validity_Checks, then the initial value of all IN parameters + -- will be checked at the point of call of a procecure or function. + + Validity_Check_Operands : Boolean := False; + -- Controls validity checking of operands. If this switch is set to + -- True using -gnatVo or an 'o' in the argument of a Validity_Checks + -- pragma, then operands of all predefined operators and attributes + -- will be validity checked. + + Validity_Check_Returns : Boolean := False; + -- Controls validity checking of returned values. If this switch is set + -- to True using -gnatVr, or an 'r' in the argument of a Validity_Checks + -- pragma, then the expression in a RETURN statement is validity checked. + + Validity_Check_Subscripts : Boolean := False; + -- Controls validity checking of subscripts. If this switch is set to + -- True using -gnatVs, or an 's' in the argument of a Validity_Checks + -- pragma, then all subscripts are checked for validity. Note that left + -- side subscript checking is controlled also by Validity_Check_Default. + -- If Validity_Check_Subscripts is True, then all subscripts are checked, + -- otherwise if Validity_Check_Default is True, then left side subscripts + -- are checked, otherwise no subscripts are checked. + + Validity_Check_Tests : Boolean := False; + -- Controls validity checking of tests that occur in conditions (i.e. the + -- tests in IF, WHILE, and EXIT statements, and in entry guards). If this + -- switch is set to True using -gnatVt, or a 't' in the argument of a + -- Validity_Checks pragma, then all such conditions are validity checked. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Set_Default_Validity_Check_Options; + -- This procedure is called to set the default validity checking options + -- that apply if no Validity_Check switches or pragma is given. + + procedure Set_Validity_Check_Options + (Options : String; + OK : out Boolean; + Err_Col : out Natural); + -- This procedure is called to set the validity check options that + -- correspond to the characters in the given Options string. If + -- all options are valid, then Set_Default_Validity_Check_Options + -- is first called to set the defaults, and then the options in the + -- given string are set in an additive manner. If any invalid character + -- is found, then OK is False on exit, and Err_Col is the index in + -- in options of the bad character. If all options are valid, then + -- OK is True on return, and Err_Col is set to options'Last + 1. + + procedure Set_Validity_Check_Options (Options : String); + -- Like the above procedure, except that the call is simply ignored if + -- there are any error conditions, this is for example appopriate for + -- calls where the string is known to be valid, e.g. because it was + -- obtained by Save_Validity_Check_Options. + + procedure Reset_Validity_Check_Options; + -- Sets all validity check options to off + + subtype Validity_Check_Options is String (1 .. 16); + -- Long enough string to hold all options from Save call below + + procedure Save_Validity_Check_Options + (Options : out Validity_Check_Options); + -- Sets Options to represent current selection of options. This + -- set can be restored by first calling Reset_Validity_Check_Options, + -- and then calling Set_Validity_Check_Options with the Options string. + +end Validsw; diff --git a/gcc/ada/widechar.adb b/gcc/ada/widechar.adb new file mode 100644 index 00000000000..39df6f7ba06 --- /dev/null +++ b/gcc/ada/widechar.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- W I D E C H A R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.15 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Note: this package uses the generic subprograms in System.Wch_Cnv, which +-- completely encapsulate the set of wide character encoding methods, so no +-- modifications are required when adding new encoding methods. + +with Opt; use Opt; + +with System.WCh_Cnv; use System.WCh_Cnv; +with System.WCh_Con; use System.WCh_Con; + +package body Widechar is + + --------------------------- + -- Is_Start_Of_Wide_Char -- + --------------------------- + + function Is_Start_Of_Wide_Char + (S : Source_Buffer_Ptr; + P : Source_Ptr) + return Boolean + is + begin + case Wide_Character_Encoding_Method is + when WCEM_Hex => + return S (P) = ASCII.ESC; + + when WCEM_Upper | + WCEM_Shift_JIS | + WCEM_EUC | + WCEM_UTF8 => + return S (P) >= Character'Val (16#80#); + + when WCEM_Brackets => + return P <= S'Last - 2 + and then S (P) = '[' + and then S (P + 1) = '"' + and then S (P + 2) /= '"'; + end case; + end Is_Start_Of_Wide_Char; + + ----------------- + -- Length_Wide -- + ----------------- + + function Length_Wide return Nat is + begin + return WC_Longest_Sequence; + end Length_Wide; + + --------------- + -- Scan_Wide -- + --------------- + + procedure Scan_Wide + (S : Source_Buffer_Ptr; + P : in out Source_Ptr; + C : out Char_Code; + Err : out Boolean) + is + function In_Char return Character; + -- Function to obtain characters of wide character escape sequence + + function In_Char return Character is + begin + P := P + 1; + return S (P - 1); + end In_Char; + + function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + + begin + C := Char_Code (Wide_Character'Pos + (WC_In (In_Char, Wide_Character_Encoding_Method))); + Err := False; + + exception + when Constraint_Error => + C := Char_Code (0); + P := P - 1; + Err := True; + end Scan_Wide; + + -------------- + -- Set_Wide -- + -------------- + + procedure Set_Wide + (C : Char_Code; + S : in out String; + P : in out Natural) + is + procedure Out_Char (C : Character); + -- Procedure to store one character of wide character sequence + + procedure Out_Char (C : Character) is + begin + P := P + 1; + S (P) := C; + end Out_Char; + + procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char); + + begin + WC_Out (Wide_Character'Val (C), Wide_Character_Encoding_Method); + end Set_Wide; + + --------------- + -- Skip_Wide -- + --------------- + + procedure Skip_Wide (S : String; P : in out Natural) is + function Skip_Char return Character; + -- Function to skip one character of wide character escape sequence + + function Skip_Char return Character is + begin + P := P + 1; + return S (P - 1); + end Skip_Char; + + function WC_Skip is new Char_Sequence_To_Wide_Char (Skip_Char); + + Discard : Wide_Character; + + begin + Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method); + end Skip_Wide; + +end Widechar; diff --git a/gcc/ada/widechar.ads b/gcc/ada/widechar.ads new file mode 100644 index 00000000000..daf297e9542 --- /dev/null +++ b/gcc/ada/widechar.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- W I D E C H A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ -- +-- -- +-- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Subprograms for manipulation of wide character sequences + +with Types; use Types; + +package Widechar is + + function Length_Wide return Nat; + -- Returns the maximum length in characters for the escape sequence that + -- is used to encode wide character literals outside the ASCII range. Used + -- only in the implementation of the attribute Width for Wide_Character. + + procedure Scan_Wide + (S : Source_Buffer_Ptr; + P : in out Source_Ptr; + C : out Char_Code; + Err : out Boolean); + -- On entry S (P) points to the first character in the source text for + -- a wide character (i.e. to an ESC character, a left bracket, or an + -- upper half character, depending on the representation method). A + -- single wide character is scanned. If no error is found, the value + -- stored in C is the code for this wide character, P is updated past + -- the sequence and Err is set to False. If an error is found, then + -- P points to the improper character, C is undefined, and Err is + -- set to True. + + procedure Set_Wide + (C : Char_Code; + S : in out String; + P : in out Natural); + -- The escape sequence (including any leading ESC character) for the + -- given character code is stored starting at S (P + 1), and on return + -- P points to the last stored character (i.e. P is the count of stored + -- characters on entry and exit, and the escape sequence is appended to + -- the end of the stored string). The character code C represents a code + -- originally constructed by Scan_Wide, so it is known to be in a range + -- that is appropriate for the encoding method in use. + + procedure Skip_Wide (S : String; P : in out Natural); + -- On entry, S (P) points to an ESC character for a wide character escape + -- sequence or to an upper half character if the encoding method uses the + -- upper bit, or to a left bracket if the brackets encoding method is in + -- use. On exit, P is bumped past the wide character sequence. No error + -- checking is done, since this is only used on escape sequences generated + -- by Set_Wide, which are known to be correct. + + function Is_Start_Of_Wide_Char + (S : Source_Buffer_Ptr; + P : Source_Ptr) + return Boolean; + -- Determines if S (P) is the start of a wide character sequence + +end Widechar; diff --git a/gcc/ada/xeinfo.adb b/gcc/ada/xeinfo.adb new file mode 100644 index 00000000000..38c35ce03c5 --- /dev/null +++ b/gcc/ada/xeinfo.adb @@ -0,0 +1,539 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X E I N F O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.29 $ +-- -- +-- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Program to construct C header file a-einfo.h (C version of einfo.ads spec) +-- for use by Gigi. This header file contaInF all definitions and access +-- functions, but does not contain set procedures, since Gigi is not allowed +-- to modify the GNAT tree) + +-- Input files: + +-- einfo.ads spec of Einfo package +-- einfo.adb body of Einfo package + +-- Output files: + +-- a-einfo.h Corresponding c header file + +-- Note: It is assumed that the input files have been compiled without errors + +-- An optional argument allows the specification of an output file name to +-- override the default a-einfo.h file name for the generated output file. + +-- Most, but not all of the functions in Einfo can be inlined in the C header. +-- They are the functions identified by pragma Inline in the spec. Functions +-- that cannot be inlined are simply defined in the header. + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; +with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean; + +procedure XEinfo is + + package TB renames GNAT.Spitbol.Table_Boolean; + + Err : exception; + + A : VString := Nul; + B : VString := Nul; + C : VString := Nul; + Einfobrev : VString := Nul; + Einfosrev : VString := Nul; + Expr : VString := Nul; + Filler : VString := Nul; + Fline : VString := Nul; + Formal : VString := Nul; + Formaltyp : VString := Nul; + FN : VString := Nul; + Line : VString := Nul; + N : VString := Nul; + N1 : VString := Nul; + N2 : VString := Nul; + N3 : VString := Nul; + Nam : VString := Nul; + Name : VString := Nul; + NewS : VString := Nul; + Nextlin : VString := Nul; + OldS : VString := Nul; + Rtn : VString := Nul; + Term : VString := Nul; + XEinforev : VString := Nul; + + InB : File_Type; + -- Used to read initial header from body + + InF : File_Type; + -- Used to read full text of both spec and body + + Ofile : File_Type; + -- Used to write output file + + wsp : Pattern := NSpan (' ' & ASCII.HT); + Get_BRev : Pattern := BreakX ('$') & "$Rev" & "ision: " + & Break (' ') * Einfobrev; + Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: " + & Break (' ') * Einfosrev; + Comment : Pattern := wsp & "--"; + For_Rep : Pattern := wsp & "for"; + Get_Func : Pattern := wsp * A & "function" & wsp & Break (' ') * Name; + Inline : Pattern := wsp & "pragma Inline (" & Break (')') * Name; + Get_Pack : Pattern := wsp & "package "; + Get_Enam : Pattern := wsp & Break (',') * N & ','; + Find_Fun : Pattern := wsp & "function"; + F_Subtyp : Pattern := wsp * A & "subtype " & Break (' ') * N; + G_Subtyp : Pattern := wsp & "subtype" & wsp & Break (' ') * NewS + & wsp & "is" & wsp & Break (" ;") * OldS + & wsp & ';' & wsp & Rtab (0); + F_Typ : Pattern := wsp * A & "type " & Break (' ') * N & " is ("; + Get_Nam : Pattern := wsp * A & Break (",)") * Nam & Len (1) * Term; + Get_Styp : Pattern := wsp * A & "subtype " & Break (' ') * N; + Get_N1 : Pattern := wsp & Break (' ') * N1; + Get_N2 : Pattern := wsp & "-- " & Rest * N2; + Get_N3 : Pattern := wsp & Break (';') * N3; + Get_FN : Pattern := wsp * C & "function" & wsp & Break (" (") * FN; + Is_Rturn : Pattern := BreakX ('r') & "return"; + Is_Begin : Pattern := wsp & "begin"; + Get_Asrt : Pattern := wsp & "pragma Assert"; + Semicoln : Pattern := BreakX (';'); + Get_Cmnt : Pattern := BreakX ('-') * A & "--"; + Get_Expr : Pattern := wsp & "return " & Break (';') * Expr; + Chek_End : Pattern := wsp & "end" & BreakX (';') & ';'; + Get_B1 : Pattern := BreakX (' ') * A & " in " & Rest * B; + Get_B2 : Pattern := BreakX (' ') * A & " = " & Rest * B; + Get_B3 : Pattern := BreakX (' ') * A & " /= " & Rest * B; + To_Paren : Pattern := wsp * Filler & '('; + Get_Fml : Pattern := Break (" :") * Formal & wsp & ':' & wsp + & BreakX (" );") * Formaltyp; + Nxt_Fml : Pattern := wsp & "; "; + Get_Rtn : Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn; + Rem_Prn : Pattern := wsp & ')'; + + M : Match_Result; + + Lineno : Natural := 0; + -- Line number in spec + + V : Natural; + Ctr : Natural; + + Inlined : TB.Table (200); + -- Inlined<N> = True for inlined function, False otherwise + + Lastinlined : Boolean; + + procedure Badfunc; + -- Signal bad function in body + + function Getlin return VString; + -- Get non-comment line (comment lines skipped, also skips FOR rep clauses) + -- Fatal error (raises End_Error exception) if end of file encountered + + procedure Must (B : Boolean); + -- Raises Err if the argument (a Match) call, returns False + + procedure Sethead (Line : in out VString; Term : String); + -- Process function header into C + + ------------- + -- Badfunc -- + ------------- + + procedure Badfunc is + begin + Put_Line + (Standard_Error, + "Body for function " & FN & " does not meet requirements"); + raise Err; + end Badfunc; + + ------------- + -- Getlin -- + ------------- + + function Getlin return VString is + Lin : VString; + + begin + loop + Lin := Get_Line (InF); + Lineno := Lineno + 1; + + if Lin /= "" + and then not Match (Lin, Comment) + and then not Match (Lin, For_Rep) + then + return Lin; + end if; + end loop; + end Getlin; + + ---------- + -- Must -- + ---------- + + procedure Must (B : Boolean) is + begin + if not B then + raise Err; + end if; + end Must; + + ------------- + -- Sethead -- + ------------- + + procedure Sethead (Line : in out VString; Term : String) is + Args : VString; + + begin + Must (Match (Line, Get_Func, "")); + Args := Nul; + + if Match (Line, To_Paren, "") then + Args := Filler & '('; + + loop + Must (Match (Line, Get_Fml, "")); + Append (Args, Formaltyp & ' ' & Formal); + exit when not Match (Line, Nxt_Fml); + Append (Args, ","); + end loop; + + Match (Line, Rem_Prn, ""); + Append (Args, ')'); + end if; + + Must (Match (Line, Get_Rtn)); + + if Present (Inlined, Name) then + Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term); + else + Put_Line (Ofile, A & Rtn & ' ' & Name & Args & Term); + end if; + end Sethead; + +-- Start of processing for XEinfo + +begin + Anchored_Mode := True; + + Match ("$Revision: 1.29 $", "$Rev" & "ision: " & Break (' ') * XEinforev); + + if Argument_Count > 0 then + Create (Ofile, Out_File, Argument (1)); + else + Create (Ofile, Out_File, "a-einfo.h"); + end if; + + Open (InB, In_File, "einfo.adb"); + Open (InF, In_File, "einfo.ads"); + + Lineno := 0; + + -- Get einfo revs and write header to output file + + loop + Line := Get_Line (InB); + + if Line = "" then + raise Err; + end if; + + exit when Match (Line, Get_BRev); + end loop; + + loop + Line := Get_Line (InF); + Lineno := Lineno + 1; + exit when Line = ""; + + if Match (Line, Get_SRev) then + Put_Line + (Ofile, + "/* Generated by xeinfo revision " & XEinforev & + " using */"); + Put_Line + (Ofile, + "/* einfo.ads revision " & Einfosrev & + " */"); + Put_Line + (Ofile, + "/* einfo.adb revision " & Einfobrev & + " */"); + else + Match (Line, + "-- S p e c ", + "-- C Header File "); + + Match (Line, "--", "/*"); + Match (Line, Rtab (2) * A & "--", M); + Replace (M, A & "*/"); + Put_Line (Ofile, Line); + end if; + end loop; + + Put_Line (Ofile, ""); + + -- Find and record pragma Inlines + + loop + Line := Get_Line (InF); + exit when Match (Line, " -- END XEINFO INLINES"); + + + if Match (Line, Inline) then + Set (Inlined, Name, True); + end if; + end loop; + + -- Skip to package line + + Reset (InF, In_File); + Lineno := 0; + + loop + Line := Getlin; + exit when Match (Line, Get_Pack); + end loop; + + V := 0; + Line := Getlin; + Must (Match (Line, wsp & "type Entity_Kind")); + + -- Process entity kind code definitions + + loop + Line := Getlin; + exit when not Match (Line, Get_Enam); + Put_Line (Ofile, " #define " & Rpad (N, 32) & " " & V); + V := V + 1; + end loop; + + Must (Match (Line, wsp & Rest * N)); + Put_Line (Ofile, " #define " & Rpad (N, 32) & ' ' & V); + Line := Getlin; + + Must (Match (Line, wsp & ");")); + Put_Line (Ofile, ""); + + -- Loop through subtype and type declarations + + loop + Line := Getlin; + exit when Match (Line, Find_Fun); + + -- Case of a subtype declaration + + if Match (Line, F_Subtyp) then + + -- Case of a subtype declaration that is an abbreviation of the + -- form subtype x is y, and if so generate the appropriate typedef + + if Match (Line, G_Subtyp) then + Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';'); + + -- Otherwise the subtype must be declaring a subrange of Entity_Id + + else + Must (Match (Line, Get_Styp)); + Line := Getlin; + Must (Match (Line, Get_N1)); + + loop + Line := Get_Line (InF); + Lineno := Lineno + 1; + exit when not Match (Line, Get_N2); + end loop; + + Must (Match (Line, Get_N3)); + Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, "); + Put_Line (Ofile, A & " " & N1 & ", " & N3 & ')'); + Put_Line (Ofile, ""); + end if; + + + -- Case of type declaration + + elsif Match (Line, F_Typ) then + -- Process type declaration (must be enumeration type) + + Ctr := 0; + Put_Line (Ofile, A & "typedef int " & N & ';'); + + loop + Line := Getlin; + Must (Match (Line, Get_Nam)); + Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr); + Ctr := Ctr + 1; + exit when Term /= ","; + end loop; + + Put_Line (Ofile, ""); + + -- Neither subtype nor type declaration + + else + raise Err; + end if; + end loop; + + -- Process function declarations + -- Note: Lastinlined used to control blank lines + + Put_Line (Ofile, ""); + Lastinlined := True; + + -- Loop through function declarations + + while Match (Line, Get_FN) loop + + -- Non-inlined funcion + + if not Present (Inlined, FN) then + Put_Line (Ofile, ""); + Put_Line + (Ofile, + " #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map)); + + -- Inlined function + + else + if not Lastinlined then + Put_Line (Ofile, ""); + end if; + end if; + + -- Merge here to output spec + + Sethead (Line, ";"); + Lastinlined := Get (Inlined, FN); + Line := Getlin; + end loop; + + Put_Line (Ofile, ""); + + -- Read body to find inlined functions + + Close (InB); + Close (InF); + Open (InF, In_File, "einfo.adb"); + Lineno := 0; + + -- Loop through input lines to find bodies of inlined functions + + while not End_Of_File (InF) loop + Fline := Get_Line (InF); + + if Match (Fline, Get_FN) + and then Get (Inlined, FN) + then + -- Here we have an inlined function + + if not Match (Fline, Is_Rturn) then + Line := Fline; + Badfunc; + end if; + + Line := Getlin; + + if not Match (Line, Is_Begin) then + Badfunc; + end if; + + -- Skip past pragma Asserts + + loop + Line := Getlin; + exit when not Match (Line, Get_Asrt); + + -- Pragma asser found, get its continuation lines + + loop + exit when Match (Line, Semicoln); + Line := Getlin; + end loop; + end loop; + + -- Process return statement + + Match (Line, Get_Cmnt, M); + Replace (M, A); + + -- Get continuations of return statemnt + + while not Match (Line, Semicoln) loop + Nextlin := Getlin; + Match (Nextlin, wsp, " "); + Append (Line, Nextlin); + end loop; + + if not Match (Line, Get_Expr) then + Badfunc; + end if; + + Line := Getlin; + + if not Match (Line, Chek_End) then + Badfunc; + end if; + + Match (Expr, Get_B1, M); + Replace (M, "IN (" & A & ", " & B & ')'); + Match (Expr, Get_B2, M); + Replace (M, A & " == " & B); + Match (Expr, Get_B3, M); + Replace (M, A & " != " & B); + Put_Line (Ofile, ""); + Sethead (Fline, ""); + Put_Line (Ofile, C & " { return " & Expr & "; }"); + end if; + end loop; + + Put_Line (Ofile, ""); + Put_Line + (Ofile, + "/* End of einfo.h (C version of Einfo package specification) */"); + +exception + when Err => + Put_Line (Standard_Error, Lineno & ". " & Line); + Put_Line (Standard_Error, "**** fatal error ****"); + Set_Exit_Status (1); + + when End_Error => + Put_Line (Standard_Error, "unexpected end of file"); + Put_Line (Standard_Error, "**** fatal error ****"); + +end XEinfo; diff --git a/gcc/ada/xnmake.adb b/gcc/ada/xnmake.adb new file mode 100644 index 00000000000..f87b8500b89 --- /dev/null +++ b/gcc/ada/xnmake.adb @@ -0,0 +1,485 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X N M A K E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.27 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Program to construct the spec and body of the Nmake package + +-- Input files: + +-- sinfo.ads Spec of Sinfo package +-- nmake.adt Template for Nmake package + +-- Output files: + +-- nmake.ads Spec of Nmake package +-- nmake.adb Body of Nmake package + +-- Note: this program assumes that sinfo.ads has passed the error checks that +-- are carried out by the csinfo utility, so it does not duplicate these +-- checks and assumes that sinfo.ads has the correct form. + +-- In the absence of any switches, both the ads and adb files are output. +-- The switch -s or /s indicates that only the ads file is to be output. +-- The switch -b or /b indicates that only the adb file is to be output. + +-- If a file name argument is given, then the output is written to this file +-- rather than to nmake.ads or nmake.adb. A file name can only be given if +-- exactly one of the -s or -b options is present. + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; + +procedure XNmake is + + Err : exception; + -- Raised to terminate execution + + A : VString := Nul; + Arg : VString := Nul; + Arg_List : VString := Nul; + Comment : VString := Nul; + Default : VString := Nul; + Field : VString := Nul; + Line : VString := Nul; + Node : VString := Nul; + Op_Name : VString := Nul; + Prevl : VString := Nul; + Sinfo_Rev : VString := Nul; + Synonym : VString := Nul; + Temp_Rev : VString := Nul; + X : VString := Nul; + XNmake_Rev : VString := Nul; + + Lineno : Natural; + NWidth : Natural; + + FileS : VString := V ("nmake.ads"); + FileB : VString := V ("nmake.adb"); + -- Set to null if corresponding file not to be generated + + Given_File : VString := Nul; + -- File name given by command line argument + + InS, InT : File_Type; + OutS, OutB : File_Type; + + wsp : Pattern := Span (' ' & ASCII.HT); + + -- Note: in following patterns, we break up the word revision to + -- avoid RCS getting enthusiastic about updating the reference! + + Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: " & + Break (' ') * Sinfo_Rev; + + GetT_Rev : Pattern := BreakX ('$') & "$Rev" & "ision: " & + Break (' ') * Temp_Rev; + + + Body_Only : Pattern := BreakX (' ') * X & Span (' ') & "-- body only"; + Spec_Only : Pattern := BreakX (' ') * X & Span (' ') & "-- spec only"; + + Node_Hdr : Pattern := wsp & "-- N_" & Rest * Node; + Punc : Pattern := BreakX (" .,"); + + Binop : Pattern := wsp & "-- plus fields for binary operator"; + Unop : Pattern := wsp & "-- plus fields for unary operator"; + Syn : Pattern := wsp & "-- " & Break (' ') * Synonym + & " (" & Break (')') * Field & Rest * Comment; + + Templ : Pattern := BreakX ('T') * A & "T e m p l a t e"; + Spec : Pattern := BreakX ('S') * A & "S p e c"; + + Sem_Field : Pattern := BreakX ('-') & "-Sem"; + Lib_Field : Pattern := BreakX ('-') & "-Lib"; + + Get_Field : Pattern := BreakX (Decimal_Digit_Set) * Field; + + Get_Dflt : Pattern := BreakX ('(') & "(set to " + & Break (" ") * Default & " if"; + + Next_Arg : Pattern := Break (',') * Arg & ','; + + Op_Node : Pattern := "Op_" & Rest * Op_Name; + + Shft_Rot : Pattern := "Shift_" or "Rotate_"; + + No_Ent : Pattern := "Or_Else" or "And_Then" or "In" or "Not_In"; + + M : Match_Result; + + V_String_Id : constant VString := V ("String_Id"); + V_Node_Id : constant VString := V ("Node_Id"); + V_Name_Id : constant VString := V ("Name_Id"); + V_List_Id : constant VString := V ("List_Id"); + V_Elist_Id : constant VString := V ("Elist_Id"); + V_Boolean : constant VString := V ("Boolean"); + + procedure WriteS (S : String); + procedure WriteB (S : String); + procedure WriteBS (S : String); + procedure WriteS (S : VString); + procedure WriteB (S : VString); + procedure WriteBS (S : VString); + -- Write given line to spec or body file or both if active + + procedure WriteB (S : String) is + begin + if FileB /= Nul then + Put_Line (OutB, S); + end if; + end WriteB; + + procedure WriteB (S : VString) is + begin + if FileB /= Nul then + Put_Line (OutB, S); + end if; + end WriteB; + + procedure WriteBS (S : String) is + begin + if FileB /= Nul then + Put_Line (OutB, S); + end if; + + if FileS /= Nul then + Put_Line (OutS, S); + end if; + end WriteBS; + + procedure WriteBS (S : VString) is + begin + if FileB /= Nul then + Put_Line (OutB, S); + end if; + + if FileS /= Nul then + Put_Line (OutS, S); + end if; + end WriteBS; + + procedure WriteS (S : String) is + begin + if FileS /= Nul then + Put_Line (OutS, S); + end if; + end WriteS; + + procedure WriteS (S : VString) is + begin + if FileS /= Nul then + Put_Line (OutS, S); + end if; + end WriteS; + +-- Start of processing for XNmake + +begin + -- Capture our revision (following line updated by RCS) + + Match ("$Revision: 1.27 $", "$Rev" & "ision: " & Break (' ') * XNmake_Rev); + + Lineno := 0; + NWidth := 28; + Anchored_Mode := True; + + for ArgN in 1 .. Argument_Count loop + declare + Arg : constant String := Argument (ArgN); + + begin + if Arg (1) = '/' or else Arg (1) = '-' then + if Arg'Length = 2 + and then (Arg (2) = 'b' or else Arg (2) = 'B') + then + FileS := Nul; + + elsif Arg'Length = 2 + and then (Arg (2) = 's' or else Arg (2) = 'S') + then + FileB := Nul; + + else + raise Err; + end if; + + else + if Given_File /= Nul then + raise Err; + else + Given_File := V (Arg); + end if; + end if; + end; + end loop; + + if FileS = Nul and then FileB = Nul then + raise Err; + + elsif Given_File /= Nul then + if FileS = Nul then + FileS := Given_File; + + elsif FileB = Nul then + FileB := Given_File; + + else + raise Err; + end if; + end if; + + Open (InS, In_File, "sinfo.ads"); + Open (InT, In_File, "nmake.adt"); + + if FileS /= Nul then + Create (OutS, Out_File, S (FileS)); + end if; + + if FileB /= Nul then + Create (OutB, Out_File, S (FileB)); + end if; + + Anchored_Mode := True; + + -- Get Sinfo revision number + + loop + Line := Get_Line (InS); + exit when Match (Line, Get_SRev); + end loop; + + -- Copy initial part of template to spec and body + + loop + Line := Get_Line (InT); + + if Match (Line, GetT_Rev) then + WriteBS + ("-- Generated by xnmake revision " & + XNmake_Rev & " using" & + " --"); + + WriteBS + ("-- sinfo.ads revision " & + Sinfo_Rev & + " --"); + + WriteBS + ("-- nmake.adt revision " & + Temp_Rev & + " --"); + + else + -- Skip lines describing the template + + if Match (Line, "-- This file is a template") then + loop + Line := Get_Line (InT); + exit when Line = ""; + end loop; + end if; + + exit when Match (Line, "package"); + + if Match (Line, Body_Only, M) then + Replace (M, X); + WriteB (Line); + + elsif Match (Line, Spec_Only, M) then + Replace (M, X); + WriteS (Line); + + else + if Match (Line, Templ, M) then + Replace (M, A & " S p e c "); + end if; + + WriteS (Line); + + if Match (Line, Spec, M) then + Replace (M, A & "B o d y"); + end if; + + WriteB (Line); + end if; + end if; + end loop; + + -- Package line reached + + WriteS ("package Nmake is"); + WriteB ("package body Nmake is"); + WriteB (""); + + -- Copy rest of lines up to template insert point to spec only + + loop + Line := Get_Line (InT); + exit when Match (Line, "!!TEMPLATE INSERTION POINT"); + WriteS (Line); + end loop; + + -- Here we are doing the actual insertions, loop through node types + + loop + Line := Get_Line (InS); + + if Match (Line, Node_Hdr) + and then not Match (Node, Punc) + and then Node /= "Unused" + then + exit when Node = "Empty"; + Prevl := " function Make_" & Node & " (Sloc : Source_Ptr"; + Arg_List := Nul; + + -- Loop through fields of one node + + loop + Line := Get_Line (InS); + exit when Line = ""; + + if Match (Line, Binop) then + WriteBS (Prevl & ';'); + Append (Arg_List, "Left_Opnd,Right_Opnd,"); + WriteBS ( + " " & Rpad ("Left_Opnd", NWidth) & " : Node_Id;"); + Prevl := + " " & Rpad ("Right_Opnd", NWidth) & " : Node_Id"; + + elsif Match (Line, Unop) then + WriteBS (Prevl & ';'); + Append (Arg_List, "Right_Opnd,"); + Prevl := " " & Rpad ("Right_Opnd", NWidth) & " : Node_Id"; + + elsif Match (Line, Syn) then + if Synonym /= "Prev_Ids" + and then Synonym /= "More_Ids" + and then Synonym /= "Comes_From_Source" + and then Synonym /= "Paren_Count" + and then not Match (Field, Sem_Field) + and then not Match (Field, Lib_Field) + then + Match (Field, Get_Field); + + if Field = "Str" then Field := V_String_Id; + elsif Field = "Node" then Field := V_Node_Id; + elsif Field = "Name" then Field := V_Name_Id; + elsif Field = "List" then Field := V_List_Id; + elsif Field = "Elist" then Field := V_Elist_Id; + elsif Field = "Flag" then Field := V_Boolean; + end if; + + if Field = "Boolean" then + Default := V ("False"); + else + Default := Nul; + end if; + + Match (Comment, Get_Dflt); + + WriteBS (Prevl & ';'); + Append (Arg_List, Synonym & ','); + Rpad (Synonym, NWidth); + + if Default = "" then + Prevl := " " & Synonym & " : " & Field; + else + Prevl := + " " & Synonym & " : " & Field & " := " & Default; + end if; + end if; + end if; + end loop; + + WriteBS (Prevl & ')'); + WriteS (" return Node_Id;"); + WriteS (" pragma Inline (Make_" & Node & ");"); + WriteB (" return Node_Id"); + WriteB (" is"); + WriteB (" N : constant Node_Id :="); + + if Match (Node, "Defining_Identifier") or else + Match (Node, "Defining_Character") or else + Match (Node, "Defining_Operator") + then + WriteB (" New_Entity (N_" & Node & ", Sloc);"); + else + WriteB (" New_Node (N_" & Node & ", Sloc);"); + end if; + + WriteB (" begin"); + + while Match (Arg_List, Next_Arg, "") loop + if Length (Arg) < NWidth then + WriteB (" Set_" & Arg & " (N, " & Arg & ");"); + else + WriteB (" Set_" & Arg); + WriteB (" (N, " & Arg & ");"); + end if; + end loop; + + if Match (Node, Op_Node) then + if Node = "Op_Plus" then + WriteB (" Set_Chars (N, Name_Op_Add);"); + + elsif Node = "Op_Minus" then + WriteB (" Set_Chars (N, Name_Op_Subtract);"); + + elsif Match (Op_Name, Shft_Rot) then + WriteB (" Set_Chars (N, Name_" & Op_Name & ");"); + + else + WriteB (" Set_Chars (N, Name_" & Node & ");"); + end if; + + if not Match (Op_Name, No_Ent) then + WriteB (" Set_Entity (N, Standard_" & Node & ");"); + end if; + end if; + + WriteB (" return N;"); + WriteB (" end Make_" & Node & ';'); + WriteBS (""); + end if; + end loop; + + WriteBS ("end Nmake;"); + +exception + + when Err => + Put_Line (Standard_Error, "usage: xnmake [-b] [-s] [filename]"); + Set_Exit_Status (1); + +end XNmake; diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb new file mode 100644 index 00000000000..02af07e75ec --- /dev/null +++ b/gcc/ada/xr_tabls.adb @@ -0,0 +1,1376 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/xr_tabls.ads b/gcc/ada/xr_tabls.ads new file mode 100644 index 00000000000..960b35def8e --- /dev/null +++ b/gcc/ada/xr_tabls.ads @@ -0,0 +1,384 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- X R _ T A B L S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.18 $ +-- -- +-- Copyright (C) 1998-2000 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded; + +package Xr_Tabls is + + ------------------- + -- Project files -- + ------------------- + + function ALI_File_Name (Ada_File_Name : String) return String; + -- Returns the ali file name corresponding to Ada_File_Name, using the + -- information provided in gnat.adc if it exists + + procedure Create_Project_File + (Name : String); + -- Open and parse a new project file + -- If the file Name could not be open or is not a valid project file + -- then a project file associated with the standard default directories + -- is returned + + function Find_ALI_File (Short_Name : String) return String; + -- Returns the directory name for the file Short_Name + -- takes into account the obj_dir lines in the project file, + -- and the default paths for Gnat + + function Find_Source_File (Short_Name : String) return String; + -- Returns the directory name for the file Short_Name + -- takes into account the src_dir lines in the project file, + -- and the default paths for Gnat + + function Next_Src_Dir return String; + -- Returns the next directory to visit to find related source files + -- If there are no more such directory, Length = 0 + + function Next_Obj_Dir return String; + -- Returns the next directory to visit to find related ali files + -- If there are no more such directory, Length = 0 + + function Current_Obj_Dir return String; + -- Returns the obj_dir which was returned by the last Next_Obj_Dir call + + procedure Parse_Gnatls + (Gnatls_Src_Cache : out Ada.Strings.Unbounded.Unbounded_String; + Gnatls_Obj_Cache : out Ada.Strings.Unbounded.Unbounded_String); + -- Parse the output of Gnatls, to find the standard + -- directories for source files + + procedure Reset_Src_Dir; + -- Reset the iterator for Src_Dir + + procedure Reset_Obj_Dir; + -- Reset the iterator for Obj_Dir + + ------------ + -- Tables -- + ------------ + + type Declaration_Reference is private; + Empty_Declaration : constant Declaration_Reference; + + type File_Reference is private; + Empty_File : constant File_Reference; + + type Reference is private; + Empty_Reference : constant Reference; + + type File_Table is limited private; + type Entity_Table is limited private; + + function Add_Declaration + (File_Ref : File_Reference; + Symbol : String; + Line : Natural; + Column : Natural; + Decl_Type : Character) + return Declaration_Reference; + -- Add a new declaration in the table and return the index to it. + -- Decl_Type is the type of the entity + + procedure Add_Parent + (Declaration : in out Declaration_Reference; + Symbol : String; + Line : Natural; + Column : Natural; + File_Ref : File_Reference); + -- The parent declaration (Symbol in file File_Ref at position Line and + -- Column) information is added to Declaration. + + procedure Add_File + (File_Name : String; + File_Existed : out Boolean; + Ref : out File_Reference; + Visited : Boolean := True; + Emit_Warning : Boolean := False; + Gnatchop_File : String := ""; + Gnatchop_Offset : Integer := 0); + -- Add a new reference to a file in the table. Ref is used to return + -- the index in the table where this file is stored On exit, + -- File_Existed is True if the file was already in the table Visited is + -- the value which will be used in the table (if True, the file will + -- not be returned by Next_Unvisited_File). If Emit_Warning is True and + -- the ali file does not exist or does not have cross-referencing + -- informations, then a warning will be emitted. + -- Gnatchop_File is the name of the file that File_Name was extracted from + -- through a call to "gnatchop -r" (with pragma Source_Reference). + -- Gnatchop_Offset should be the index of the first line of File_Name + -- withing Gnatchop_File. + + procedure Add_Line + (File : File_Reference; + Line : Natural; + Column : Natural); + -- Add a new reference in a file, which the user has provided + -- on the command line. This is used for a optimized matching + -- algorithm. + + procedure Add_Reference + (Declaration : Declaration_Reference; + File_Ref : File_Reference; + Line : Natural; + Column : Natural; + Ref_Type : Character); + -- Add a new reference (Ref_Type = 'r'), body (Ref_Type = 'b') or + -- modification (Ref_Type = 'm') to an entity + + type Compare_Result is (LessThan, Equal, GreaterThan); + function Compare (Ref1, Ref2 : Reference) return Compare_Result; + function Compare + (Decl1 : Declaration_Reference; + File2 : File_Reference; + Line2 : Integer; + Col2 : Integer; + Symb2 : String) + return Compare_Result; + -- Compare two references + + function First_Body (Decl : Declaration_Reference) return Reference; + function First_Declaration return Declaration_Reference; + function First_Modif (Decl : Declaration_Reference) return Reference; + function First_Reference (Decl : Declaration_Reference) return Reference; + -- Initialize the iterators + + function Get_Column (Decl : Declaration_Reference) return String; + function Get_Column (Ref : Reference) return String; + + function Get_Declaration + (File_Ref : File_Reference; + Line : Natural; + Column : Natural) + return Declaration_Reference; + -- Returns reference to the declaration found in file File_Ref at the + -- given Line and Column + + function Get_Parent + (Decl : Declaration_Reference) + return Declaration_Reference; + -- Returns reference to Decl's parent declaration + + function Get_Emit_Warning (File : File_Reference) return Boolean; + -- Returns the Emit_Warning field of the structure + + function Get_Gnatchop_File + (File : File_Reference; With_Dir : Boolean := False) return String; + function Get_Gnatchop_File + (Ref : Reference; With_Dir : Boolean := False) return String; + function Get_Gnatchop_File + (Decl : Declaration_Reference; With_Dir : Boolean := False) return String; + -- Return the name of the file that File was extracted from through a + -- call to "gnatchop -r". + -- The file name for File is returned if File wasn't extracted from such a + -- file. The directory will be given only if With_Dir is True. + + + function Get_File + (Decl : Declaration_Reference; + With_Dir : Boolean := False) + return String; + -- Extract column number or file name from reference + + function Get_File + (Ref : Reference; + With_Dir : Boolean := False) + return String; + pragma Inline (Get_File); + + function Get_File + (File : File_Reference; + With_Dir : Boolean := False; + Strip : Natural := 0) + return String; + -- Returns the file name (and its directory if With_Dir is True or + -- the user as used the -f switch on the command line. + -- If Strip is not 0, then the last Strip-th "-..." substrings are + -- removed first. For instance, with Strip=2, a file name + -- "parent-child1-child2-child3.ali" would be returned as + -- "parent-child1.ali". This is used when looking for the ALI file to use + -- for a package, since for separates with have to use the parent's ALI. + -- + -- "" is returned if there is no such parent unit + + function Get_File_Ref (Ref : Reference) return File_Reference; + function Get_Line (Decl : Declaration_Reference) return String; + function Get_Line (Ref : Reference) return String; + function Get_Symbol (Decl : Declaration_Reference) return String; + function Get_Type (Decl : Declaration_Reference) return Character; + -- Functions that return the content of a declaration + + function Get_Source_Line (Ref : Reference) return String; + function Get_Source_Line (Decl : Declaration_Reference) return String; + -- Return the source line associated with the reference + + procedure Grep_Source_Files; + -- Parse all the source files which have at least one reference, and + -- grep the appropriate lines so that we'll be able to display them. + -- This function should be called once all the .ali files have been + -- parsed, and only if the appropriate user switch has been used. + + function Longest_File_Name return Natural; + -- Returns the longest file name found + + function Match (Decl : Declaration_Reference) return Boolean; + -- Return True if the declaration matches + + function Match + (File : File_Reference; + Line : Natural; + Column : Natural) + return Boolean; + -- Returns True if File:Line:Column was given on the command line + -- by the user + + function Next (Decl : Declaration_Reference) return Declaration_Reference; + function Next (Ref : Reference) return Reference; + -- Returns the next declaration, or Empty_Declaration + + function Next_Unvisited_File return File_Reference; + -- Returns the next unvisited library file in the list + -- If there is no more unvisited file, return Empty_File + + procedure Set_Default_Match (Value : Boolean); + -- Set the default value for match in declarations. + -- This is used so that if no file was provided in the + -- command line, then every file match + + procedure Set_Directory + (File : File_Reference; + Dir : String); + -- Set the directory for a file + + procedure Set_Unvisited (File_Ref : in File_Reference); + -- Set File_Ref as unvisited. So Next_Unvisited_File will return it. + + +private + type Project_File (Src_Dir_Length, Obj_Dir_Length : Natural) is record + Src_Dir : String (1 .. Src_Dir_Length); + Src_Dir_Index : Integer; + + Obj_Dir : String (1 .. Obj_Dir_Length); + Obj_Dir_Index : Integer; + Last_Obj_Dir_Start : Natural; + end record; + + type Project_File_Ptr is access all Project_File; + -- This is actually a list of all the directories to be searched, + -- either for source files or for library files + + type String_Access is access all String; + + type Ref_In_File; + type Ref_In_File_Ptr is access all Ref_In_File; + + type Ref_In_File is record + Line : Natural; + Column : Natural; + Next : Ref_In_File_Ptr := null; + end record; + + type File_Record; + type File_Reference is access all File_Record; + + Empty_File : constant File_Reference := null; + + type File_Record (File_Length : Natural) is record + File : String (1 .. File_Length); + Dir : String_Access := null; + Lines : Ref_In_File_Ptr := null; + Visited : Boolean := False; + Emit_Warning : Boolean := False; + Gnatchop_File : String_Access := null; + Gnatchop_Offset : Integer := 0; + Next : File_Reference := null; + end record; + -- Holds a reference to a source file, that was referenced in at least one + -- ALI file. + -- Gnatchop_File will contain the name of the file that File was extracted + -- From. Gnatchop_Offset contains the index of the first line of File + -- within Gnatchop_File. These two fields are used to properly support + -- gnatchop files and pragma Source_Reference. + + + type Reference_Record; + type Reference is access all Reference_Record; + + Empty_Reference : constant Reference := null; + + type Reference_Record is record + File : File_Reference; + Line : Natural; + Column : Natural; + Source_Line : Ada.Strings.Unbounded.Unbounded_String; + Next : Reference := null; + end record; + -- File is a reference to the Ada source file + -- Source_Line is the Line as it appears in the source file. This + -- field is only used when the switch is set on the command line + + type Declaration_Record; + type Declaration_Reference is access all Declaration_Record; + + Empty_Declaration : constant Declaration_Reference := null; + + type Declaration_Record (Symbol_Length : Natural) is record + Symbol : String (1 .. Symbol_Length); + Decl : aliased Reference_Record; + Decl_Type : Character; + Body_Ref : Reference := null; + Ref_Ref : Reference := null; + Modif_Ref : Reference := null; + Match : Boolean := False; + Par_Symbol : Declaration_Reference := null; + Next : Declaration_Reference := null; + end record; + + type File_Table is record + Table : File_Reference := null; + Longest_Name : Natural := 0; + end record; + + type Entity_Table is record + Table : Declaration_Reference := null; + end record; + + pragma Inline (First_Body); + pragma Inline (First_Declaration); + pragma Inline (First_Modif); + pragma Inline (First_Reference); + pragma Inline (Get_Column); + pragma Inline (Get_Emit_Warning); + pragma Inline (Get_File); + pragma Inline (Get_File_Ref); + pragma Inline (Get_Line); + pragma Inline (Get_Symbol); + pragma Inline (Get_Type); + pragma Inline (Longest_File_Name); + pragma Inline (Next); + +end Xr_Tabls; diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb new file mode 100644 index 00000000000..d3dfe37859a --- /dev/null +++ b/gcc/ada/xref_lib.adb @@ -0,0 +1,1676 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/xref_lib.ads b/gcc/ada/xref_lib.ads new file mode 100644 index 00000000000..1282ad142dc --- /dev/null +++ b/gcc/ada/xref_lib.ads @@ -0,0 +1,205 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- X R E F _ L I B -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.20 $ +-- -- +-- Copyright (C) 1998-1999 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Dynamic_Tables; + +with Xr_Tabls; use Xr_Tabls; +with GNAT.Regexp; use GNAT.Regexp; + +-- Misc. utilities for the cross-referencing tool + +package Xref_Lib is + + subtype File_Name_String is String (1 .. Hostparm.Max_Name_Length); + subtype Line_String is String (1 .. Hostparm.Max_Line_Length); + + type ALI_File is limited private; + + --------------------- + -- Directory Input -- + --------------------- + type Rec_DIR is limited private; + -- This one is used for recursive search of .ali files + + procedure Find_ALI_Files; + -- Find all the ali files that we will have to parse, and have them to + -- the file list + + --------------------- + -- Search patterns -- + --------------------- + + type Search_Pattern is private; + type Search_Pattern_Ptr is access all Search_Pattern; + + procedure Add_Entity + (Pattern : in out Search_Pattern; + Entity : String; + Glob : Boolean := False); + -- Add a new entity to the search pattern (the entity should have the + -- form pattern[:file[:line[:column]]], and it is parsed entirely in + -- this procedure. Glob indicates if we should use the 'globbing + -- patterns' (True) or the full regular expressions (False) + + procedure Add_File (File : String); + -- Add a new file in the list of files to search for references. + -- File is considered to be a globbing regular expression, which is thus + -- expanded + + Invalid_Argument : exception; + -- Exception raised when there is a syntax error in the command line + + function Match + (Pattern : Search_Pattern; + Symbol : String) + return Boolean; + -- Returns true if Symbol matches one of the entities in the command line + + ----------------------- + -- Output Algorithms -- + ----------------------- + + procedure Print_Gnatfind + (References : in Boolean; + Full_Path_Name : in Boolean); + procedure Print_Unused (Full_Path_Name : in Boolean); + procedure Print_Vi (Full_Path_Name : in Boolean); + procedure Print_Xref (Full_Path_Name : in Boolean); + -- The actual print procedures. These functions step through the symbol + -- table and print all the symbols if they match the files given on the + -- command line (they already match the entities if they are in the + -- symbol table) + + ------------------------ + -- General Algorithms -- + ------------------------ + function Default_Project_File (Dir_Name : in String) return String; + -- Returns the default Project file name + + procedure Search + (Pattern : Search_Pattern; + Local_Symbols : Boolean; + Wide_Search : Boolean; + Read_Only : Boolean; + Der_Info : Boolean; + Type_Tree : Boolean); + -- Search every ali file (following the Readdir rule above), for + -- each line matching Pattern, and executes Process on these + -- lines. If World is True, Search will look into every .ali file + -- in the object search path. If Read_Only is True, we parse the + -- read-only ali files too. If Der_Mode is true then the derived type + -- information will be processed. If Type_Tree is true then the type + -- hierarchy will be search going from pattern to the parent type + + procedure Search_Xref + (Local_Symbols : Boolean; + Read_Only : Boolean; + Der_Info : Boolean); + -- Search every ali file given in the command line and all their + -- dependencies. If Read_Only is True, we parse the read-only ali + -- files too. If Der_Mode is true then the derived type information will + -- be processed + + --------------- + -- ALI files -- + --------------- + + function Current_Xref_File + (File : ALI_File) + return Xr_Tabls.File_Reference; + -- Returns the name of the file in which the last identifier + -- is declared + + function File_Name + (File : ALI_File; + Num : Positive) + return Xr_Tabls.File_Reference; + -- Returns the dependency file name number Num + + function Get_Full_Type (Abbrev : Character) return String; + -- Returns the full type corresponding to a type letter as found in + -- the .ali files. + + procedure Open + (Name : in String; + File : out ALI_File; + Dependencies : in Boolean := False); + -- Open a new ALI file + -- if Dependencies is True, the insert every library file 'with'ed in + -- the files database (used for gnatxref) + + +private + type Rec_DIR is limited record + Dir : GNAT.Directory_Operations.Dir_Type; + end record; + + package Dependencies_Tables is new GNAT.Dynamic_Tables + (Table_Component_Type => Xr_Tabls.File_Reference, + Table_Index_Type => Positive, + Table_Low_Bound => 1, + Table_Initial => 400, + Table_Increment => 100); + use Dependencies_Tables; + + type Dependencies is new Dependencies_Tables.Instance; + + type ALI_File is limited record + Buffer : String_Access := null; + -- Buffer used to read the whole file at once + + Current_Line : Positive; + -- Start of the current line in Buffer + + Xref_Line : Positive; + -- Start of the xref lines in Buffer + + X_File : Xr_Tabls.File_Reference; + -- Stores the cross-referencing file-name ("X..." lines), as an + -- index into the dependencies table + + Dep : Dependencies; + -- Store file name associated with each number ("D..." lines) + end record; + + -- The following record type stores all the patterns that are searched for + + type Search_Pattern is record + Entity : GNAT.Regexp.Regexp; + -- A regular expression matching the entities we are looking for. + -- File is a list of the places where the declaration of the entities + -- has to be. When the user enters a file:line:column on the command + -- line, it is stored as "Entity_Name Declaration_File:line:column" + + Initialized : Boolean := False; + -- Set to True when Entity has been initialized. + end record; + -- Stores all the pattern that are search for. +end Xref_Lib; diff --git a/gcc/ada/xsinfo.adb b/gcc/ada/xsinfo.adb new file mode 100644 index 00000000000..57d4b3e1580 --- /dev/null +++ b/gcc/ada/xsinfo.adb @@ -0,0 +1,261 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X S I N F O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.19 $ +-- -- +-- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Program to construct C header file a-sinfo.h (C version of sinfo.ads spec, +-- for use by Gigi, contains all definitions and access functions, but does +-- not contain set procedures, since Gigi never modifies the GNAT tree) + +-- Input files: + +-- sinfo.ads Spec of Sinfo package + +-- Output files: + +-- a-sinfo.h Corresponding c header file + +-- Note: this program assumes that sinfo.ads has passed the error checks +-- which are carried out by the CSinfo utility, so it does not duplicate +-- these checks and assumes the soruce is correct. + +-- An optional argument allows the specification of an output file name to +-- override the default a-sinfo.h file name for the generated output file. + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; + +procedure XSinfo is + + Done : exception; + Err : exception; + + A : VString := Nul; + Arg : VString := Nul; + Comment : VString := Nul; + Line : VString := Nul; + N : VString := Nul; + N1, N2 : VString := Nul; + Nam : VString := Nul; + Rtn : VString := Nul; + Sinforev : VString := Nul; + Term : VString := Nul; + XSinforev : VString := Nul; + + InS : File_Type; + Ofile : File_Type; + + wsp : Pattern := Span (' ' & ASCII.HT); + Get_Vsn : Pattern := BreakX ('$') & "$Rev" & "ision: " + & Break (' ') * Sinforev; + Wsp_For : Pattern := wsp & "for"; + Is_Cmnt : Pattern := wsp & "--"; + Typ_Nod : Pattern := wsp * A & "type Node_Kind is"; + Get_Nam : Pattern := wsp * A & "N_" & Break (",)") * Nam + & Len (1) * Term; + Sub_Typ : Pattern := wsp * A & "subtype " & Break (' ') * N; + No_Cont : Pattern := wsp & Break (' ') * N1 & " .. " & Break (';') * N2; + Cont_N1 : Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0); + Cont_N2 : Pattern := Span (' ') & Break (';') * N2; + Is_Func : Pattern := wsp * A & "function " & Rest * Nam; + Get_Arg : Pattern := wsp & "(N : " & Break (')') * Arg + & ") return " & Break (';') * Rtn + & ';' & wsp & "--" & wsp & Rest * Comment; + + NKV : Natural; + + M : Match_Result; + + + procedure Getline; + -- Get non-comment, non-blank line. Also skips "for " rep clauses. + + procedure Getline is + begin + loop + Line := Get_Line (InS); + + if Line /= "" + and then not Match (Line, Wsp_For) + and then not Match (Line, Is_Cmnt) + then + return; + + elsif Match (Line, " -- End functions (note") then + raise Done; + end if; + end loop; + end Getline; + +-- Start of processing for XSinfo + +begin + Set_Exit_Status (1); + Anchored_Mode := True; + Match ("$Revision: 1.19 $", "$Rev" & "ision: " & Break (' ') * XSinforev); + + if Argument_Count > 0 then + Create (Ofile, Out_File, Argument (1)); + else + Create (Ofile, Out_File, "a-sinfo.h"); + end if; + + Open (InS, In_File, "sinfo.ads"); + + -- Get Sinfo rev and write header to output file + + loop + Line := Get_Line (InS); + exit when Line = ""; + + if Match (Line, Get_Vsn) then + Put_Line + (Ofile, "/* Generated by xsinfo revision " + & XSinforev & " using */"); + Put_Line + (Ofile, "/* sinfo.ads revision " + & Sinforev & " */"); + + else + Match + (Line, + "-- S p e c ", + "-- C Header File "); + + Match (Line, "--", "/*"); + Match (Line, Rtab (2) * A & "--", M); + Replace (M, A & "*/"); + Put_Line (Ofile, Line); + end if; + end loop; + + -- Skip to package line + + loop + Getline; + exit when Match (Line, "package"); + end loop; + + -- Skip to first node kind line + + loop + Getline; + exit when Match (Line, Typ_Nod); + Put_Line (Ofile, Line); + end loop; + + Put_Line (Ofile, ""); + NKV := 0; + + -- Loop through node kind codes + + loop + Getline; + + if Match (Line, Get_Nam) then + Put_Line (Ofile, A & "#define N_" & Nam & ' ' & NKV); + NKV := NKV + 1; + exit when not Match (Term, ","); + + else + Put_Line (Ofile, Line); + end if; + end loop; + + Put_Line (Ofile, ""); + Put_Line (Ofile, A & "#define Number_Node_Kinds " & NKV); + + -- Loop through subtype declarations + + loop + Getline; + + if not Match (Line, Sub_Typ) then + exit when Match (Line, " function"); + Put_Line (Ofile, Line); + + else + Put_Line (Ofile, A & "SUBTYPE (" & N & ", Node_Kind, "); + Getline; + + -- Normal case + + if Match (Line, No_Cont) then + Put_Line (Ofile, A & " " & N1 & ", " & N2 & ')'); + + -- Continuation case + + else + if not Match (Line, Cont_N1) then + raise Err; + end if; + + Getline; + + if not Match (Line, Cont_N2) then + raise Err; + end if; + + Put_Line (Ofile, A & " " & N1 & ','); + Put_Line (Ofile, A & " " & N2 & ')'); + end if; + end if; + end loop; + + -- Loop through functions. Note that this loop is terminated by + -- the call to Getfile encountering the end of functions sentinel + + loop + if Match (Line, Is_Func) then + Getline; + if not Match (Line, Get_Arg) then + raise Err; + end if; + Put_Line + (Ofile, + A & "INLINE " & Rpad (Rtn, 9) + & ' ' & Rpad (Nam, 30) & " (" & Arg & " N)"); + + Put_Line (Ofile, A & " { return " & Comment & " (N); }"); + + else + Put_Line (Ofile, Line); + end if; + + Getline; + end loop; + +exception + when Done => + Put_Line (Ofile, ""); + Set_Exit_Status (0); + +end XSinfo; diff --git a/gcc/ada/xtreeprs.adb b/gcc/ada/xtreeprs.adb new file mode 100644 index 00000000000..995401e4984 --- /dev/null +++ b/gcc/ada/xtreeprs.adb @@ -0,0 +1,383 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X T R E E P R S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.33 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Program to construct the spec of the Treeprs package + +-- Input files: + +-- sinfo.ads Spec of Sinfo package +-- treeprs.adt Template for Treeprs package + +-- Output files: + +-- treeprs.ads Spec of Treeprs package + +-- Note: this program assumes that sinfo.ads has passed the error checks which +-- are carried out by the CSinfo utility so it does not duplicate these checks + +-- An optional argument allows the specification of an output file name to +-- override the default treeprs.ads file name for the generated output file. + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; +with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean; +with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString; + +procedure XTreeprs is + + package TB renames GNAT.Spitbol.Table_Boolean; + package TV renames GNAT.Spitbol.Table_VString; + + Err : exception; + -- Raised on fatal error + + A : VString := Nul; + Ffield : VString := Nul; + Field : VString := Nul; + Fieldno : VString := Nul; + Flagno : VString := Nul; + Line : VString := Nul; + Name : VString := Nul; + Node : VString := Nul; + Outstring : VString := Nul; + Prefix : VString := Nul; + S : VString := Nul; + S1 : VString := Nul; + Sinforev : VString := Nul; + Syn : VString := Nul; + Synonym : VString := Nul; + Temprev : VString := Nul; + Term : VString := Nul; + Treeprsrev : VString := Nul; + + OutS : File_Type; + -- Output file + + InS : File_Type; + -- Read sinfo.ads + + InT : File_Type; + -- Read treeprs.adt + + Special : TB.Table (20); + -- Table of special fields. These fields are not included in the table + -- constructed by Xtreeprs, since they are specially handled in treeprs. + -- This means these field definitions are completely ignored. + + Names : array (1 .. 500) of VString; + -- Table of names of synonyms + + Positions : array (1 .. 500) of Natural; + -- Table of starting positions in Pchars string for synonyms + + Strings : TV.Table (300); + -- Contribution of each synonym to Pchars string, indexed by name + + Count : Natural := 0; + -- Number of synonyms processed so far + + Curpos : Natural := 1; + -- Number of characters generated in Pchars string so far + + Lineno : Natural := 0; + -- Line number in sinfo.ads + + Field_Base : constant := Character'Pos ('#'); + -- Fields 1-5 are represented by the characters #$%&' (i.e. by five + -- contiguous characters starting at # (16#23#)). + + Flag_Base : constant := Character'Pos ('('); + -- Flags 1-18 are represented by the characters ()*+,-./0123456789 + -- (i.e. by 18 contiguous characters starting at (16#28#)). + + Fieldch : Character; + -- Field character, as per above tables + + Sp : aliased Natural; + -- Space left on line for Pchars output + + wsp : Pattern := Span (' ' & ASCII.HT); + + Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: " + & Break (' ') * Sinforev; + Get_TRev : Pattern := BreakX ('$') & "$Rev" & "ision: " + & Break (' ') * Temprev; + Is_Temp : Pattern := BreakX ('T') * A & "T e m p l a t e"; + Get_Node : Pattern := wsp & "-- N_" & Rest * Node; + Tst_Punc : Pattern := Break (" ,."); + Get_Syn : Pattern := Span (' ') & "-- " & Break (' ') * Synonym + & " (" & Break (')') * Field; + Brk_Min : Pattern := Break ('-') * Ffield; + Is_Flag : Pattern := "Flag" & Rest * Flagno; + Is_Field : Pattern := Rtab (1) & Len (1) * Fieldno; + Is_Syn : Pattern := wsp & "N_" & Break (",)") * Syn & Len (1) * Term; + Brk_Node : Pattern := Break (' ') * Node & ' '; + Chop_SP : Pattern := Len (Sp'Unrestricted_Access) * S1; + + M : Match_Result; + +begin + Anchored_Mode := True; + + Match ("$Revision: 1.33 $", "$Rev" & "ision: " & Break (' ') * Treeprsrev); + + if Argument_Count > 0 then + Create (OutS, Out_File, Argument (1)); + else + Create (OutS, Out_File, "treeprs.ads"); + end if; + + Open (InS, In_File, "sinfo.ads"); + Open (InT, In_File, "treeprs.adt"); + + -- Initialize special fields table + + Set (Special, "Analyzed", True); + Set (Special, "Cannot_Be_Constant", True); + Set (Special, "Chars", True); + Set (Special, "Comes_From_Source", True); + Set (Special, "Error_Posted", True); + Set (Special, "Etype", True); + Set (Special, "Has_No_Side_Effects", True); + Set (Special, "Is_Controlling_Actual", True); + Set (Special, "Is_Overloaded", True); + Set (Special, "Is_Static_Expression", True); + Set (Special, "Left_Opnd", True); + Set (Special, "Must_Check_Expr", True); + Set (Special, "No_Overflow_Expr", True); + Set (Special, "Paren_Count", True); + Set (Special, "Raises_Constraint_Error", True); + Set (Special, "Right_Opnd", True); + + -- Get sinfo revs and write header to output file + + loop + Line := Get_Line (InS); + Lineno := Lineno + 1; + + if Line = "" then + raise Err; + end if; + + exit when Match (Line, Get_SRev); + end loop; + + -- Read template header and generate new header + + loop + Line := Get_Line (InT); + + if Match (Line, Get_TRev) then + Put_Line + (OutS, + "-- Generated by xtreeprs revision " & + Treeprsrev & " using --"); + + Put_Line + (OutS, + "-- sinfo.ads revision " & + Sinforev & " --"); + + Put_Line + (OutS, + "-- treeprs.adt revision " + & Temprev & " --"); + + else + -- Skip lines describing the template + + if Match (Line, "-- This file is a template") then + loop + Line := Get_Line (InT); + exit when Line = ""; + end loop; + end if; + + exit when Match (Line, "package"); + + if Match (Line, Is_Temp, M) then + Replace (M, A & " S p e c "); + end if; + + Put_Line (OutS, Line); + end if; + end loop; + + Put_Line (OutS, Line); + + -- Copy rest of comments up to template insert point to spec + + loop + Line := Get_Line (InT); + exit when Match (Line, "!!TEMPLATE INSERTION POINT"); + Put_Line (OutS, Line); + end loop; + + -- Here we are doing the actual insertions + + Put_Line (OutS, " Pchars : constant String :="); + + -- Loop through comments describing nodes, picking up fields + + loop + Line := Get_Line (InS); + Lineno := Lineno + 1; + exit when Match (Line, " type Node_Kind"); + + if Match (Line, Get_Node) + and then not Match (Node, Tst_Punc) + then + Outstring := Node & ' '; + + loop + Line := Get_Line (InS); + exit when Line = ""; + + if Match (Line, Get_Syn) + and then not Match (Synonym, "plus") + and then not Present (Special, Synonym) + then + -- Convert this field into the character used to + -- represent the field according to the table: + + -- Field1 '#' + -- Field2 '$' + -- Field3 '%' + -- Field4 '&' + -- Field5 "'" + -- Flag1 "(" + -- Flag2 ")" + -- Flag3 '*' + -- Flag4 '+' + -- Flag5 ',' + -- Flag6 '-' + -- Flag7 '.' + -- Flag8 '/' + -- Flag9 '0' + -- Flag10 '1' + -- Flag11 '2' + -- Flag12 '3' + -- Flag13 '4' + -- Flag14 '5' + -- Flag15 '6' + -- Flag16 '7' + -- Flag17 '8' + -- Flag18 '9' + + if Match (Field, Brk_Min) then + Field := Ffield; + end if; + + if Match (Field, Is_Flag) then + Fieldch := Char (Flag_Base - 1 + N (Flagno)); + + elsif Match (Field, Is_Field) then + Fieldch := Char (Field_Base - 1 + N (Fieldno)); + + else + Put_Line + (Standard_Error, + "*** Line " & + Lineno & + " has unrecognized field name " & + Field); + raise Err; + end if; + + Append (Outstring, Fieldch & Synonym); + end if; + end loop; + + Set (Strings, Node, Outstring); + end if; + end loop; + + -- Loop through actual definitions of node kind enumeration literals + + loop + loop + Line := Get_Line (InS); + Lineno := Lineno + 1; + exit when Match (Line, Is_Syn); + end loop; + + S := Get (Strings, Syn); + Match (S, Brk_Node, ""); + Count := Count + 1; + Names (Count) := Syn; + Positions (Count) := Curpos; + Curpos := Curpos + Length (S); + Put_Line (OutS, " -- " & Node); + Prefix := V (" "); + exit when Term = ")"; + + -- Loop to output the string literal for Pchars + + loop + Sp := 79 - 4 - Length (Prefix); + exit when (Size (S) <= Sp); + Match (S, Chop_SP, ""); + Put_Line (OutS, Prefix & '"' & S1 & """ &"); + Prefix := V (" "); + end loop; + + Put_Line (OutS, Prefix & '"' & S & """ &"); + end loop; + + Put_Line (OutS, " """";"); + Put_Line (OutS, ""); + Put_Line + (OutS, " type Pchar_Pos_Array is array (Node_Kind) of Positive;"); + Put_Line + (OutS, + " Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'("); + + -- Output lines for Pchar_Pos_Array values + + for M in 1 .. Count - 1 loop + Name := Rpad ("N_" & Names (M), 40); + Put_Line (OutS, " " & Name & " => " & Positions (M) & ','); + end loop; + + Name := Rpad ("N_" & Names (Count), 40); + Put_Line (OutS, " " & Name & " => " & Positions (Count) & ");"); + + Put_Line (OutS, ""); + Put_Line (OutS, "end Treeprs;"); + +exception + when Err => + Put_Line (Standard_Error, "*** fatal error"); + Set_Exit_Status (1); + +end XTreeprs; |