Skip to content

R
riscv-gcc-1
Commit 835d23b2 by Robert Dewar Committed by Arnaud Charlet
Options

uintp.adb, [...]: Minor reformatting. 

2007-08-14  Robert Dewar  <dewar@adacore.com>

	* uintp.adb, a-ztedit.adb, s-wchcon.adb, xnmake.adb, s-wchcon.adb,
	par-ch5.adb, par-ch10.adb, get_targ.adb, a-wtedit.adb, a-teioed.adb,
	s-osinte-solaris.adb, s-osinte-solaris.ads,
	s-osinte-freebsd.ads, s-osinte-freebsd.adb: Minor reformatting.

	* styleg.adb, styleg.ads, stylesw.adb, stylesw.ads: implement style
	switch -gnatyS. Enable -gnatyS in GNAT style check mode

From-SVN: r127409
parent 4a9b6b95
Showing with 479 additions and 283 deletions
gcc/ada/a-teioed.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -933,7 +933,9 @@ package body Ada.Text_IO.Editing is
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;
......@@ -2448,9 +2450,10 @@ package body Ada.Text_IO.Editing is
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;
......@@ -2462,8 +2465,8 @@ package body Ada.Text_IO.Editing is
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;
......
gcc/ada/a-wtedit.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -1100,7 +1100,9 @@ package body Ada.Wide_Text_IO.Editing is
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;
......
gcc/ada/a-ztedit.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -1102,7 +1102,9 @@ package body Ada.Wide_Wide_Text_IO.Editing is
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;
......
gcc/ada/get_targ.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -32,11 +32,16 @@ package body Get_Targ is
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;
......@@ -57,10 +62,14 @@ package body Get_Targ is
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;
......
gcc/ada/par-ch10.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -244,7 +244,9 @@ package body Ch10 is
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
......@@ -320,7 +322,9 @@ package body Ch10 is
-- 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
......@@ -807,7 +811,9 @@ package body Ch10 is
-- 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
......
gcc/ada/par-ch5.adb
......@@ -210,7 +210,9 @@ package body Ch5 is
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)
......@@ -1121,7 +1123,10 @@ package body Ch5 is
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;
......@@ -1397,7 +1402,10 @@ package body Ch5 is
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);
......@@ -2069,7 +2077,9 @@ package body Ch5 is
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;
......
gcc/ada/s-osinte-freebsd.adb
......@@ -38,21 +38,34 @@ with Interfaces.C; use Interfaces.C;
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;
......@@ -85,13 +98,18 @@ 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'(ts_sec => S,
ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
......
gcc/ada/s-osinte-freebsd.ads
......@@ -235,7 +235,7 @@ package System.OS_Interface is
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 --
......
gcc/ada/s-osinte-solaris.adb
......@@ -7,7 +7,7 @@
-- 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- --
......@@ -32,7 +32,7 @@
-- --
------------------------------------------------------------------------------
-- 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.
......@@ -42,6 +42,7 @@ pragma Polling (Off);
-- tasking operations. It causes infinite loops and other problems.
with Interfaces.C; use Interfaces.C;
package body System.OS_Interface is
-----------------
......@@ -60,38 +61,60 @@ 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;
......
gcc/ada/s-osinte-solaris.ads
......@@ -126,7 +126,7 @@ package System.OS_Interface is
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);
......@@ -451,7 +451,7 @@ package System.OS_Interface is
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;
......@@ -485,21 +485,21 @@ package System.OS_Interface is
-- 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");
......@@ -512,7 +512,7 @@ package System.OS_Interface is
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
......
gcc/ada/s-wchcon.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -50,12 +50,18 @@ package body System.WCh_Con is
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;
......
gcc/ada/styleg.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -63,7 +63,11 @@ package body Styleg is
-- 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
......@@ -699,6 +703,82 @@ package body Styleg is
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 --
----------------
......
gcc/ada/styleg.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -133,6 +133,13 @@ package Styleg is
-- 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
......
gcc/ada/stylesw.adb
......@@ -54,6 +54,7 @@ package body Stylesw is
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;
......@@ -126,6 +127,7 @@ package body Stylesw is
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);
......@@ -167,7 +169,7 @@ package body Stylesw is
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;
-----------------------------
......@@ -359,6 +361,9 @@ package body Stylesw is
when 's' =>
Style_Check_Specs := True;
when 'S' =>
Style_Check_Separate_Stmt_Lines := True;
when 't' =>
Style_Check_Tokens := True;
......
gcc/ada/stylesw.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -38,14 +38,15 @@ package Stylesw is
--------------------------
-- 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
......@@ -54,31 +55,31 @@ package Stylesw is
-- 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
--
......@@ -89,40 +90,39 @@ package Stylesw is
--
-- 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
--
......@@ -139,69 +139,76 @@ package Stylesw is
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
--
......@@ -210,6 +217,7 @@ package Stylesw is
-- <> 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
......@@ -220,36 +228,36 @@ package Stylesw is
-- 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
......@@ -261,12 +269,12 @@ package Stylesw is
-----------------
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;
......@@ -301,8 +309,8 @@ package Stylesw is
-- 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;
gcc/ada/uintp.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -46,8 +46,8 @@ package body Uintp is
-- 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
......@@ -70,11 +70,11 @@ package body Uintp is
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;
......@@ -86,9 +86,9 @@ package body Uintp is
-- 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;
......@@ -112,8 +112,8 @@ package body Uintp is
-- 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
......@@ -122,28 +122,28 @@ package body Uintp is
(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;
......@@ -151,17 +151,17 @@ package body Uintp is
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
......@@ -174,24 +174,25 @@ package body Uintp is
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.
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 --
......@@ -225,7 +226,6 @@ package body Uintp is
J := Jin;
K := Kin;
while K /= Uint_0 loop
Tmp := J mod K;
J := K;
......@@ -276,8 +276,8 @@ package body Uintp is
-- 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
......@@ -1094,12 +1094,15 @@ package body Uintp is
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);
......@@ -1162,9 +1165,9 @@ package body Uintp is
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;
......@@ -1216,10 +1219,10 @@ package body Uintp is
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;
......@@ -1233,8 +1236,8 @@ package body Uintp is
-- 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;
......@@ -1487,6 +1490,7 @@ package body Uintp is
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
......@@ -1695,14 +1699,14 @@ package body Uintp is
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);
......@@ -1745,13 +1749,13 @@ package body Uintp is
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);
......@@ -1841,8 +1845,8 @@ package body Uintp is
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;
......@@ -1871,24 +1875,28 @@ package body Uintp is
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);
......@@ -2368,18 +2376,17 @@ package body Uintp is
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
......@@ -2438,19 +2445,18 @@ package body Uintp is
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
......@@ -2484,6 +2490,7 @@ package body Uintp is
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.
......@@ -2492,6 +2499,7 @@ package body Uintp is
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.
......@@ -2500,6 +2508,7 @@ package body Uintp is
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.
......@@ -2507,26 +2516,28 @@ package body Uintp is
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;
......@@ -2655,9 +2666,9 @@ package body Uintp is
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);
......@@ -2723,10 +2734,10 @@ package body Uintp is
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;
......
gcc/ada/xnmake.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -372,12 +372,18 @@ begin
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment