-- --
------------------------------------------------------------------------------
--- This is the Alpha/VMS version.
+-- This is the Alpha/VMS version
with System.OS_Primitives;
-- Used for Max_Sensible_Delay
-- --
------------------------------------------------------------------------------
--- This package implements Calendar.Time delays using protected objects.
+-- This package implements Calendar.Time delays using protected objects
-- Note: the compiler generates direct calls to this interface, in the
-- processing of time types.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
-- --
------------------------------------------------------------------------------
--- This is the Alpha/VMS version.
+-- This is the Alpha/VMS version
with System.Aux_DEC; use System.Aux_DEC;
-- --
------------------------------------------------------------------------------
--- This is the Alpha/VMS version.
+-- This is the Alpha/VMS version
with System.OS_Primitives;
package Ada.Calendar is
Index_As_Int : constant Int := Int (Index);
Old_Last_As_Int : constant Int := Int (Container.Last);
- -- TODO: somewhat vestigial...fix.
+ -- TODO: somewhat vestigial...fix ???
Count1 : constant Int'Base := Int (Count);
Count2 : constant Int'Base := Old_Last_As_Int - Index_As_Int + 1;
N : constant Int'Base := Int'Min (Count1, Count2);
procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
function File_Exists (Name : String) return Boolean;
- -- Returns True if the named file exists.
+ -- Returns True if the named file exists
procedure Fetch_Next_Entry (Search : Search_Type);
-- Get the next entry in a directory, setting Entry_Fetched if successful
then
raise Name_Error;
- -- This is not an invalid case. Build the path name.
+ -- This is not an invalid case so build the path name
else
Last := Containing_Directory'Length;
Zeroes : constant System.Storage_Elements.Storage_Array :=
(1 .. System.Storage_Elements.Storage_Offset (Bytes) => 0);
- -- Buffer used to fill out partial records.
+ -- Buffer used to fill out partial records
package FCB renames System.File_Control_Block;
package FIO renames System.File_IO;
-- B o d y --
-- (Windows Version) --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 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- --
end if;
end loop;
- -- If no invalid chars, and not all spaces, file name is valid.
+ -- If no invalid chars, and not all spaces, file name is valid
return not Only_Spaces;
end if;
-- --
------------------------------------------------------------------------------
--- This is a HP-UX version of this package.
+-- This is a HP-UX version of this package
-- The following signals are reserved by the run time:
SIGUME : constant Interrupt_ID :=
System.OS_Interface.SIGUME; -- Uncorrectable memory error
- -- Signals defined for Posix 1003.1c.
+ -- Signals defined for Posix 1003.1c
SIGPTINTR : constant Interrupt_ID :=
System.OS_Interface.SIGPTINTR; -- Pthread Interrupt Signal
-- --
------------------------------------------------------------------------------
--- This is a NT (native) version of this package.
+-- This is a NT (native) version of this package
--- This target-dependent package spec contains names of interrupts
--- supported by the local system.
+-- This target-dependent package spec contains names of interrupts supported
+-- by the local system.
with System.OS_Interface;
-- used for names of interrupts
-- --
------------------------------------------------------------------------------
--- This is an OS/2 version of this package.
+-- This is an OS/2 version of this package
-- This target-dependent package spec contains names of interrupts
-- supported by the local system.
-- --
------------------------------------------------------------------------------
--- This is the VxWorks version of this package.
+-- This is the VxWorks version of this package
with System.OS_Interface;
subtype Hardware_Interrupts is Interrupt_ID
range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt;
- -- Range of values that can be used for hardware interrupts.
+ -- Range of values that can be used for hardware interrupts
end Ada.Interrupts.Names;
Result_Index := Result_Index + Count - 1;
- -- Last + 1 was a ')' throw it away too.
+ -- Last + 1 was a ')' throw it away too
Picture_Index := Last + 2;
In_Currency : Boolean := False;
Dollar : Boolean := False;
- -- Overridden immediately if necessary.
+ -- Overridden immediately if necessary
Zero : Boolean := True;
- -- Set to False when a non-zero digit is output.
+ -- Set to False when a non-zero digit is output
begin
for J in reverse Last .. Answer'Last loop
exit when J = Pic.Radix_Position;
- -- Do this test First, Separator_Character can equal Pic.Floater.
+ -- Do this test First, Separator_Character can equal Pic.Floater
if Answer (J) = Pic.Floater then
exit;
end case;
end loop;
- -- Now get rid of Blank_when_Zero and complete Star fill.
+ -- Now get rid of Blank_when_Zero and complete Star fill
if Zero and Pic.Blank_When_Zero then
- -- Value is zero, and blank it.
+ -- Value is zero, and blank it
Last := Answer'Last;
raise Picture_Error;
end if;
- -- Two decimal points is a no-no.
+ -- Two decimal points is a no-no
Answer.Has_Fraction := True;
Answer.End_Of_Fraction := J;
Answer.Start_Of_Int := Answer.End_Of_Int + 1;
end if;
- -- No significant (intger) digits needs a null range.
+ -- No significant (integer) digits needs a null range
return Answer;
end Parse_Number_String;
type Legality is (Okay, Reject);
State : Legality := Reject;
- -- Start in reject, which will reject null strings.
+ -- Start in reject, which will reject null strings
Index : Pic_Index := Pic.Picture.Expanded'First;
begin
Debug_Start ("Floating_Bracket");
- -- Two different floats not allowed.
+ -- Two different floats not allowed
if Pic.Floater /= '!' and then Pic.Floater /= '<' then
raise Picture_Error;
raise Picture_Error;
else
-- Overwrite Floater and Start_Float
+
Pic.Floater := '*';
Pic.Start_Float := Index;
Star_Suppression;
Pic.End_Float := Invalid_Position;
end if;
- -- A single dollar does not a floating make.
+ -- A single dollar does not a floating make
Number_Completion;
return;
Pic.End_Float := Invalid_Position;
end if;
- -- Only one dollar before the sign is okay,
- -- but doesn't float.
+ -- Only one dollar before the sign is okay, but doesn't
+ -- float.
Pic.Radix_Position := Index;
Skip;
-- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
Must_Float : Boolean := False;
- -- Set to true if a '#' occurs after an insert.
+ -- Set to true if a '#' occurs after an insert
begin
Debug_Start ("Leading_Pound");
when '9' =>
if State /= Okay then
- -- A single '#' doesn't float.
+ -- A single '#' doesn't float
Pic.Floater := '!';
Pic.Start_Float := Invalid_Position;
Pic.End_Float := Invalid_Position;
end if;
- -- Only one pound before the sign is okay,
- -- but doesn't float.
+ -- Only one pound before the sign is okay, but doesn't
+ -- float.
Pic.Radix_Position := Index;
Skip;
return;
end if;
- -- Will return in Okay state if a '9' was seen.
+ -- Will return in Okay state if a '9' was seen
end loop;
end Number;
-- Picture --
-------------
- -- Note that Picture can be called in either State.
+ -- Note that Picture can be called in either State
-- It will set state to Valid only if a 9 is encountered or floating
-- currency is called.
Debug_Start ("Picture_Bracket");
Pic.Sign_Position := Index;
- -- Treat as a floating sign, and unwind otherwise.
+ -- Treat as a floating sign, and unwind otherwise
Pic.Floater := '<';
Pic.Start_Float := Index;
Pic.Sign_Position := Index;
- -- Treat as a floating sign, and unwind otherwise.
+ -- Treat as a floating sign, and unwind otherwise
Pic.Floater := '-';
Pic.Start_Float := Index;
when 'Z' | 'z' =>
- -- Can't have Z and a floating sign.
+ -- Can't have Z and a floating sign
if State = Okay then
Set_State (Reject);
Pic.End_Float := Invalid_Position;
end if;
- -- Don't assume that state is okay, haven't seen a digit.
+ -- Don't assume that state is okay, haven't seen a digit
Picture;
return;
Debug_Start ("Picture_Plus");
Pic.Sign_Position := Index;
- -- Treat as a floating sign, and unwind otherwise.
+ -- Treat as a floating sign, and unwind otherwise
Pic.Floater := '+';
Pic.Start_Float := Index;
Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
Pic.End_Float := Index;
Skip;
- Set_State (Okay); -- "++" is enough.
+ Set_State (Okay); -- "++" is enough
Floating_Plus;
Trailing_Currency;
return;
Set_State (Reject);
end if;
- -- Can't have Z and a floating sign.
+ -- Can't have Z and a floating sign
Pic.Picture.Expanded (Index) := 'Z'; -- consistency
Pic.End_Float := Invalid_Position;
end if;
- -- Don't assume that state is okay, haven't seen a digit.
+ -- Don't assume that state is okay, haven't seen a digit
Picture;
return;
end case;
-- Blank when zero either if the PIC does not contain a '9' or if
- -- requested by the user and no '*'
+ -- requested by the user and no '*'.
Pic.Blank_When_Zero :=
(Computed_BWZ or Pic.Blank_When_Zero) and not Pic.Star_Fill;
- -- Star fill if '*' and no '9'.
+ -- Star fill if '*' and no '9'
Pic.Star_Fill := Pic.Star_Fill and Computed_BWZ;
when Constraint_Error =>
- -- To deal with special cases like null strings.
+ -- To deal with special cases like null strings
raise Picture_Error;
end Precalculate;
-- Fore + Aft + Exp + Extra_Layout_Space
- -- is always long enough for formatting any fixed point number.
+ -- is always long enough for formatting any fixed point number
-- Implementation of Put routines
-- least 20 in order to print T'First, which is at most -2.0**63.
-- This means D < 0, so use
- -- (1) Y = -S and Z = -10**(-D).
+ -- (1) Y = -S and Z = -10**(-D)
-- If 1.0 / S is an integer greater than one, use
Result_Index := Result_Index + Count - 1;
- -- Last was a ')' throw it away too.
+ -- Last was a ')' throw it away too
Picture_Index := Last + 1;
Currency_Pos : Integer := Pic.Start_Currency;
Dollar : Boolean := False;
- -- Overridden immediately if necessary.
+ -- Overridden immediately if necessary
Zero : Boolean := True;
- -- Set to False when a non-zero digit is output.
+ -- Set to False when a non-zero digit is output
begin
end case;
end loop;
- -- Now get rid of Blank_when_Zero and complete Star fill.
+ -- Now get rid of Blank_when_Zero and complete Star fill
if Zero and Pic.Blank_When_Zero then
- -- Value is zero, and blank it.
+ -- Value is zero, and blank it
Last := Answer'Last;
raise Picture_Error;
end if;
- -- Two decimal points is a no-no.
+ -- Two decimal points is a no-no
Answer.Has_Fraction := True;
Answer.End_Of_Fraction := J;
Answer.Start_Of_Int := Answer.End_Of_Int + 1;
end if;
- -- No significant (intger) digits needs a null range.
+ -- No significant (intger) digits needs a null range
return Answer;
end Parse_Number_String;
type Legality is (Okay, Reject);
State : Legality := Reject;
- -- Start in reject, which will reject null strings.
+ -- Start in reject, which will reject null strings
Index : Pic_Index := Pic.Picture.Expanded'First;
procedure Leading_Dollar is
begin
- -- Treat as a floating dollar, and unwind otherwise.
+ -- Treat as a floating dollar, and unwind otherwise
Pic.Floater := '$';
Pic.Start_Currency := Index;
Pic.End_Float := Invalid_Position;
end if;
- -- A single dollar does not a floating make.
+ -- A single dollar does not a floating make
Number_Completion;
return;
Pic.End_Float := Invalid_Position;
end if;
- -- Only one dollar before the sign is okay,
- -- but doesn't float.
+ -- Only one dollar before the sign is okay, but doesn't
+ -- float.
Pic.Radix_Position := Index;
Skip;
-- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
Must_Float : Boolean := False;
- -- Set to true if a '#' occurs after an insert.
+ -- Set to true if a '#' occurs after an insert
begin
-- Treat as a floating currency. If it isn't, this will be
when '9' =>
if State /= Okay then
- -- A single '#' doesn't float.
+ -- A single '#' doesn't float
Pic.Floater := '!';
Pic.Start_Float := Invalid_Position;
Pic.End_Float := Invalid_Position;
end if;
- -- Only one pound before the sign is okay,
- -- but doesn't float.
+ -- Only one pound before the sign is okay, but doesn't
+ -- float.
Pic.Radix_Position := Index;
Skip;
return;
end if;
- -- Will return in Okay state if a '9' was seen.
+ -- Will return in Okay state if a '9' was seen
end loop;
end Number;
-- Picture --
-------------
- -- Note that Picture can be called in either State.
+ -- Note that Picture can be called in either State
-- It will set state to Valid only if a 9 is encountered or floating
-- currency is called.
Pic.Sign_Position := Index;
Pic.Sign_Position := Index;
- -- Treat as a floating sign, and unwind otherwise.
+ -- Treat as a floating sign, and unwind otherwise
Pic.Floater := '<';
Pic.Start_Float := Index;
begin
Pic.Sign_Position := Index;
- -- Treat as a floating sign, and unwind otherwise.
+ -- Treat as a floating sign, and unwind otherwise
Pic.Floater := '-';
Pic.Start_Float := Index;
Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
Pic.End_Float := Index;
Skip;
- Set_State (Okay); -- "-- " is enough.
+ Set_State (Okay); -- "-- " is enough
Floating_Minus;
Trailing_Currency;
return;
when 'Z' | 'z' =>
- -- Can't have Z and a floating sign.
+ -- Can't have Z and a floating sign
if State = Okay then
Set_State (Reject);
Pic.End_Float := Invalid_Position;
end if;
- -- Don't assume that state is okay, haven't seen a digit.
+ -- Don't assume that state is okay, haven't seen a digit
Picture;
return;
begin
Pic.Sign_Position := Index;
- -- Treat as a floating sign, and unwind otherwise.
+ -- Treat as a floating sign, and unwind otherwise
Pic.Floater := '+';
Pic.Start_Float := Index;
Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
Pic.End_Float := Index;
Skip;
- Set_State (Okay); -- "++" is enough.
+ Set_State (Okay); -- "++" is enough
Floating_Plus;
Trailing_Currency;
return;
Set_State (Reject);
end if;
- -- Can't have Z and a floating sign.
+ -- Can't have Z and a floating sign
Pic.Picture.Expanded (Index) := 'Z'; -- consistency
Pic.End_Float := Invalid_Position;
end if;
- -- Don't assume that state is okay, haven't seen a digit.
+ -- Don't assume that state is okay, haven't seen a digit
Picture;
return;
Pic.Blank_When_Zero :=
(Computed_BWZ or Pic.Blank_When_Zero) and not Pic.Star_Fill;
- -- Star fill if '*' and no '9'.
+ -- Star fill if '*' and no '9'
Pic.Star_Fill := Pic.Star_Fill and Computed_BWZ;
when Constraint_Error =>
- -- To deal with special cases like null strings.
+ -- To deal with special cases like null strings
raise Picture_Error;
-----------------------
procedure Store_Char
- (WC : Wide_Character;
- Buf : out Wide_String;
- Ptr : in out Integer);
- -- Store a single character in buffer, checking for overflow.
+ (WC : Wide_Character;
+ Buf : out Wide_String;
+ Ptr : in out Integer);
+ -- Store a single character in buffer, checking for overflow
-- These definitions replace the ones in Ada.Characters.Handling, which
-- do not seem to work for some strange not understood reason ??? at
----------------
procedure Store_Char
- (WC : Wide_Character;
- Buf : out Wide_String;
- Ptr : in out Integer)
+ (WC : Wide_Character;
+ Buf : out Wide_String;
+ Ptr : in out Integer)
is
begin
if Ptr = Buf'Last then
Result_Index := Result_Index + Count - 1;
- -- Last was a ')' throw it away too.
+ -- Last was a ')' throw it away too
Picture_Index := Last + 1;
Currency_Pos : Integer := Pic.Start_Currency;
Dollar : Boolean := False;
- -- Overridden immediately if necessary.
+ -- Overridden immediately if necessary
Zero : Boolean := True;
- -- Set to False when a non-zero digit is output.
+ -- Set to False when a non-zero digit is output
begin
end case;
end loop;
- -- Now get rid of Blank_when_Zero and complete Star fill.
+ -- Now get rid of Blank_when_Zero and complete Star fill
if Zero and Pic.Blank_When_Zero then
- -- Value is zero, and blank it.
+ -- Value is zero, and blank it
Last := Answer'Last;
raise Picture_Error;
end if;
- -- Two decimal points is a no-no.
+ -- Two decimal points is a no-no
Answer.Has_Fraction := True;
Answer.End_Of_Fraction := J;
Answer.Start_Of_Int := Answer.End_Of_Int + 1;
end if;
- -- No significant (intger) digits needs a null range.
+ -- No significant (intger) digits needs a null range
return Answer;
end Parse_Number_String;
type Legality is (Okay, Reject);
State : Legality := Reject;
- -- Start in reject, which will reject null strings.
+ -- Start in reject, which will reject null strings
Index : Pic_Index := Pic.Picture.Expanded'First;
-- Leading_Dollar --
--------------------
- -- Note that Leading_Dollar can be called in either State.
- -- It will set state to Okay only if a 9 or (second) $
- -- is encountered.
+ -- Note that Leading_Dollar can be called in either State. It will set
+ -- state to Okay only if a 9 or (second) is encountered.
-- Also notice the tricky bit with State and Zero_Suppression.
-- Zero_Suppression is Picture_Error if a '$' or a '9' has been
procedure Leading_Dollar is
begin
- -- Treat as a floating dollar, and unwind otherwise.
+ -- Treat as a floating dollar, and unwind otherwise
Pic.Floater := '$';
Pic.Start_Currency := Index;
Pic.End_Float := Invalid_Position;
end if;
- -- A single dollar does not a floating make.
+ -- A single dollar does not a floating make
Number_Completion;
return;
Pic.End_Float := Invalid_Position;
end if;
- -- Only one dollar before the sign is okay,
- -- but doesn't float.
+ -- Only one dollar before the sign is okay, but doesn't
+ -- float.
Pic.Radix_Position := Index;
Skip;
-- this procedure. Also note that Leading_Pound can be called in
-- either State.
- -- It will set state to Okay only if a 9 or (second) # is
- -- encountered.
+ -- It will set state to Okay only if a 9 or (second) # is encountered
-- One Last note: In ambiguous cases, the currency is treated as
-- floating unless there is only one '#'.
-- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
Must_Float : Boolean := False;
- -- Set to true if a '#' occurs after an insert.
+ -- Set to true if a '#' occurs after an insert
begin
-- Treat as a floating currency. If it isn't, this will be
when '9' =>
if State /= Okay then
- -- A single '#' doesn't float.
+ -- A single '#' doesn't float
Pic.Floater := '!';
Pic.Start_Float := Invalid_Position;
Pic.End_Float := Invalid_Position;
end if;
- -- Only one pound before the sign is okay,
- -- but doesn't float.
+ -- Only one pound before the sign is okay, but doesn't
+ -- float.
Pic.Radix_Position := Index;
Skip;
return;
end if;
- -- Will return in Okay state if a '9' was seen.
+ -- Will return in Okay state if a '9' was seen
end loop;
end Number;
-- Picture --
-------------
- -- Note that Picture can be called in either State.
+ -- Note that Picture can be called in either State
-- It will set state to Valid only if a 9 is encountered or floating
-- currency is called.
Pic.Sign_Position := Index;
Pic.Sign_Position := Index;
- -- Treat as a floating sign, and unwind otherwise.
+ -- Treat as a floating sign, and unwind otherwise
Pic.Floater := '<';
Pic.Start_Float := Index;
begin
Pic.Sign_Position := Index;
- -- Treat as a floating sign, and unwind otherwise.
+ -- Treat as a floating sign, and unwind otherwise
Pic.Floater := '-';
Pic.Start_Float := Index;
when 'Z' | 'z' =>
- -- Can't have Z and a floating sign.
+ -- Can't have Z and a floating sign
if State = Okay then
Set_State (Reject);
Pic.End_Float := Invalid_Position;
end if;
- -- Don't assume that state is okay, haven't seen a digit.
+ -- Don't assume that state is okay, haven't seen a digit
Picture;
return;
begin
Pic.Sign_Position := Index;
- -- Treat as a floating sign, and unwind otherwise.
+ -- Treat as a floating sign, and unwind otherwise
Pic.Floater := '+';
Pic.Start_Float := Index;
Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
Pic.End_Float := Index;
Skip;
- Set_State (Okay); -- "++" is enough.
+ Set_State (Okay); -- "++" is enough
Floating_Plus;
Trailing_Currency;
return;
Set_State (Reject);
end if;
- -- Can't have Z and a floating sign.
+ -- Can't have Z and a floating sign
Pic.Picture.Expanded (Index) := 'Z'; -- consistency
Pic.End_Float := Invalid_Position;
end if;
- -- Don't assume that state is okay, haven't seen a digit.
+ -- Don't assume that state is okay, haven't seen a digit
Picture;
return;
Pic.Blank_When_Zero :=
(Computed_BWZ or Pic.Blank_When_Zero) and not Pic.Star_Fill;
- -- Star fill if '*' and no '9'.
+ -- Star fill if '*' and no '9'
Pic.Star_Fill := Pic.Star_Fill and Computed_BWZ;
when Constraint_Error =>
- -- To deal with special cases like null strings.
+ -- To deal with special cases like null strings
raise Picture_Error;
-----------------------
procedure Store_Char
- (WC : Wide_Wide_Character;
- Buf : out Wide_Wide_String;
- Ptr : in out Integer);
- -- Store a single character in buffer, checking for overflow.
+ (WC : Wide_Wide_Character;
+ Buf : out Wide_Wide_String;
+ Ptr : in out Integer);
+ -- Store a single character in buffer, checking for overflow
-- These definitions replace the ones in Ada.Characters.Handling, which
-- do not seem to work for some strange not understood reason ??? at
----------------
procedure Store_Char
- (WC : Wide_Wide_Character;
- Buf : out Wide_Wide_String;
- Ptr : in out Integer)
+ (WC : Wide_Wide_Character;
+ Buf : out Wide_Wide_String;
+ Ptr : in out Integer)
is
begin
if Ptr = Buf'Last then
-- Make an entry in the names table for Nam, and set as Chars field of Id
function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id;
- -- Build entity for standard operator with given name and type.
+ -- Build entity for standard operator with given name and type
function New_Standard_Entity
(New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id;
Set_Is_Known_Valid (Standard_Character);
Set_Size_Known_At_Compile_Time (Standard_Character);
- -- Create the bounds for type Character.
+ -- Create the bounds for type Character
R_Node := New_Node (N_Range, Stloc);
Set_Is_Known_Valid (Standard_Wide_Character);
Set_Size_Known_At_Compile_Time (Standard_Wide_Character);
- -- Create the bounds for type Wide_Character.
+ -- Create the bounds for type Wide_Character
R_Node := New_Node (N_Range, Stloc);
(Standard_Exception_Type, True);
Make_Name (Standard_Exception_Type, "exception");
- Make_Component (Standard_Exception_Type, Standard_Boolean,
- "Not_Handled_By_Others");
- Make_Component (Standard_Exception_Type, Standard_Character, "Lang");
- Make_Component (Standard_Exception_Type, Standard_Natural,
- "Name_Length");
- Make_Component (Standard_Exception_Type, Standard_A_Char,
- "Full_Name");
- Make_Component (Standard_Exception_Type, Standard_A_Char,
- "HTable_Ptr");
- Make_Component (Standard_Exception_Type, Standard_Unsigned,
- "Import_Code");
- Make_Component (Standard_Exception_Type, Standard_A_Char,
- "Raise_Hook");
- -- Build tree for record declaration, for use by the back-end.
+ Make_Component
+ (Standard_Exception_Type, Standard_Boolean, "Not_Handled_By_Others");
+ Make_Component
+ (Standard_Exception_Type, Standard_Character, "Lang");
+ Make_Component
+ (Standard_Exception_Type, Standard_Natural, "Name_Length");
+ Make_Component
+ (Standard_Exception_Type, Standard_A_Char, "Full_Name");
+ Make_Component
+ (Standard_Exception_Type, Standard_A_Char, "HTable_Ptr");
+ Make_Component
+ (Standard_Exception_Type, Standard_Unsigned, "Import_Code");
+ Make_Component
+ (Standard_Exception_Type, Standard_A_Char, "Raise_Hook");
+
+ -- Build tree for record declaration, for use by the back-end
declare
Comp_List : List_Id;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
New_Occurrence_Of (Rnd, Loc))));
end if;
- -- Set type of result, for use in caller.
+ -- Set type of result, for use in caller
Set_Etype (Qnn, QR_Typ);
end Build_Scaled_Divide_Code;
-- is an integer or the reciprocal of an integer, and for
-- implementation efficiency we need the smallest such K.
- -- First we reduce the left fraction to lowest terms.
+ -- First we reduce the left fraction to lowest terms
-- If numerator = 1, then for K = 1, the small ratio is the reciprocal
-- of an integer, and this is clearly the minimum K case, so set K = 1,
-- is an integer or the reciprocal of an integer, and for
-- implementation efficiency we need the smallest such K.
- -- First we reduce the left fraction to lowest terms.
+ -- First we reduce the left fraction to lowest terms
-- If denominator = 1, then for K = 1, the small ratio is an integer
-- (the numerator) and this is clearly the minimum K case, so set K = 1,
-- is an integer or the reciprocal of an integer, and for
-- implementation efficiency we need the smallest such K.
- -- First we reduce the left fraction to lowest terms.
+ -- First we reduce the left fraction to lowest terms
- -- If denominator = 1, then for K = 1, the small ratio is an
- -- integer, and this is clearly the minimum K case, so set
- -- K = 1, Right_Small = Lit_Value.
+ -- If denominator = 1, then for K = 1, the small ratio is an integer, and
+ -- this is clearly the minimum K case, so set
- -- If denominator > 1, then set K to the numerator of the
- -- fraction, so that the resulting small ratio is the
- -- reciprocal of the integer (the denominator value).
+ -- K = 1, Right_Small = Lit_Value.
+
+ -- If denominator > 1, then set K to the numerator of the fraction, so
+ -- that the resulting small ratio is the reciprocal of the integer (the
+ -- denominator value).
procedure Do_Multiply_Fixed_Universal
(N : Node_Id;
procedure Build_Full_Name
(E : in Entity_Id;
N : out String_Id);
- -- Build the fully qualified string name of a shared variable.
+ -- Build the fully qualified string name of a shared variable
function On_Lhs_Of_Assignment (N : Node_Id) return Boolean;
-- Determines if N is on the left hand of the assignment. This means
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2005 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- --
function Count
(Source : Element_Sequence;
- Pattern : Element_Set)
- return Natural;
+ Pattern : Element_Set) return Natural;
-- Returns the number of occurences of Pattern elements in Source, 0 is
-- returned if no occurence is found in Source.
function Count
(Source : Element_Sequence;
- Pattern : Element_Set)
- return Natural
+ Pattern : Element_Set) return Natural
is
C : Natural := 0;
begin
function Separators
(S : Slice_Set;
- Index : Slice_Number)
- return Slice_Separators
+ Index : Slice_Number) return Slice_Separators
is
begin
if Index > S.N_Slice then
elsif Index = 0
or else (Index = 1 and then S.N_Slice = 1)
then
- -- Whole string, or no separator used.
+ -- Whole string, or no separator used
return (Before => Array_End,
After => Array_End);
loop
if K > Count_Sep then
- -- No more separator, last slice end at the end of the source
+
+ -- No more separators, last slice ends at the end of the source
-- string.
+
Stop := S.Source'Last;
else
Stop := S.Indexes (K) - 1;
case Mode is
when Single =>
+
-- In this mode just set start to character next to the
-- current separator, advance the separator index.
+
Start := S.Indexes (K) + 1;
K := K + 1;
when Multiple =>
- -- In this mode skip separators following each others
+
+ -- In this mode skip separators following each other
+
loop
Start := S.Indexes (K) + 1;
K := K + 1;
function Slice
(S : Slice_Set;
- Index : Slice_Number)
- return Element_Sequence
+ Index : Slice_Number) return Element_Sequence
is
begin
if Index = 0 then
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2005 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- --
-- Element of the array, this must be a discrete type
type Element_Sequence is array (Positive range <>) of Element;
- -- The array which is a sequence of element.
+ -- The array which is a sequence of element
type Element_Set is private;
-- This type represent a set of elements. This set does not defined a
function Slice
(S : Slice_Set;
- Index : Slice_Number)
- return Element_Sequence;
+ Index : Slice_Number) return Element_Sequence;
pragma Inline (Slice);
-- Returns the slice at position Index. First slice is 1. If Index is 0
-- the whole array is returned including the separators (this is the
function Separators
(S : Slice_Set;
- Index : Slice_Number)
- return Slice_Separators;
+ Index : Slice_Number) return Slice_Separators;
-- Returns the separators used to slice (front and back) the slice at
-- position Index. For slices at start and end of the original array, the
-- Array_End value is returned for the corresponding outer bound. In
Start : Positive;
Stop : Natural;
end record;
- -- Starting/Ending position of a slice. This does not include separators.
+ -- Starting/Ending position of a slice. This does not include separators
type Slices_Indexes is array (Slice_Number range <>) of Slice_Info;
type Slices_Access is access Slices_Indexes;
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2005 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- --
procedure Current_Line (S : Mode; Session : Session_Type)
is abstract;
- -- Split Session's current line using split mode.
+ -- Split current line of Session using split mode S
------------------------
-- Split on separator --
package File_Table is
new Dynamic_Tables (AWK_File, Natural, 1, 5, 50);
- -- List of filename associated with a Session.
+ -- List of file names associated with a Session
procedure Free is new Unchecked_Deallocation (String, AWK_File);
First : Positive;
Last : Natural;
end record;
- -- This is a field slice (First .. Last) in session's current line.
+ -- This is a field slice (First .. Last) in session's current line
package Field_Table is
new Dynamic_Tables (Field_Slice, Natural, 1, 10, 100);
- -- List of fields for the current line.
+ -- List of fields for the current line
--------------
-- Patterns --
--------------
- -- Define all patterns style : exact string, regular expression, boolean
+ -- Define all patterns style: exact string, regular expression, boolean
-- function.
package Patterns is
function Match
(P : Pattern;
- Session : Session_Type)
- return Boolean
+ Session : Session_Type) return Boolean
is abstract;
- -- Returns True if P match for the current session and False otherwise.
+ -- Returns True if P match for the current session and False otherwise
procedure Release (P : in out Pattern);
- -- Release memory used by the pattern structure.
+ -- Release memory used by the pattern structure
--------------------------
-- Exact string pattern --
function Match
(P : String_Pattern;
- Session : Session_Type)
- return Boolean;
+ Session : Session_Type) return Boolean;
--------------------------------
-- Regular expression pattern --
function Match
(P : Regexp_Pattern;
- Session : Session_Type)
- return Boolean;
+ Session : Session_Type) return Boolean;
procedure Release (P : in out Regexp_Pattern);
function Match
(P : Callback_Pattern;
- Session : Session_Type)
- return Boolean;
+ Session : Session_Type) return Boolean;
end Patterns;
procedure Call
(A : Action;
- Session : Session_Type)
- is abstract;
- -- Call action A as required.
+ Session : Session_Type) is abstract;
+ -- Call action A as required
-------------------
-- Simple action --
procedure Finalize (Session : in out Session_Type) is
begin
- -- We release the session data only if it is not the default session.
+ -- We release the session data only if it is not the default session
if Session.Data /= Def_Session.Data then
Free (Session.Data);
- -- Since we have closed the current session, set it to point
- -- now to the default session.
+ -- Since we have closed the current session, set it to point now to
+ -- the default session.
Cur_Session.Data := Def_Session.Data;
end if;
----------------------
function Always_True return Boolean;
- -- A function that always returns True.
+ -- A function that always returns True
function Apply_Filters
- (Session : Session_Type := Current_Session)
- return Boolean;
+ (Session : Session_Type := Current_Session) return Boolean;
-- Apply any filters for which the Pattern is True for Session. It returns
-- True if a least one filters has been applied (i.e. associated action
-- callback has been called).
-- number and the filename if possible.
procedure Read_Line (Session : Session_Type);
- -- Read a line for the Session and set Current_Line.
+ -- Read a line for the Session and set Current_Line
procedure Split_Line (Session : Session_Type);
-- Split session's Current_Line according to the session separators and
function Match
(P : String_Pattern;
- Session : Session_Type)
- return Boolean
+ Session : Session_Type) return Boolean
is
begin
return P.Str = Field (P.Rank, Session);
function Match
(P : Regexp_Pattern;
- Session : Session_Type)
- return Boolean
+ Session : Session_Type) return Boolean
is
use type Regpat.Match_Location;
function Match
(P : Callback_Pattern;
- Session : Session_Type)
- return Boolean
+ Session : Session_Type) return Boolean
is
pragma Unreferenced (Session);
-------------------
function Apply_Filters
- (Session : Session_Type := Current_Session)
- return Boolean
+ (Session : Session_Type := Current_Session) return Boolean
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
Results : Boolean := False;
begin
- -- Iterate through the filters table, if pattern match call action.
+ -- Iterate through the filters table, if pattern match call action
for F in 1 .. Pattern_Action_Table.Last (Filters) loop
if Patterns.Match (Filters.Table (F).Pattern.all, Session) then
function Discrete_Field
(Rank : Count;
- Session : Session_Type := Current_Session)
- return Discrete
+ Session : Session_Type := Current_Session) return Discrete
is
begin
return Discrete'Value (Field (Rank, Session));
-----------------
function End_Of_Data
- (Session : Session_Type := Current_Session)
- return Boolean
+ (Session : Session_Type := Current_Session) return Boolean
is
begin
return Session.Data.File_Index = File_Table.Last (Session.Data.Files)
-----------------
function End_Of_File
- (Session : Session_Type := Current_Session)
- return Boolean
+ (Session : Session_Type := Current_Session) return Boolean
is
begin
return Text_IO.End_Of_File (Session.Data.Current_File);
function Field
(Rank : Count;
- Session : Session_Type := Current_Session)
- return String
+ Session : Session_Type := Current_Session) return String
is
Fields : Field_Table.Instance renames Session.Data.Fields;
elsif Rank = 0 then
- -- Returns the whole line, this is what $0 does under Session_Type.
+ -- Returns the whole line, this is what $0 does under Session_Type
return To_String (Session.Data.Current_Line);
function Field
(Rank : Count;
- Session : Session_Type := Current_Session)
- return Integer
+ Session : Session_Type := Current_Session) return Integer
is
begin
return Integer'Value (Field (Rank, Session));
function Field
(Rank : Count;
- Session : Session_Type := Current_Session)
- return Float
+ Session : Session_Type := Current_Session) return Float
is
begin
return Float'Value (Field (Rank, Session));
----------
function File
- (Session : Session_Type := Current_Session)
- return String
+ (Session : Session_Type := Current_Session) return String
is
Files : File_Table.Instance renames Session.Data.Files;
----------------------
function Number_Of_Fields
- (Session : Session_Type := Current_Session)
- return Count
+ (Session : Session_Type := Current_Session) return Count
is
begin
return Count (Field_Table.Last (Session.Data.Fields));
--------------------------
function Number_Of_File_Lines
- (Session : Session_Type := Current_Session)
- return Count
+ (Session : Session_Type := Current_Session) return Count
is
begin
return Count (Session.Data.FNR);
---------------------
function Number_Of_Files
- (Session : Session_Type := Current_Session)
- return Natural
+ (Session : Session_Type := Current_Session) return Natural
is
Files : File_Table.Instance renames Session.Data.Files;
---------------------
function Number_Of_Lines
- (Session : Session_Type := Current_Session)
- return Count
+ (Session : Session_Type := Current_Session) return Count
is
begin
return Count (Session.Data.NR);
Session : Session_Type)
is
function Filename return String;
- -- Returns current filename and "??" if the informations is not
+ -- Returns current filename and "??" if this information is not
-- available.
function Line return String;
function Filename return String is
File : constant String := AWK.File (Session);
-
begin
if File = "" then
return "??";
function Line return String is
L : constant String := Natural'Image (Session.Data.FNR);
-
begin
return L (2 .. L'Last);
end Line;
NR : Natural renames Session.Data.NR;
FNR : Natural renames Session.Data.FNR;
+ ---------------
+ -- Read_Line --
+ ---------------
+
function Read_Line return String is
Buffer : String (1 .. 1_024);
Last : Natural;
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2005 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- --
package GNAT.AWK is
Session_Error : exception;
- -- Raised when a Session is reused but is not closed.
+ -- Raised when a Session is reused but is not closed
File_Error : exception;
- -- Raised when there is a file problem (see below).
+ -- Raised when there is a file problem (see below)
End_Error : exception;
-- Raised when an attempt is made to read beyond the end of the last
-- file of a session.
Field_Error : exception;
- -- Raised when accessing a field value which does not exist.
+ -- Raised when accessing a field value which does not exist
Data_Error : exception;
- -- Raised when it is not possible to convert a field value to a specific
- -- type.
+ -- Raised when it is impossible to convert a field value to a specific type
type Count is new Natural;
type Widths_Set is array (Positive range <>) of Positive;
- -- Used to store a set of columns widths.
+ -- Used to store a set of columns widths
Default_Separators : constant String := " " & ASCII.HT;
Use_Current : constant String := "";
- -- Value used when no separator or filename is specified in iterators.
+ -- Value used when no separator or filename is specified in iterators
type Session_Type is limited private;
-- This is the main exported type. A session is used to keep the state of
(Separators : String := Default_Separators;
Session : Session_Type := Current_Session)
renames Set_Field_Separators;
- -- FS is the AWK abbreviation for above service.
+ -- FS is the AWK abbreviation for above service
procedure Set_Field_Widths
(Field_Widths : Widths_Set;
-------------------------------------
function Number_Of_Fields
- (Session : Session_Type := Current_Session)
- return Count;
+ (Session : Session_Type := Current_Session) return Count;
pragma Inline (Number_Of_Fields);
-- Returns the number of fields in the current record. It returns 0 when
-- no file is being processed.
function NF
- (Session : Session_Type := Current_Session)
- return Count
+ (Session : Session_Type := Current_Session) return Count
renames Number_Of_Fields;
- -- AWK abbreviation for above service.
+ -- AWK abbreviation for above service
function Number_Of_File_Lines
- (Session : Session_Type := Current_Session)
- return Count;
+ (Session : Session_Type := Current_Session) return Count;
pragma Inline (Number_Of_File_Lines);
-- Returns the current line number in the processed file. It returns 0 when
-- no file is being processed.
- function FNR
- (Session : Session_Type := Current_Session)
- return Count renames Number_Of_File_Lines;
- -- AWK abbreviation for above service.
+ function FNR (Session : Session_Type := Current_Session) return Count
+ renames Number_Of_File_Lines;
+ -- AWK abbreviation for above service
function Number_Of_Lines
- (Session : Session_Type := Current_Session)
- return Count;
+ (Session : Session_Type := Current_Session) return Count;
pragma Inline (Number_Of_Lines);
-- Returns the number of line processed until now. This is equal to number
-- of line in each already processed file plus FNR. It returns 0 when
-- no file is being processed.
- function NR
- (Session : Session_Type := Current_Session)
- return Count
+ function NR (Session : Session_Type := Current_Session) return Count
renames Number_Of_Lines;
- -- AWK abbreviation for above service.
+ -- AWK abbreviation for above service
function Number_Of_Files
- (Session : Session_Type := Current_Session)
- return Natural;
+ (Session : Session_Type := Current_Session) return Natural;
pragma Inline (Number_Of_Files);
-- Returns the number of files associated with Session. This is the total
-- number of files added with Add_File and Add_Files services.
- function File
- (Session : Session_Type := Current_Session)
- return String;
+ function File (Session : Session_Type := Current_Session) return String;
-- Returns the name of the file being processed. It returns the empty
-- string when no file is being processed.
function Field
(Rank : Count;
- Session : Session_Type := Current_Session)
- return String;
+ Session : Session_Type := Current_Session) return String;
-- Returns field number Rank value of the current record. If Rank = 0 it
-- returns the current record (i.e. the line as read in the file). It
-- raises Field_Error if Rank > NF or if Session is not open.
function Field
(Rank : Count;
- Session : Session_Type := Current_Session)
- return Integer;
+ Session : Session_Type := Current_Session) return Integer;
-- Returns field number Rank value of the current record as an integer. It
-- raises Field_Error if Rank > NF or if Session is not open. It
-- raises Data_Error if the field value cannot be converted to an integer.
function Field
(Rank : Count;
- Session : Session_Type := Current_Session)
- return Float;
+ Session : Session_Type := Current_Session) return Float;
-- Returns field number Rank value of the current record as a float. It
-- raises Field_Error if Rank > NF or if Session is not open. It
-- raises Data_Error if the field value cannot be converted to a float.
type Discrete is (<>);
function Discrete_Field
(Rank : Count;
- Session : Session_Type := Current_Session)
- return Discrete;
+ Session : Session_Type := Current_Session) return Discrete;
-- Returns field number Rank value of the current record as a type
-- Discrete. It raises Field_Error if Rank > NF. It raises Data_Error if
-- the field value cannot be converted to type Discrete.
-- or by an instantiation of For_Every_Line (see below).
function End_Of_Data
- (Session : Session_Type := Current_Session)
- return Boolean;
+ (Session : Session_Type := Current_Session) return Boolean;
pragma Inline (End_Of_Data);
-- Returns True if there is no more data to be processed in Session. It
-- means that the latest session's file is being processed and that
-- there is no more data to be read in this file (End_Of_File is True).
function End_Of_File
- (Session : Session_Type := Current_Session)
- return Boolean;
+ (Session : Session_Type := Current_Session) return Boolean;
pragma Inline (End_Of_File);
-- Returns True when there is no more data to be processed on the current
-- session's file.
-- --
-- S p e c --
-- --
--- Copyright (C) 2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2003-2005, AdaCore --
-- --
-- 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- --
generic
type Element is private;
-- The type of the values contained within buffer objects
+
package GNAT.Bounded_Buffers is
pragma Pure;
type Content is array (Positive range <>) of Element;
- -- Content is an internal artefact that cannot be hidden
- -- because protected types cannot contain type declarations.
+ -- Content is an internal artefact that cannot be hidden because protected
+ -- types cannot contain type declarations.
Default_Ceiling : constant System.Priority := System.Default_Priority;
- -- A convenience value for the Ceiling discriminant.
+ -- A convenience value for the Ceiling discriminant
protected type Bounded_Buffer
(Capacity : Positive;
- -- Objects of type Bounded_Buffer specify the maximum
- -- number of Element values they can hold via the
- -- discriminant Capacity.
+ -- Objects of type Bounded_Buffer specify the maximum number of Element
+ -- values they can hold via the discriminant Capacity.
+
Ceiling : System.Priority)
- -- Users must specify the ceiling priority for the object.
- -- If the Real-Time Systems Annex is not in use this value
- -- is not important.
+ -- Users must specify the ceiling priority for the object. If the
+ -- Real-Time Systems Annex is not in use this value is not important.
is
pragma Priority (Ceiling);
entry Insert (Item : in Element);
- -- Insert Item into the buffer. Blocks caller
- -- until space is available.
+ -- Insert Item into the buffer, blocks caller until space is available
entry Remove (Item : out Element);
- -- Remove next available Element from buffer.
- -- Blocks caller until an Element is available.
+ -- Remove next available Element from buffer. Blocks caller until an
+ -- Element is available.
function Empty return Boolean;
-- Returns whether the instance contains any Elements.
private
Values : Content (1 .. Capacity);
- -- The container for the values held by the buffer instance.
+ -- The container for the values held by the buffer instance
+
Next_In : Positive := 1;
- -- The index of the next Element inserted. Wraps around.
+ -- The index of the next Element inserted. Wraps around
+
Next_Out : Positive := 1;
- -- The index of the next Element removed. Wraps around.
+ -- The index of the next Element removed. Wraps around
+
Count : Natural := 0;
- -- The number of Elements currently held.
+ -- The number of Elements currently held
end Bounded_Buffer;
end GNAT.Bounded_Buffers;
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- has the advantage of being Pure, while this unit can only be Preelaborate.
package GNAT.Bubble_Sort is
-pragma Preelaborate (Bubble_Sort);
+ pragma Preelaborate;
-- 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.
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- offers a similar routine with a more convenient interface.
package GNAT.Bubble_Sort_A is
-pragma Preelaborate (Bubble_Sort_A);
+ pragma Preelaborate;
-- 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
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- item is greater than or equal to the Op1 item.
package GNAT.Bubble_Sort_G is
-pragma Pure (Bubble_Sort_G);
+ pragma Pure;
procedure Sort (N : Natural);
-- This procedures sorts items in the range from 1 to N into ascending
function Julian_Day
(Year : Year_Number;
Month : Month_Number;
- Day : Day_Number)
- return Integer
+ Day : Day_Number) return Integer
is
Internal_Year : Integer;
Internal_Month : Integer;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
- Sub_Second : Second_Duration := 0.0)
- return Time
+ Sub_Second : Second_Duration := 0.0) return Time
is
Dsecs : constant Day_Duration :=
Day_Duration (Hour * 3600 + Minute * 60 + Second) +
------------------
function Week_In_Year
- (Date : Ada.Calendar.Time)
- return Week_In_Year_Number
+ (Date : Ada.Calendar.Time) return Week_In_Year_Number
is
Year : Year_Number;
Month : Month_Number;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
- -- Day offset number for the first week of the year.
+ -- Day offset number for the first week of the year
Offset := Julian_Day (Year, 1, 1) mod 7;
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2005 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- --
-- Second_Duration precision depends on the target clock precision.
function Day_Of_Week (Date : Ada.Calendar.Time) return Day_Name;
- -- Return the 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
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.
+ 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
function Julian_Day
(Year : Ada.Calendar.Year_Number;
Month : Ada.Calendar.Month_Number;
- Day : Ada.Calendar.Day_Number)
- return Integer;
- -- Compute Julian day 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.
+ -- 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;
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
with System.Case_Util;
package GNAT.Case_Util is
-pragma Pure (Case_Util);
-
-pragma Elaborate_Body;
--- The elaborate body is because we have a dummy body to deal with bootstrap
--- path problems (we used to have a real body, and now we don't need it any
--- more, but the bootstrap requires that we have a dummy body, since otherwise
--- the old body gets picked up.
+ pragma Pure;
+ pragma Elaborate_Body;
+ -- The elaborate body is because we have a dummy body to deal with
+ -- bootstrap path problems (we used to have a real body, and now we don't
+ -- need it any more, but the bootstrap requires that we have a dummy body,
+ -- since otherwise the old body gets picked up.
-- Note: all the following functions handle the full Latin-1 set
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2005 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 --
-----------------------
function Am_Pm (H : Natural) return String;
- -- return AM or PM depending on the hour H
+ -- Return AM or PM depending on the hour H
function Hour_12 (H : Natural) return Positive;
- -- Convert a 1-24h format to a 0-12 hour format.
+ -- Convert a 1-24h format to a 0-12 hour format
function Image (Str : String; Length : Natural := 0) return String;
-- Return Str capitalized and cut to length number of characters. If
function Image
(N : Long_Integer;
Padding : Padding_Mode := Zero;
- Length : Natural := 0)
- return String;
- -- Return image of N. This number is eventually padded with zeros or
- -- spaces depending of the length required. If length is 0 then no padding
- -- occurs.
+ Length : Natural := 0) return String;
+ -- Return image of N. This number is eventually padded with zeros or spaces
+ -- depending of the length required. If length is 0 then no padding occurs.
function Image
(N : Integer;
Padding : Padding_Mode := Zero;
- Length : Natural := 0)
- return String;
- -- As above with N provided in Integer format.
+ Length : Natural := 0) return String;
+ -- As above with N provided in Integer format
-----------
-- Am_Pm --
function Image
(Str : String;
- Length : Natural := 0)
- return String
+ Length : Natural := 0) return String
is
use Ada.Characters.Handling;
Local : constant String :=
function Image
(N : Integer;
Padding : Padding_Mode := Zero;
- Length : Natural := 0)
- return String
+ Length : Natural := 0) return String
is
begin
return Image (Long_Integer (N), Padding, Length);
function Image
(N : Long_Integer;
Padding : Padding_Mode := Zero;
- Length : Natural := 0)
- return String
+ Length : Natural := 0) return String
is
function Pad_Char return String;
function Image
(Date : Ada.Calendar.Time;
- Picture : Picture_String)
- return String
+ Picture : Picture_String) return String
is
- Padding : Padding_Mode := Zero;
+ Padding : Padding_Mode := Zero;
-- Padding is set for one directive
- Result : Unbounded_String;
+ Result : Unbounded_String;
Year : Year_Number;
Month : Month_Number;
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2005, AdaCore --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
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
+ 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
+ -- Put Date with format Picture. Raise Picture_Error if picture string is
+ -- wrong
private
ISO_Date : constant Picture_String := "%Y-%m-%d";
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2005, AdaCore --
-- --
-- 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- --
-- services exported by this unit.
Current_Method : Method_Type;
- -- This is the current method used to pass CGI parameters.
+ -- This is the current method used to pass CGI parameters
Header_Sent : Boolean := False;
- -- Will be set to True when the header will be sent.
+ -- Will be set to True when the header will be sent
-- Key/Value table declaration
procedure Check_Environment;
pragma Inline (Check_Environment);
- -- This procedure will raise Data_Error if Valid_Environment is False.
+ -- This procedure will raise Data_Error if Valid_Environment is False
procedure Initialize;
-- Initialize CGI package by reading the runtime environment. This
-- for the data is passed in CONTENT_LENGTH environment variable.
procedure Set_Parameter_Table (Data : String);
- -- Parse the parameter data and set the parameter table.
+ -- Parse the parameter data and set the parameter table
--------------------
-- Initialize_GET --
Required : Boolean := False) return String
is
function Get_Environment (Variable_Name : String) return String;
- -- Returns the environment variable content.
+ -- Returns the environment variable content
---------------------
-- Get_Environment --
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2005, AdaCore --
-- --
-- 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- --
-- and will be raised when calling any services below (except for Ok).
Parameter_Not_Found : exception;
- -- This exception is raised when a specific parameter is not found.
+ -- This exception is raised when a specific parameter is not found
Default_Header : constant String := "Content-type: text/html";
-- This is the default header returned by Put_Header. If the CGI program
-- the exception Data_Error.
function Method return Method_Type;
- -- Returns the method used to call the CGI.
+ -- Returns the method used to call the CGI
function Metavariable
(Name : Metavariable_Name;
- Required : Boolean := False)
- return String;
+ Required : Boolean := False) return String;
-- Returns parameter Name value. Returns the null string if Name
-- environment variable is not defined or raises Data_Error if
-- Required is set to True.
function Value
(Key : String;
- Required : Boolean := False)
- return String;
+ Required : Boolean := False) return String;
-- Returns the parameter value associated to the parameter named Key.
-- If parameter does not exist, returns an empty string if Required
-- is False and raises the exception Parameter_Not_Found otherwise.
-- (i.e. Position > Argument_Count)
function Key_Exists (Key : String) return Boolean;
- -- Returns True if the parameter named Key existx and False otherwise.
+ -- Returns True if the parameter named Key exists and False otherwise
function Key (Position : Positive) return String;
-- Returns the parameter key associated with the CGI parameter number
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2005, AdaCore --
-- --
-- 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- --
use Ada;
Valid_Environment : Boolean := False;
- -- This boolean will be set to True if the initialization was fine.
+ -- This boolean will be set to True if the initialization was fine
Header_Sent : Boolean := False;
- -- Will be set to True when the header will be sent.
+ -- Will be set to True when the header will be sent
- -- Cookie data that have been added.
+ -- Cookie data that has been added
type String_Access is access String;
end record;
package Cookie_Table is new Table (Cookie_Data, Positive, 1, 5, 50);
- -- This is the table to keep all cookies to be sent back to the server.
+ -- This is the table to keep all cookies to be sent back to the server
package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
- -- This is the table to keep all cookies received from the server.
+ -- This is the table to keep all cookies received from the server
procedure Check_Environment;
pragma Inline (Check_Environment);
- -- This procedure will raise Data_Error if Valid_Environment is False.
+ -- This procedure will raise Data_Error if Valid_Environment is False
procedure Initialize;
-- Initialize CGI package by reading the runtime environment. This
HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie);
procedure Set_Parameter_Table (Data : String);
- -- Parse Data and insert information in Key_Value_Table.
+ -- Parse Data and insert information in Key_Value_Table
-------------------------
-- Set_Parameter_Table --
-- Add a single parameter into the table at index K. The parameter
-- format is "key=value".
- Count : constant Positive
- := 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";"));
+ Count : constant Positive :=
+ 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";"));
-- Count is the number of parameters in the string. Parameters are
-- separated by ampersand character.
end if;
end Add_Parameter;
+ -- Start of processing for Set_Parameter_Table
+
begin
Key_Value_Table.Set_Last (Count);
Index := Sep + 2;
end loop;
- -- add last parameter
+ -- Add last parameter
Add_Parameter (Count, Data (Index .. Data'Last));
end Set_Parameter_Table;
+ -- Start of processing for Initialize
+
begin
if HTTP_COOKIE /= "" then
Set_Parameter_Table (HTTP_COOKIE);
(Header : String := Default_Header;
Force : Boolean := False)
is
-
procedure Output_Cookies;
-- Iterate through the list of cookies to be sent to the server
-- and output them.
Max_Age : Natural;
Path : String;
Secure : Boolean);
- -- Output one cookie in the CGI header.
+ -- Output one cookie in the CGI header
-----------------------
-- Output_One_Cookie --
Domain : String := "";
Max_Age : Natural := Natural'Last;
Path : String := "/";
- Secure : Boolean := False) is
+ Secure : Boolean := False)
+ is
begin
Cookie_Table.Increment_Last;
function Value
(Key : String;
- Required : Boolean := False)
- return String
+ Required : Boolean := False) return String
is
begin
Check_Environment;
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2005, AdaCore --
-- --
-- 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- --
-- 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.
+-- 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
-- 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.
+ -- This exception is raised when a specific parameter is not found
procedure Put_Header
(Header : String := Default_Header;
-- 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.
+ -- 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.
+ -- 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.
+ 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)
+ -- 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.
+ -- 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)
+ -- 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;
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.
+ -- 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
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2005, AdaCore --
-- --
-- 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- --
use Ada.Strings.Unbounded;
- --
- -- Define the abstract type which act as a template for all debug IO mode.
+ -- Define the abstract type which act as a template for all debug IO modes.
-- 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
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;
+ 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;
+ 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;
+ 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
- --
+ ----------------------
+ -- IO for HTML Mode --
+ ----------------------
package HTML_IO is
- -- see IO for comments about these routines.
+ -- 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;
+ Value : String) return String;
function New_Line (IO : in Format) return String;
end HTML_IO;
- --
- -- IO for plain text mode
- --
+ ----------------------------
+ -- IO for Plain Text Mode --
+ ----------------------------
package Text_IO is
function Variable
(IO : Format;
Name : String;
- Value : String)
- return String;
+ Value : String) return String;
function New_Line (IO : in Format) return String;
NL : constant String := (1 => ASCII.LF);
function Bold (S : in String) return String;
- -- Returns S as an HTML bold string.
+ -- Returns S as an HTML bold string
function Italic (S : in String) return String;
- -- Returns S as an HTML italic string.
+ -- Returns S as an HTML italic string
----------
-- Bold --
------------
function Header (IO : in Format; Str : in String) return String is
- pragma Warnings (Off, IO);
-
+ pragma Unreferenced (IO);
begin
return "<h2>" & Str & "</h2>" & NL;
end Header;
--------------
function New_Line (IO : in Format) return String is
- pragma Warnings (Off, IO);
-
+ pragma Unreferenced (IO);
begin
return "<br>" & NL;
end New_Line;
-----------
function Title (IO : in Format; Str : in String) return String is
- pragma Warnings (Off, IO);
-
+ pragma Unreferenced (IO);
begin
return "<p align=center><font size=+2>" & Str & "</font></p>" & NL;
end Title;
function Variable
(IO : Format;
Name : String;
- Value : String)
- return String
+ Value : String) return String
is
- pragma Warnings (Off, IO);
-
+ pragma Unreferenced (IO);
begin
return Bold (Name) & " = " & Italic (Value);
end Variable;
--------------
function New_Line (IO : in Format) return String is
- pragma Warnings (Off, IO);
-
+ pragma Unreferenced (IO);
begin
return String'(1 => ASCII.LF);
end New_Line;
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;
function Variable
(IO : Format;
Name : String;
- Value : String)
- return String
+ Value : String) return String
is
- pragma Warnings (Off, IO);
-
+ pragma Unreferenced (IO);
begin
return " " & Name & " = " & Value;
end Variable;
function HTML_Output return String is
HTML : HTML_IO.Format;
-
begin
return IO.Output (Mode => HTML);
end HTML_Output;
function Text_Output return String is
Text : Text_IO.Format;
-
begin
return IO.Output (Mode => Text);
end Text_Output;
-- --
-- S p e c --
-- --
--- Copyright (C) 2000 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2005, AdaCore --
-- --
-- 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- --
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.
+ -- 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
The_Parameter : Parameter_Type;
The_Switch : Parameter_Type;
-- This type and this variable are provided to store the current switch
- -- and parameter
+ -- and parameter.
type Is_Switch_Type is array (1 .. CL.Argument_Count) of Boolean;
pragma Pack (Is_Switch_Type);
Is_Switch : Is_Switch_Type := (others => False);
-- Indicates wich arguments on the command line are considered not be
- -- switches or parameters to switches (this leaves e.g. the filenames...)
+ -- switches or parameters to switches (this leaves e.g. the filenames...).
type Section_Type is array (1 .. CL.Argument_Count + 1) of Section_Number;
pragma Pack (Section_Type);
Section : Section_Type := (others => 1);
- -- Contains the number of the section associated with the current
- -- switch. If this number is 0, then it is a section delimiter, which
- -- is never returns by GetOpt.
- -- The last element of this array is set to 0 to avoid the need to test for
- -- if we have reached the end of the command line in loops.
+ -- Contains the number of the section associated with the current switch.
+ -- If this number is 0, then it is a section delimiter, which is never
+ -- returns by GetOpt. The last element of this array is set to 0 to avoid
+ -- the need to test for reaching the end of the command line in loops.
Current_Argument : Natural := 1;
-- Number of the current argument parsed on the command line
-- True if we are expanding a file
Switch_Character : Character := '-';
- -- The character at the beginning of the command line arguments,
- -- indicating the beginning of a switch
+ -- The character at the beginning of the command line arguments, indicating
+ -- the beginning of a switch.
Stop_At_First : Boolean := False;
-- If it is True then Getopt stops at the first non-switch argument
-- Set the parameter that will be returned by Parameter below
function Goto_Next_Argument_In_Section return Boolean;
- -- Go to the next argument on the command line. If we are at the end
- -- of the current section, we want to make sure there is no other
- -- identical section on the command line (there might be multiple
- -- instances of -largs). Returns True iff there is another argument.
+ -- Go to the next argument on the command line. If we are at the end of the
+ -- current section, we want to make sure there is no other identical
+ -- section on the command line (there might be multiple instances of
+ -- -largs). Returns True iff there is another argument.
function Get_File_Names_Case_Sensitive return Integer;
pragma Import (C, Get_File_Names_Case_Sensitive,
"__gnat_get_file_names_case_sensitive");
+
File_Names_Case_Sensitive : constant Boolean :=
Get_File_Names_Case_Sensitive /= 0;
procedure Canonical_Case_File_Name (S : in out String);
- -- Given a file name, converts it to canonical case form. For systems
- -- where file names are case sensitive, this procedure has no effect.
- -- If file names are not case sensitive (i.e. for example if you have
- -- the file "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then
- -- this call converts the given string to canonical all lower case form,
- -- so that two file names compare equal if they refer to the same file.
+ -- Given a file name, converts it to canonical case form. For systems where
+ -- file names are case sensitive, this procedure has no effect. If file
+ -- names are not case sensitive (i.e. for example if you have the file
+ -- "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then this call
+ -- converts the given string to canonical all lower case form, so that two
+ -- file names compare equal if they refer to the same file.
------------------------------
-- Canonical_Case_File_Name --
NL : Positive;
begin
- -- It is assumed that a directory is opened at the current level;
- -- otherwise, GNAT.Directory_Operations.Directory_Error will be raised
+ -- It is assumed that a directory is opened at the current level.
+ -- Otherwise GNAT.Directory_Operations.Directory_Error will be raised
-- at the first call to Read.
loop
if Last = 0 then
Close (It.Levels (Current).Dir);
- -- If we are at level 1, we are finished; return an empty string.
+ -- If we are at level 1, we are finished; return an empty string
if Current = 1 then
return String'(1 .. 0 => ' ');
-- --
-- S p e c --
-- --
--- Copyright (C) 2002 Ada Core Technologies --
+-- Copyright (C) 2002-2005, AdaCore --
-- --
-- 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- --
-- GNAT compiler used to compile the program. It relies on the generated
-- constant in the binder generated package that records this information.
--- Note: to use this package you must first instantiate it, e.g.
+-- Note: to use this package you must first instantiate it, for example:
-- package CVer is new GNAT.Compiler_Version;
-- to import the necessary variable from the binder file causes trouble when
-- building a shared library, since the symbol is not available.
--- Note: this unit is only useable if the main program is written
--- in Ada. It cannot be used if the main program is written in a
--- foreign language.
+-- Note: this unit is only useable if the main program is written in Ada.
+-- It cannot be used if the main program is written in foreign language.
generic
package GNAT.Compiler_Version is
-pragma Pure (Compiler_Version);
+ pragma Pure;
function Version return String;
-- This function returns the version in the form "v.vvx (yyyyddmm)".
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
with System;
package GNAT.Debug_Utilities is
-pragma Pure (Debug_Utilities);
+ pragma Pure;
Address_64 : constant Boolean := Standard'Address_Size = 64;
-- Set true if 64 bit addresses (assumes only 32 and 64 are possible)
Cut_Start := Cut_Start + 1;
end if;
- -- Cut_End point to the last basename character.
+ -- Cut_End point to the last basename character
Cut_End := Path'Last;
- -- If basename ends with Suffix, adjust Cut_End.
+ -- If basename ends with Suffix, adjust Cut_End
if Suffix /= ""
and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
procedure Double_Result_Size is
New_Result : constant OS_Lib.String_Access :=
- new String (1 .. 2 * Result'Last);
-
+ new String (1 .. 2 * Result'Last);
begin
New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
OS_Lib.Free (Result);
procedure Read (K : in out Positive) is
P : Character;
+
begin
For_All_Characters : loop
if Is_Var_Prefix (Path (K)) then
-- Could be a variable
if K < Path'Last then
-
if Path (K + 1) = P then
-- Not a variable after all, this is a double $ or %,
function Get_Current_Dir return Dir_Name_Str is
Current_Dir : String (1 .. Max_Path + 1);
Last : Natural;
-
begin
Get_Current_Dir (Current_Dir, Last);
return Current_Dir (1 .. Last);
-------------------------
function Read_Is_Thread_Safe return Boolean is
-
function readdir_is_thread_safe return Integer;
pragma Import
(C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
-
begin
return (readdir_is_thread_safe /= 0);
end Read_Is_Thread_Safe;
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2005 AdaCore --
+-- Copyright (C) 2002-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
generic
type Header_Num is range <>;
- -- An integer type indicating the number and range of hash headers.
+ -- An integer type indicating the number and range of hash headers
type Element (<>) is limited private;
-- The type of element to be stored
-- 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.
+ -- 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;
generic
type Header_Num is range <>;
- -- An integer type indicating the number and range of hash headers.
+ -- An integer type indicating the number and range of hash headers
type Element is private;
-- The type of element to be stored
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- the body for exact details of the algorithm used.
package GNAT.Heap_Sort is
-pragma Preelaborate (Heap_Sort);
+ pragma Preelaborate;
-- 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.
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- the body for exact details of the algorithm used.
package GNAT.Heap_Sort_A is
-pragma Preelaborate (Heap_Sort_A);
+ pragma Preelaborate;
-- 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
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- zero will in this case be resolved at instantiation time.
package GNAT.Heap_Sort_G is
-pragma Pure (Heap_Sort_G);
+ pragma Pure;
procedure Sort (N : Natural);
-- This procedures sorts items in the range from 1 to N into ascending
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
with System.HTable;
package GNAT.HTable is
-pragma Preelaborate (HTable);
-
-pragma Elaborate_Body;
--- The elaborate body is because we have a dummy body to deal with bootstrap
--- path problems (we used to have a real body, and now we don't need it any
--- more, but the bootstrap requires that we have a dummy body, since otherwise
--- the old body gets picked up.
+ pragma Preelaborate;
+ pragma Elaborate_Body;
+ -- The elaborate body is because we have a dummy body to deal with
+ -- bootstrap path problems (we used to have a real body, and now we don't
+ -- need it any more, but the bootstrap requires that we have a dummy body,
+ -- since otherwise the old body gets picked up.
-------------------
-- Simple_HTable --
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- If such checks are needed then the regular Text_IO package must be used.
package GNAT.IO is
-pragma Preelaborate (IO);
+ pragma Preelaborate;
type File_Type is limited private;
-- Specifies file to be used (the only possibilities are Standard_Output
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2005 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- --
-- purpose of providing realiable system wide locking capability.
package GNAT.Lock_Files is
-pragma Preelaborate;
+ pragma Preelaborate;
Lock_Error : exception;
-- Exception raised if file cannot be locked
(Lock_File_Name : Path_Name;
Wait : Duration := 1.0;
Retries : Natural := Natural'Last);
- -- See above. The full lock file path is given as one string.
+ -- See above. The full lock file path is given as one string
procedure Unlock_File (Directory : Path_Name; Lock_File_Name : Path_Name);
-- Unlock a file. Directory can optionally terminate with a directory
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2005 AdaCore --
+-- Copyright (C) 2003-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2005 AdaCore --
+-- Copyright (C) 2003-2005, AdaCore --
-- --
-- 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- --
with System;
package GNAT.Memory_Dump is
-pragma Preelaborate (Memory_Dump);
+ pragma Preelaborate;
procedure Dump (Addr : System.Address; Count : Natural);
-- Dumps indicated number (Count) of bytes, starting at the address given
-- --
-- S p e c --
-- --
--- Copyright (C) 2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2003-2005, AdaCore --
-- --
-- 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- --
package GNAT.Semaphores is
Default_Ceiling : constant System.Priority := System.Default_Priority;
- -- A convenient value for the priority discriminants that follow.
+ -- A convenient value for the priority discriminants that follow
------------------------
-- Counting_Semaphore --
-- value of this counter is set by clients via the discriminant.
Ceiling : System.Priority)
- -- Users must specify the ceiling priority for the object.
- -- If the Real-Time Systems Annex is not in use this value
- -- is not important.
+ -- Users must specify the ceiling priority for the object. If the
+ -- Real-Time Systems Annex is not in use this value is not important.
is
pragma Priority (Ceiling);
entry Seize;
- -- Blocks caller until/unless the semaphore's internal counter
- -- is greater than zero.
- -- Decrements the semaphore's internal counter when executed.
+ -- Blocks caller until/unless the semaphore's internal counter is
+ -- greater than zero. Decrements the semaphore's internal counter when
+ -- executed.
procedure Release;
- -- Increments the semaphore's internal counter.
+ -- Increments the semaphore's internal counter
private
Count : Natural := Initial_Value;
----------------------
protected type Binary_Semaphore
- (Initially_Available : Boolean;
- -- Binary semaphores are either available or not; there is no
- -- internal count involved. The discriminant value determines
- -- whether the individual object is initially available.
+ (Initially_Available : Boolean;
+ -- Binary semaphores are either available or not; there is no internal
+ -- count involved. The discriminant value determines whether the
+ -- individual object is initially available.
+
Ceiling : System.Priority)
- -- Users must specify the ceiling priority for the object.
- -- If the Real-Time Systems Annex is not in use
- -- this value is not important.
+ -- Users must specify the ceiling priority for the object. If the
+ -- Real-Time Systems Annex is not in use this value is not important.
is
pragma Priority (Ceiling);
entry Seize;
- -- Blocks the caller unless/until semaphore is available.
- -- After execution the semaphore is no longer available.
+ -- Blocks the caller unless/until semaphore is available. After
+ -- execution the semaphore is no longer available.
procedure Release;
- -- Makes the semaphore available.
+ -- Makes the semaphore available
private
Available : Boolean := Initially_Available;
-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
-- should not be directly with'ed by an applications program.
--- This version is for NT.
+-- This version is for NT
with GNAT.Sockets.Constants; use GNAT.Sockets.Constants;
with Interfaces.C.Strings; use Interfaces.C.Strings;
package C renames Interfaces.C;
use type C.int;
- -- So that we can declare the Failure constant below.
+ -- So that we can declare the Failure constant below
Success : constant C.int := 0;
Failure : constant C.int := -1;
function Socket_Errno return Integer;
- -- Returns last socket error number.
+ -- Returns last socket error number
procedure Set_Socket_Errno (Errno : Integer);
- -- Set last socket error number.
+ -- Set last socket error number
function Socket_Error_Message
(Errno : Integer)
procedure Free_Socket_Set
(Set : Fd_Set_Access);
- -- Free system-dependent socket set.
+ -- Free system-dependent socket set
procedure Get_Socket_From_Set
(Set : Fd_Set_Access;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2004 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2005 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- --
-- --
------------------------------------------------------------------------------
--- Temporary version for Alpha/VMS.
+-- Temporary version for Alpha/VMS
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Task_Lock;
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2004 Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2005 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- --
-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
-- should not be directly with'ed by an applications program.
--- This is the Alpha/VMS version.
+-- This is the Alpha/VMS version
with Interfaces.C.Pointers;
Failure : constant C.int := -1;
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
- -- Returns last socket error number.
+ -- Returns last socket error number
function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If
procedure Free_Socket_Set
(Set : Fd_Set_Access);
- -- Free system-dependent socket set.
+ -- Free system-dependent socket set
procedure Get_Socket_From_Set
(Set : Fd_Set_Access;
procedure Insert_Socket_In_Set
(Set : Fd_Set_Access;
Socket : C.int);
- -- Insert socket in the socket set.
+ -- Insert socket in the socket set
function Is_Socket_In_Set
(Set : Fd_Set_Access;
procedure Remove_Socket_From_Set
(Set : Fd_Set_Access;
Socket : C.int);
- -- Remove socket from the socket set.
+ -- Remove socket from the socket set
procedure Finalize;
procedure Initialize (Process_Blocking_IO : Boolean);
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2004 Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2005 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- --
Failure : constant C.int := -1;
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
- -- Returns last socket error number.
+ -- Returns last socket error number
function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
- -- Returns the error message string for the error number Errno. If
- -- Errno is not known it returns "Unknown system error".
+ -- Returns the error message string for the error number Errno. If Errno is
+ -- not known it returns "Unknown system error".
subtype Fd_Set_Access is System.Address;
No_Fd_Set : constant Fd_Set_Access := System.Null_Address;
(Sin : Sockaddr_In_Access;
Len : C.int);
pragma Inline (Set_Length);
- -- Set Sin.Sin_Length to Len.
+ -- Set Sin.Sin_Length to Len
procedure Set_Family
(Sin : Sockaddr_In_Access;
Family : C.int);
pragma Inline (Set_Family);
- -- Set Sin.Sin_Family to Family.
+ -- Set Sin.Sin_Family to Family
procedure Set_Port
(Sin : Sockaddr_In_Access;
Port : C.unsigned_short);
pragma Inline (Set_Port);
- -- Set Sin.Sin_Port to Port.
+ -- Set Sin.Sin_Port to Port
procedure Set_Address
(Sin : Sockaddr_In_Access;
Address : In_Addr);
pragma Inline (Set_Address);
- -- Set Sin.Sin_Addr to Address.
+ -- Set Sin.Sin_Addr to Address
type Hostent is record
H_Name : C.Strings.chars_ptr;
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2004 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2005 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- --
Failure : constant C.int := -1;
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
- -- Returns last socket error number.
+ -- Returns last socket error number
function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
- -- Returns the error message string for the error number Errno. If
- -- Errno is not known it returns "Unknown system error".
+ -- Returns the error message string for the error number Errno. If Errno is
+ -- not known it returns "Unknown system error".
subtype Fd_Set_Access is System.Address;
No_Fd_Set : constant Fd_Set_Access := System.Null_Address;
procedure Last_Socket_In_Set
(Set : Fd_Set_Access;
Last : Int_Access);
- -- Find the largest socket in the socket set. This is needed for
- -- select(). When Last_Socket_In_Set is called, parameter Last is
- -- a maximum value of the largest socket. This hint is used to
- -- avoid scanning very large socket sets. After the call, Last is
- -- set back to the real largest socket in the socket set.
+ -- Find the largest socket in the socket set. This is needed for select().
+ -- When Last_Socket_In_Set is called, parameter Last is a maximum value of
+ -- the largest socket. This hint is used to avoid scanning very large
+ -- socket sets. After the call, Last is set back to the real largest socket
+ -- in the socket set.
function New_Socket_Set
(Set : Fd_Set_Access) return Fd_Set_Access;
- -- Allocate a new socket set which is a system-dependent structure
- -- and initialize by copying Set if it is non-null, by making it
- -- empty otherwise.
+ -- Allocate a new socket set which is a system-dependent structure and
+ -- initialize by copying Set if it is non-null, by making it empty
+ -- otherwise.
procedure Remove_Socket_From_Set
(Set : Fd_Set_Access;
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2005 AdaCore --
+-- Copyright (C) 1998-2005, AdaCore --
-- --
-- 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- --
-- ensures that we initially allocate the table.
Last_Val : Integer;
- -- Current value of Last.
+ -- Current value of Last
-----------------------
-- Local Subprograms --
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2000 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2005, AdaCore --
-- --
-- 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2004 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2005, AdaCore --
-- --
-- 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- --
-- Code location used in building tracebacks
subtype Tracebacks_Array is Ada.Exceptions.Traceback.Tracebacks_Array;
- -- Traceback array used to hold a generated traceback list.
+ -- Traceback array used to hold a generated traceback list
----------------
-- Call_Chain --
-- --
------------------------------------------------------------------------------
--- The body of Interfaces.COBOL is implementation independent (i.e. the
--- same version is used with all versions of GNAT). The specialization
--- to a particular COBOL format is completely contained in the private
--- part ot the spec.
+-- The body of Interfaces.COBOL is implementation independent (i.e. the same
+-- version is used with all versions of GNAT). The specialization to a
+-- particular COBOL format is completely contained in the private part of
+-- the spec.
with Interfaces; use Interfaces;
with System; use System;
function Binary_To_Decimal
(Item : Byte_Array;
- Format : Binary_Format)
- return Integer_64;
+ Format : Binary_Format) return Integer_64;
-- This function converts a numeric value in the given format to its
-- corresponding integer value. This is the non-generic implementation
-- of Decimal_Conversions.To_Decimal. The generic routine does the
function Numeric_To_Decimal
(Item : Numeric;
- Format : Display_Format)
- return Integer_64;
+ Format : Display_Format) return Integer_64;
-- This function converts a numeric value in the given format to its
-- corresponding integer value. This is the non-generic implementation
-- of Decimal_Conversions.To_Decimal. The generic routine does the
function Packed_To_Decimal
(Item : Packed_Decimal;
- Format : Packed_Format)
- return Integer_64;
+ Format : Packed_Format) return Integer_64;
-- This function converts a packed value in the given format to its
-- corresponding integer value. This is the non-generic implementation
-- of Decimal_Conversions.To_Decimal. The generic routine does the
-- Numeric_To_Decimal --
------------------------
- -- The following assumptions are made in the coding of this routine
+ -- The following assumptions are made in the coding of this routine:
-- The range of COBOL_Digits is compact and the ten values
-- represent the digits 0-9 in sequence
-- The COBOL_Minus_Digits set is disjoint from COBOL_Digits
- -- These assumptions are true for all COBOL representations we know of.
+ -- These assumptions are true for all COBOL representations we know of
function Numeric_To_Decimal
(Item : Numeric;
-- Note that the tests here are all compile time tests
function Length (Format : Binary_Format) return Natural is
- pragma Warnings (Off, Format);
+ pragma Unreferenced (Format);
begin
if Num'Digits <= 2 then
return 1;
function Length
(Format : Packed_Format) return Natural
is
- pragma Warnings (Off, Format);
-
+ pragma Unreferenced (Format);
begin
case Packed_Representation is
when IBM =>
function To_Decimal
(Item : Numeric;
- Format : Display_Format)
- return Num
+ Format : Display_Format) return Num
is
pragma Unsuppress (Range_Check);
begin
return Num'Fixed_Value (Numeric_To_Decimal (Item, Format));
-
exception
when Constraint_Error =>
raise Conversion_Error;
-- S p e c --
-- (ASCII Version) --
-- --
--- Copyright (C) 1993-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
function Valid
(Item : Numeric;
- Format : Display_Format)
- return Boolean;
+ Format : Display_Format) return Boolean;
function Length
- (Format : Display_Format)
- return Natural;
+ (Format : Display_Format) return Natural;
function To_Decimal
(Item : Numeric;
function To_Display
(Item : Num;
- Format : Display_Format)
- return Numeric;
+ Format : Display_Format) return Numeric;
-- Packed Formats: data values are represented as Packed_Decimal
function Valid
(Item : Packed_Decimal;
- Format : Packed_Format)
- return Boolean;
+ Format : Packed_Format) return Boolean;
function Length
- (Format : Packed_Format)
- return Natural;
+ (Format : Packed_Format) return Natural;
function To_Decimal
(Item : Packed_Decimal;
- Format : Packed_Format)
- return Num;
+ Format : Packed_Format) return Num;
function To_Packed
(Item : Num;
- Format : Packed_Format)
- return Packed_Decimal;
+ Format : Packed_Format) return Packed_Decimal;
-- Binary Formats: external data values are represented as Byte_Array
function Valid
(Item : Byte_Array;
- Format : Binary_Format)
- return Boolean;
+ Format : Binary_Format) return Boolean;
function Length
(Format : Binary_Format)
function To_Binary
(Item : Num;
- Format : Binary_Format)
- return Byte_Array;
+ Format : Binary_Format) return Byte_Array;
-- Internal Binary formats: data values are of type Binary/Long_Binary
type Packed_Format is (U, S);
- Packed_Unsigned : constant Packed_Format := U;
- Packed_Signed : constant Packed_Format := S;
+ Packed_Unsigned : constant Packed_Format := U;
+ Packed_Signed : constant Packed_Format := S;
type Packed_Representation_Type is (IBM);
-- Indicator for format used for packed decimal
Packed_Representation : constant Packed_Representation_Type := IBM;
- -- This version of the spec uses IBM internal format, as described above.
+ -- This version of the spec uses IBM internal format, as described above
-----------------------------
-- Display Decimal Formats --
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2005 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- --
-- --
------------------------------------------------------------------------------
--- This is the Alpha/VMS version.
+-- This is the Alpha/VMS version
with Unchecked_Conversion;
package body Interfaces.C_Streams is
Ch : int;
begin
- -- This Fread goes with the Fwrite below.
- -- The C library fread sometimes can't read fputc generated files.
+ -- This Fread goes with the Fwrite below. The C library fread sometimes
+ -- can't read fputc generated files.
for C in 1 .. count loop
for S in 1 .. size loop
Ch : int;
begin
- -- This Fread goes with the Fwrite below.
- -- The C library fread sometimes can't read fputc generated files.
+ -- This Fread goes with the Fwrite below. The C library fread sometimes
+ -- can't read fputc generated files.
for C in 1 + index .. count + index loop
for S in 1 .. size loop
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2005 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- --
(buffer : voids;
size : size_t;
count : size_t;
- stream : FILEs)
- return size_t;
+ stream : FILEs) return size_t;
function fread
(buffer : voids;
index : size_t;
size : size_t;
count : size_t;
- stream : FILEs)
- return size_t;
+ stream : FILEs) return size_t;
-- Same as normal fread, but has a parameter 'index' that indicates
-- the starting index for the read within 'buffer' (which must be the
-- address of the beginning of a whole array object with an assumed
-- functions.
function file_exists (name : chars) return int;
- -- Tests if given name corresponds to an existing file.
+ -- Tests if given name corresponds to an existing file
function is_regular_file (handle : int) return int;
- -- Tests if given handle is for a regular file (result 1) or for
- -- a non-regular file (pipe or device, result 0).
+ -- Tests if given handle is for a regular file (result 1) or for a
+ -- non-regular file (pipe or device, result 0).
---------------------------------
-- Control of Text/Binary Mode --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
package body Interfaces.C.Strings is
- -- Note that the type chars_ptr has a pragma No_Strict_Aliasing in
- -- the spec, to prevent any assumptions about aliasing for values
- -- of this type, since arbitrary addresses can be converted, and it
- -- is quite likely that this type will in fact be used for aliasing
- -- values of other types.
+ -- Note that the type chars_ptr has a pragma No_Strict_Aliasing in the
+ -- spec, to prevent any assumptions about aliasing for values of this type,
+ -- since arbitrary addresses can be converted, and it is quite likely that
+ -- this type will in fact be used for aliasing values of other types.
function To_chars_ptr is
new Unchecked_Conversion (Address, chars_ptr);
Index := Position_Of_Nul (Into => Chars);
Pointer := Memory_Alloc ((Index - Chars'First + 1));
- -- If nul is present, transfer string up to and including it.
+ -- If nul is present, transfer string up to and including nul
if Index <= Chars'Last then
Update (Item => Pointer,
Result : char_array (0 .. Length);
begin
- -- As per AI-00177, this is equivalent to
- -- To_Ada (Value (Item, Length) & nul);
+ -- As per AI-00177, this is equivalent to:
+
+ -- To_Ada (Value (Item, Length) & nul);
if Item = Null_Ptr then
raise Dereference_Error;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
-- even though we have to copy Tbl back and forth.
function Lt_Uname (C1, C2 : Natural) return Boolean;
- -- Comparison routine for comparing Unames. Needed by the sorting routine.
+ -- Comparison routine for comparing Unames. Needed by the sorting routine
procedure Move_Uname (From : Natural; To : Natural);
- -- Move routine needed by the sorting routine below.
+ -- Move routine needed by the sorting routine below
--------------
-- Lt_Uname --
Next_Elmt (Priv_Elmt);
end loop;
- -- Now restore the type itself to its private view.
+ -- Now restore the type itself to its private view
Exchange_Declarations (Id);
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2005 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- --
procedure Write_Map (E : Entity_Id);
pragma Warnings (Off, Write_Map);
- -- For debugging purposes.
+ -- For debugging purposes
---------------------
-- Add_Association --
if Headers_Table.Table (Offh + J) /= No_Assoc then
- -- Place new association at head of chain.
+ -- Place new association at head of chain
Associations_Table.Table (K).Next := Headers_Table.Table (Offh + J);
end if;
projects / platform / upstream / linaro-gcc.git / commitdiff