Skip to content

R
riscv-gcc-1
Commit 415dddc8 by Richard Kenner
Options

New Language: Ada 

From-SVN: r45960
parent 996ae0b0
Showing with 2676 additions and 0 deletions
gcc/ada/targparm.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/targtyps.c 0 → 100644
/****************************************************************************
* *
* 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;
}
gcc/ada/text_io.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/trans.c 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/tree_gen.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/tree_gen.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/tree_in.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/tree_in.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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.
gcc/ada/tree_io.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/treepr.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/treeprs.adt 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/types.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/types.h 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/uintp.h 0 → 100644
/****************************************************************************
* *
* 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)
gcc/ada/uname.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/unchconv.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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);
gcc/ada/unchdeal.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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);
gcc/ada/urealp.h 0 → 100644
/****************************************************************************
* *
* 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));
gcc/ada/usage.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/utils.c 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/validsw.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/validsw.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/widechar.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/widechar.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/xref_lib.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/xsinfo.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment