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