-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
Pic.Contents.Picture.Expanded;
begin
for J in Temp'Range loop
- if Temp (J) = 'b' then Temp (J) := 'B'; end if;
+ if Temp (J) = 'b' then
+ Temp (J) := 'B';
+ end if;
end loop;
return Temp;
procedure Set_State (L : Legality) is
begin
- if Debug then Ada.Text_IO.Put_Line
- (" Set state from " & Legality'Image (State) &
- " to " & Legality'Image (L));
+ if Debug then
+ Ada.Text_IO.Put_Line
+ (" Set state from " & Legality'Image (State)
+ & " to " & Legality'Image (L));
end if;
State := L;
procedure Skip is
begin
- if Debug then Ada.Text_IO.Put_Line
- (" Skip " & Pic.Picture.Expanded (Index));
+ if Debug then
+ Ada.Text_IO.Put_Line (" Skip " & Pic.Picture.Expanded (Index));
end if;
Index := Index + 1;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
Pic.Contents.Picture.Expanded;
begin
for J in Temp'Range loop
- if Temp (J) = 'b' then Temp (J) := 'B'; end if;
+ if Temp (J) = 'b' then
+ Temp (J) := 'B';
+ end if;
end loop;
return Temp;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
Pic.Contents.Picture.Expanded;
begin
for J in Temp'Range loop
- if Temp (J) = 'b' then Temp (J) := 'B'; end if;
+ if Temp (J) = 'b' then
+ Temp (J) := 'B';
+ end if;
end loop;
return Temp;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
function Digits_From_Size (Size : Pos) return Pos is
begin
- if Size = 32 then return 6;
- elsif Size = 48 then return 9;
- elsif Size = 64 then return 15;
- elsif Size = 96 then return 18;
- elsif Size = 128 then return 18;
+ if Size = 32 then
+ return 6;
+ elsif Size = 48 then
+ return 9;
+ elsif Size = 64 then
+ return 15;
+ elsif Size = 96 then
+ return 18;
+ elsif Size = 128 then
+ return 18;
else
raise Program_Error;
end if;
function Width_From_Size (Size : Pos) return Pos is
begin
- if Size = 8 then return 4;
- elsif Size = 16 then return 6;
- elsif Size = 32 then return 11;
- elsif Size = 64 then return 21;
+ if Size = 8 then
+ return 4;
+ elsif Size = 16 then
+ return 6;
+ elsif Size = 32 then
+ return 11;
+ elsif Size = 64 then
+ return 21;
else
raise Program_Error;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
if Token = Tok_Private then
Private_Sloc := Token_Ptr;
Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
- if Style_Check then Style.Check_Indentation; end if;
+ if Style_Check then
+ Style.Check_Indentation;
+ end if;
Save_Scan_State (Scan_State); -- at PRIVATE
Scan; -- past PRIVATE
-- it hasn't already been done on seeing a WITH or PRIVATE.
Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
- if Style_Check then Style.Check_Indentation; end if;
+ if Style_Check then
+ Style.Check_Indentation;
+ end if;
-- Remaining processing depends on particular type of compilation unit
-- Loop through context items
loop
- if Style_Check then Style.Check_Indentation; end if;
+ if Style_Check then
+ Style.Check_Indentation;
+ end if;
-- Gather any pragmas appearing in the context clause
end loop;
begin
- if Style_Check then Style.Check_Indentation; end if;
+ if Style_Check then
+ Style.Check_Indentation;
+ end if;
-- Deal with reserved identifier (in assignment or call)
begin
if Token_Is_At_Start_Of_Line and then Token = Tok_Then then
Check_If_Column;
- if Style_Check then Style.Check_Then (Loc); end if;
+
+ if Style_Check then
+ Style.Check_Then (Loc);
+ end if;
end if;
end Check_Then_Column;
Case_Alt_Node : Node_Id;
begin
- if Style_Check then Style.Check_Indentation; end if;
+ if Style_Check then
+ Style.Check_Indentation;
+ end if;
+
Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr);
T_When; -- past WHEN (or give error in OTHERS case)
Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
Set_Declarations (Parent, Decls);
if Token = Tok_Begin then
- if Style_Check then Style.Check_Indentation; end if;
+ if Style_Check then
+ Style.Check_Indentation;
+ end if;
Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
package body System.OS_Interface is
+ -----------
+ -- Errno --
+ -----------
+
function Errno return int is
type int_ptr is access all int;
function internal_errno return int_ptr;
pragma Import (C, internal_errno, "__error");
+
begin
return (internal_errno.all);
end Errno;
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
function Get_Stack_Base (thread : pthread_t) return Address is
pragma Unreferenced (thread);
begin
return (0);
end Get_Stack_Base;
+ ------------------
+ -- pthread_init --
+ ------------------
+
procedure pthread_init is
begin
null;
function To_Timespec (D : Duration) return timespec is
S : time_t;
F : Duration;
+
begin
S := time_t (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
- -- value.
- if F < 0.0 then S := S - 1; F := F + 1.0; end if;
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
return timespec'(ts_sec => S,
- ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
end System.OS_Interface;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- --
-- GNARL 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 To_Target_Priority
(Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority.
+ -- Maps System.Any_Priority to a POSIX priority
-------------
-- Process --
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2005, AdaCore --
+-- Copyright (C) 1995-2007, AdaCore --
-- --
-- GNARL 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 a Solaris version of this package.
+-- This is a Solaris version of this package
-- This package encapsulates all direct interfaces to OS services
-- that are needed by children of System.
-- tasking operations. It causes infinite loops and other problems.
with Interfaces.C; use Interfaces.C;
+
package body System.OS_Interface is
-----------------
function To_Timespec (D : Duration) return timespec is
S : time_t;
F : Duration;
+
begin
S := time_t (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
- -- value.
- if F < 0.0 then S := S - 1; F := F + 1.0; end if;
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
return timespec'(tv_sec => S,
tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
+ -----------------
+ -- To_Duration --
+ -----------------
+
function To_Duration (TV : struct_timeval) return Duration is
begin
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end To_Duration;
+ ----------------
+ -- To_Timeval --
+ ----------------
+
function To_Timeval (D : Duration) return struct_timeval is
S : long;
F : Duration;
+
begin
S := long (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
- -- value.
- if F < 0.0 then S := S - 1; F := F + 1.0; end if;
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
return
struct_timeval'
(tv_sec => S,
tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
+ ------------------
+ -- pthread_init --
+ ------------------
+
procedure pthread_init is
begin
null;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF);
-- Following signals should not be disturbed.
- -- See c-posix-signals.c in FLORIST
+ -- See c-posix-signals.c in FLORIST.
Reserved : constant Signal_Set :=
(SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL, SIGTRAP, SIGSEGV);
type id_t is new long;
P_MYID : constant := -1;
- -- the specified LWP or process is the current one.
+ -- The specified LWP or process is the current one
type struct_pcinfo is record
pc_cid : id_t;
-- Constants for function processor_bind
PBIND_QUERY : constant processorid_t := -2;
- -- the processor bindings are not changed.
+ -- The processor bindings are not changed
PBIND_NONE : constant processorid_t := -1;
- -- the processor bindings of the specified LWPs are cleared.
+ -- The processor bindings of the specified LWPs are cleared
-- Flags for function p_online
PR_OFFLINE : constant int := 1;
- -- processor is offline, as quiet as possible
+ -- Processor is offline, as quiet as possible
PR_ONLINE : constant int := 2;
- -- processor online
+ -- Processor online
PR_STATUS : constant int := 3;
- -- value passed to p_online to request status
+ -- Value passed to p_online to request status
function p_online (processorid : processorid_t; flag : int) return int;
pragma Import (C, p_online, "p_online");
pragma Import (C, processor_bind, "processor_bind");
procedure pthread_init;
- -- dummy procedure to share s-intman.adb with other Solaris targets.
+ -- Dummy procedure to share s-intman.adb with other Solaris targets
private
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-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- --
function Get_WC_Encoding_Method (S : String) return WC_Encoding_Method is
begin
- if S = "hex" then return WCEM_Hex;
- elsif S = "upper" then return WCEM_Upper;
- elsif S = "shift_jis" then return WCEM_Shift_JIS;
- elsif S = "euc" then return WCEM_EUC;
- elsif S = "utf8" then return WCEM_UTF8;
- elsif S = "brackets" then return WCEM_Brackets;
+ if S = "hex" then
+ return WCEM_Hex;
+ elsif S = "upper" then
+ return WCEM_Upper;
+ elsif S = "shift_jis" then
+ return WCEM_Shift_JIS;
+ elsif S = "euc" then
+ return WCEM_EUC;
+ elsif S = "utf8" then
+ return WCEM_UTF8;
+ elsif S = "brackets" then
+ return WCEM_Brackets;
else
raise Constraint_Error;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- Check that token is first token on line, or else is not preceded
-- by white space. Signal error of space not allowed if not.
+ procedure Check_Separate_Stmt_Lines_Cont;
+ -- Non-inlined continuation of Check_Separate_Stmt_Lines
+
function Determine_Token_Casing return Casing_Type;
+ -- Determine casing of current token
procedure Error_Space_Not_Allowed (S : Source_Ptr);
-- Posts an error message indicating that a space is not allowed
end if;
end Check_Semicolon;
+ -------------------------------
+ -- Check_Separate_Stmt_Lines --
+ -------------------------------
+
+ procedure Check_Separate_Stmt_Lines is
+ begin
+ if Style_Check_Separate_Stmt_Lines then
+ Check_Separate_Stmt_Lines_Cont;
+ end if;
+ end Check_Separate_Stmt_Lines;
+
+ ------------------------------------
+ -- Check_Separate_Stmt_Lines_Cont --
+ ------------------------------------
+
+ procedure Check_Separate_Stmt_Lines_Cont is
+ S : Source_Ptr;
+
+ begin
+ -- Skip past white space
+
+ S := Scan_Ptr;
+ while Is_White_Space (Source (S)) loop
+ S := S + 1;
+ end loop;
+
+ -- Line terminator is OK
+
+ if Source (S) in Line_Terminator then
+ return;
+
+ -- Comment is OK
+
+ elsif Source (S) = '-' and then Source (S + 1) = '-' then
+ return;
+
+ -- ABORT keyword is OK after THEN (THEN ABORT case)
+
+ elsif Token = Tok_Then
+ and then (Source (S + 0) = 'a' or else Source (S + 0) = 'A')
+ and then (Source (S + 1) = 'b' or else Source (S + 1) = 'B')
+ and then (Source (S + 2) = 'o' or else Source (S + 2) = 'O')
+ and then (Source (S + 3) = 'r' or else Source (S + 3) = 'R')
+ and then (Source (S + 4) = 't' or else Source (S + 4) = 'T')
+ and then (Source (S + 5) in Line_Terminator
+ or else Is_White_Space (Source (S + 5)))
+ then
+ return;
+
+ -- PRAGMA keyword is OK after ELSE
+
+ elsif Token = Tok_Else
+ and then (Source (S + 0) = 'p' or else Source (S + 0) = 'P')
+ and then (Source (S + 1) = 'r' or else Source (S + 1) = 'R')
+ and then (Source (S + 2) = 'a' or else Source (S + 2) = 'A')
+ and then (Source (S + 3) = 'g' or else Source (S + 3) = 'G')
+ and then (Source (S + 4) = 'm' or else Source (S + 4) = 'M')
+ and then (Source (S + 5) = 'a' or else Source (S + 5) = 'A')
+ and then (Source (S + 6) in Line_Terminator
+ or else Is_White_Space (Source (S + 6)))
+ then
+ return;
+
+ -- Otherwise we have the style violation we are looking for
+
+ else
+ if Token = Tok_Then then
+ Error_Msg
+ ("(style) no statements may follow THEN on same line", S);
+ else
+ Error_Msg
+ ("(style) no statements may follow ELSE on same line", S);
+ end if;
+ end if;
+ end Check_Separate_Stmt_Lines_Cont;
+
----------------
-- Check_Then --
----------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- procedure is called only if THEN appears at the start of a line with
-- Token_Ptr pointing to the THEN keyword.
+ procedure Check_Separate_Stmt_Lines;
+ pragma Inline (Check_Separate_Stmt_Lines);
+ -- Called after scanning THEN (not preceded by AND) or ELSE (not preceded
+ -- by OR). Used to check that no tokens follow on the same line (which
+ -- would intefere with coverage testing). Handles case of THEN ABORT as
+ -- an exception, as well as PRAGMA after ELSE.
+
procedure Check_Unary_Plus_Or_Minus;
-- Called after scanning a unary plus or minus to check spacing
Style_Check_Order_Subprograms := False;
Style_Check_Pragma_Casing := False;
Style_Check_References := False;
+ Style_Check_Separate_Stmt_Lines := False;
Style_Check_Specs := False;
Style_Check_Standard := False;
Style_Check_Tokens := False;
------------------------------
procedure Save_Style_Check_Options (Options : out Style_Check_Options) is
- P : Natural := 0;
+ P : Natural := 0;
procedure Add (C : Character; S : Boolean);
-- Add given character C to string if switch S is true
Add ('p', Style_Check_Pragma_Casing);
Add ('r', Style_Check_References);
Add ('s', Style_Check_Specs);
+ Add ('S', Style_Check_Separate_Stmt_Lines);
Add ('t', Style_Check_Tokens);
Add ('u', Style_Check_Blank_Lines);
Add ('x', Style_Check_Xtra_Parens);
procedure Set_GNAT_Style_Check_Options is
begin
Reset_Style_Check_Options;
- Set_Style_Check_Options ("3aAbcdefhiklmnprstux");
+ Set_Style_Check_Options ("3aAbcdefhiklmnprsStux");
end Set_GNAT_Style_Check_Options;
-----------------------------
when 's' =>
Style_Check_Specs := True;
+ when 'S' =>
+ Style_Check_Separate_Stmt_Lines := True;
+
when 't' =>
Style_Check_Tokens := True;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
--------------------------
-- These flags are used to control the details of the style checking
- -- options. The default values shown here correspond to no style
- -- checking. If any of these values is set to a non-default value,
- -- then Opt.Style_Check is set True to active calls to this package.
+ -- options. The default values shown here correspond to no style checking.
- -- The actual mechanism for setting these switches to other than
- -- default values is via the Set_Style_Check_Option procedure or
- -- through a call to Set_Default_Style_Check_Options. They should
- -- not be set directly in any other manner.
+ -- If any of these values is set to a non-default value, then
+ -- Opt.Style_Check is set True to active calls to this package.
+
+ -- The actual mechanism for setting these switches to other than default
+ -- values is via the Set_Style_Check_Option procedure or through a call to
+ -- Set_Default_Style_Check_Options. They should not be set directly in any
+ -- other manner.
Style_Check_Array_Attribute_Index : Boolean := False;
-- This can be set True by using -gnatg or -gnatyA switches. If it is True
-- array attribute references.
Style_Check_Attribute_Casing : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatya switches. If
- -- it is True, then attribute names (including keywords such as
- -- digits used as attribute names) must be in mixed case.
+ -- This can be set True by using the -gnatg or -gnatya switches. If it is
+ -- True, then attribute names (including keywords such as digits used as
+ -- attribute names) must be in mixed case.
Style_Check_Blanks_At_End : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyb switches. If
- -- it is True, then spaces at the end of lines are not permitted.
+ -- This can be set True by using the -gnatg or -gnatyb switches. If it is
+ -- True, then spaces at the end of lines are not permitted.
Style_Check_Blank_Lines : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyu switches. If
- -- it is True, then multiple blank lines are not permitted, and there
- -- may not be a blank line at the end of the file.
+ -- This can be set True by using the -gnatg or -gnatyu switches. If it is
+ -- True, then multiple blank lines are not permitted, and there may not be
+ -- a blank line at the end of the file.
Style_Check_Comments : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyc switches. If
- -- it is True, then comments are style checked as follows:
+ -- This can be set True by using the -gnatg or -gnatyc switches. If it is
+ -- True, then comments are style checked as follows:
--
- -- All comments must be at the start of the line, or the first
- -- minus must be preceded by at least one space.
+ -- All comments must be at the start of the line, or the first minus must
+ -- be preceded by at least one space.
--
- -- For a comment that is not at the start of a line, the only
- -- requirement is that a space follow the comment characters.
+ -- For a comment that is not at the start of a line, the only requirement
+ -- is that a space follow the comment characters.
--
- -- For a coment that is at the start of the line, one of the
- -- following conditions must hold:
+ -- For a coment that is at the start of the line, one of the following
+ -- conditions must hold:
--
-- The comment characters are the only non-blank characters on the line
--
--
-- The line consists entirely of minus signs
--
- -- The comment characters are followed by a single space, and the
- -- last two characters on the line are also comment characters.
+ -- The comment characters are followed by a single space, and the last
+ -- two characters on the line are also comment characters.
--
-- Note: the reason for the last two conditions is to allow "boxed"
-- comments where only a single space separates the comment characters.
Style_Check_DOS_Line_Terminator : Boolean := False;
- -- This can be set true by using the -gnatg or -gnatyd switches. If
- -- it is True, then the line terminator must be a single LF, without an
+ -- This can be set true by using the -gnatg or -gnatyd switches. If it
+ -- is True, then the line terminator must be a single LF, without an
-- associated CR (e.g. DOS line terminator sequence CR/LF not allowed).
Style_Check_End_Labels : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatye switches. If
- -- it is True, then optional END labels must always be present.
+ -- This can be set True by using the -gnatg or -gnatye switches. If it is
+ -- True, then optional END labels must always be present.
Style_Check_Form_Feeds : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyf switches. If
- -- it is True, then form feeds and vertical tabs are not allowed in
- -- the source text.
+ -- This can be set True by using the -gnatg or -gnatyf switches. If it is
+ -- True, then form feeds and vertical tabs are not allowed in the source
+ -- text.
Style_Check_Horizontal_Tabs : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyh switches. If
- -- it is True, then horizontal tabs are not allowed in source text.
+ -- This can be set True by using the -gnatg or -gnatyh switches. If it is
+ -- True, then horizontal tabs are not allowed in source text.
Style_Check_If_Then_Layout : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyi switches. If
- -- it is True, then a THEN keyword may not appear on the line that
- -- immediately follows the line containing the corresponding IF.
+ -- This can be set True by using the -gnatg or -gnatyi switches. If it is
+ -- True, then a THEN keyword may not appear on the line that immediately
+ -- follows the line containing the corresponding IF.
--
- -- This permits one of two styles for IF-THEN layout. Either the
- -- IF and THEN keywords are on the same line, where the condition
- -- is short enough, or the conditions are continued over to the
- -- lines following the IF and the THEN stands on its own. For
- -- example:
+ -- This permits one of two styles for IF-THEN layout. Either the IF and
+ -- THEN keywords are on the same line, where the condition is short enough,
+ -- or the conditions are continued over to the lines following the IF and
+ -- the THEN stands on its own. For example:
--
-- if X > Y then
--
Style_Check_Indentation : Column_Number range 0 .. 9 := 0;
-- This can be set non-zero by using the -gnatg or -gnatyn (n a digit)
- -- switches. If it is non-zero it activates indentation checking with
- -- the indicated indentation value. A value of zero turns off checking.
- -- The requirement is that any new statement, line comment, declaration
- -- or keyword such as END, start on a column that is a multiple of the
+ -- switches. If it is non-zero it activates indentation checking with the
+ -- indicated indentation value. A value of zero turns off checking. The
+ -- requirement is that any new statement, line comment, declaration or
+ -- keyword such as END, start on a column that is a multiple of the
-- indentiation value.
Style_Check_Keyword_Casing : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyk switches. If
- -- it is True, then keywords are required to be in all lower case.
- -- This rule does not apply to keywords such as digits appearing as
- -- an attribute name.
+ -- This can be set True by using the -gnatg or -gnatyk switches. If it is
+ -- True, then keywords are required to be in all lower case. This rule does
+ -- not apply to keywords such as digits appearing as an attribute name.
+
+ Style_Check_Layout : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyl switches. If it is
+ -- True, it activates checks that constructs are indented as suggested by
+ -- the examples in the RM syntax, e.g. that the ELSE keyword must line up
+ -- with the IF keyword.
Style_Check_Max_Line_Length : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatym/M switches.
- -- If it is True, it activates checking for a maximum line length of
+ -- This can be set True by using the -gnatg or -gnatym/M switches. If
+ -- it is True, it activates checking for a maximum line length of
-- Style_Max_Line_Length characters.
Style_Check_Max_Nesting_Level : Boolean := False;
- -- This can be set True by using -gnatyLnnn with a value other than
- -- zero (a value of zero resets it to False). If True, it activates
- -- checking the maximum nesting level against Style_Max_Nesting_Level.
+ -- This can be set True by using -gnatyLnnn with a value other than zero
+ -- (a value of zero resets it to False). If True, it activates checking
+ -- the maximum nesting level against Style_Max_Nesting_Level.
Style_Check_Mode_In : Boolean := False;
-- This can be set True by using -gnatyI. If True, it activates checking
-- that mode IN is not used on its own (since it is the default).
Style_Check_Order_Subprograms : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyo switch. If it
- -- is True, then names of subprogram bodies must be in alphabetical
- -- order (not taking casing into account).
+ -- This can be set True by using the -gnatg or -gnatyo switch. If it is
+ -- True, then names of subprogram bodies must be in alphabetical order
+ -- (not taking casing into account).
Style_Check_Pragma_Casing : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyp switches. If
- -- it is True, then pragma names must use mixed case.
-
- Style_Check_Layout : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyl switches. If
- -- it is True, it activates checks that constructs are indented as
- -- suggested by the examples in the RM syntax, e.g. that the ELSE
- -- keyword must line up with the IF keyword.
+ -- This can be set True by using the -gnatg or -gnatyp switches. If it is
+ -- True, then pragma names must use mixed case.
Style_Check_References : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyr switches. If
- -- it is True, then all references to declared identifiers are
- -- checked. The requirement is that casing of the reference be the
- -- same as the casing of the corresponding declaration.
+ -- This can be set True by using the -gnatg or -gnatyr switches. If it is
+ -- True, then all references to declared identifiers are checked. The
+ -- requirement is that casing of the reference be the same as the casing
+ -- of the corresponding declaration.
+
+ Style_Check_Separate_Stmt_Lines : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyS switches. If it is
+ -- TRUE, then for the case of keywords THEN (not preceded by AND) or ELSE
+ -- (not preceded by OR) which introduce a conditionally executed statement
+ -- sequence, there must be no tokens on the same line as the keyword, so
+ -- that coverage testing can clearly identify execution of the statement
+ -- sequence. A comment is permitted, as is THEN ABORT or a PRAGMA keyword
+ -- after ELSE (a common style to specify the condition for the ELSE).
Style_Check_Specs : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatys switches. If
- -- it is True, then separate specs are required to be present for
- -- all procedures except parameterless library level procedures.
- -- The exception means that typical main programs do not require
- -- separate specs.
+ -- This can be set True by using the -gnatg or -gnatys switches. If it is
+ -- True, then separate specs are required to be present for all procedures
+ -- except parameterless library level procedures. The exception means that
+ -- typical main programs do not require separate specs.
Style_Check_Standard : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyn switches. If
- -- it is True, then any references to names in Standard have to be
- -- in mixed case mode (e.g. Integer, Boolean).
+ -- This can be set True by using the -gnatg or -gnatyn switches. If it is
+ -- True, then any references to names in Standard have to be in mixed case
+ -- mode (e.g. Integer, Boolean).
Style_Check_Tokens : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatyt switches. If
- -- it is True, then the style check that requires canonical spacing
- -- between various punctuation tokens as follows:
+ -- This can be set True by using the -gnatg or -gnatyt switches. If it is
+ -- True, then the style check that requires canonical spacing between
+ -- various punctuation tokens as follows:
--
-- ABS and NOT must be followed by a space
--
-- <> must be preceded by a space or left paren
--
-- Binary operators other than ** must be surrounded by spaces.
+ --
-- There is no restriction on the layout of the ** binary operator.
--
-- Colon must be surrounded by spaces
-- immediately preceded by a non-blank character, and must be followed
-- by a blank.
--
- -- A space must precede a left paren following a digit or letter,
- -- and a right paren must not be followed by a space (it can be
- -- at the end of the line).
+ -- A space must precede a left paren following a digit or letter, and a
+ -- right paren must not be followed by a space (it can be at the end of
+ -- the line).
--
- -- A right paren must either be the first non-blank character on
- -- a line, or it must be preceded by a non-blank character.
+ -- A right paren must either be the first non-blank character on a line,
+ -- or it must be preceded by a non-blank character.
--
- -- A semicolon must not be preceded by a blank, and must not be
- -- followed by a non-blank character.
+ -- A semicolon must not be preceded by a blank, and must not be followed
+ -- by a non-blank character.
--
-- A unary plus or minus may not be followed by a space
--
-- A vertical bar must be surrounded by spaces
--
- -- Note that a requirement that a token be preceded by a space is
- -- met by placing the token at the start of the line, and similarly
- -- a requirement that a token be followed by a space is met by
- -- placing the token at the end of the line. Note that in the case
- -- where horizontal tabs are permitted, a horizontal tab is acceptable
- -- for meeting the requirement for a space.
+ -- Note that a requirement that a token be preceded by a space is met by
+ -- placing the token at the start of the line, and similarly a requirement
+ -- that a token be followed by a space is met by placing the token at
+ -- the end of the line. Note that in the case where horizontal tabs are
+ -- permitted, a horizontal tab is acceptable for meeting the requirement
+ -- for a space.
Style_Check_Xtra_Parens : Boolean := False;
-- This can be set True by using the -gnatg or -gnatyx switch. If true,
- -- then it is not allowed to enclose entire conditional expressions
- -- in parentheses (C style).
+ -- then it is not allowed to enclose entire conditional expressions in
+ -- parentheses (C style).
Style_Max_Line_Length : Int := 0;
- -- Value used to check maximum line length. Gets reset as a result of
- -- use of -gnatym or -gnatyMnnn switches (or by use of -gnatg). This
- -- value is only read if Style_Check_Max_Line_Length is True.
+ -- Value used to check maximum line length. Gets reset as a result of use
+ -- of -gnatym or -gnatyMnnn switches (or by use of -gnatg). This value is
+ -- only read if Style_Check_Max_Line_Length is True.
Style_Max_Nesting_Level : Int := 0;
-- Value used to check maximum nesting level. Gets reset as a result
-----------------
procedure Set_Default_Style_Check_Options;
- -- This procedure is called to set the default style checking options
- -- in response to a -gnaty switch with no suboptions.
+ -- This procedure is called to set the default style checking options in
+ -- response to a -gnaty switch with no suboptions.
procedure Set_GNAT_Style_Check_Options;
- -- This procedure is called to set the default style checking options
- -- for GNAT units (as set by -gnatg or -gnatyg).
+ -- This procedure is called to set the default style checking options for
+ -- GNAT units (as set by -gnatg or -gnatyg).
Style_Msg_Buf : String (1 .. 80);
Style_Msg_Len : Natural;
-- Long enough string to hold all options from Save call below
procedure Save_Style_Check_Options (Options : out Style_Check_Options);
- -- Sets Options to represent current selection of options. This
- -- set can be restored by first calling Reset_Style_Check_Options,
- -- and then calling Set_Style_Check_Options with the Options string.
+ -- Sets Options to represent current selection of options. This set can be
+ -- restored by first calling Reset_Style_Check_Options, and then calling
+ -- Set_Style_Check_Options with the Options string.
end Stylesw;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- Uint value containing Int'First value, set by Initialize. The initial
-- value of Uint_0 is used for an assertion check that ensures that this
-- value is not used before it is initialized. This value is used in the
- -- UI_Is_In_Int_Range predicate, and it is right that this is a host
- -- value, since the issue is host representation of integer values.
+ -- UI_Is_In_Int_Range predicate, and it is right that this is a host value,
+ -- since the issue is host representation of integer values.
Uint_Int_Last : Uint;
-- Uint value containing Int'Last value set by Initialize
Uints_Min : Uint;
Udigits_Min : Int;
- -- These values are used to make sure that the mark/release mechanism
- -- does not destroy values saved in the U_Power tables or in the hash
- -- table used by UI_From_Int. Whenever an entry is made in either of
- -- these tabls, Uints_Min and Udigits_Min are updated to protect the
- -- entry, and Release never cuts back beyond these minimum values.
+ -- These values are used to make sure that the mark/release mechanism does
+ -- not destroy values saved in the U_Power tables or in the hash table used
+ -- by UI_From_Int. Whenever an entry is made in either of these tabls,
+ -- Uints_Min and Udigits_Min are updated to protect the entry, and Release
+ -- never cuts back beyond these minimum values.
Int_0 : constant Int := 0;
Int_1 : constant Int := 1;
-- UI_From_Int Hash Table --
----------------------------
- -- UI_From_Int uses a hash table to avoid duplicating entries and
- -- wasting storage. This is particularly important for complex cases
- -- of back annotation.
+ -- UI_From_Int uses a hash table to avoid duplicating entries and wasting
+ -- storage. This is particularly important for complex cases of back
+ -- annotation.
subtype Hnum is Nat range 0 .. 1022;
-- Returns True if U is represented directly
function Direct_Val (U : Uint) return Int;
- -- U is a Uint for is represented directly. The returned result
- -- is the value represented.
+ -- U is a Uint for is represented directly. The returned result is the
+ -- value represented.
function GCD (Jin, Kin : Int) return Int;
-- Compute GCD of two integers. Assumes that Jin >= Kin >= 0
(Input : Uint;
To_Buffer : Boolean;
Format : UI_Format);
- -- Common processing for UI_Image and UI_Write, To_Buffer is set
- -- True for UI_Image, and false for UI_Write, and Format is copied
- -- from the Format parameter to UI_Image or UI_Write.
+ -- Common processing for UI_Image and UI_Write, To_Buffer is set True for
+ -- UI_Image, and false for UI_Write, and Format is copied from the Format
+ -- parameter to UI_Image or UI_Write.
procedure Init_Operand (UI : Uint; Vec : out UI_Vector);
pragma Inline (Init_Operand);
-- This procedure puts the value of UI into the vector in canonical
- -- multiple precision format. The parameter should be of the correct
- -- size as determined by a previous call to N_Digits (UI). The first
- -- digit of Vec contains the sign, all other digits are always non-
- -- negative. Note that the input may be directly represented, and in
- -- this case Vec will contain the corresponding one or two digit value.
- -- The low bound of Vec is always 1.
+ -- multiple precision format. The parameter should be of the correct size
+ -- as determined by a previous call to N_Digits (UI). The first digit of
+ -- Vec contains the sign, all other digits are always non- negative. Note
+ -- that the input may be directly represented, and in this case Vec will
+ -- contain the corresponding one or two digit value. The low bound of Vec
+ -- is always 1.
function Least_Sig_Digit (Arg : Uint) return Int;
pragma Inline (Least_Sig_Digit);
- -- Returns the Least Significant Digit of Arg quickly. When the given
- -- Uint is less than 2**15, the value returned is the input value, in
- -- this case the result may be negative. It is expected that any use
- -- will mask off unnecessary bits. This is used for finding Arg mod B
- -- where B is a power of two. Hence the actual base is irrelevent as
- -- long as it is a power of two.
+ -- Returns the Least Significant Digit of Arg quickly. When the given Uint
+ -- is less than 2**15, the value returned is the input value, in this case
+ -- the result may be negative. It is expected that any use will mask off
+ -- unnecessary bits. This is used for finding Arg mod B where B is a power
+ -- of two. Hence the actual base is irrelevent as long as it is a power of
+ -- two.
procedure Most_Sig_2_Digits
(Left : Uint;
Left_Hat : out Int;
Right_Hat : out Int);
-- Returns leading two significant digits from the given pair of Uint's.
- -- Mathematically: returns Left / (Base ** K) and Right / (Base ** K)
- -- where K is as small as possible S.T. Right_Hat < Base * Base.
- -- It is required that Left > Right for the algorithm to work.
+ -- Mathematically: returns Left / (Base ** K) and Right / (Base ** K) where
+ -- K is as small as possible S.T. Right_Hat < Base * Base. It is required
+ -- that Left > Right for the algorithm to work.
function N_Digits (Input : Uint) return Int;
pragma Inline (N_Digits);
-- Returns number of "digits" in a Uint
function Sum_Digits (Left : Uint; Sign : Int) return Int;
- -- If Sign = 1 return the sum of the "digits" of Abs (Left). If the
- -- total has more then one digit then return Sum_Digits of total.
+ -- If Sign = 1 return the sum of the "digits" of Abs (Left). If the total
+ -- has more then one digit then return Sum_Digits of total.
function Sum_Double_Digits (Left : Uint; Sign : Int) return Int;
-- Same as above but work in New_Base = Base * Base
Discard_Remainder : Boolean);
-- Compute euclidian division of Left by Right, and return Quotient and
-- signed Remainder (Left rem Right).
- -- If Discard_Quotient is True, Quotient is left unchanged.
- -- If Discard_Remainder is True, Remainder is left unchanged.
+ --
+ -- If Discard_Quotient is True, Quotient is left unchanged.
+ -- If Discard_Remainder is True, Remainder is left unchanged.
function Vector_To_Uint
(In_Vec : UI_Vector;
Negative : Boolean) return Uint;
- -- Functions that calculate values in UI_Vectors, call this function
- -- to create and return the Uint value. In_Vec contains the multiple
- -- precision (Base) representation of a non-negative value. Leading
- -- zeroes are permitted. Negative is set if the desired result is
- -- the negative of the given value. The result will be either the
- -- appropriate directly represented value, or a table entry in the
- -- proper canonical format is created and returned.
+ -- Functions that calculate values in UI_Vectors, call this function to
+ -- create and return the Uint value. In_Vec contains the multiple precision
+ -- (Base) representation of a non-negative value. Leading zeroes are
+ -- permitted. Negative is set if the desired result is the negative of the
+ -- given value. The result will be either the appropriate directly
+ -- represented value, or a table entry in the proper canonical format is
+ -- created and returned.
--
- -- Note that Init_Operand puts a signed value in the result vector,
- -- but Vector_To_Uint is always presented with a non-negative value.
- -- The processing of signs is something that is done by the caller
- -- before calling Vector_To_Uint.
+ -- Note that Init_Operand puts a signed value in the result vector, but
+ -- Vector_To_Uint is always presented with a non-negative value. The
+ -- processing of signs is something that is done by the caller before
+ -- calling Vector_To_Uint.
------------
-- Direct --
J := Jin;
K := Kin;
-
while K /= Uint_0 loop
Tmp := J mod K;
J := K;
-- Internal procedure to output one character
procedure Image_Exponent (N : Natural);
- -- Output non-zero exponent. Note that we only use the exponent
- -- form in the buffer case, so we know that To_Buffer is true.
+ -- Output non-zero exponent. Note that we only use the exponent form in
+ -- the buffer case, so we know that To_Buffer is true.
procedure Image_Uint (U : Uint);
-- Internal procedure to output characters of non-negative Uint
X_Bigger := True;
else
Sum_Length := R_Length + 1;
- if R_Length > L_Length then Y_Bigger := True; end if;
+
+ if R_Length > L_Length then
+ Y_Bigger := True;
+ end if;
end if;
- -- Make copies of the absolute values of L_Vec and R_Vec into
- -- X and Y both with lengths equal to the maximum possibly
- -- needed. This makes looping over the digits much simpler.
+ -- Make copies of the absolute values of L_Vec and R_Vec into X and Y
+ -- both with lengths equal to the maximum possibly needed. This makes
+ -- looping over the digits much simpler.
declare
X : UI_Vector (1 .. Sum_Length);
end loop;
end if;
- -- If they have identical magnitude, just return 0, else
- -- swap if necessary so that X had the bigger magnitude.
- -- Determine if result is negative at this time.
+ -- If they have identical magnitude, just return 0, else swap
+ -- if necessary so that X had the bigger magnitude. Determine
+ -- if result is negative at this time.
Result_Neg := False;
function UI_Decimal_Digits_Hi (U : Uint) return Nat is
begin
- -- The maximum value of a "digit" is 32767, which is 5 decimal
- -- digits, so an N_Digit number could take up to 5 times this
- -- number of digits. This is certainly too high for large
- -- numbers but it is not worth worrying about.
+ -- The maximum value of a "digit" is 32767, which is 5 decimal digits,
+ -- so an N_Digit number could take up to 5 times this number of digits.
+ -- This is certainly too high for large numbers but it is not worth
+ -- worrying about.
return 5 * N_Digits (U);
end UI_Decimal_Digits_Hi;
-- The maximum value of a "digit" is 32767, which is more than four
-- decimal digits, but not a full five digits. The easily computed
-- minimum number of decimal digits is thus 1 + 4 * the number of
- -- digits. This is certainly too low for large numbers but it is
- -- not worth worrying about.
+ -- digits. This is certainly too low for large numbers but it is not
+ -- worth worrying about.
return 1 + 4 * (N_Digits (U) - 1);
end UI_Decimal_Digits_Lo;
Dividend (J) := Dividend (J) + Carry;
-- [ TEST REMAINDER ] & [ ADD BACK ] (steps D5 and D6)
+
-- Here there is a slight difference from the book: the last
-- carry is always added in above and below (cancelling each
-- other). In fact the dividend going negative is used as
if Dint (Min_Direct) <= Input and then Input <= Dint (Max_Direct) then
return Uint (Dint (Uint_Direct_Bias) + Input);
- -- For values of larger magnitude, compute digits into a vector and
- -- call Vector_To_Uint.
+ -- For values of larger magnitude, compute digits into a vector and call
+ -- Vector_To_Uint.
else
declare
Max_For_Dint : constant := 5;
- -- Base is defined so that 5 Uint digits is sufficient
- -- to hold the largest possible Dint value.
+ -- Base is defined so that 5 Uint digits is sufficient to hold the
+ -- largest possible Dint value.
V : UI_Vector (1 .. Max_For_Dint);
return U;
end if;
- -- For values of larger magnitude, compute digits into a vector and
- -- call Vector_To_Uint.
+ -- For values of larger magnitude, compute digits into a vector and call
+ -- Vector_To_Uint.
declare
Max_For_Int : constant := 3;
- -- Base is defined so that 3 Uint digits is sufficient
- -- to hold the largest possible Int value.
+ -- Base is defined so that 3 Uint digits is sufficient to hold the
+ -- largest possible Int value.
V : UI_Vector (1 .. Max_For_Int);
exit when Q /= ((U_Hat + B) / Den2);
- -- A single precision step Euclid step will give same answer as
- -- a multiprecision one.
+ -- A single precision step Euclid step will give same answer as a
+ -- multiprecision one.
T := A - (Q * C);
A := C;
else
-- Use prior single precision steps to compute this Euclid step
- -- Fixed bug 1415-008 spends 80% of its time working on this
- -- step. Perhaps we need a special case Int / Uint dot
- -- product to speed things up. ???
+ -- For constructs such as:
+ -- sqrt_2: constant := 1.41421_35623_73095_04880_16887_24209_698;
+ -- sqrt_eps: constant long_float := long_float( 1.0 / sqrt_2)
+ -- ** long_float'machine_mantissa;
+ --
+ -- we spend 80% of our time working on this step. Perhaps we need
+ -- a special case Int / Uint dot product to speed things up. ???
- -- Alternatively we could increase the single precision
- -- iterations to handle Uint's of some small size ( <5
- -- digits?). Then we would have more iterations on small Uint.
- -- Fixed bug 1415-008 only gets 5 (on average) single
- -- precision iterations per large iteration. ???
+ -- Alternatively we could increase the single precision iterations
+ -- to handle Uint's of some small size ( <5 digits?). Then we
+ -- would have more iterations on small Uint. On the code above, we
+ -- only get 5 (on average) single precision iterations per large
+ -- iteration. ???
Tmp_UI := (UI_From_Int (A) * U) + (UI_From_Int (B) * V);
V := (UI_From_Int (C) * U) + (UI_From_Int (D) * V);
U := Tmp_UI;
end if;
- -- If the operands are very different in magnitude, the loop
- -- will generate large amounts of short-lived data, which it is
- -- worth removing periodically.
+ -- If the operands are very different in magnitude, the loop will
+ -- generate large amounts of short-lived data, which it is worth
+ -- removing periodically.
if Iterations > 100 then
Release_And_Save (Marks, U, V);
function UI_Negate (Right : Uint) return Uint is
begin
- -- Case where input is directly represented. Note that since the
- -- range of Direct values is non-symmetrical, the result may not
- -- be directly represented, this is taken care of in UI_From_Int.
+ -- Case where input is directly represented. Note that since the range
+ -- of Direct values is non-symmetrical, the result may not be directly
+ -- represented, this is taken care of in UI_From_Int.
if Direct (Right) then
return UI_From_Int (-Direct_Val (Right));
- -- Full processing for multi-digit case. Note that we cannot just
- -- copy the value to the end of the table negating the first digit,
- -- since the range of Direct values is non-symmetrical, so we can
- -- have a negative value that is not Direct whose negation can be
- -- represented directly.
+ -- Full processing for multi-digit case. Note that we cannot just copy
+ -- the value to the end of the table negating the first digit, since the
+ -- range of Direct values is non-symmetrical, so we can have a negative
+ -- value that is not Direct whose negation can be represented directly.
else
declare
Sign := 1;
end if;
- -- All cases are listed, grouped by mathematical method
- -- It is not inefficient to do have this case list out
- -- of order since GCC sorts the cases we list.
+ -- All cases are listed, grouped by mathematical method It is
+ -- not inefficient to do have this case list out of order since
+ -- GCC sorts the cases we list.
case Int1_12 (abs (Direct_Val (Right))) is
when 1 =>
return Uint_0;
- -- Powers of two are simple AND's with LS Left Digit
- -- GCC will recognise these constants as powers of 2
- -- and replace the rem with simpler operations where
- -- possible.
+ -- Powers of two are simple AND's with LS Left Digit GCC
+ -- will recognise these constants as powers of 2 and replace
+ -- the rem with simpler operations where possible.
-- Least_Sig_Digit might return Negative numbers
Sign * (Sum_Digits (Left, 1) rem Int (7)));
-- Note: 2^32 mod 5 = -1
+
-- Alternating sums might be negative, but rem is always
-- positive hence we must use mod here.
return UI_From_Int (Sign * Tmp);
-- Note: 2^15 mod 9 = -1
+
-- Alternating sums might be negative, but rem is always
-- positive hence we must use mod here.
return UI_From_Int (Sign * Tmp);
-- Note: 2^15 mod 11 = -1
+
-- Alternating sums might be negative, but rem is always
-- positive hence we must use mod here.
Tmp := Sum_Digits (Left, -1) mod Int (11);
return UI_From_Int (Sign * Tmp);
- -- Now resort to Chinese Remainder theorem
- -- to reduce 6, 10, 12 to previous special cases
+ -- Now resort to Chinese Remainder theorem to reduce 6, 10,
+ -- 12 to previous special cases
- -- There is no reason we could not add more cases
- -- like these if it proves useful.
+ -- There is no reason we could not add more cases like these
+ -- if it proves useful.
- -- Perhaps we should go up to 16, however
- -- I have no "trick" for 13.
+ -- Perhaps we should go up to 16, however we have no "trick"
+ -- for 13.
-- To find u mod m we:
+
-- Pick m1, m2 S.T.
-- GCD(m1, m2) = 1 AND m = (m1 * m2).
+
-- Next we pick (Basis) M1, M2 small S.T.
-- (M1 mod m1) = (M2 mod m2) = 1 AND
-- (M1 mod m2) = (M2 mod m1) = 0
- -- So u mod m = (u1 * M1 + u2 * M2) mod m
- -- Where u1 = (u mod m1) AND u2 = (u mod m2);
- -- Under typical circumstances the last mod m
- -- can be done with a (possible) single subtraction.
+ -- So u mod m = (u1 * M1 + u2 * M2) mod m Where u1 = (u mod
+ -- m1) AND u2 = (u mod m2); Under typical circumstances the
+ -- last mod m can be done with a (possible) single
+ -- subtraction.
-- m1 = 2; m2 = 3; M1 = 3; M2 = 4;
Init_Operand (Input, In_Vec);
Ret_Int := 0;
- -- Calculate -|Input| and then negates if value is positive.
- -- This handles our current definition of Int (based on
- -- 2s complement). Is it secure enough?
+ -- Calculate -|Input| and then negates if value is positive. This
+ -- handles our current definition of Int (based on 2s complement).
+ -- Is it secure enough???
for Idx in In_Vec'Range loop
Ret_Int := Ret_Int * Base - abs In_Vec (Idx);
end if;
end if;
- -- The value is outside the direct representation range and
- -- must therefore be stored in the table. Expand the table
- -- to contain the count and tigis. The index of the new table
- -- entry will be returned as the result.
+ -- The value is outside the direct representation range and must
+ -- therefore be stored in the table. Expand the table to contain
+ -- the count and tigis. The index of the new table entry will be
+ -- returned as the result.
Uints.Increment_Last;
Uints.Table (Uints.Last).Length := Size;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
then
Match (Field, Get_Field);
- if Field = "Str" then Field := V_String_Id;
- elsif Field = "Node" then Field := V_Node_Id;
- elsif Field = "Name" then Field := V_Name_Id;
- elsif Field = "List" then Field := V_List_Id;
- elsif Field = "Elist" then Field := V_Elist_Id;
- elsif Field = "Flag" then Field := V_Boolean;
+ if Field = "Str" then
+ Field := V_String_Id;
+ elsif Field = "Node" then
+ Field := V_Node_Id;
+ elsif Field = "Name" then
+ Field := V_Name_Id;
+ elsif Field = "List" then
+ Field := V_List_Id;
+ elsif Field = "Elist" then
+ Field := V_Elist_Id;
+ elsif Field = "Flag" then
+ Field := V_Boolean;
end if;
if Field = "Boolean" then
projects / platform / upstream / linaro-gcc.git / commitdiff