Skip to content

R
riscv-gcc-1
Commit 38cbfe40 by Richard Kenner
Options

New Language: Ada 

From-SVN: r45955
parent 70482933
Showing with 4998 additions and 0 deletions
gcc/ada/g-busora.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . B U B B L E _ S O R T _ A --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $ --
-- --
-- Copyright (C) 1995-1998 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Bubble_Sort_A is
----------
-- Sort --
----------
procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function) is
Switched : Boolean;
begin
loop
Switched := False;
for J in 1 .. N - 1 loop
if Lt (J + 1, J) then
Move (J, 0);
Move (J + 1, J);
Move (0, J + 1);
Switched := True;
end if;
end loop;
exit when not Switched;
end loop;
end Sort;
end GNAT.Bubble_Sort_A;
gcc/ada/g-busora.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . B U B B L E _ S O R T _ A --
-- --
-- S p e c --
-- --
-- $Revision: 1.8 $
-- --
-- Copyright (C) 1995-2000 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Bubblesort using access to procedure parameters
-- This package provides a bubblesort routine that works with access to
-- subprogram parameters, so that it can be used with different types with
-- shared sorting code. See also GNAT.Bubble_Sort_G, the generic version
-- which is a little more efficient, but does not allow code sharing.
-- The generic version is also Pure, while the access version can
-- only be Preelaborate.
package GNAT.Bubble_Sort_A is
pragma Preelaborate (Bubble_Sort_A);
-- The data to be sorted is assumed to be indexed by integer values from
-- 1 to N, where N is the number of items to be sorted. In addition, the
-- index value zero is used for a temporary location used during the sort.
type Move_Procedure is access procedure (From : Natural; To : Natural);
-- A pointer to a procedure that moves the data item with index From to
-- the data item with index To. An index value of zero is used for moves
-- from and to the single temporary location used by the sort.
type Lt_Function is access function (Op1, Op2 : Natural) return Boolean;
-- A pointer to a function that compares two items and returns True if
-- the item with index Op1 is less than the item with index Op2, and False
-- if the Op2 item is greater than or equal to the Op1 item.
procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function);
-- This procedures sorts items in the range from 1 to N into ascending
-- order making calls to Lt to do required comparisons, and Move to move
-- items around. Note that, as described above, both Move and Lt use a
-- single temporary location with index value zero. This sort is not
-- stable, i.e. the order of equal elements in the input is not preserved.
end GNAT.Bubble_Sort_A;
gcc/ada/g-busorg.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . B U B B L E _ S O R T _ G --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 1995-1998 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Bubble_Sort_G is
----------
-- Sort --
----------
procedure Sort (N : Natural) is
Switched : Boolean;
begin
loop
Switched := False;
for J in 1 .. N - 1 loop
if Lt (J + 1, J) then
Move (J, 0);
Move (J + 1, J);
Move (0, J + 1);
Switched := True;
end if;
end loop;
exit when not Switched;
end loop;
end Sort;
end GNAT.Bubble_Sort_G;
gcc/ada/g-busorg.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . B U B B L E _ S O R T _ G --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $
-- --
-- Copyright (C) 1995-2000 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Bubblesort generic package using formal procedures
-- This package provides a generic bubble sort routine that can be used with
-- different types of data. See also GNAT.Bubble_Sort_A, a version that works
-- with subprogram parameters, allowing code sharing. The generic version
-- is slightly more efficient but does not allow code sharing. The generic
-- version is also Pure, while the access version can only be Preelaborate.
generic
-- The data to be sorted is assumed to be indexed by integer values from
-- 1 to N, where N is the number of items to be sorted. In addition, the
-- index value zero is used for a temporary location used during the sort.
with procedure Move (From : Natural; To : Natural);
-- A procedure that moves the data item with index From to the data item
-- with Index To. An index value of zero is used for moves from and to a
-- single temporary location used by the sort.
with function Lt (Op1, Op2 : Natural) return Boolean;
-- A function that compares two items and returns True if the item with
-- index Op1 is less than the item with Index Op2, and False if the Op2
-- item is greater than or equal to the Op1 item.
package GNAT.Bubble_Sort_G is
pragma Pure (Bubble_Sort_G);
procedure Sort (N : Natural);
-- This procedures sorts items in the range from 1 to N into ascending
-- order making calls to Lt to do required comparisons, and Move to move
-- items around. Note that, as described above, both Move and Lt use a
-- single temporary location with index value zero. This sort is not
-- stable, i.e. the order of equal elements in the input is not preserved.
end GNAT.Bubble_Sort_G;
gcc/ada/g-calend.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . C A L E N D A R --
-- --
-- B o d y --
-- --
-- $Revision: 1.8 $
-- --
-- Copyright (C) 1999-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 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 GNAT.Calendar is
use Ada.Calendar;
use Interfaces;
-----------------
-- Day_In_Year --
-----------------
function Day_In_Year (Date : Time) return Day_In_Year_Number is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Dsecs : Day_Duration;
begin
Split (Date, Year, Month, Day, Dsecs);
return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1;
end Day_In_Year;
-----------------
-- Day_Of_Week --
-----------------
function Day_Of_Week (Date : Time) return Day_Name is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Dsecs : Day_Duration;
begin
Split (Date, Year, Month, Day, Dsecs);
return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7);
end Day_Of_Week;
----------
-- Hour --
----------
function Hour (Date : Time) return Hour_Number is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Hour;
end Hour;
----------------
-- Julian_Day --
----------------
-- Julian_Day is used to by Day_Of_Week and Day_In_Year. Note
-- that this implementation is not expensive.
function Julian_Day
(Year : Year_Number;
Month : Month_Number;
Day : Day_Number)
return Integer
is
Internal_Year : Integer;
Internal_Month : Integer;
Internal_Day : Integer;
Julian_Date : Integer;
C : Integer;
Ya : Integer;
begin
Internal_Year := Integer (Year);
Internal_Month := Integer (Month);
Internal_Day := Integer (Day);
if Internal_Month > 2 then
Internal_Month := Internal_Month - 3;
else
Internal_Month := Internal_Month + 9;
Internal_Year := Internal_Year - 1;
end if;
C := Internal_Year / 100;
Ya := Internal_Year - (100 * C);
Julian_Date := (146_097 * C) / 4 +
(1_461 * Ya) / 4 +
(153 * Internal_Month + 2) / 5 +
Internal_Day + 1_721_119;
return Julian_Date;
end Julian_Day;
------------
-- Minute --
------------
function Minute (Date : Time) return Minute_Number is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Minute;
end Minute;
------------
-- Second --
------------
function Second (Date : Time) return Second_Number is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Second;
end Second;
-----------
-- Split --
-----------
procedure Split
(Date : Time;
Year : out Year_Number;
Month : out Month_Number;
Day : out Day_Number;
Hour : out Hour_Number;
Minute : out Minute_Number;
Second : out Second_Number;
Sub_Second : out Second_Duration)
is
Dsecs : Day_Duration;
Secs : Natural;
begin
Split (Date, Year, Month, Day, Dsecs);
if Dsecs = 0.0 then
Secs := 0;
else
Secs := Natural (Dsecs - 0.5);
end if;
Sub_Second := Second_Duration (Dsecs - Day_Duration (Secs));
Hour := Hour_Number (Secs / 3600);
Secs := Secs mod 3600;
Minute := Minute_Number (Secs / 60);
Second := Second_Number (Secs mod 60);
end Split;
----------------
-- Sub_Second --
----------------
function Sub_Second (Date : Time) return Second_Duration is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Sub_Second;
end Sub_Second;
-------------
-- Time_Of --
-------------
function Time_Of
(Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration := 0.0)
return Time
is
Dsecs : constant Day_Duration :=
Day_Duration (Hour * 3600 + Minute * 60 + Second) +
Sub_Second;
begin
return Time_Of (Year, Month, Day, Dsecs);
end Time_Of;
-----------------
-- To_Duration --
-----------------
function To_Duration (T : access timeval) return Duration is
procedure timeval_to_duration
(T : access timeval;
sec : access C.long;
usec : access C.long);
pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
Micro : constant := 10**6;
sec : aliased C.long;
usec : aliased C.long;
begin
timeval_to_duration (T, sec'Access, usec'Access);
return Duration (sec) + Duration (usec) / Micro;
end To_Duration;
----------------
-- To_Timeval --
----------------
function To_Timeval (D : Duration) return timeval is
procedure duration_to_timeval (Sec, Usec : C.long; T : access timeval);
pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval");
Micro : constant := 10**6;
Result : aliased timeval;
sec : C.long;
usec : C.long;
begin
if D = 0.0 then
sec := 0;
usec := 0;
else
sec := C.long (D - 0.5);
usec := C.long ((D - Duration (sec)) * Micro - 0.5);
end if;
duration_to_timeval (sec, usec, Result'Access);
return Result;
end To_Timeval;
------------------
-- Week_In_Year --
------------------
function Week_In_Year
(Date : Ada.Calendar.Time)
return Week_In_Year_Number
is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
Offset : Natural;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
-- Day offset number for the first week of the year.
Offset := Julian_Day (Year, 1, 1) mod 7;
return 1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
end Week_In_Year;
end GNAT.Calendar;
gcc/ada/g-calend.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . C A L E N D A R --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- 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. --
-- --
-- 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 extends Ada.Calendar to handle Hour, Minute, Second,
-- Second_Duration and Day_Of_Week and Day_In_Year from Calendar.Time.
-- Second_Duration precision depends on the target clock precision.
--
-- GNAT.Calendar provides the same kind of abstraction found in
-- Ada.Calendar. It provides Split and Time_Of to build and split a Time
-- data. And it provides accessor functions to get only one of Hour, Minute,
-- Second, Second_Duration. Other functions are to access more advanced
-- valueas like Day_Of_Week, Day_In_Year and Week_In_Year.
with Ada.Calendar;
with Interfaces.C;
package GNAT.Calendar is
type Day_Name is
(Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday);
subtype Hour_Number is Natural range 0 .. 23;
subtype Minute_Number is Natural range 0 .. 59;
subtype Second_Number is Natural range 0 .. 59;
subtype Second_Duration is Ada.Calendar.Day_Duration range 0.0 .. 1.0;
subtype Day_In_Year_Number is Positive range 1 .. 366;
subtype Week_In_Year_Number is Positive range 1 .. 53;
function Hour (Date : Ada.Calendar.Time) return Hour_Number;
function Minute (Date : Ada.Calendar.Time) return Minute_Number;
function Second (Date : Ada.Calendar.Time) return Second_Number;
function Sub_Second (Date : Ada.Calendar.Time) return Second_Duration;
-- Hour, Minute, Sedond and Sub_Second returns the complete time data for
-- the Date (H:M:S.SS). See Ada.Calendar for Year, Month, Day accessors.
-- Second_Duration precision depends on the target clock precision.
function Day_Of_Week (Date : Ada.Calendar.Time) return Day_Name;
-- Return the day name.
function Day_In_Year (Date : Ada.Calendar.Time) return Day_In_Year_Number;
-- Returns the day number in the year. (1st January is day 1 and 31st
-- December is day 365 or 366 for leap year).
function Week_In_Year (Date : Ada.Calendar.Time) return Week_In_Year_Number;
-- Returns the week number in the year with Monday as first day of week
procedure Split
(Date : Ada.Calendar.Time;
Year : out Ada.Calendar.Year_Number;
Month : out Ada.Calendar.Month_Number;
Day : out Ada.Calendar.Day_Number;
Hour : out Hour_Number;
Minute : out Minute_Number;
Second : out Second_Number;
Sub_Second : out Second_Duration);
-- Split the standard Ada.Calendar.Time data in date data (Year, Month,
-- Day) and Time data (Hour, Minute, Second, Sub_Second)
function Time_Of
(Year : Ada.Calendar.Year_Number;
Month : Ada.Calendar.Month_Number;
Day : Ada.Calendar.Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration := 0.0)
return Ada.Calendar.Time;
-- Returns an Ada.Calendar.Time data built from the date and time values.
-- C timeval conversion
-- C timeval represent a duration (used in Select for example). This
-- structure is composed of a number of seconds and a number of micro
-- seconds. The timeval structure is not exposed here because its
-- definition is target dependent. Interface to C programs is done via a
-- pointer to timeval structure.
type timeval is private;
function To_Duration (T : access timeval) return Duration;
function To_Timeval (D : Duration) return timeval;
private
-- This is a dummy declaration that should be the largest possible timeval
-- structure of all supported targets.
type timeval is array (1 .. 2) of Interfaces.C.long;
function Julian_Day
(Year : Ada.Calendar.Year_Number;
Month : Ada.Calendar.Month_Number;
Day : Ada.Calendar.Day_Number)
return Integer;
-- Compute Julian day number.
--
-- The code of this function is a modified version of algorithm
-- 199 from the Collected Algorithms of the ACM.
-- The author of algorithm 199 is Robert G. Tantzen.
end GNAT.Calendar;
gcc/ada/g-casuti.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . C A S E _ U T I L --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 1995-1999 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Case_Util is
--------------
-- To_Lower --
--------------
function To_Lower (A : Character) return Character is
A_Val : constant Natural := Character'Pos (A);
begin
if A in 'A' .. 'Z'
or else A_Val in 16#C0# .. 16#D6#
or else A_Val in 16#D8# .. 16#DE#
then
return Character'Val (A_Val + 16#20#);
else
return A;
end if;
end To_Lower;
procedure To_Lower (A : in out String) is
begin
for J in A'Range loop
A (J) := To_Lower (A (J));
end loop;
end To_Lower;
--------------
-- To_Mixed --
--------------
procedure To_Mixed (A : in out String) is
Ucase : Boolean := True;
begin
for J in A'Range loop
if Ucase then
A (J) := To_Upper (A (J));
else
A (J) := To_Lower (A (J));
end if;
Ucase := A (J) = '_';
end loop;
end To_Mixed;
--------------
-- To_Upper --
--------------
function To_Upper (A : Character) return Character is
A_Val : constant Natural := Character'Pos (A);
begin
if A in 'a' .. 'z'
or else A_Val in 16#E0# .. 16#F6#
or else A_Val in 16#F8# .. 16#FE#
then
return Character'Val (A_Val - 16#20#);
else
return A;
end if;
end To_Upper;
procedure To_Upper (A : in out String) is
begin
for J in A'Range loop
A (J) := To_Upper (A (J));
end loop;
end To_Upper;
end GNAT.Case_Util;
gcc/ada/g-casuti.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . C A S E _ U T I L --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1995-1998 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Simple casing functions
-- This package provides simple casing functions that do not require the
-- overhead of the full casing tables found in Ada.Characters.Handling.
package GNAT.Case_Util is
pragma Pure (Case_Util);
-- Note: all the following functions handle the full Latin-1 set
function To_Upper (A : Character) return Character;
-- Converts A to upper case if it is a lower case letter, otherwise
-- returns the input argument unchanged.
procedure To_Upper (A : in out String);
-- Folds all characters of string A to upper csae
function To_Lower (A : Character) return Character;
-- Converts A to lower case if it is an upper case letter, otherwise
-- returns the input argument unchanged.
procedure To_Lower (A : in out String);
-- Folds all characters of string A to lower case
procedure To_Mixed (A : in out String);
-- Converts A to mixed case (i.e. lower case, except for initial
-- character and any character after an underscore, which are
-- converted to upper case.
end GNAT.Case_Util;
gcc/ada/g-catiio.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . C A L E N D A R . T I M E _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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 augments standard Ada.Text_IO with facilities for input
-- and output of time values in standardized format.
package GNAT.Calendar.Time_IO is
Picture_Error : exception;
type Picture_String is new String;
-- This is a string to describe date and time output format. The string is
-- a set of standard character and special tag that are replaced by the
-- corresponding values. It follows the GNU Date specification. Here are
-- the recognized directives :
--
-- % a literal %
-- n a newline
-- t a horizontal tab
--
-- Time fields:
--
-- %H hour (00..23)
-- %I hour (01..12)
-- %k hour ( 0..23)
-- %l hour ( 1..12)
-- %M minute (00..59)
-- %p locale's AM or PM
-- %r time, 12-hour (hh:mm:ss [AP]M)
-- %s seconds since 1970-01-01 00:00:00 UTC
-- (a nonstandard extension)
-- %S second (00..59)
-- %T time, 24-hour (hh:mm:ss)
--
-- Date fields:
--
-- %a locale's abbreviated weekday name (Sun..Sat)
-- %A locale's full weekday name, variable length
-- (Sunday..Saturday)
-- %b locale's abbreviated month name (Jan..Dec)
-- %B locale's full month name, variable length
-- (January..December)
-- %c locale's date and time (Sat Nov 04 12:02:33 EST 1989)
-- %d day of month (01..31)
-- %D date (mm/dd/yy)
-- %h same as %b
-- %j day of year (001..366)
-- %m month (01..12)
-- %U week number of year with Sunday as first day of week
-- (00..53)
-- %w day of week (0..6) with 0 corresponding to Sunday
-- %W week number of year with Monday as first day of week
-- (00..53)
-- %x locale's date representation (mm/dd/yy)
-- %y last two digits of year (00..99)
-- %Y year (1970...)
--
-- By default, date pads numeric fields with zeroes. GNU date
-- recognizes the following nonstandard numeric modifiers:
--
-- - (hyphen) do not pad the field
-- _ (underscore) pad the field with spaces
ISO_Date : constant Picture_String;
-- This format follow the ISO 8601 standard. The format is "YYYY-MM-DD",
-- four digits year, month and day number separated by minus.
US_Date : constant Picture_String;
-- This format is the common US date format: "MM/DD/YY",
-- month and day number, two digits year separated by slashes.
European_Date : constant Picture_String;
-- This format is the common European date format: "DD/MM/YY",
-- day and month number, two digits year separated by slashes.
function Image
(Date : Ada.Calendar.Time;
Picture : Picture_String)
return String;
-- Return Date as a string with format Picture.
-- raise Picture_Error if picture string is wrong
procedure Put_Time
(Date : Ada.Calendar.Time;
Picture : Picture_String);
-- Put Date with format Picture.
-- raise Picture_Error if picture string is wrong
private
ISO_Date : constant Picture_String := "%Y-%m-%d";
US_Date : constant Picture_String := "%m/%d/%y";
European_Date : constant Picture_String := "%d/%m/%y";
end GNAT.Calendar.Time_IO;
gcc/ada/g-cgicoo.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C G I . C O O K I E --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $
-- --
-- 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This is a package to interface a GNAT program with a Web server via the
-- Common Gateway Interface (CGI). It exports services to deal with Web
-- cookies (piece of information kept in the Web client software).
-- The complete CGI Cookie specification can be found in the RFC2109 at:
-- http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt
-- This package builds up data tables whose memory is not released.
-- A CGI program is expected to be a short lived program and so it
-- is adequate to have the underlying OS free the program on exit.
package GNAT.CGI.Cookie is
-- The package will initialize itself by parsing the HTTP_Cookie runtime
-- CGI environment variable during elaboration but we do not want to raise
-- an exception at this time, so the exception Data_Error is deferred and
-- will be raised when calling any services below (except for Ok).
Cookie_Not_Found : exception;
-- This exception is raised when a specific parameter is not found.
procedure Put_Header
(Header : String := Default_Header;
Force : Boolean := False);
-- Output standard CGI header by default. This header must be returned
-- back to the server at the very beginning and will be output only for
-- the first call to Put_Header if Force is set to False. This procedure
-- also outputs the Cookies that have been defined. If the program uses
-- the GNAT.CGI.Put_Header service, cookies will not be set.
--
-- Cookies are passed back to the server in the header, the format is:
--
-- Set-Cookie: <key>=<value>; comment=<comment>; domain=<domain>;
-- max_age=<max_age>; path=<path>[; secured]
function Ok return Boolean;
-- Returns True if the CGI cookie environment is valid and False
-- otherwise. Every service used when the CGI environment is not valid
-- will raise the exception Data_Error.
function Count return Natural;
-- Returns the number of cookies received by the CGI.
function Value
(Key : String;
Required : Boolean := False)
return String;
-- Returns the cookie value associated with the cookie named Key. If
-- cookie does not exist, returns an empty string if Required is
-- False and raises the exception Cookie_Not_Found otherwise.
function Value (Position : Positive) return String;
-- Returns the value associated with the cookie number Position
-- of the CGI. It raises Cookie_Not_Found if there is no such
-- cookie (i.e. Position > Count)
function Exists (Key : String) return Boolean;
-- Returns True if the cookie named Key exist and False otherwise.
function Key (Position : Positive) return String;
-- Returns the key associated with the cookie number Position of
-- the CGI. It raises Cookie_Not_Found if there is no such cookie
-- (i.e. Position > Count)
procedure Set
(Key : String;
Value : String;
Comment : String := "";
Domain : String := "";
Max_Age : Natural := Natural'Last;
Path : String := "/";
Secure : Boolean := False);
-- Add a cookie to the list of cookies. This will be sent back
-- to the server by the Put_Header service above.
generic
with procedure
Action
(Key : String;
Value : String;
Position : Positive;
Quit : in out Boolean);
procedure For_Every_Cookie;
-- Iterate through all cookies received from the server and call
-- the Action supplied procedure. The Key, Value parameters are set
-- appropriately, Position is the cookie order in the list, Quit is set to
-- True by default. Quit can be set to False to control the iterator
-- termination.
end GNAT.CGI.Cookie;
gcc/ada/g-cgideb.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C G I . D E B U G --
-- --
-- B o d y --
-- --
-- $Revision: 1.3 $
-- --
-- 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Strings.Unbounded;
package body GNAT.CGI.Debug is
use Ada.Strings.Unbounded;
--
-- Define the abstract type which act as a template for all debug IO mode.
-- To create a new IO mode you must:
-- 1. create a new package spec
-- 2. create a new type derived from IO.Format
-- 3. implement all the abstract rountines in IO
--
package IO is
type Format is abstract tagged null record;
function Output (Mode : in Format'Class) return String;
function Variable
(Mode : Format;
Name : String;
Value : String)
return String
is abstract;
-- Returns variable Name and its associated value.
function New_Line
(Mode : Format)
return String
is abstract;
-- Returns a new line such as this concatenated between two strings
-- will display the strings on two lines.
function Title
(Mode : Format;
Str : String)
return String
is abstract;
-- Returns Str as a Title. A title must be alone and centered on a
-- line. Next output will be on the following line.
function Header
(Mode : Format;
Str : String)
return String
is abstract;
-- Returns Str as an Header. An header must be alone on its line. Next
-- output will be on the following line.
end IO;
--
-- IO for HTML mode
--
package HTML_IO is
-- see IO for comments about these routines.
type Format is new IO.Format with null record;
function Variable
(IO : Format;
Name : String;
Value : String)
return String;
function New_Line (IO : in Format) return String;
function Title (IO : in Format; Str : in String) return String;
function Header (IO : in Format; Str : in String) return String;
end HTML_IO;
--
-- IO for plain text mode
--
package Text_IO is
-- See IO for comments about these routines
type Format is new IO.Format with null record;
function Variable
(IO : Format;
Name : String;
Value : String)
return String;
function New_Line (IO : in Format) return String;
function Title (IO : in Format; Str : in String) return String;
function Header (IO : in Format; Str : in String) return String;
end Text_IO;
--------------
-- Debug_IO --
--------------
package body IO is
------------
-- Output --
------------
function Output (Mode : in Format'Class) return String is
Result : Unbounded_String;
begin
Result := Result
& Title (Mode, "CGI complete runtime environment");
Result := Result
& Header (Mode, "CGI parameters:")
& New_Line (Mode);
for K in 1 .. Argument_Count loop
Result := Result
& Variable (Mode, Key (K), Value (K))
& New_Line (Mode);
end loop;
Result := Result
& New_Line (Mode)
& Header (Mode, "CGI environment variables (Metavariables):")
& New_Line (Mode);
for P in Metavariable_Name'Range loop
if Metavariable_Exists (P) then
Result := Result
& Variable (Mode,
Metavariable_Name'Image (P),
Metavariable (P))
& New_Line (Mode);
end if;
end loop;
return To_String (Result);
end Output;
end IO;
-------------
-- HTML_IO --
-------------
package body HTML_IO is
NL : constant String := (1 => ASCII.LF);
function Bold (S : in String) return String;
-- Returns S as an HTML bold string.
function Italic (S : in String) return String;
-- Returns S as an HTML italic string.
----------
-- Bold --
----------
function Bold (S : in String) return String is
begin
return "<b>" & S & "</b>";
end Bold;
------------
-- Header --
------------
function Header (IO : in Format; Str : in String) return String is
begin
return "<h2>" & Str & "</h2>" & NL;
end Header;
------------
-- Italic --
------------
function Italic (S : in String) return String is
begin
return "<i>" & S & "</i>";
end Italic;
--------------
-- New_Line --
--------------
function New_Line (IO : in Format) return String is
begin
return "<br>" & NL;
end New_Line;
-----------
-- Title --
-----------
function Title (IO : in Format; Str : in String) return String is
begin
return "<p align=center><font size=+2>" & Str & "</font></p>" & NL;
end Title;
--------------
-- Variable --
--------------
function Variable
(IO : Format;
Name : String;
Value : String)
return String
is
begin
return Bold (Name) & " = " & Italic (Value);
end Variable;
end HTML_IO;
-------------
-- Text_IO --
-------------
package body Text_IO is
------------
-- Header --
------------
function Header (IO : in Format; Str : in String) return String is
begin
return "*** " & Str & New_Line (IO);
end Header;
--------------
-- New_Line --
--------------
function New_Line (IO : in Format) return String is
begin
return String'(1 => ASCII.LF);
end New_Line;
-----------
-- Title --
-----------
function Title (IO : in Format; Str : in String) return String is
Spaces : constant Natural := (80 - Str'Length) / 2;
Indent : constant String (1 .. Spaces) := (others => ' ');
begin
return Indent & Str & New_Line (IO);
end Title;
--------------
-- Variable --
--------------
function Variable
(IO : Format;
Name : String;
Value : String)
return String
is
begin
return " " & Name & " = " & Value;
end Variable;
end Text_IO;
-----------------
-- HTML_Output --
-----------------
function HTML_Output return String is
HTML : HTML_IO.Format;
begin
return IO.Output (Mode => HTML);
end HTML_Output;
-----------------
-- Text_Output --
-----------------
function Text_Output return String is
Text : Text_IO.Format;
begin
return IO.Output (Mode => Text);
end Text_Output;
end GNAT.CGI.Debug;
gcc/ada/g-cgideb.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C G I . D E B U G --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $
-- --
-- Copyright (C) 2000 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This is a package to help debugging CGI (Common Gateway Interface)
-- programs written in Ada.
package GNAT.CGI.Debug is
-- Both functions below output all possible CGI parameters set. These
-- are the form field and all CGI environment variables which make the
-- CGI environment at runtime.
function Text_Output return String;
-- Returns a plain text version of the CGI runtime environment
function HTML_Output return String;
-- Returns an HTML version of the CGI runtime environment
end GNAT.CGI.Debug;
gcc/ada/g-curexc.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . C U R R E N T _ E X C E P T I O N --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- Copyright (C) 1996-2000 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 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 routines for obtaining the current exception
-- information in Ada 83 style. In Ada 83, there was no official method
-- for obtaining exception information, but a number of vendors supplied
-- routines for this purpose, and this package closely approximates the
-- interfaces supplied by DEC Ada 83 and VADS Ada.
-- The routines in this package are associated with a particular exception
-- handler, and can only be called from within an exception handler. See
-- also the package GNAT.Most_Recent_Exception, which provides access to
-- the most recently raised exception, and is not limited to static calls
-- from an exception handler.
package GNAT.Current_Exception is
pragma Pure (Current_Exception);
-----------------
-- Subprograms --
-----------------
function Exception_Information return String;
-- Returns the result of calling Ada.Exceptions.Exception_Information
-- with an argument that is the Exception_Occurrence corresponding to
-- the current exception. Returns the null string if called from outside
-- an exception handler.
function Exception_Message return String;
-- Returns the result of calling Ada.Exceptions.Exception_Message with
-- an argument that is the Exception_Occurrence corresponding to the
-- current exception. Returns the null string if called from outside an
-- exception handler.
function Exception_Name return String;
-- Returns the result of calling Ada.Exceptions.Exception_Name with
-- an argument that is the Exception_Occurrence corresponding to the
-- current exception. Returns the null string if called from outside
-- an exception handler.
-- Note: all these functions return useful information only if
-- called statically from within an exception handler, and they
-- return information about the exception corresponding to the
-- handler in which they appear. This is NOT the same as the most
-- recently raised exception. Consider the example:
-- exception
-- when Constraint_Error =>
-- begin
-- ...
-- exception
-- when Tasking_Error => ...
-- end;
--
-- -- Exception_xxx at this point returns the information about
-- -- the constraint error, not about any exception raised within
-- -- the nested block since it is the static nesting that counts.
-----------------------------------
-- Use of Library Level Renaming --
-----------------------------------
-- For greater compatibility with existing legacy software, library
-- level renaming may be used to create a function with a name matching
-- one that is in use. For example, some versions of VADS Ada provided
-- a functin called Current_Exception whose semantics was identical to
-- that of GNAT. The following library level renaming declaration:
-- with GNAT.Current_Exception;
-- function Current_Exception
-- renames GNAT.Current_Exception.Exception_Name;
-- placed in a file called current_exception.ads and compiled into the
-- application compilation environment, will make the function available
-- in a manner exactly compatible with that in VADS Ada 83.
private
pragma Import (Intrinsic, Exception_Information);
pragma Import (intrinsic, Exception_Message);
pragma Import (Intrinsic, Exception_Name);
end GNAT.Current_Exception;
gcc/ada/g-debpoo.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . D E B U G _ P O O L S --
-- --
-- B o d y --
-- --
-- $Revision: 1.14 $
-- --
-- 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_Conversion;
with GNAT.HTable;
with System.Memory;
pragma Elaborate_All (GNAT.HTable);
package body GNAT.Debug_Pools is
use System;
use System.Memory;
use System.Storage_Elements;
-- Definition of a H-table storing the status of each storage chunck
-- used by this pool
type State is (Not_Allocated, Deallocated, Allocated);
type Header is range 1 .. 1023;
function H (F : Address) return Header;
package Table is new GNAT.HTable.Simple_HTable (
Header_Num => Header,
Element => State,
No_Element => Not_Allocated,
Key => Address,
Hash => H,
Equal => "=");
--------------
-- Allocate --
--------------
procedure Allocate
(Pool : in out Debug_Pool;
Storage_Address : out Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count) is
begin
Storage_Address := Alloc (size_t (Size_In_Storage_Elements));
if Storage_Address = Null_Address then
raise Storage_Error;
else
Table.Set (Storage_Address, Allocated);
Pool.Allocated := Pool.Allocated + Size_In_Storage_Elements;
if Pool.Allocated - Pool.Deallocated > Pool.High_Water then
Pool.High_Water := Pool.Allocated - Pool.Deallocated;
end if;
end if;
end Allocate;
----------------
-- Deallocate --
----------------
procedure Deallocate
(Pool : in out Debug_Pool;
Storage_Address : Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
procedure Free (Address : System.Address; Siz : Storage_Count);
-- Faked free, that reset all the deallocated storage to "DEADBEEF"
procedure Free (Address : System.Address; Siz : Storage_Count) is
DB1 : constant Integer := 16#DEAD#;
DB2 : constant Integer := 16#BEEF#;
type Dead_Memory is array (1 .. Siz / 4) of Integer;
type Mem_Ptr is access all Dead_Memory;
function From_Ptr is
new Unchecked_Conversion (System.Address, Mem_Ptr);
J : Storage_Offset;
begin
J := Dead_Memory'First;
while J < Dead_Memory'Last loop
From_Ptr (Address) (J) := DB1;
From_Ptr (Address) (J + 1) := DB2;
J := J + 2;
end loop;
if J = Dead_Memory'Last then
From_Ptr (Address) (J) := DB1;
end if;
end Free;
S : State := Table.Get (Storage_Address);
-- Start of processing for Deallocate
begin
case S is
when Not_Allocated =>
raise Freeing_Not_Allocated_Storage;
when Deallocated =>
raise Freeing_Deallocated_Storage;
when Allocated =>
Free (Storage_Address, Size_In_Storage_Elements);
Table.Set (Storage_Address, Deallocated);
Pool.Deallocated := Pool.Deallocated + Size_In_Storage_Elements;
end case;
end Deallocate;
-----------------
-- Dereference --
-----------------
procedure Dereference
(Pool : in out Debug_Pool;
Storage_Address : Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
S : State := Table.Get (Storage_Address);
Max_Dim : constant := 3;
Dim : Integer := 1;
begin
-- If this is not a known address, maybe it is because is is an
-- unconstained array. In which case, the bounds have used the
-- 2 first words (per dimension) of the allocated spot.
while S = Not_Allocated and then Dim <= Max_Dim loop
S := Table.Get (Storage_Address - Storage_Offset (Dim * 2 * 4));
Dim := Dim + 1;
end loop;
case S is
when Not_Allocated =>
raise Accessing_Not_Allocated_Storage;
when Deallocated =>
raise Accessing_Deallocated_Storage;
when Allocated =>
null;
end case;
end Dereference;
-------
-- H --
-------
function H (F : Address) return Header is
begin
return
Header (1 + (To_Integer (F) mod Integer_Address (Header'Last)));
end H;
----------------
-- Print_Info --
----------------
procedure Print_Info (Pool : Debug_Pool) is
use System.Storage_Elements;
begin
Put_Line ("Debug Pool info:");
Put_Line (" Total allocated bytes : "
& Storage_Offset'Image (Pool.Allocated));
Put_Line (" Total deallocated bytes : "
& Storage_Offset'Image (Pool.Deallocated));
Put_Line (" Current Water Mark: "
& Storage_Offset'Image (Pool.Allocated - Pool.Deallocated));
Put_Line (" High Water Mark: "
& Storage_Offset'Image (Pool.High_Water));
Put_Line ("");
end Print_Info;
------------------
-- Storage_Size --
------------------
function Storage_Size (Pool : Debug_Pool) return Storage_Count is
begin
return Storage_Count'Last;
end Storage_Size;
end GNAT.Debug_Pools;
gcc/ada/g-debpoo.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . D E B U G _ P O O L S --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $
-- --
-- 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 System; use System;
with System.Storage_Elements; use System.Storage_Elements;
with System.Checked_Pools;
package GNAT.Debug_Pools is
-- The debug pool is used to track down memory corruption due to use of
-- deallocated memory or incorrect unchecked conversions. Allocation
-- strategy :
-- - allocation: . memory is normally allocated with malloc
-- . the allocated address is noted in a table
-- - deallocation: . memory is filled with "DEAD_BEEF" patterns
-- . memory is not freed
-- . exceptions are raised if the memory was not
-- allocated or was already deallocated
-- - dereference: . exceptions are raised if the memory was not
-- allocated or was already deallocated
Accessing_Not_Allocated_Storage : exception;
Accessing_Deallocated_Storage : exception;
Freeing_Not_Allocated_Storage : exception;
Freeing_Deallocated_Storage : exception;
type Debug_Pool is
new System.Checked_Pools.Checked_Pool with private;
procedure Allocate
(Pool : in out Debug_Pool;
Storage_Address : out Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
procedure Deallocate
(Pool : in out Debug_Pool;
Storage_Address : Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
function Storage_Size
(Pool : Debug_Pool)
return System.Storage_Elements.Storage_Count;
procedure Dereference
(Pool : in out Debug_Pool;
Storage_Address : System.Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
generic
with procedure Put_Line (S : String);
procedure Print_Info (Pool : Debug_Pool);
-- Print out information about the High Water Mark, the current and
-- total number of bytes allocated and the total number of bytes
-- deallocated.
private
type Debug_Pool is new System.Checked_Pools.Checked_Pool with record
Allocated : Storage_Count := 0;
-- Total number of bytes allocated in this pool
Deallocated : Storage_Count := 0;
-- Total number of bytes deallocated in this pool
High_Water : Storage_Count := 0;
-- Maximum of during the time of Allocated - Deallocated
end record;
end GNAT.Debug_Pools;
gcc/ada/g-debuti.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . D E B U G _ U T I L I T I E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1997-1998 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
package body GNAT.Debug_Utilities is
--------------------------
-- Image (address case) --
--------------------------
function Image (A : Address) return String is
S : String (1 .. Address_Image_Length);
P : Natural := S'Last - 1;
N : Integer_Address := To_Integer (A);
U : Natural := 0;
H : array (Integer range 0 .. 15) of Character := "0123456789ABCDEF";
begin
S (S'Last) := '#';
while P > 3 loop
if U = 4 then
S (P) := '_';
P := P - 1;
U := 1;
else
U := U + 1;
end if;
S (P) := H (Integer (N mod 16));
P := P - 1;
N := N / 16;
end loop;
S (1 .. 3) := "16#";
return S;
end Image;
-------------------------
-- Image (string case) --
-------------------------
function Image (S : String) return String is
W : String (1 .. 2 * S'Length + 2);
P : Positive := 1;
begin
W (1) := '"';
for J in S'Range loop
if S (J) = '"' then
P := P + 1;
W (P) := '"';
end if;
P := P + 1;
W (P) := S (J);
end loop;
P := P + 1;
W (P) := '"';
return W (1 .. P);
end Image;
-----------
-- Value --
-----------
function Value (S : String) return System.Address is
N : constant Integer_Address := Integer_Address'Value (S);
begin
return To_Address (N);
end Value;
end GNAT.Debug_Utilities;
gcc/ada/g-debuti.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . D E B U G _ U T I L I T I E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1995-1998 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Debugging utilities
-- This package provides some useful utility subprograms for use in writing
-- routines that generate debugging output.
with System;
package GNAT.Debug_Utilities is
pragma Pure (Debug_Utilities);
function Image (S : String) return String;
-- Returns a string image of S, obtained by prepending and appending
-- quote (") characters and doubling any quote characters in the string.
-- The maximum length of the result is thus 2 ** S'Length + 2.
Address_Image_Length : constant :=
13 + 10 * Boolean'Pos (Standard'Address_Size > 32);
-- Length of string returned by Image function
function Image (A : System.Address) return String;
-- Returns a string of the form 16#xxxx_xxxx# for 32-bit addresses
-- or 16#xxxx_xxxx_xxxx_xxxx# for 64-bit addresses. Hex characters
-- are in upper case.
function Value (S : String) return System.Address;
-- Given a valid integer literal in any form, including the form returned
-- by the Image function in this package, yields the corresponding address.
end GNAT.Debug_Utilities;
gcc/ada/g-dyntab.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . D Y N A M I C _ T A B L E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $
-- --
-- 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System; use System;
package body GNAT.Dynamic_Tables is
Min : constant Integer := Integer (Table_Low_Bound);
-- Subscript of the minimum entry in the currently allocated table
type size_t is new Integer;
-----------------------
-- Local Subprograms --
-----------------------
procedure Reallocate (T : in out Instance);
-- 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.
--------------
-- Allocate --
--------------
procedure Allocate
(T : in out Instance;
Num : Integer := 1)
is
begin
T.P.Last_Val := T.P.Last_Val + Num;
if T.P.Last_Val > T.P.Max then
Reallocate (T);
end if;
end Allocate;
------------
-- Append --
------------
procedure Append (T : in out Instance; New_Val : Table_Component_Type) is
begin
Increment_Last (T);
T.Table (Table_Index_Type (T.P.Last_Val)) := New_Val;
end Append;
--------------------
-- Decrement_Last --
--------------------
procedure Decrement_Last (T : in out Instance) is
begin
T.P.Last_Val := T.P.Last_Val - 1;
end Decrement_Last;
----------
-- Free --
----------
procedure Free (T : in out Instance) is
procedure free (T : Table_Ptr);
pragma Import (C, free);
begin
free (T.Table);
T.Table := null;
T.P.Length := 0;
end Free;
--------------------
-- Increment_Last --
--------------------
procedure Increment_Last (T : in out Instance) is
begin
T.P.Last_Val := T.P.Last_Val + 1;
if T.P.Last_Val > T.P.Max then
Reallocate (T);
end if;
end Increment_Last;
----------
-- Init --
----------
procedure Init (T : in out Instance) is
Old_Length : constant Integer := T.P.Length;
begin
T.P.Last_Val := Min - 1;
T.P.Max := Min + Table_Initial - 1;
T.P.Length := T.P.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 = T.P.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 (T);
end if;
end Init;
----------
-- Last --
----------
function Last (T : in Instance) return Table_Index_Type is
begin
return Table_Index_Type (T.P.Last_Val);
end Last;
----------------
-- Reallocate --
----------------
procedure Reallocate (T : in out Instance) 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 T.P.Max < T.P.Last_Val then
while T.P.Max < T.P.Last_Val loop
T.P.Length := T.P.Length * (100 + Table_Increment) / 100;
T.P.Max := Min + T.P.Length - 1;
end loop;
end if;
New_Size :=
size_t ((T.P.Max - Min + 1) *
(Table_Type'Component_Size / Storage_Unit));
if T.Table = null then
T.Table := malloc (New_Size);
elsif New_Size > 0 then
T.Table :=
realloc
(memblock => T.Table,
size => New_Size);
end if;
if T.P.Length /= 0 and then T.Table = null then
raise Storage_Error;
end if;
end Reallocate;
-------------
-- Release --
-------------
procedure Release (T : in out Instance) is
begin
T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
T.P.Max := T.P.Last_Val;
Reallocate (T);
end Release;
--------------
-- Set_Item --
--------------
procedure Set_Item
(T : in out Instance;
Index : Table_Index_Type;
Item : Table_Component_Type)
is
begin
if Integer (Index) > T.P.Max then
Set_Last (T, Index);
end if;
T.Table (Index) := Item;
end Set_Item;
--------------
-- Set_Last --
--------------
procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is
begin
if Integer (New_Val) < T.P.Last_Val then
T.P.Last_Val := Integer (New_Val);
else
T.P.Last_Val := Integer (New_Val);
if T.P.Last_Val > T.P.Max then
Reallocate (T);
end if;
end if;
end Set_Last;
end GNAT.Dynamic_Tables;
gcc/ada/g-dyntab.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . D Y N A M I C _ T A B L E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.11 $
-- --
-- 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Resizable one dimensional array support
-- 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.
-- This package provides a facility similar to that of GNAT.Table, except
-- that this package declares a type that can be used to define dynamic
-- instances of the table, while an instantiation of GNAT.Table creates a
-- single instance of the table type.
-- Note that this interface should remain synchronized with those in
-- GNAT.Table and the GNAT compiler source unit Table to keep as much
-- coherency as possible between these three related units.
generic
type Table_Component_Type is private;
type Table_Index_Type is range <>;
Table_Low_Bound : Table_Index_Type;
Table_Initial : Positive;
Table_Increment : Natural;
package GNAT.Dynamic_Tables 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_Low_Bound .. <>) of Table_Component_Type;
-- 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 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 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
-- restrict 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.
type Table_Private is private;
-- table private data that is not exported in Instance.
type Instance is record
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.
P : Table_Private;
end record;
procedure Init (T : in out Instance);
-- This procedure allocates a new table of size Initial (freeing any
-- previously allocated larger table). Init must be called before using
-- the table. Init is convenient in reestablishing a table for new use.
function Last (T : in Instance) 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 (T : in out Instance);
-- 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 (T : in out Instance);
-- 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 (T : in out Instance; 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 (T : in out Instance);
pragma Inline (Increment_Last);
-- Adds 1 to Last (same as Set_Last (Last + 1).
procedure Decrement_Last (T : in out Instance);
pragma Inline (Decrement_Last);
-- Subtracts 1 from Last (same as Set_Last (Last - 1).
procedure Append (T : in out Instance; New_Val : Table_Component_Type);
pragma Inline (Append);
-- Equivalent to:
-- Increment_Last (T);
-- T.Table (T.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
(T : in out Instance;
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.
procedure Allocate (T : in out Instance; Num : Integer := 1);
pragma Inline (Allocate);
-- Adds Num to Last.
private
type Table_Private is record
Max : Integer;
-- Subscript of the maximum entry in the currently allocated table
Length : Integer := 0;
-- Number of entries in currently allocated table. The value of zero
-- ensures that we initially allocate the table.
Last_Val : Integer;
-- Current value of Last.
end record;
end GNAT.Dynamic_Tables;
gcc/ada/g-except.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . E X C E P T I O N S --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $
-- --
-- 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 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 interface for raising predefined exceptions
-- with an exception message. It can be used from Pure units. This unit
-- is for internal use only, it is not generally available to applications.
package GNAT.Exceptions is
pragma Pure (Exceptions);
type Exception_Type is limited null record;
-- Type used to specify which exception to raise.
-- Really Exception_Type is Exception_Id, but Exception_Id can't be
-- used directly since it is declared in the non-pure unit Ada.Exceptions,
-- Exception_Id is in fact simply a pointer to the type Exception_Data
-- declared in System.Standard_Library (which is also non-pure). So what
-- we do is to define it here as a by reference type (any by reference
-- type would do), and then Import the definitions from Standard_Library.
-- Since this is a by reference type, these will be passed by reference,
-- which has the same effect as passing a pointer.
-- This type is not private because keeping it by reference would require
-- defining it in a way (e.g a tagged type) that would drag other run time
-- files, which is unwanted in the case of e.g ravenscar where we want to
-- minimize the number of run time files needed by default.
CE : constant Exception_Type; -- Constraint_Error
PE : constant Exception_Type; -- Program_Error
SE : constant Exception_Type; -- Storage_Error
TE : constant Exception_Type; -- Tasking_Error
-- One of these constants is used in the call to specify the exception
procedure Raise_Exception (E : Exception_Type; Message : String);
pragma Import (Ada, Raise_Exception, "__gnat_raise_exception");
pragma No_Return (Raise_Exception);
-- Raise specified exception with specified message
private
pragma Import (C, CE, "constraint_error");
pragma Import (C, PE, "program_error");
pragma Import (C, SE, "storage_error");
pragma Import (C, TE, "tasking_error");
-- References to the exception structures in the standard library
end GNAT.Exceptions;
gcc/ada/g-exctra.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . E X C E P T I O N _ T R A C E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $
-- --
-- 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Standard_Library; use System.Standard_Library;
with System.Soft_Links; use System.Soft_Links;
package body GNAT.Exception_Traces is
-- Calling the decorator directly from where it is needed would require
-- introducing nasty dependencies upon the spec of this package (typically
-- in a-except.adb). We also have to deal with the fact that the traceback
-- array within an exception occurrence and the one the decorator shall
-- accept are of different types. These are two reasons for which a wrapper
-- with a System.Address argument is indeed used to call the decorator
-- provided by the user of this package. This wrapper is called via a
-- soft-link, which either is null when no decorator is in place or "points
-- to" the following function otherwise.
function Decorator_Wrapper
(Traceback : System.Address;
Len : Natural)
return String;
-- The wrapper to be called when a decorator is in place for exception
-- backtraces.
--
-- Traceback is the address of the call chain array as stored in the
-- exception occurrence and Len is the number of significant addresses
-- contained in this array.
Current_Decorator : Traceback_Decorator := null;
-- The decorator to be called by the wrapper when it is not null, as set
-- by Set_Trace_Decorator. When this access is null, the wrapper is null
-- also and shall then not be called.
-----------------------
-- Decorator_Wrapper --
-----------------------
function Decorator_Wrapper
(Traceback : System.Address;
Len : Natural)
return String
is
Decorator_Traceback : Tracebacks_Array (1 .. Len);
for Decorator_Traceback'Address use Traceback;
-- Handle the "transition" from the array stored in the exception
-- occurrence to the array expected by the decorator.
pragma Import (Ada, Decorator_Traceback);
begin
return Current_Decorator.all (Decorator_Traceback);
end Decorator_Wrapper;
-------------------------
-- Set_Trace_Decorator --
-------------------------
procedure Set_Trace_Decorator (Decorator : Traceback_Decorator) is
begin
Current_Decorator := Decorator;
if Current_Decorator /= null then
Traceback_Decorator_Wrapper := Decorator_Wrapper'Access;
else
Traceback_Decorator_Wrapper := null;
end if;
end Set_Trace_Decorator;
-- Trace_On/Trace_Off control the kind of automatic output to occur
-- by way of the global Exception_Trace variable.
---------------
-- Trace_Off --
---------------
procedure Trace_Off is
begin
Exception_Trace := RM_Convention;
end Trace_Off;
--------------
-- Trace_On --
--------------
procedure Trace_On (Kind : in Trace_Kind) is
begin
case Kind is
when Every_Raise =>
Exception_Trace := Every_Raise;
when Unhandled_Raise =>
Exception_Trace := Unhandled_Raise;
end case;
end Trace_On;
end GNAT.Exception_Traces;
gcc/ada/g-exctra.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . E X C E P T I O N _ T R A C E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.4 $
-- --
-- Copyright (C) 2000 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package provides an interface allowing to control *automatic* output
-- to standard error upon exception occurrences (as opposed to explicit
-- generation of traceback information using GNAT.Traceback).
--
-- This output includes the basic information associated with the exception
-- (name, message) as well as a backtrace of the call chain at the point
-- where the exception occured. This backtrace is only output if the call
-- chain information is available, depending if the binder switch dedicated
-- to that purpose has been used or not.
--
-- The default backtrace is in the form of absolute code locations which may
-- be converted to corresponding source locations using the addr2line utility
-- or from within GDB. Please refer to GNAT.Traceback for information about
-- what is necessary to be able to exploit thisg possibility.
--
-- The backtrace output can also be customized by way of a "decorator" which
-- may return any string output in association with a provided call chain.
with GNAT.Traceback; use GNAT.Traceback;
package GNAT.Exception_Traces is
-- The following defines the exact situations in which raises will
-- cause automatic output of trace information.
type Trace_Kind is
(Every_Raise,
-- Denotes the initial raise event for any exception occurrence, either
-- explicit or due to a specific language rule, within the context of a
-- task or not.
Unhandled_Raise
-- Denotes the raise events corresponding to exceptions for which there
-- is no user defined handler, in particular, when a task dies due to an
-- unhandled exception.
);
-- The following procedures can be used to activate and deactivate
-- traces identified by the above trace kind values.
procedure Trace_On (Kind : in Trace_Kind);
-- Activate the traces denoted by Kind.
procedure Trace_Off;
-- Stop the tracing requested by the last call to Trace_On.
-- Has no effect if no such call has ever occurred.
-- The following provide the backtrace decorating facilities
type Traceback_Decorator is access
function (Traceback : Tracebacks_Array) return String;
-- A backtrace decorator is a function which returns the string to be
-- output for a call chain provided by way of a tracebacks array.
procedure Set_Trace_Decorator (Decorator : Traceback_Decorator);
-- Set the decorator to be used for future automatic outputs. Restore
-- the default behavior (output of raw addresses) if the provided
-- access value is null.
end GNAT.Exception_Traces;
gcc/ada/g-flocon.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . F L O A T _ C O N T R O L --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 2000 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 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). --
-- --
------------------------------------------------------------------------------
-- Control functions for floating-point unit
package GNAT.Float_Control is
procedure Reset;
-- Reset the floating-point processor to the default state needed to get
-- correct Ada semantics for the target. Some third party tools change
-- the settings for the floating-point processor. Reset can be called
-- to reset the floating-point processor into the mode required by GNAT
-- for correct operation. Use this call after a call to foreign code if
-- you suspect incorrect floating-point operation after the call.
--
-- For example under Windows NT some system DLL calls change the default
-- FPU arithmetic to 64 bit precision mode. However, since in Ada 95 it
-- is required to provide full access to the floating-point types of the
-- architecture, GNAT requires full 80-bit precision mode, and Reset makes
-- sure this mode is established.
--
-- Similarly on the PPC processor, it is important that overflow and
-- underflow exceptions be disabled.
--
-- The call to Reset simply has no effect if the target environment
-- does not give rise to such concerns.
private
pragma Import (C, Reset, "__gnat_init_float");
end GNAT.Float_Control;
gcc/ada/g-hesora.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H E A P _ S O R T _ A --
-- --
-- B o d y --
-- --
-- $Revision: 1.8 $ --
-- --
-- Copyright (C) 1995-1999 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Heap_Sort_A is
----------
-- Sort --
----------
-- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3)
-- as described by Knuth ("The Art of Programming", Volume III, first
-- edition, section 5.2.3, p. 145-147) with the modification that is
-- mentioned in exercise 18. For more details on this algorithm, see
-- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray
-- Phase Problem". University of Chicago, 1968, which was the first
-- publication of the modification, which reduces the number of compares
-- from 2NlogN to NlogN.
procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function) is
Max : Natural := N;
-- Current Max index in tree being sifted
procedure Sift (S : Positive);
-- This procedure sifts up node S, i.e. converts the subtree rooted
-- at node S into a heap, given the precondition that any sons of
-- S are already heaps. On entry, the contents of node S is found
-- in the temporary (index 0), the actual contents of node S on
-- entry are irrelevant. This is just a minor optimization to avoid
-- what would otherwise be two junk moves in phase two of the sort.
procedure Sift (S : Positive) is
C : Positive := S;
Son : Positive;
Father : Positive;
begin
-- This is where the optimization is done, normally we would do a
-- comparison at each stage between the current node and the larger
-- of the two sons, and continue the sift only if the current node
-- was less than this maximum. In this modified optimized version,
-- we assume that the current node will be less than the larger
-- son, and unconditionally sift up. Then when we get to the bottom
-- of the tree, we check parents to make sure that we did not make
-- a mistake. This roughly cuts the number of comparisions in half,
-- since it is almost always the case that our assumption is correct.
-- Loop to pull up larger sons
loop
Son := 2 * C;
exit when Son > Max;
if Son < Max and then Lt (Son, Son + 1) then
Son := Son + 1;
end if;
Move (Son, C);
C := Son;
end loop;
-- Loop to check fathers
while C /= S loop
Father := C / 2;
if Lt (Father, 0) then
Move (Father, C);
C := Father;
else
exit;
end if;
end loop;
-- Last step is to pop the sifted node into place
Move (0, C);
end Sift;
-- Start of processing for Sort
begin
-- Phase one of heapsort is to build the heap. This is done by
-- sifting nodes N/2 .. 1 in sequence.
for J in reverse 1 .. N / 2 loop
Move (J, 0);
Sift (J);
end loop;
-- In phase 2, the largest node is moved to end, reducing the size
-- of the tree by one, and the displaced node is sifted down from
-- the top, so that the largest node is again at the top.
while Max > 1 loop
Move (Max, 0);
Move (1, Max);
Max := Max - 1;
Sift (1);
end loop;
end Sort;
end GNAT.Heap_Sort_A;
gcc/ada/g-hesora.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H E A P _ S O R T _ A --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $
-- --
-- Copyright (C) 1995-2000 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Heapsort using access to procedure parameters
-- This package provides a heapsort routine that works with access to
-- subprogram parameters, so that it can be used with different types with
-- shared sorting code. See also GNAT.Heap_Sort_G, the generic version,
-- which is a little more efficient but does not allow code sharing.
-- The generic version is also Pure, while the access version can
-- only be Preelaborate.
package GNAT.Heap_Sort_A is
pragma Preelaborate (Heap_Sort_A);
-- The data to be sorted is assumed to be indexed by integer values from
-- 1 to N, where N is the number of items to be sorted. In addition, the
-- index value zero is used for a temporary location used during the sort.
type Move_Procedure is access procedure (From : Natural; To : Natural);
-- A pointer to a procedure that moves the data item with index From to
-- the data item with index To. An index value of zero is used for moves
-- from and to the single temporary location used by the sort.
type Lt_Function is access function (Op1, Op2 : Natural) return Boolean;
-- A pointer to a function that compares two items and returns True if
-- the item with index Op1 is less than the item with index Op2, and False
-- if the Op1 item is greater than or equal to the Op2 item.
procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function);
-- This procedures sorts items in the range from 1 to N into ascending
-- order making calls to Lt to do required comparisons, and Move to move
-- items around. Note that, as described above, both Move and Lt use a
-- single temporary location with index value zero. This sort is not
-- stable, i.e. the order of equal elements in the input is not preserved.
end GNAT.Heap_Sort_A;
gcc/ada/g-hesorg.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H E A P _ S O R T _ G --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $ --
-- --
-- Copyright (C) 1995-1999 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Heap_Sort_G is
----------
-- Sort --
----------
-- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3)
-- as described by Knuth ("The Art of Programming", Volume III, first
-- edition, section 5.2.3, p. 145-147) with the modification that is
-- mentioned in exercise 18. For more details on this algorithm, see
-- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray
-- Phase Problem". University of Chicago, 1968, which was the first
-- publication of the modification, which reduces the number of compares
-- from 2NlogN to NlogN.
procedure Sort (N : Natural) is
Max : Natural := N;
-- Current Max index in tree being sifted
procedure Sift (S : Positive);
-- This procedure sifts up node S, i.e. converts the subtree rooted
-- at node S into a heap, given the precondition that any sons of
-- S are already heaps. On entry, the contents of node S is found
-- in the temporary (index 0), the actual contents of node S on
-- entry are irrelevant. This is just a minor optimization to avoid
-- what would otherwise be two junk moves in phase two of the sort.
procedure Sift (S : Positive) is
C : Positive := S;
Son : Positive;
Father : Positive;
begin
-- This is where the optimization is done, normally we would do a
-- comparison at each stage between the current node and the larger
-- of the two sons, and continue the sift only if the current node
-- was less than this maximum. In this modified optimized version,
-- we assume that the current node will be less than the larger
-- son, and unconditionally sift up. Then when we get to the bottom
-- of the tree, we check parents to make sure that we did not make
-- a mistake. This roughly cuts the number of comparisions in half,
-- since it is almost always the case that our assumption is correct.
-- Loop to pull up larger sons
loop
Son := 2 * C;
exit when Son > Max;
if Son < Max and then Lt (Son, Son + 1) then
Son := Son + 1;
end if;
Move (Son, C);
C := Son;
end loop;
-- Loop to check fathers
while C /= S loop
Father := C / 2;
if Lt (Father, 0) then
Move (Father, C);
C := Father;
else
exit;
end if;
end loop;
-- Last step is to pop the sifted node into place
Move (0, C);
end Sift;
-- Start of processing for Sort
begin
-- Phase one of heapsort is to build the heap. This is done by
-- sifting nodes N/2 .. 1 in sequence.
for J in reverse 1 .. N / 2 loop
Move (J, 0);
Sift (J);
end loop;
-- In phase 2, the largest node is moved to end, reducing the size
-- of the tree by one, and the displaced node is sifted down from
-- the top, so that the largest node is again at the top.
while Max > 1 loop
Move (Max, 0);
Move (1, Max);
Max := Max - 1;
Sift (1);
end loop;
end Sort;
end GNAT.Heap_Sort_G;
gcc/ada/g-hesorg.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H E A P _ S O R T _ G --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $
-- --
-- Copyright (C) 1995-2000 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Heapsort generic package using formal procedures
-- This package provides a generic heapsort routine that can be used with
-- different types of data. See also GNAT.Heap_Sort_A, a version that works
-- with subprogram parameters, allowing code sharing. The generic version
-- is slightly more efficient but does not allow code sharing. The generic
-- version is also Pure, while the access version can only be Preelaborate.
generic
-- The data to be sorted is assumed to be indexed by integer values from
-- 1 to N, where N is the number of items to be sorted. In addition, the
-- index value zero is used for a temporary location used during the sort.
with procedure Move (From : Natural; To : Natural);
-- A procedure that moves the data item with index From to the data item
-- with Index To. An index value of zero is used for moves from and to a
-- single temporary location used by the sort.
with function Lt (Op1, Op2 : Natural) return Boolean;
-- A function that compares two items and returns True if the item with
-- index Op1 is less than the item with Index Op2, and False if the Op1
-- item is greater than or equal to the Op2 item.
package GNAT.Heap_Sort_G is
pragma Pure (Heap_Sort_G);
procedure Sort (N : Natural);
-- This procedures sorts items in the range from 1 to N into ascending
-- order making calls to Lt to do required comparisons, and Move to move
-- items around. Note that, as described above, both Move and Lt use a
-- single temporary location with index value zero. This sort is not
-- stable, i.e. the order of equal elements in the input is not preserved.
end GNAT.Heap_Sort_G;
gcc/ada/g-htable.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H T A B L E --
-- --
-- B o d y --
-- --
-- $Revision: 1.14 $
-- --
-- Copyright (C) 1995-1999 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
package body GNAT.HTable is
--------------------
-- Static_HTable --
--------------------
package body Static_HTable is
Table : array (Header_Num) of Elmt_Ptr;
Iterator_Index : Header_Num;
Iterator_Ptr : Elmt_Ptr;
Iterator_Started : Boolean := False;
function Get_Non_Null return Elmt_Ptr;
-- Returns Null_Ptr if Iterator_Started is false of the Table is
-- empty. Returns Iterator_Ptr if non null, or the next non null
-- element in table if any.
---------
-- Get --
---------
function Get (K : Key) return Elmt_Ptr is
Elmt : Elmt_Ptr;
begin
Elmt := Table (Hash (K));
loop
if Elmt = Null_Ptr then
return Null_Ptr;
elsif Equal (Get_Key (Elmt), K) then
return Elmt;
else
Elmt := Next (Elmt);
end if;
end loop;
end Get;
---------------
-- Get_First --
---------------
function Get_First return Elmt_Ptr is
begin
Iterator_Started := True;
Iterator_Index := Table'First;
Iterator_Ptr := Table (Iterator_Index);
return Get_Non_Null;
end Get_First;
--------------
-- Get_Next --
--------------
function Get_Next return Elmt_Ptr is
begin
if not Iterator_Started then
return Null_Ptr;
end if;
Iterator_Ptr := Next (Iterator_Ptr);
return Get_Non_Null;
end Get_Next;
------------------
-- Get_Non_Null --
------------------
function Get_Non_Null return Elmt_Ptr is
begin
while Iterator_Ptr = Null_Ptr loop
if Iterator_Index = Table'Last then
Iterator_Started := False;
return Null_Ptr;
end if;
Iterator_Index := Iterator_Index + 1;
Iterator_Ptr := Table (Iterator_Index);
end loop;
return Iterator_Ptr;
end Get_Non_Null;
------------
-- Remove --
------------
procedure Remove (K : Key) is
Index : constant Header_Num := Hash (K);
Elmt : Elmt_Ptr;
Next_Elmt : Elmt_Ptr;
begin
Elmt := Table (Index);
if Elmt = Null_Ptr then
return;
elsif Equal (Get_Key (Elmt), K) then
Table (Index) := Next (Elmt);
else
loop
Next_Elmt := Next (Elmt);
if Next_Elmt = Null_Ptr then
return;
elsif Equal (Get_Key (Next_Elmt), K) then
Set_Next (Elmt, Next (Next_Elmt));
return;
else
Elmt := Next_Elmt;
end if;
end loop;
end if;
end Remove;
-----------
-- Reset --
-----------
procedure Reset is
begin
for J in Table'Range loop
Table (J) := Null_Ptr;
end loop;
end Reset;
---------
-- Set --
---------
procedure Set (E : Elmt_Ptr) is
Index : Header_Num;
begin
Index := Hash (Get_Key (E));
Set_Next (E, Table (Index));
Table (Index) := E;
end Set;
end Static_HTable;
--------------------
-- Simple_HTable --
--------------------
package body Simple_HTable is
type Element_Wrapper;
type Elmt_Ptr is access all Element_Wrapper;
type Element_Wrapper is record
K : Key;
E : Element;
Next : Elmt_Ptr;
end record;
procedure Free is new
Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
function Next (E : Elmt_Ptr) return Elmt_Ptr;
function Get_Key (E : Elmt_Ptr) return Key;
package Tab is new Static_HTable (
Header_Num => Header_Num,
Element => Element_Wrapper,
Elmt_Ptr => Elmt_Ptr,
Null_Ptr => null,
Set_Next => Set_Next,
Next => Next,
Key => Key,
Get_Key => Get_Key,
Hash => Hash,
Equal => Equal);
---------
-- Get --
---------
function Get (K : Key) return Element is
Tmp : constant Elmt_Ptr := Tab.Get (K);
begin
if Tmp = null then
return No_Element;
else
return Tmp.E;
end if;
end Get;
---------------
-- Get_First --
---------------
function Get_First return Element is
Tmp : constant Elmt_Ptr := Tab.Get_First;
begin
if Tmp = null then
return No_Element;
else
return Tmp.E;
end if;
end Get_First;
-------------
-- Get_Key --
-------------
function Get_Key (E : Elmt_Ptr) return Key is
begin
return E.K;
end Get_Key;
--------------
-- Get_Next --
--------------
function Get_Next return Element is
Tmp : constant Elmt_Ptr := Tab.Get_Next;
begin
if Tmp = null then
return No_Element;
else
return Tmp.E;
end if;
end Get_Next;
----------
-- Next --
----------
function Next (E : Elmt_Ptr) return Elmt_Ptr is
begin
return E.Next;
end Next;
------------
-- Remove --
------------
procedure Remove (K : Key) is
Tmp : Elmt_Ptr;
begin
Tmp := Tab.Get (K);
if Tmp /= null then
Tab.Remove (K);
Free (Tmp);
end if;
end Remove;
-----------
-- Reset --
-----------
procedure Reset is
E1, E2 : Elmt_Ptr;
begin
E1 := Tab.Get_First;
while E1 /= null loop
E2 := Tab.Get_Next;
Free (E1);
E1 := E2;
end loop;
Tab.Reset;
end Reset;
---------
-- Set --
---------
procedure Set (K : Key; E : Element) is
Tmp : constant Elmt_Ptr := Tab.Get (K);
begin
if Tmp = null then
Tab.Set (new Element_Wrapper'(K, E, null));
else
Tmp.E := E;
end if;
end Set;
--------------
-- Set_Next --
--------------
procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
begin
E.Next := Next;
end Set_Next;
end Simple_HTable;
----------
-- Hash --
----------
function Hash (Key : String) return Header_Num is
type Uns is mod 2 ** 32;
function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
pragma Import (Intrinsic, Rotate_Left);
Tmp : Uns := 0;
begin
for J in Key'Range loop
Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J));
end loop;
return Header_Num'First +
Header_Num'Base (Tmp mod Header_Num'Range_Length);
end Hash;
end GNAT.HTable;
gcc/ada/g-htable.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H T A B L E --
-- --
-- S p e c --
-- --
-- $Revision: 1.19 $
-- --
-- Copyright (C) 1995-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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Hash table searching routines
-- This package contains two separate packages. The Simple_Htable package
-- provides a very simple abstraction that asosicates one element to one
-- key values and takes care of all allocation automatically using the heap.
-- The Static_Htable package provides a more complex interface that allows
-- complete control over allocation.
package GNAT.HTable is
pragma Preelaborate (HTable);
-------------------
-- Simple_HTable --
-------------------
-- A simple hash table abstraction, easy to instantiate, easy to use.
-- The table associates one element to one key with the procedure Set.
-- Get retrieves the Element stored for a given Key. The efficiency of
-- retrieval is function of the size of the Table parameterized by
-- Header_Num and the hashing function Hash.
generic
type Header_Num is range <>;
-- An integer type indicating the number and range of hash headers.
type Element is private;
-- The type of element to be stored
No_Element : Element;
-- The object that is returned by Get when no element has been set for
-- a given key
type Key is private;
with function Hash (F : Key) return Header_Num;
with function Equal (F1, F2 : Key) return Boolean;
package Simple_HTable is
procedure Set (K : Key; E : Element);
-- Associates an element with a given key. Overrides any previously
-- associated element.
procedure Reset;
-- Removes and frees all elements in the table
function Get (K : Key) return Element;
-- Returns the Element associated with a key or No_Element if the
-- given key has not associated element
procedure Remove (K : Key);
-- Removes the latest inserted element pointer associated with the
-- given key if any, does nothing if none.
function Get_First return Element;
-- Returns No_Element if the Htable is empty, otherwise returns one
-- non specified element. There is no guarantee that 2 calls to this
-- function will return the same element.
function Get_Next return Element;
-- Returns a non-specified element that has not been returned by the
-- same function since the last call to Get_First or No_Element if
-- there is no such element. If there is no call to 'Set' in between
-- Get_Next calls, all the elements of the Htable will be traversed.
end Simple_HTable;
-------------------
-- Static_HTable --
-------------------
-- A low-level Hash-Table abstraction, not as easy to instantiate as
-- Simple_HTable but designed to allow complete control over the
-- allocation of necessary data structures. Particularly useful when
-- dynamic allocation is not desired. The model is that each Element
-- contains its own Key that can be retrieved by Get_Key. Furthermore,
-- Element provides a link that can be used by the HTable for linking
-- elements with same hash codes:
-- Element
-- +-------------------+
-- | Key |
-- +-------------------+
-- : other data :
-- +-------------------+
-- | Next Elmt |
-- +-------------------+
generic
type Header_Num is range <>;
-- An integer type indicating the number and range of hash headers.
type Element (<>) is limited private;
-- The type of element to be stored
type Elmt_Ptr is private;
-- The type used to reference an element (will usually be an access
-- type, but could be some other form of type such as an integer type).
Null_Ptr : Elmt_Ptr;
-- The null value of the Elmt_Ptr type.
with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
with function Next (E : Elmt_Ptr) return Elmt_Ptr;
-- The type must provide an internal link for the sake of the
-- staticness of the HTable.
type Key is limited private;
with function Get_Key (E : Elmt_Ptr) return Key;
with function Hash (F : Key) return Header_Num;
with function Equal (F1, F2 : Key) return Boolean;
package Static_HTable is
procedure Reset;
-- Resets the hash table by setting all its elements to Null_Ptr. The
-- effect is to clear the hash table so that it can be reused. For the
-- most common case where Elmt_Ptr is an access type, and Null_Ptr is
-- null, this is only needed if the same table is reused in a new
-- context. If Elmt_Ptr is other than an access type, or Null_Ptr is
-- other than null, then Reset must be called before the first use
-- of the hash table.
procedure Set (E : Elmt_Ptr);
-- Insert the element pointer in the HTable
function Get (K : Key) return Elmt_Ptr;
-- Returns the latest inserted element pointer with the given Key
-- or null if none.
procedure Remove (K : Key);
-- Removes the latest inserted element pointer associated with the
-- given key if any, does nothing if none.
function Get_First return Elmt_Ptr;
-- Returns Null_Ptr if the Htable is empty, otherwise returns one
-- non specified element. There is no guarantee that 2 calls to this
-- function will return the same element.
function Get_Next return Elmt_Ptr;
-- Returns a non-specified element that has not been returned by the
-- same function since the last call to Get_First or Null_Ptr if
-- there is no such element or Get_First has bever been called. If
-- there is no call to 'Set' in between Get_Next calls, all the
-- elements of the Htable will be traversed.
end Static_HTable;
----------
-- Hash --
----------
-- A generic hashing function working on String keys
generic
type Header_Num is range <>;
function Hash (Key : String) return Header_Num;
end GNAT.HTable;
gcc/ada/g-io.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . I O --
-- --
-- B o d y --
-- --
-- $Revision: 1.12 $
-- --
-- Copyright (C) 1995-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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.IO is
Current_Out : File_Type := Stdout;
pragma Atomic (Current_Out);
-- Current output file (modified by Set_Output)
---------
-- Get --
---------
procedure Get (X : out Integer) is
function Get_Int return Integer;
pragma Import (C, Get_Int, "get_int");
begin
X := Get_Int;
end Get;
procedure Get (C : out Character) is
function Get_Char return Character;
pragma Import (C, Get_Char, "get_char");
begin
C := Get_Char;
end Get;
--------------
-- Get_Line --
--------------
procedure Get_Line (Item : in out String; Last : out Natural) is
C : Character;
begin
for Nstore in Item'Range loop
Get (C);
if C = ASCII.LF then
Last := Nstore - 1;
return;
else
Item (Nstore) := C;
end if;
end loop;
Last := Item'Last;
end Get_Line;
--------------
-- New_Line --
--------------
procedure New_Line (File : File_Type; Spacing : Positive := 1) is
begin
for J in 1 .. Spacing loop
Put (File, ASCII.LF);
end loop;
end New_Line;
procedure New_Line (Spacing : Positive := 1) is
begin
New_Line (Current_Out, Spacing);
end New_Line;
---------
-- Put --
---------
procedure Put (X : Integer) is
begin
Put (Current_Out, X);
end Put;
procedure Put (File : File_Type; X : Integer) is
procedure Put_Int (X : Integer);
pragma Import (C, Put_Int, "put_int");
procedure Put_Int_Stderr (X : Integer);
pragma Import (C, Put_Int_Stderr, "put_int_stderr");
begin
case File is
when Stdout => Put_Int (X);
when Stderr => Put_Int_Stderr (X);
end case;
end Put;
procedure Put (C : Character) is
begin
Put (Current_Out, C);
end Put;
procedure Put (File : in File_Type; C : Character) is
procedure Put_Char (C : Character);
pragma Import (C, Put_Char, "put_char");
procedure Put_Char_Stderr (C : Character);
pragma Import (C, Put_Char_Stderr, "put_char_stderr");
begin
case File is
when Stdout => Put_Char (C);
when Stderr => Put_Char_Stderr (C);
end case;
end Put;
procedure Put (S : String) is
begin
Put (Current_Out, S);
end Put;
procedure Put (File : File_Type; S : String) is
begin
for J in S'Range loop
Put (File, S (J));
end loop;
end Put;
--------------
-- Put_Line --
--------------
procedure Put_Line (S : String) is
begin
Put_Line (Current_Out, S);
end Put_Line;
procedure Put_Line (File : File_Type; S : String) is
begin
Put (File, S);
New_Line (File);
end Put_Line;
----------------
-- Set_Output --
----------------
procedure Set_Output (File : in File_Type) is
begin
Current_Out := File;
end Set_Output;
---------------------
-- Standard_Output --
---------------------
function Standard_Output return File_Type is
begin
return Stdout;
end Standard_Output;
--------------------
-- Standard_Error --
--------------------
function Standard_Error return File_Type is
begin
return Stderr;
end Standard_Error;
end GNAT.IO;
gcc/ada/g-io.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.10 $
-- --
-- Copyright (C) 1995-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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- A simple preelaborable subset of Text_IO capabilities
-- A simple text I/O package that can be used for simple I/O functions in
-- user programs as required. This package is also preelaborated, unlike
-- Text_Io, and can thus be with'ed by preelaborated library units.
-- Note that Data_Error is not raised by these subprograms for bad data.
-- If such checks are needed then the regular Text_IO package such be used.
package GNAT.IO is
pragma Preelaborate (IO);
type File_Type is limited private;
-- Specifies file to be used (the only possibilities are Standard_Output
-- and Standard_Error). There is no Create or Open facility that would
-- allow more general use of file names.
function Standard_Output return File_Type;
function Standard_Error return File_Type;
-- These functions are the only way to get File_Type values
procedure Get (X : out Integer);
procedure Get (C : out Character);
procedure Get_Line (Item : in out String; Last : out Natural);
-- These routines always read from Standard_Input
procedure Put (File : File_Type; X : Integer);
procedure Put (X : Integer);
-- Output integer to specified file, or to current output file, same
-- output as if Ada.Text_IO.Integer_IO had been instantiated for Integer.
procedure Put (File : File_Type; C : Character);
procedure Put (C : Character);
-- Output character to specified file, or to current output file
procedure Put (File : File_Type; S : String);
procedure Put (S : String);
-- Output string to specified file, or to current output file
procedure Put_Line (File : File_Type; S : String);
procedure Put_Line (S : String);
-- Output string followed by new line to specified file, or to
-- current output file.
procedure New_Line (File : File_Type; Spacing : Positive := 1);
procedure New_Line (Spacing : Positive := 1);
-- Output new line character to specified file, or to current output file
procedure Set_Output (File : File_Type);
-- Set current output file, default is Standard_Output if no call to
-- Set_Output is made.
private
type File_Type is (Stdout, Stderr);
-- Stdout = Standard_Output, Stderr = Standard_Error
pragma Inline (Standard_Error);
pragma Inline (Standard_Output);
end GNAT.IO;
gcc/ada/g-io_aux.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . I O _ A U X --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $
-- --
-- Copyright (C) 1995-2000 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Interfaces.C_Streams; use Interfaces.C_Streams;
package body GNAT.IO_Aux is
Buflen : constant := 2000;
-- Buffer length. Works for any non-zero value, larger values take
-- more stack space, smaller values require more recursion.
-----------------
-- File_Exists --
-----------------
function File_Exists (Name : String) return Boolean
is
Namestr : aliased String (1 .. Name'Length + 1);
-- Name as given with ASCII.NUL appended
begin
Namestr (1 .. Name'Length) := Name;
Namestr (Name'Length + 1) := ASCII.NUL;
return file_exists (Namestr'Address) /= 0;
end File_Exists;
--------------
-- Get_Line --
--------------
-- Current_Input case
function Get_Line return String is
Buffer : String (1 .. Buflen);
-- Buffer to read in chunks of remaining line. Will work with any
-- size buffer. We choose a length so that most of the time no
-- recursion will be required.
Last : Natural;
begin
Ada.Text_IO.Get_Line (Buffer, Last);
-- If the buffer is not full, then we are all done
if Last < Buffer'Last then
return Buffer (1 .. Last);
-- Otherwise, we still have characters left on the line. Note that
-- as specified by (RM A.10.7(19)) the end of line is not skipped
-- in this case, even if we are right at it now.
else
return Buffer & GNAT.IO_Aux.Get_Line;
end if;
end Get_Line;
-- Case of reading from a specified file. Note that we could certainly
-- share code between these two versions, but these are very short
-- routines, and we may as well aim for maximum speed, cutting out an
-- intermediate call (calls returning string may be somewhat slow)
function Get_Line (File : Ada.Text_IO.File_Type) return String is
Buffer : String (1 .. Buflen);
Last : Natural;
begin
Ada.Text_IO.Get_Line (File, Buffer, Last);
if Last < Buffer'Last then
return Buffer (1 .. Last);
else
return Buffer & Get_Line (File);
end if;
end Get_Line;
end GNAT.IO_Aux;
gcc/ada/g-io_aux.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . I O _ A U X --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1995-1998 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Auxiliary functions or use with Text_IO
-- This package provides some auxiliary functions for use with Text_IO,
-- including a test for an existing file, and a Get_Line function which
-- returns a string.
with Ada.Text_IO;
package GNAT.IO_Aux is
function File_Exists (Name : String) return Boolean;
-- Test for existence of a file named Name
function Get_Line return String;
-- Read Ada.Text_IO.Current_Input and return string that includes all
-- characters from the current character up to the end of the line,
-- with no limit on its length. Raises Ada.IO_Exceptions.End_Error if
-- at end of file.
function Get_Line (File : Ada.Text_IO.File_Type) return String;
-- Same, but reads from specified file
end GNAT.IO_Aux;
gcc/ada/g-locfil.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . L O C K _ F I L E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $
-- --
-- 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. --
-- --
-- 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System;
package body GNAT.Lock_Files is
Dir_Separator : Character;
pragma Import (C, Dir_Separator, "__gnat_dir_separator");
---------------
-- Lock_File --
---------------
procedure Lock_File
(Directory : String;
Lock_File_Name : String;
Wait : Duration := 1.0;
Retries : Natural := Natural'Last)
is
Dir : aliased String := Directory & ASCII.NUL;
File : aliased String := Lock_File_Name & ASCII.NUL;
function Try_Lock (Dir, File : System.Address) return Integer;
pragma Import (C, Try_Lock, "__gnat_try_lock");
begin
for I in 0 .. Retries loop
if Try_Lock (Dir'Address, File'Address) = 1 then
return;
end if;
exit when I = Retries;
delay Wait;
end loop;
raise Lock_Error;
end Lock_File;
---------------
-- Lock_File --
---------------
procedure Lock_File
(Lock_File_Name : String;
Wait : Duration := 1.0;
Retries : Natural := Natural'Last)
is
begin
for J in reverse Lock_File_Name'Range loop
if Lock_File_Name (J) = Dir_Separator then
Lock_File
(Lock_File_Name (Lock_File_Name'First .. J - 1),
Lock_File_Name (J + 1 .. Lock_File_Name'Last),
Wait,
Retries);
return;
end if;
end loop;
Lock_File (".", Lock_File_Name, Wait, Retries);
end Lock_File;
-----------------
-- Unlock_File --
-----------------
procedure Unlock_File (Lock_File_Name : String) is
S : aliased String := Lock_File_Name & ASCII.NUL;
procedure unlink (A : System.Address);
pragma Import (C, unlink, "unlink");
begin
unlink (S'Address);
end Unlock_File;
-----------------
-- Unlock_File --
-----------------
procedure Unlock_File (Directory : String; Lock_File_Name : String) is
begin
Unlock_File (Directory & Dir_Separator & Lock_File_Name);
end Unlock_File;
end GNAT.Lock_Files;
gcc/ada/g-locfil.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . L O C K _ F I L E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $
-- --
-- Copyright (C) 1995-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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains the necessary routines for using files for the
-- purpose of providing realiable system wide locking capability.
package GNAT.Lock_Files is
pragma Preelaborate;
Lock_Error : exception;
-- Exception raised if file cannot be locked
procedure Lock_File
(Directory : String;
Lock_File_Name : String;
Wait : Duration := 1.0;
Retries : Natural := Natural'Last);
-- Create a lock file Lock_File_Name in directory Directory. If the file
-- cannot be locked because someone already owns the lock, this procedure
-- waits Wait seconds and retries at most Retries times. If the file
-- still cannot be locked, Lock_Error is raised. The default is to try
-- every second, almost forever (Natural'Last times).
procedure Lock_File
(Lock_File_Name : String;
Wait : Duration := 1.0;
Retries : Natural := Natural'Last);
-- See above. The full lock file path is given as one string.
procedure Unlock_File (Directory : String; Lock_File_Name : String);
-- Unlock a file
procedure Unlock_File (Lock_File_Name : String);
-- Unlock a file whose full path is given in Lock_File_Name
end GNAT.Lock_Files;
gcc/ada/g-moreex.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . M O S T _ R E C E N T _ E X C E P T I O N --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 2000 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 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 Ada.Exceptions.Is_Null_Occurrence;
with System.Soft_Links;
package body GNAT.Most_Recent_Exception is
----------------
-- Occurrence --
----------------
function Occurrence
return Ada.Exceptions.Exception_Occurrence
is
EOA : constant Ada.Exceptions.Exception_Occurrence_Access :=
GNAT.Most_Recent_Exception.Occurrence_Access;
use type Ada.Exceptions.Exception_Occurrence_Access;
begin
if EOA = null then
return Ada.Exceptions.Null_Occurrence;
else
return EOA.all;
end if;
end Occurrence;
-----------------------
-- Occurrence_Access --
-----------------------
function Occurrence_Access
return Ada.Exceptions.Exception_Occurrence_Access
is
use Ada.Exceptions;
EOA : constant Exception_Occurrence_Access :=
System.Soft_Links.Get_Current_Excep.all;
begin
if EOA = null then
return null;
elsif Is_Null_Occurrence (EOA.all) then
return null;
else
return EOA;
end if;
end Occurrence_Access;
end GNAT.Most_Recent_Exception;
gcc/ada/g-moreex.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . M O S T _ R E C E N T _ E X C E P T I O N --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $
-- --
-- Copyright (C) 2000 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 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 routines for accessing the most recently raised
-- exception. This may be useful for certain logging activities. It may
-- also be useful for mimicing implementation dependent capabilities in
-- Ada 83 compilers, but see also GNAT.Current_Exceptions for this usage.
with Ada.Exceptions;
package GNAT.Most_Recent_Exception is
-----------------
-- Subprograms --
-----------------
function Occurrence
return Ada.Exceptions.Exception_Occurrence;
-- Returns the Exception_Occurrence for the most recently raised
-- exception in the current task. If no exception has been raised
-- in the current task prior to the call, returns Null_Occurrence.
function Occurrence_Access
return Ada.Exceptions.Exception_Occurrence_Access;
-- Similar to the above, but returns an access to the occurrence value.
-- This value is in a task specific location, and may be validly accessed
-- as long as no further exception is raised in the calling task.
-- Note: unlike the routines in GNAT.Current_Exception, these functions
-- access the most recently raised exception, regardless of where they
-- are called. Consider the following example:
-- exception
-- when Constraint_Error =>
-- begin
-- ...
-- exception
-- when Tasking_Error => ...
-- end;
--
-- -- Assuming a Tasking_Error was raised in the inner block,
-- -- a call to GNAT.Most_Recent_Exception.Occurrence will
-- -- return information about this Tasking_Error exception,
-- -- not about the Constraint_Error exception being handled
-- -- by the current handler code.
end GNAT.Most_Recent_Exception;
gcc/ada/g-regexp.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . R E G E X P --
-- --
-- S p e c --
-- --
-- $Revision: 1.12 $
-- --
-- Copyright (C) 1998-1999 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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Simple Regular expression matching
-- This package provides a simple implementation of a regular expression
-- pattern matching algorithm, using a subset of the syntax of regular
-- expressions copied from familiar Unix style utilities.
------------------------------------------------------------
-- Summary of Pattern Matching Packages in GNAT Hierarchy --
------------------------------------------------------------
-- There are three related packages that perform pattern maching functions.
-- the following is an outline of these packages, to help you determine
-- which is best for your needs.
-- GNAT.Regexp (files g-regexp.ads/g-regexp.adb)
-- This is a simple package providing Unix-style regular expression
-- matching with the restriction that it matches entire strings. It
-- is particularly useful for file name matching, and in particular
-- it provides "globbing patterns" that are useful in implementing
-- unix or DOS style wild card matching for file names.
-- GNAT.Regpat (files g-regpat.ads/g-regpat.adb)
-- This is a more complete implementation of Unix-style regular
-- expressions, copied from the original V7 style regular expression
-- library written in C by Henry Spencer. It is functionally the
-- same as this library, and uses the same internal data structures
-- stored in a binary compatible manner.
-- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb)
-- This is a completely general patterm matching package based on the
-- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern
-- language is modeled on context free grammars, with context sensitive
-- extensions that provide full (type 0) computational capabilities.
with Ada.Finalization;
package GNAT.Regexp is
-- The regular expression must first be compiled, using the Compile
-- function, which creates a finite state matching table, allowing
-- very fast matching once the expression has been compiled.
-- The following is the form of a regular expression, expressed in Ada
-- reference manual style BNF is as follows
-- regexp ::= term
-- regexp ::= term | term -- alternation (term or term ...)
-- term ::= item
-- term ::= item item ... -- concatenation (item then item)
-- item ::= elmt -- match elmt
-- item ::= elmt * -- zero or more elmt's
-- item ::= elmt + -- one or more elmt's
-- item ::= elmt ? -- matches elmt or nothing
-- elmt ::= nchr -- matches given character
-- elmt ::= [nchr nchr ...] -- matches any character listed
-- elmt ::= [^ nchr nchr ...] -- matches any character not listed
-- elmt ::= [char - char] -- matches chars in given range
-- elmt ::= . -- matches any single character
-- elmt ::= ( regexp ) -- parens used for grouping
-- char ::= any character, including special characters
-- nchr ::= any character except \()[].*+?^ or \char to match char
-- ... is used to indication repetition (one or more terms)
-- See also regexp(1) man page on Unix systems for further details
-- A second kind of regular expressions is provided. This one is more
-- like the wild card patterns used in file names by the Unix shell (or
-- DOS prompt) command lines. The grammar is the following:
-- regexp ::= term
-- term ::= elmt
-- term ::= elmt elmt ... -- concatenation (elmt then elmt)
-- term ::= * -- any string of 0 or more characters
-- term ::= ? -- matches any character
-- term ::= [char char ...] -- matches any character listed
-- term ::= [char - char] -- matches any character in given range
-- term ::= {elmt, elmt, ...} -- alternation (matches any of elmt)
-- Important note : This package was mainly intended to match regular
-- expressions against file names. The whole string has to match the
-- regular expression. If only a substring matches, then the function
-- Match will return False.
type Regexp is private;
-- Private type used to represent a regular expression
Error_In_Regexp : exception;
-- Exception raised when an error is found in the regular expression
function Compile
(Pattern : String;
Glob : Boolean := False;
Case_Sensitive : Boolean := True)
return Regexp;
-- Compiles a regular expression S. If the syntax of the given
-- expression is invalid (does not match above grammar, Error_In_Regexp
-- is raised. If Glob is True, the pattern is considered as a 'globbing
-- pattern', that is a pattern as given by the second grammar above
function Match (S : String; R : Regexp) return Boolean;
-- True if S matches R, otherwise False. Raises Constraint_Error if
-- R is an uninitialized regular expression value.
private
type Regexp_Value;
type Regexp_Access is access Regexp_Value;
type Regexp is new Ada.Finalization.Controlled with record
R : Regexp_Access := null;
end record;
pragma Finalize_Storage_Only (Regexp);
procedure Finalize (R : in out Regexp);
-- Free the memory occupied by R
procedure Adjust (R : in out Regexp);
-- Called after an assignment (do a copy of the Regexp_Access.all)
end GNAT.Regexp;
gcc/ada/g-regist.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . R E G I S T R Y --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- 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. --
-- --
-- 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- The registry is a Windows database to store key/value pair. It is used
-- to keep Windows operation system and applications configuration options.
-- The database is a hierarchal set of key and for each key a value can
-- be associated. This package provides high level routines to deal with
-- the Windows registry. For full registry API, but at a lower level of
-- abstraction, refer to the Win32.Winreg package provided with the
-- Win32Ada binding. For example this binding handle only key values of
-- type Standard.String.
-- This package is specific to the NT version of GNAT, and is not available
-- on any other platforms.
package GNAT.Registry is
type HKEY is private;
-- HKEY is a handle to a registry key, including standard registry keys:
-- HKEY_CLASSES_ROOT, HKEY_CURRENT_CONFIG, HKEY_CURRENT_USER,
-- HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_PERFORMANCE_DATA.
HKEY_CLASSES_ROOT : constant HKEY;
HKEY_CURRENT_USER : constant HKEY;
HKEY_CURRENT_CONFIG : constant HKEY;
HKEY_LOCAL_MACHINE : constant HKEY;
HKEY_USERS : constant HKEY;
HKEY_PERFORMANCE_DATA : constant HKEY;
type Key_Mode is (Read_Only, Read_Write);
-- Access mode for the registry key.
Registry_Error : exception;
-- Registry_Error is raises by all routines below if a problem occurs
-- (key cannot be opened, key cannot be found etc).
function Create_Key
(From_Key : HKEY;
Sub_Key : String;
Mode : Key_Mode := Read_Write)
return HKEY;
-- Open or create a key (named Sub_Key) in the Windows registry database.
-- The key will be created under key From_Key. It returns the key handle.
-- From_Key must be a valid handle to an already opened key or one of
-- the standard keys identified by HKEY declarations above.
function Open_Key
(From_Key : HKEY;
Sub_Key : String;
Mode : Key_Mode := Read_Only)
return HKEY;
-- Return a registry key handle for key named Sub_Key opened under key
-- From_Key. It is possible to open a key at any level in the registry
-- tree in a single call to Open_Key.
procedure Close_Key (Key : HKEY);
-- Close registry key handle. All resources used by Key are released.
function Key_Exists (From_Key : HKEY; Sub_Key : String) return Boolean;
-- Returns True if Sub_Key is defined under From_Key in the registry.
function Query_Value (From_Key : HKEY; Sub_Key : String) return String;
-- Returns the registry key's value associated with Sub_Key in From_Key
-- registry key.
procedure Set_Value (From_Key : HKEY; Sub_Key : String; Value : String);
-- Add the pair (Sub_Key, Value) into From_Key registry key.
procedure Delete_Key (From_Key : HKEY; Sub_Key : String);
-- Remove Sub_Key from the registry key From_Key.
procedure Delete_Value (From_Key : HKEY; Sub_Key : String);
-- Remove the named value Sub_Key from the registry key From_Key.
generic
with procedure Action
(Index : Positive;
Sub_Key : String;
Value : String;
Quit : in out Boolean);
procedure For_Every_Key_Value (From_Key : HKEY);
-- Iterates over all the pairs (Sub_Key, Value) registered under
-- From_Key. Index will be set to 1 for the first key and will be
-- incremented by one in each iteration. Quit can be set to True to
-- stop iteration; its initial value is False.
--
-- Key value that are not of type string are skipped. In this case, the
-- iterator behaves exactly as if the key was not present. Note that you
-- must use the Win32.Winreg API to deal with this case.
private
type HKEY is mod 2 ** Integer'Size;
HKEY_CLASSES_ROOT : constant HKEY := 16#80000000#;
HKEY_CURRENT_USER : constant HKEY := 16#80000001#;
HKEY_LOCAL_MACHINE : constant HKEY := 16#80000002#;
HKEY_USERS : constant HKEY := 16#80000003#;
HKEY_PERFORMANCE_DATA : constant HKEY := 16#80000004#;
HKEY_CURRENT_CONFIG : constant HKEY := 16#80000005#;
end GNAT.Registry;
gcc/ada/g-regpat.adb 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/g-spipat.adb 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/gigi.h 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/gmem.c 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/gnatcmd.adb 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/hlo.adb 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/hlo.ads 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/i-c.adb 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/i-c.ads 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/init.c 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/lib.adb 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/lib.ads 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/link.c 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/namet.h 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/opt.adb 0 → 100644
This diff is collapsed. Click to expand it.
gcc/ada/opt.ads 0 → 100644
This diff is collapsed. Click to expand it.
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