type Argument_List_Access is access Argument_List;
procedure Free is new Ada.Unchecked_Deallocation
(Argument_List, Argument_List_Access);
- -- Free only the allocated Argument_List, not the allocated String
- -- components.
+ -- Free only the allocated Argument_List, not allocated String components
--------------------
-- Arguments_From --
-- if necessary.
procedure Recurse (File_Name : String);
- -- Get the arguments from the file and call itself recursively if
- -- one of the argument starts with character '@'.
+ -- Get the arguments from the file and call itself recursively if one of
+ -- the argument starts with character '@'.
------------------
-- Add_Argument --
First_Char : Positive;
-- Index of the first character of an argument in Line
- Last_Char : Natural;
+ Last_Char : Natural;
-- Index of the last character of an argument in Line
In_String : Boolean;
-- True when inside a quoted string
- Arg : Positive;
+ Arg : Positive;
function End_Of_File return Boolean;
-- True when the end of the response file has been reached
procedure Get_Line is
Ch : Character;
+
begin
Last := 0;
if FD = Invalid_FD then
if Ignore_Non_Existing_Files then
return;
-
else
raise File_Does_Not_Exist;
end if;
Next => null,
Prev => null);
Last_File := First_File;
+
else
declare
Current : File_Ptr := First_File;
+
begin
loop
if Current.Name.all = File_Name then
Character_Loop :
while Last_Char <= Last loop
+
-- Inside a string, check only for '"'
if In_String then
if Line (Last_Char) = '"' then
+
-- Remove the '"'
Line (Last_Char .. Last - 1) :=
Last := Last - 1;
-- End of string is end of argument
+
if Last_Char > Last or else
Line (Last_Char) = ' ' or else
Line (Last_Char) = ASCII.HT
end if;
elsif Last_Char = Last then
+
-- An opening '"' at the end of the line is an error
if Line (Last) = '"' then
end if;
elsif Line (Last_Char) = '"' then
+
-- Entering a quoted string: remove the '"'
In_String := True;
Last := Last - 1;
else
- -- Outside of quoted strings, white space ends the
- -- argument.
+ -- Outside quoted strings, white space ends the argument
exit Character_Loop
when Line (Last_Char + 1) = ' ' or else
Last_Arg := Last_Arg - 1;
else
- -- Save the current arguments and get those in the
- -- new response file.
+ -- Save the current arguments and get those in the new
+ -- response file.
declare
Inc_File_Name : constant String :=
begin
-- Grow Arguments if it is not large enough
+
if Arguments'Last < New_Last_Arg then
Last_Arg := Arguments'Last;
Free (Arguments);
exception
when others =>
+
-- When an exception occurs, deallocate everything
Free (Arguments);
-- --
-- B o d y --
-- --
--- Copyright (C) 2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2007, 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- --
begin
if Left'Length (2) /= Right'Length (1) then
raise Constraint_Error with
- "incompatible dimensions in matrix-matrix multipication";
+ "incompatible dimensions in matrix-matrix multiplication";
end if;
gemm (Trans_A => No_Trans'Access,
-- dx Force the binder to read (and then ignore) the xref information
-- in ali files (used to check that read circuit is working OK).
- ------------------------------------------------------------
- -- Documentation for the Debug Flags used in package Make --
- ------------------------------------------------------------
-
- -- Please note that such flags apply to all of Make clients,
- -- such as gnatmake.
+ --------------------------------------------
+ -- Documentation for gnatmake Debug Flags --
+ --------------------------------------------
- -- dn Do not delete temporary files creates by Make at the end
+ -- dn Do not delete temporary files created by gnatmake at the end
-- of execution, such as temporary config pragma files, mapping
-- files or project path files.
-- dw Prints the list of units withed by the unit currently explored
-- during the main loop of Make.Compile_Sources.
+ ---------------------------------------------
+ -- Documentation for gprbuild Debug Flags --
+ ---------------------------------------------
+
+ -- dn Do not delete temporary files createed by gprbuild at the end
+ -- of execution, such as temporary config pragma files, mapping
+ -- files or project path files.
+
+ -- dt When a time stamp mismatch has been found for an ALI file,
+ -- display the source file name, the time stamp expected and
+ -- the time stamp found.
+
--------------------
-- Set_Debug_Flag --
--------------------
sprintf (expression, "%s=%s", name, value);
putenv (expression);
-#if (defined (__FreeBSD__) && (__FreeBSD__ < 7)) || defined (__APPLE__) \
- || defined (__MINGW32__) ||(defined (__vxworks) && ! defined (__RTP__))
- /* On some systems like pre-7 FreeBSD, MacOS X and Windows, putenv is making
- a copy of the expression string so we can free it after the call to
- putenv */
+#if (defined (__FreeBSD__) && (__FreeBSD__ < 7)) \
+ || defined (__APPLE__) || defined (__MINGW32__) \
+ ||(defined (__vxworks) && ! defined (__RTP__))
+ /* On some systems like FreeBSD 6.x and earlier, MacOS X and Windows,
+ putenv is making a copy of the expression string so we can free
+ it after the call to putenv */
free (expression);
#endif
#endif
-- This procedure performs in-place aggregate assignment.
procedure Convert_Aggr_In_Allocator
- (Alloc : Node_Id;
- Decl : Node_Id;
- Aggr : Node_Id);
+ (Alloc : Node_Id;
+ Decl : Node_Id;
+ Aggr : Node_Id);
-- Alloc is the allocator whose expression is the aggregate Aggr.
-- Decl is an N_Object_Declaration created during allocator expansion.
-- This procedure perform in-place aggregate assignment into the
-- ??? passing a formal as actual for a mode IN formal is
-- considered as an assignment?
- if Nkind (Parent (N)) = N_Procedure_Call_Statement
- or else Nkind (Parent (N)) = N_Entry_Call_Statement
- or else
- (Nkind (Parent (N)) = N_Assignment_Statement
- and then N = Name (Parent (N)))
+ if Nkind_In (Parent (N), N_Procedure_Call_Statement,
+ N_Entry_Call_Statement)
+ or else (Nkind (Parent (N)) = N_Assignment_Statement
+ and then N = Name (Parent (N)))
then
return True;
-- which case there is an implicit dereference, and the formal itself
-- is not being assigned to).
- elsif (Nkind (Parent (N)) = N_Selected_Component
- or else Nkind (Parent (N)) = N_Indexed_Component
- or else Nkind (Parent (N)) = N_Slice)
+ elsif Nkind_In (Parent (N), N_Selected_Component,
+ N_Indexed_Component,
+ N_Slice)
and then N = Prefix (Parent (N))
and then not Is_Access_Type (Etype (N))
and then In_Assignment_Context (Parent (N))
begin
-- Simple reference case
- if Nkind (N) = N_Identifier or else Nkind (N) = N_Expanded_Name then
+ if Nkind_In (N, N_Identifier, N_Expanded_Name) then
if Is_Formal (Entity (N)) then
return Entity (N);
Attribute_Name => Name_Pos,
Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Styp, Loc),
- Attribute_Name => Name_First)))));
+ Prefix => New_Occurrence_Of (Styp, Loc),
+ Attribute_Name => Name_First)))));
end if;
Set_Paren_Count (Newsub, 1);
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (Indx_Typ, Loc),
Attribute_Name => Name_Pos,
- Expressions => New_List (
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (Indx_Typ, Loc),
Attribute_Name => Name_First))),
High_Bound =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (Indx_Typ, Loc),
Attribute_Name => Name_Pos,
- Expressions => New_List (
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (Indx_Typ, Loc),
Attribute_Name => Name_Last)))))));
Name => New_Occurrence_Of (Set_nn, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => Obj),
+ Prefix => Obj,
+ Attribute_Name => Name_Address),
Subscr,
Unchecked_Convert_To (Bits_nn,
Convert_To (Ctyp, Rhs)))));
Parameter_Associations => New_List (
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => L),
+ Prefix => L,
+ Attribute_Name => Name_Address),
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of
(Etype (First_Index (Ltyp)), Loc),
Attribute_Name => Name_Range_Length),
+
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Ltyp))),
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => R),
+ Prefix => R,
+ Attribute_Name => Name_Address),
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of
(Etype (First_Index (Rtyp)), Loc),
Attribute_Name => Name_Range_Length),
+
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Rtyp))),
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => New_Occurrence_Of (Result_Ent, Loc))))));
+ Prefix => New_Occurrence_Of (Result_Ent, Loc),
+ Attribute_Name => Name_Address)))));
Rewrite (N,
New_Occurrence_Of (Result_Ent, Loc));
Name => New_Occurrence_Of (Get_nn, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => Obj),
+ Prefix => Obj,
+ Attribute_Name => Name_Address),
Subscr))));
end;
end if;
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix => New_Occurrence_Of (Ltyp, Loc)),
+ Prefix => New_Occurrence_Of (Ltyp, Loc),
+ Attribute_Name => Name_Length),
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Ltyp)));
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix => New_Occurrence_Of (Rtyp, Loc)),
+ Prefix => New_Occurrence_Of (Rtyp, Loc),
+ Attribute_Name => Name_Length),
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Rtyp)));
Name => New_Occurrence_Of (RTE (RE_Bit_Eq), Loc),
Parameter_Associations => New_List (
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => L),
+ Prefix => L,
+ Attribute_Name => Name_Address),
LLexpr,
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => R),
+ Prefix => R,
+ Attribute_Name => Name_Address),
RLexpr)));
end if;
Parameter_Associations => New_List (
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => Opnd),
+ Prefix => Opnd,
+ Attribute_Name => Name_Address),
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of
(Etype (First_Index (Rtyp)), Loc),
Attribute_Name => Name_Range_Length),
+
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Rtyp))),
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => New_Occurrence_Of (Result_Ent, Loc))))));
+ Prefix => New_Occurrence_Of (Result_Ent, Loc),
+ Attribute_Name => Name_Address)))));
Rewrite (N,
New_Occurrence_Of (Result_Ent, Loc));
-- B o d y --
-- (Soft Binding Version) --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, 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 GNAT.Altivec.Low_Level_Vectors is
- -- This package assumes C_float is an IEEE single-precision float type
-
- pragma Assert (C_float'Machine_Radix = 2);
- pragma Assert (C_float'Machine_Mantissa = 24);
- pragma Assert (C_float'Machine_Emin = -125);
- pragma Assert (C_float'Machine_Emax = 128);
- pragma Assert (C_float'Machine_Rounds);
- pragma Assert (not C_float'Machine_Overflows);
- pragma Assert (C_float'Signed_Zeros);
- pragma Assert (C_float'Denorm);
-
-- Pixel types. As defined in [PIM-2.1 Data types]:
-- A 16-bit pixel is 1/5/5/5;
-- A 32-bit pixel is 8/8/8/8.
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, 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- --
type C_float is digits FLOAT_DIGIT range FLOAT_MIN .. FLOAT_MAX;
for C_float'Size use FLOAT_BIT;
+ -- Altivec operations always use the standard native floating-point
+ -- support of the target. Note that this means that there may be
+ -- minor differences in results between targets when the floating-
+ -- point implementations are slightly different, as would happen
+ -- with normal non-altivec floating-point operations. In particular
+ -- the Altivec simulations may yield slightly different results
+ -- from those obtained on a true hardware Altivec target if the
+ -- floating-point implementation is not 100% compatible.
----------------------
-- pixel components --
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2007, AdaCore -- --
+-- Copyright (C) 2006-2007, 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- --
-- Extended pseudo-random number generation
--- This package provides a type representing pseudo-random number
--- generators, and subprograms to extract various distributions of numbers
--- from them. It also provides types for representing initialization values
--- and snapshots of internal generator state, which permit reproducible
--- pseudo-random streams.
+-- This package provides a type representing pseudo-random number generators,
+-- and subprograms to extract various distributions of numbers from them. It
+-- also provides types for representing initialization values and snapshots of
+-- internal generator state, which permit reproducible pseudo-random streams.
-- The generator currently provided by this package has an extremely long
--- period (at least 2**19937-1), and passes the Big Crush test suite, with
--- the exception of the two linear complexity tests. Therefore, it is
--- suitable for simulations, but should not be used as a cryptographic
--- pseudo-random source without additional processing.
-
--- The design of this package effects some simplification from that of
--- the standard Ada.Numerics packages. There is no separate State type;
--- the Generator type itself suffices for this purpose. The parameter
--- modes on Reset procedures better reflect the effect of these routines.
+-- period (at least 2**19937-1), and passes the Big Crush test suite, with the
+-- exception of the two linear complexity tests. Therefore, it is suitable for
+-- simulations, but should not be used as a cryptographic pseudo-random source
+-- without additional processing.
+
+-- The design of this package effects is simplified compared to the design
+-- of standard Ada.Numerics packages. There is no separate State type; the
+-- Generator type itself suffices for this purpose. The parameter modes on
+-- Reset procedures better reflect the effect of these routines.
with System.Random_Numbers;
with Interfaces; use Interfaces;
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2006, AdaCore --
+-- Copyright (C) 2001-2007, 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- --
-- This is the Windows/NT version of this package
+-- This package should not be directly with'ed by an application program
+
package GNAT.Sockets.Linker_Options is
private
pragma Linker_Options ("-lws2_32");
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2005, AdaCore --
+-- Copyright (C) 2001-2007, 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- --
-- This is the Solaris version of this package
+-- This package should not be directly with'ed by an application program
+
package GNAT.Sockets.Linker_Options is
private
pragma Linker_Options ("-lnsl");
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2005, AdaCore --
+-- Copyright (C) 2001-2007, 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- --
-- are required. On some targets a target specific version of this unit
-- ensures linking with required libraries for proper sockets operation.
+-- This package should not be directly with'ed by an application program
+
package GNAT.Sockets.Linker_Options is
end GNAT.Sockets.Linker_Options;
-- This version is used on VMS, LynxOS, and VxWorks. There are two versions of
-- the body: one for VMS and LynxOS, the other for VxWorks.
+-- This package should not be directly with'ed by an application
+
package GNAT.Sockets.Thin.Task_Safe_NetDB is
----------------------------------------
-- from C; see gsocket.h for details. Different versions are provided on
-- platforms where this functionality is implemented in Ada.
+-- This package should not be directly with'ed by an application
+
package GNAT.Sockets.Thin.Task_Safe_NetDB is
----------------------------------------
Parm : Void_Ptr;
Code : Code_Proc)
is
- pragma Unreferenced (Parm);
pragma Priority (Prio);
pragma Storage_Size (Stsz);
end Thread;
-- Special Handling of Subprogram Bodies --
-------------------------------------------
- -- A subprogram body (in an adb file) may stand for both a spec and a
- -- body. A simple model (and one that was adopted through version 2.07),
- -- is simply to assume that such an adb file acts as its own spec if no
- -- ads file is present.
+ -- A subprogram body (in an adb file) may stand for both a spec and a body.
+ -- A simple model (and one that was adopted through version 2.07) is simply
+ -- to assume that such an adb file acts as its own spec if no ads file is
+ -- is present.
-- However, this is not correct. RM 10.1.4(4) requires that such a body
-- act as a spec unless a subprogram declaration of the same name is
if (Is_Overriding or else Not_Overriding) then
if Ada_Version < Ada_05 then
- Error_Msg_SP (" overriding indicator is an Ada 2005 extension");
+ Error_Msg_SP ("overriding indicator is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
elsif Token = Tok_Entry then
if (Is_Overriding or else Not_Overriding) then
if Ada_Version < Ada_05 then
- Error_Msg_SP (" overriding indicator is an Ada 2005 extension");
+ Error_Msg_SP ("overriding indicator is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
elsif Token /= Tok_Entry then
if File.Shared_Status = Yes
or else File.Name'Length <= 1
or else File.Is_System_File
- or else (not File.Is_Regular_File)
+ or else not File.Is_Regular_File
then
raise Use_Error;
-- Local Tasks --
-----------------
- -- WARNING: System.Tasking.Stages performs calls to this task
- -- with low-level constructs. Do not change this spec without synchro-
- -- nizing it.
+ -- WARNING: System.Tasking.Stages performs calls to this task with
+ -- low-level constructs. Do not change this spec without synchronizing it.
task Interrupt_Manager is
entry Detach_Interrupt_Entries (T : Task_Id);
task type Server_Task (Interrupt : Interrupt_ID) is
pragma Priority (System.Interrupt_Priority'Last);
- -- Note: the above pragma Priority is strictly speaking improper
- -- since it is outside the range of allowed priorities, but the
- -- compiler treats system units specially and does not apply
- -- this range checking rule to system units.
+ -- Note: the above pragma Priority is strictly speaking improper since
+ -- it is outside the range of allowed priorities, but the compiler
+ -- treats system units specially and does not apply this range checking
+ -- rule to system units.
end Server_Task;
(others => (null, Static => False));
pragma Volatile_Components (User_Handler);
-- Holds the protected procedure handler (if any) and its Static
- -- information for each interrupt. A handler is a Static one if
- -- it is specified through the pragma Attach_Handler.
- -- Attach_Handler. Otherwise, not static)
+ -- information for each interrupt. A handler is a Static one if it is
+ -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise,
+ -- not static)
User_Entry : array (Interrupt_ID'Range) of Entry_Assoc :=
(others => (T => Null_Task, E => Null_Task_Entry));
Last_Unblocker :
array (Interrupt_ID'Range) of Task_Id := (others => Null_Task);
pragma Atomic_Components (Last_Unblocker);
- -- Holds the ID of the last Task which Unblocked this Interrupt.
- -- It contains Null_Task if no tasks have ever requested the
- -- Unblocking operation or the Interrupt is currently Blocked.
+ -- Holds the ID of the last Task which Unblocked this Interrupt. It
+ -- contains Null_Task if no tasks have ever requested the Unblocking
+ -- operation or the Interrupt is currently Blocked.
Server_ID : array (Interrupt_ID'Range) of Task_Id :=
(others => Null_Task);
pragma Atomic_Components (Server_ID);
- -- Holds the Task_Id of the Server_Task for each interrupt.
- -- Task_Id is needed to accomplish locking per Interrupt base. Also
- -- is needed to decide whether to create a new Server_Task.
+ -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is
+ -- needed to accomplish locking per Interrupt base. Also is needed to
+ -- decide whether to create a new Server_Task.
-- Type and Head, Tail of the list containing Registered Interrupt
-- Handlers. These definitions are used to register the handlers
-----------------------
function Is_Registered (Handler : Parameterless_Handler) return Boolean;
- -- See if the Handler has been "pragma"ed using Interrupt_Handler.
- -- Always consider a null handler as registered.
+ -- See if the Handler has been "pragma"ed using Interrupt_Handler. Always
+ -- consider a null handler as registered.
--------------------
-- Attach_Handler --
--------------------
- -- Calling this procedure with New_Handler = null and Static = True
- -- means we want to detach the current handler regardless of the
- -- previous handler's binding status (ie. do not care if it is a
- -- dynamic or static handler).
+ -- Calling this procedure with New_Handler = null and Static = True means
+ -- we want to detach the current handler regardless of the previous
+ -- handler's binding status (ie. do not care if it is a dynamic or static
+ -- handler).
- -- This option is needed so that during the finalization of a PO, we
- -- can detach handlers attached through pragma Attach_Handler.
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
procedure Attach_Handler
(New_Handler : Parameterless_Handler;
-- Bind_Interrupt_To_Entry --
-----------------------------
- -- This procedure raises a Program_Error if it tries to bind an
- -- interrupt to which an Entry or a Procedure is already bound.
+ -- This procedure raises a Program_Error if it tries to bind an interrupt
+ -- to which an Entry or a Procedure is already bound.
procedure Bind_Interrupt_To_Entry
(T : Task_Id;
-- Exchange_Handler --
----------------------
- -- Calling this procedure with New_Handler = null and Static = True
- -- means we want to detach the current handler regardless of the
- -- previous handler's binding status (ie. do not care if it is a
- -- dynamic or static handler).
+ -- Calling this procedure with New_Handler = null and Static = True means
+ -- we want to detach the current handler regardless of the previous
+ -- handler's binding status (ie. do not care if it is a dynamic or static
+ -- handler).
- -- This option is needed so that during the finalization of a PO,
- -- we can detach handlers attached through pragma Attach_Handler.
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
procedure Exchange_Handler
(Old_Handler : out Parameterless_Handler;
-- --
-- S Y S T E M . T A S K _ I N F O --
-- --
--- S p e c --
+-- B o d y --
-- --
-- Copyright (C) 2007, Free Software Foundation, Inc. --
-- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2007, 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- --
-- Register an exception in the hash table mapping with a VMS
-- condition code.
- -- LOTS more comments needed here regarding the enire scheme ???
+ -- LOTS more comments needed here regarding the entire scheme ???
private
else
Choice := First (Get_Choices (Alt));
-
while Present (Choice) loop
Analyze (Choice);
Kind := Nkind (Choice);
Spawn (Addr2line_Cmd.all,
Addr2line_Args (1 .. Addr2line_Args_Count), Success);
+ if not Success then
+ Error ("Couldn't spawn " & Addr2line_Cmd.all);
+ end if;
+
exception
when others =>
Err : exception;
+ pragma Warnings (Off);
+ -- These seem not to be referenced, but they are (by * operator)
+
A : VString := Nul;
B : VString := Nul;
C : VString := Nul;
Rtn : VString := Nul;
Term : VString := Nul;
+ pragma Warnings (On);
+
InB : File_Type;
-- Used to read initial header from body
Ofile : File_Type;
-- Used to write output file
- wsp : Pattern := NSpan (' ' & ASCII.HT);
- Comment : Pattern := wsp & "--";
- For_Rep : Pattern := wsp & "for";
- Get_Func : Pattern := wsp * A & "function" & wsp & Break (' ') * Name;
- Inline : Pattern := wsp & "pragma Inline (" & Break (')') * Name;
- Get_Pack : Pattern := wsp & "package ";
- Get_Enam : Pattern := wsp & Break (',') * N & ',';
- Find_Fun : Pattern := wsp & "function";
- F_Subtyp : Pattern := wsp * A & "subtype " & Break (' ') * N;
- G_Subtyp : Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
- & wsp & "is" & wsp & Break (" ;") * OldS
- & wsp & ';' & wsp & Rtab (0);
- F_Typ : Pattern := wsp * A & "type " & Break (' ') * N & " is (";
- Get_Nam : Pattern := wsp * A & Break (",)") * Nam & Len (1) * Term;
- Get_Styp : Pattern := wsp * A & "subtype " & Break (' ') * N;
- Get_N1 : Pattern := wsp & Break (' ') * N1;
- Get_N2 : Pattern := wsp & "-- " & Rest * N2;
- Get_N3 : Pattern := wsp & Break (';') * N3;
- Get_FN : Pattern := wsp * C & "function" & wsp & Break (" (") * FN;
- Is_Rturn : Pattern := BreakX ('r') & "return";
- Is_Begin : Pattern := wsp & "begin";
- Get_Asrt : Pattern := wsp & "pragma Assert";
- Semicoln : Pattern := BreakX (';');
- Get_Cmnt : Pattern := BreakX ('-') * A & "--";
- Get_Expr : Pattern := wsp & "return " & Break (';') * Expr;
- Chek_End : Pattern := wsp & "end" & BreakX (';') & ';';
- Get_B1 : Pattern := BreakX (' ') * A & " in " & Rest * B;
- Get_B2 : Pattern := BreakX (' ') * A & " = " & Rest * B;
- Get_B3 : Pattern := BreakX (' ') * A & " /= " & Rest * B;
- To_Paren : Pattern := wsp * Filler & '(';
- Get_Fml : Pattern := Break (" :") * Formal & wsp & ':' & wsp
- & BreakX (" );") * Formaltyp;
- Nxt_Fml : Pattern := wsp & "; ";
- Get_Rtn : Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
- Rem_Prn : Pattern := wsp & ')';
+ wsp : constant Pattern := NSpan (' ' & ASCII.HT);
+ Comment : constant Pattern := wsp & "--";
+ For_Rep : constant Pattern := wsp & "for";
+ Get_Func : constant Pattern := wsp * A & "function" & wsp
+ & Break (' ') * Name;
+ Inline : constant Pattern := wsp & "pragma Inline (" & Break (')') * Name;
+ Get_Pack : constant Pattern := wsp & "package ";
+ Get_Enam : constant Pattern := wsp & Break (',') * N & ',';
+ Find_Fun : constant Pattern := wsp & "function";
+ F_Subtyp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
+ G_Subtyp : constant Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
+ & wsp & "is" & wsp & Break (" ;") * OldS
+ & wsp & ';' & wsp & Rtab (0);
+ F_Typ : constant Pattern := wsp * A & "type " & Break (' ') * N &
+ " is (";
+ Get_Nam : constant Pattern := wsp * A & Break (",)") * Nam
+ & Len (1) * Term;
+ Get_Styp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
+ Get_N1 : constant Pattern := wsp & Break (' ') * N1;
+ Get_N2 : constant Pattern := wsp & "-- " & Rest * N2;
+ Get_N3 : constant Pattern := wsp & Break (';') * N3;
+ Get_FN : constant Pattern := wsp * C & "function" & wsp
+ & Break (" (") * FN;
+ Is_Rturn : constant Pattern := BreakX ('r') & "return";
+ Is_Begin : constant Pattern := wsp & "begin";
+ Get_Asrt : constant Pattern := wsp & "pragma Assert";
+ Semicoln : constant Pattern := BreakX (';');
+ Get_Cmnt : constant Pattern := BreakX ('-') * A & "--";
+ Get_Expr : constant Pattern := wsp & "return " & Break (';') * Expr;
+ Chek_End : constant Pattern := wsp & "end" & BreakX (';') & ';';
+ Get_B1 : constant Pattern := BreakX (' ') * A & " in " & Rest * B;
+ Get_B2 : constant Pattern := BreakX (' ') * A & " = " & Rest * B;
+ Get_B3 : constant Pattern := BreakX (' ') * A & " /= " & Rest * B;
+ To_Paren : constant Pattern := wsp * Filler & '(';
+ Get_Fml : constant Pattern := Break (" :") * Formal & wsp & ':' & wsp
+ & BreakX (" );") * Formaltyp;
+ Nxt_Fml : constant Pattern := wsp & "; ";
+ Get_Rtn : constant Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
+ Rem_Prn : constant Pattern := wsp & ')';
M : Match_Result;
Err : exception;
-- Raised to terminate execution
- A : VString := Nul;
- Arg : VString := Nul;
- Arg_List : VString := Nul;
- Comment : VString := Nul;
- Default : VString := Nul;
- Field : VString := Nul;
- Line : VString := Nul;
- Node : VString := Nul;
- Op_Name : VString := Nul;
- Prevl : VString := Nul;
- Synonym : VString := Nul;
- X : VString := Nul;
+ pragma Warnings (Off);
+ -- The following are modified by * operator
+
+ A : VString := Nul;
+ Arg : VString := Nul;
+ Arg_List : VString := Nul;
+ Comment : VString := Nul;
+ Default : VString := Nul;
+ Field : VString := Nul;
+ Line : VString := Nul;
+ Node : VString := Nul;
+ Op_Name : VString := Nul;
+ Prevl : VString := Nul;
+ Synonym : VString := Nul;
+ X : VString := Nul;
NWidth : Natural;
InS, InT : Ada.Text_IO.File_Type;
OutS, OutB : Sfile;
- wsp : Pattern := Span (' ' & ASCII.HT);
+ wsp : constant Pattern := Span (' ' & ASCII.HT);
- Body_Only : Pattern := BreakX (' ') * X & Span (' ') & "-- body only";
- Spec_Only : Pattern := BreakX (' ') * X & Span (' ') & "-- spec only";
+ Body_Only : constant Pattern := BreakX (' ') * X
+ & Span (' ') & "-- body only";
+ Spec_Only : constant Pattern := BreakX (' ') * X
+ & Span (' ') & "-- spec only";
- Node_Hdr : Pattern := wsp & "-- N_" & Rest * Node;
- Punc : Pattern := BreakX (" .,");
+ Node_Hdr : constant Pattern := wsp & "-- N_" & Rest * Node;
+ Punc : constant Pattern := BreakX (" .,");
- Binop : Pattern := wsp & "-- plus fields for binary operator";
- Unop : Pattern := wsp & "-- plus fields for unary operator";
- Syn : Pattern := wsp & "-- " & Break (' ') * Synonym
- & " (" & Break (')') * Field & Rest * Comment;
+ Binop : constant Pattern := wsp
+ & "-- plus fields for binary operator";
+ Unop : constant Pattern := wsp
+ & "-- plus fields for unary operator";
+ Syn : constant Pattern := wsp & "-- " & Break (' ') * Synonym
+ & " (" & Break (')') * Field
+ & Rest * Comment;
- Templ : Pattern := BreakX ('T') * A & "T e m p l a t e";
- Spec : Pattern := BreakX ('S') * A & "S p e c";
+ Templ : constant Pattern := BreakX ('T') * A & "T e m p l a t e";
+ Spec : constant Pattern := BreakX ('S') * A & "S p e c";
- Sem_Field : Pattern := BreakX ('-') & "-Sem";
- Lib_Field : Pattern := BreakX ('-') & "-Lib";
+ Sem_Field : constant Pattern := BreakX ('-') & "-Sem";
+ Lib_Field : constant Pattern := BreakX ('-') & "-Lib";
- Get_Field : Pattern := BreakX (Decimal_Digit_Set) * Field;
+ Get_Field : constant Pattern := BreakX (Decimal_Digit_Set) * Field;
- Get_Dflt : Pattern := BreakX ('(') & "(set to "
- & Break (" ") * Default & " if";
+ Get_Dflt : constant Pattern := BreakX ('(') & "(set to "
+ & Break (" ") * Default & " if";
- Next_Arg : Pattern := Break (',') * Arg & ',';
+ Next_Arg : constant Pattern := Break (',') * Arg & ',';
- Op_Node : Pattern := "Op_" & Rest * Op_Name;
+ Op_Node : constant Pattern := "Op_" & Rest * Op_Name;
- Shft_Rot : Pattern := "Shift_" or "Rotate_";
+ Shft_Rot : constant Pattern := "Shift_" or "Rotate_";
- No_Ent : Pattern := "Or_Else" or "And_Then" or "In" or "Not_In";
+ No_Ent : constant Pattern := "Or_Else" or "And_Then"
+ or "In" or "Not_In";
M : Match_Result;
Done : exception;
Err : exception;
+ pragma Warnings (Off);
+ -- Below variables are referenced using * operator
+
A : VString := Nul;
Arg : VString := Nul;
Comment : VString := Nul;
Rtn : VString := Nul;
Term : VString := Nul;
+ pragma Warnings (On);
+
InS : File_Type;
Ofile : File_Type;
- wsp : Pattern := Span (' ' & ASCII.HT);
- Wsp_For : Pattern := wsp & "for";
- Is_Cmnt : Pattern := wsp & "--";
- Typ_Nod : Pattern := wsp * A & "type Node_Kind is";
- Get_Nam : Pattern := wsp * A & "N_" & Break (",)") * Nam
- & Len (1) * Term;
- Sub_Typ : Pattern := wsp * A & "subtype " & Break (' ') * N;
- No_Cont : Pattern := wsp & Break (' ') * N1 & " .. " & Break (';') * N2;
- Cont_N1 : Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0);
- Cont_N2 : Pattern := Span (' ') & Break (';') * N2;
- Is_Func : Pattern := wsp * A & "function " & Rest * Nam;
- Get_Arg : Pattern := wsp & "(N : " & Break (')') * Arg
- & ") return " & Break (';') * Rtn
- & ';' & wsp & "--" & wsp & Rest * Comment;
+ wsp : constant Pattern := Span (' ' & ASCII.HT);
+ Wsp_For : constant Pattern := wsp & "for";
+ Is_Cmnt : constant Pattern := wsp & "--";
+ Typ_Nod : constant Pattern := wsp * A & "type Node_Kind is";
+ Get_Nam : constant Pattern := wsp * A & "N_" & Break (",)") * Nam
+ & Len (1) * Term;
+ Sub_Typ : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
+ No_Cont : constant Pattern := wsp & Break (' ') * N1
+ & " .. " & Break (';') * N2;
+ Cont_N1 : constant Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0);
+ Cont_N2 : constant Pattern := Span (' ') & Break (';') * N2;
+ Is_Func : constant Pattern := wsp * A & "function " & Rest * Nam;
+ Get_Arg : constant Pattern := wsp & "(N : " & Break (')') * Arg
+ & ") return " & Break (';') * Rtn
+ & ';' & wsp & "--" & wsp & Rest * Comment;
NKV : Natural;
InH : File_Type;
OutH : File_Type;
- A, B : VString := Nul;
- Line : VString := Nul;
- Name : VString := Nul;
- Name1 : VString := Nul;
- Oname : VString := Nul;
- Oval : VString := Nul;
- Restl : VString := Nul;
+ pragma Warnings (Off);
+ -- Variables below are modifed by * operator
- Tdigs : Pattern := Any (Decimal_Digit_Set) &
- Any (Decimal_Digit_Set) &
- Any (Decimal_Digit_Set);
+ A, B : VString := Nul;
+ Line : VString := Nul;
+ Name : VString := Nul;
+ Name1 : VString := Nul;
+ Oname : VString := Nul;
+ Oval : VString := Nul;
+ Restl : VString := Nul;
- Name_Ref : Pattern := Span (' ') * A & Break (' ') * Name
- & Span (' ') * B
- & ": constant Name_Id := N + " & Tdigs
- & ';' & Rest * Restl;
+ pragma Warnings (On);
- Get_Name : Pattern := "Name_" & Rest * Name1;
+ Tdigs : constant Pattern := Any (Decimal_Digit_Set) &
+ Any (Decimal_Digit_Set) &
+ Any (Decimal_Digit_Set);
- Chk_Low : Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
+ Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name
+ & Span (' ') * B
+ & ": constant Name_Id := N + " & Tdigs
+ & ';' & Rest * Restl;
- Findu : Pattern := Span ('u') * A;
+ Get_Name : constant Pattern := "Name_" & Rest * Name1;
+ Chk_Low : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
+ Findu : constant Pattern := Span ('u') * A;
Val : Natural;
- Xlate_U_Und : Character_Mapping := To_Mapping ("u", "_");
+ Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_");
M : Match_Result;
type Header_Symbol is (None, Attr, Conv, Prag);
-- A symbol in the header file
- -- Prefixes used in the header file
+ procedure Output_Header_Line (S : Header_Symbol);
+ -- Output header line
Header_Attr : aliased String := "Attr";
Header_Conv : aliased String := "Convention";
Header_Prag : aliased String := "Pragma";
+ -- Prefixes used in the header file
type String_Ptr is access all String;
Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
-- Patterns used in the spec file
- Get_Attr : Pattern := Span (' ') & "Attribute_" & Break (",)") * Name1;
- Get_Conv : Pattern := Span (' ') & "Convention_" & Break (",)") * Name1;
- Get_Prag : Pattern := Span (' ') & "Pragma_" & Break (",)") * Name1;
+ Get_Attr : constant Pattern := Span (' ') & "Attribute_"
+ & Break (",)") * Name1;
+ Get_Conv : constant Pattern := Span (' ') & "Convention_"
+ & Break (",)") * Name1;
+ Get_Prag : constant Pattern := Span (' ') & "Pragma_"
+ & Break (",)") * Name1;
type Header_Symbol_Counter is array (Header_Symbol) of Natural;
Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0);
if Header_Current_Symbol /= S then
declare
- Pat : String := "#define " & Header_Prefix (S).all;
+ Pat : constant String := "#define " & Header_Prefix (S).all;
In_Pat : Boolean := False;
begin
Line := Get_Line (InH);
if Match (Line, Pat) then
- In_Pat := true;
+ In_Pat := True;
elsif In_Pat then
Header_Pending_Line := Line;
exit;
Err : exception;
-- Raised on fatal error
- A : VString := Nul;
- Ffield : VString := Nul;
- Field : VString := Nul;
- Fieldno : VString := Nul;
- Flagno : VString := Nul;
- Line : VString := Nul;
- Name : VString := Nul;
- Node : VString := Nul;
- Outstring : VString := Nul;
- Prefix : VString := Nul;
- S : VString := Nul;
- S1 : VString := Nul;
- Syn : VString := Nul;
- Synonym : VString := Nul;
- Term : VString := Nul;
+ pragma Warnings (Off);
+ -- Following variables are assigned by * operator
+
+ A : VString := Nul;
+ Ffield : VString := Nul;
+ Field : VString := Nul;
+ Fieldno : VString := Nul;
+ Flagno : VString := Nul;
+ Line : VString := Nul;
+ Name : VString := Nul;
+ Node : VString := Nul;
+ Outstring : VString := Nul;
+ Prefix : VString := Nul;
+ S : VString := Nul;
+ S1 : VString := Nul;
+ Syn : VString := Nul;
+ Synonym : VString := Nul;
+ Term : VString := Nul;
+
+ pragma Warnings (On);
subtype Sfile is Ada.Streams.Stream_IO.File_Type;
Sp : aliased Natural;
-- Space left on line for Pchars output
- wsp : Pattern := Span (' ' & ASCII.HT);
-
- Is_Temp : Pattern := BreakX ('T') * A & "T e m p l a t e";
- Get_Node : Pattern := wsp & "-- N_" & Rest * Node;
- Tst_Punc : Pattern := Break (" ,.");
- Get_Syn : Pattern := Span (' ') & "-- " & Break (' ') * Synonym
- & " (" & Break (')') * Field;
- Brk_Min : Pattern := Break ('-') * Ffield;
- Is_Flag : Pattern := "Flag" & Rest * Flagno;
- Is_Field : Pattern := Rtab (1) & Len (1) * Fieldno;
- Is_Syn : Pattern := wsp & "N_" & Break (",)") * Syn & Len (1) * Term;
- Brk_Node : Pattern := Break (' ') * Node & ' ';
- Chop_SP : Pattern := Len (Sp'Unrestricted_Access) * S1;
+ wsp : constant Pattern := Span (' ' & ASCII.HT);
+ Is_Temp : constant Pattern := BreakX ('T') * A & "T e m p l a t e";
+ Get_Node : constant Pattern := wsp & "-- N_" & Rest * Node;
+ Tst_Punc : constant Pattern := Break (" ,.");
+ Get_Syn : constant Pattern := Span (' ') & "-- " & Break (' ') * Synonym
+ & " (" & Break (')') * Field;
+ Brk_Min : constant Pattern := Break ('-') * Ffield;
+ Is_Flag : constant Pattern := "Flag" & Rest * Flagno;
+ Is_Field : constant Pattern := Rtab (1) & Len (1) * Fieldno;
+ Is_Syn : constant Pattern := wsp & "N_" & Break (",)") * Syn
+ & Len (1) * Term;
+ Brk_Node : constant Pattern := Break (' ') * Node & ' ';
+ Chop_SP : constant Pattern := Len (Sp'Unrestricted_Access) * S1;
M : Match_Result;
OSDN Git Service
