FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

a-reatim.adb: Documentation addition

Browse source 
2007-04-20  Robert Dewar  <dewar@adacore.com>

	* a-reatim.adb: Documentation addition

	* g-cgideb.adb: Minor code reorganization

	* tree_io.adb, treepr.adb, cstand.adb, krunch.adb, par.adb,
	mdll-utl.adb, par-ch5.adb, par-tchk.adb, s-exctab.ads, s-memory.ads,
	s-osprim.ads, s-restri.ads, s-soflin.ads: Minor reformatting.

	* debug.ads, debug.adb (Get_Debug_Flag_K): Remove unused obsolete
	function.  Change name New_Scope to Push_Scope
	(Get_Debug_Flag_K): Remove unused obsolete function.

	* exp_ch8.adb, inline.adb, sem_ch8.ads: Change name New_Scope to
	Push_Scope.

	* makeusg.adb: Update Copyright notice
	Add line for switch -aP

	* makeusg.adb: Fix wording of some usage messages

	* s-assert.adb (Raise_Assert_Failure): Add call to
	Debug_Raise_Assert_Failure.

	* s-unstyp.ads (type Packed_Bytes2): Change alignment to use 'Min
	(2, Standard'Alignment) for compatibility with AAMP (where alignment
	is restricted to 1).

	* s-wchjis.adb: Remove use of System.Pure_Exceptions

	* tbuild.ads, tbuild.adb (Make_Implicit_Exception_Handler): Set the
	node location to No_Location when we're not debugging the expanded
	code.

From-SVN: r125478
This commit is contained in:
Robert Dewar 2007-06-06 12:52:32 +02:00 • committed by Arnaud Charlet
parent 7d2e68b351
commit a99ada67cf
26 changed files with 157 additions and 153 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
gcc/ada/a-reatim.adb
View file

@ -241,6 +241,11 @@ package body Ada.Real_Time is
function To_Time_Span (D : Duration) return Time_Span is
begin
-- Note regarding AI-00432 requiring range checking on this conversion.
-- In almost all versions of GNAT (and all to which this version of the
-- Ada.Real_Time package apply), the range of Time_Span and Duration are
-- the same, so there is no issue of overflow.
return Time_Span (D);
end To_Time_Span;

2
gcc/ada/cstand.adb
View file

@ -430,7 +430,7 @@ package body CStand is
-- range False .. True
-- where the occurrences of the literals must point to the
-- corresponding definition.
-- corresponding definition.
R_Node := New_Node (N_Range, Stloc);
B_Node := New_Node (N_Identifier, Stloc);

13
gcc/ada/debug.adb
View file

@ -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- --
@ -326,7 +326,7 @@ package body Debug is
-- an interepretation is incompatible with the context.
-- dw Write semantic scope stack messages. Each time a scope is created
-- or removed, a message is output (see the Sem_Ch8.New_Scope and
-- or removed, a message is output (see the Sem_Ch8.Push_Scope and
-- Sem_Ch8.Pop_Scope subprograms).
-- dx Force expansion on, even if no code being generated. Normally the
@ -604,15 +604,6 @@ package body Debug is
-- dw Prints the list of units withed by the unit currently explored
-- during the main loop of Make.Compile_Sources.
----------------------
-- Get_Debug_Flag_K --
----------------------
function Get_Debug_Flag_K return Boolean is
begin
return Debug_Flag_K;
end Get_Debug_Flag_K;
--------------------
-- Set_Debug_Flag --
--------------------

6
gcc/ada/debug.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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- --
@ -179,10 +179,6 @@ package Debug is
Debug_Flag_Dot_8 : Boolean := False;
Debug_Flag_Dot_9 : Boolean := False;
function Get_Debug_Flag_K return Boolean;
-- This function is called from C code to get the setting of the K flag
-- (it does not work to try to access a constant object directly).
procedure Set_Debug_Flag (C : Character; Val : Boolean := True);
-- Where C is 0-9, A-Z, or a-z, sets the corresponding debug flag to
-- the given value. In the checks off version of debug, the call to

4
gcc/ada/exp_ch8.adb
View file

@ -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- --
@ -310,7 +310,7 @@ package body Exp_Ch8 is
Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
begin
New_Scope (Standard_Standard);
Push_Scope (Standard_Standard);
if No (Actions (Aux)) then
Set_Actions (Aux, New_List (Decl));

13
gcc/ada/g-cgideb.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2006, AdaCore --
-- Copyright (C) 2000-2007, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -131,12 +131,11 @@ package body GNAT.CGI.Debug is
Result : Unbounded_String;
begin
Result := Result
& Title (Mode, "CGI complete runtime environment");
Result := Result
& Header (Mode, "CGI parameters:")
& New_Line (Mode);
Result :=
To_Unbounded_String
(Title (Mode, "CGI complete runtime environment")
& Header (Mode, "CGI parameters:")
& New_Line (Mode));
for K in 1 .. Argument_Count loop
Result := Result

30
gcc/ada/inline.adb
View file

@ -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- --
@ -33,6 +33,7 @@ with Exp_Tss; use Exp_Tss;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem_Ch8; use Sem_Ch8;
@ -246,12 +247,24 @@ package body Inline is
-----------------
function Must_Inline return Boolean is
Scop : Entity_Id := Current_Scope;
Scop : Entity_Id;
Comp : Node_Id;
begin
-- Check if call is in main unit
Scop := Current_Scope;
-- Do not try to inline if scope is standard. This could happen, for
-- example, for a call to Add_Global_Declaration, and it causes
-- trouble to try to inline at this level.
if Scop = Standard_Standard then
return False;
end if;
-- Otherwise lookup scope stack to outer scope
while Scope (Scop) /= Standard_Standard
and then not Is_Child_Unit (Scop)
loop
@ -259,7 +272,6 @@ package body Inline is
end loop;
Comp := Parent (Scop);
while Nkind (Comp) /= N_Compilation_Unit loop
Comp := Parent (Comp);
end loop;
@ -271,8 +283,7 @@ package body Inline is
return True;
end if;
-- Call is not in main unit. See if it's in some inlined
-- subprogram.
-- Call is not in main unit. See if it's in some inlined subprogram
Scop := Current_Scope;
while Scope (Scop) /= Standard_Standard
@ -289,7 +300,6 @@ package body Inline is
end loop;
return False;
end Must_Inline;
-- Start of processing for Add_Inlined_Body
@ -563,7 +573,7 @@ package body Inline is
Analyzing_Inlined_Bodies := False;
if Serious_Errors_Detected = 0 then
New_Scope (Standard_Standard);
Push_Scope (Standard_Standard);
J := 0;
while J <= Inlined_Bodies.Last
@ -609,7 +619,7 @@ package body Inline is
Error_Msg_N
("one or more inlined subprograms accessed in $!",
Comp_Unit);
Error_Msg_Name_1 :=
Error_Msg_File_1 :=
Get_File_Name (Bname, Subunit => False);
Error_Msg_N ("\but file{ was not found!", Comp_Unit);
raise Unrecoverable_Error;
@ -860,7 +870,7 @@ package body Inline is
end if;
end if;
New_Scope (Scop);
Push_Scope (Scop);
Expand_Cleanup_Actions (Decl);
End_Scope;
@ -935,7 +945,7 @@ package body Inline is
if Serious_Errors_Detected = 0 then
Expander_Active := (Operating_Mode = Opt.Generate_Code);
New_Scope (Standard_Standard);
Push_Scope (Standard_Standard);
To_Clean := New_Elmt_List;
if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then

4
gcc/ada/krunch.adb
View file

@ -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- --
@ -130,7 +130,7 @@ begin
and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
and then Len <= Maxlen
then
-- When VMS is the host, it is always also the target.
-- When VMS is the host, it is always also the target
if Hostparm.OpenVMS or else VMS_On_Target then
Len := Len + 1;

15
gcc/ada/makeusg.adb
View file

@ -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- --
@ -203,17 +203,17 @@ begin
-- Line for -we
Write_Str (" -we treat all Warnings as Errors");
Write_Str (" -we Treat all warnings as errors");
Write_Eol;
-- Line for -wn
Write_Str (" -wn Normal Warning mode (cancels -we/-ws)");
Write_Str (" -wn Normal warning mode (cancels -we/-ws)");
Write_Eol;
-- Line for -ws
Write_Str (" -ws Suppress all Warnings");
Write_Str (" -ws Suppress all warnings");
Write_Eol;
-- Line for -x
@ -246,7 +246,12 @@ begin
-- Source and Library search path switches
Write_Str ("Source and Library search path switches:");
Write_Str ("Project, Source and Library search path switches:");
Write_Eol;
-- Line for -aP
Write_Str (" -aPdir Add directory dir to project search path");
Write_Eol;
-- Line for -aL

6
gcc/ada/mdll-utl.adb
View file

@ -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- --
@ -100,6 +100,7 @@ package body MDLL.Utl is
Bas_Opt : aliased String := "--base-file";
Bas_V : aliased String := Base_File;
No_Suf_Opt : aliased String := "-k";
begin
Arguments (1 .. 4) := (1 => Def_Opt'Unchecked_Access,
2 => Def_V'Unchecked_Access,
@ -141,7 +142,6 @@ package body MDLL.Utl is
Exceptions.Raise_Exception
(Tools_Error'Identity, Dlltool_Name & " execution error.");
end if;
end Dlltool;
---------
@ -286,7 +286,7 @@ package body MDLL.Utl is
-- Delete binder files
declare
Base_Name : constant String :=
Directory_Operations.Base_Name (Ali, ".ali");
Directory_Operations.Base_Name (Ali, ".ali");
begin
OS_Lib.Delete_File ("b~" & Base_Name & ".ads", Success);
OS_Lib.Delete_File ("b~" & Base_Name & ".adb", Success);

6
gcc/ada/par-ch5.adb
View file

@ -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- --
@ -602,8 +602,8 @@ package body Ch5 is
Statement_Required := False;
-- A slash following an identifier or a selected
-- component in this situation is most likely a
-- period (have a look at the keyboard :-)
-- component in this situation is most likely a period
-- (see location of keys on keyboard).
elsif Token = Tok_Slash
and then (Nkind (Name_Node) = N_Identifier

21
gcc/ada/par-tchk.adb
View file

@ -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- --
@ -417,26 +417,25 @@ package body Tchk is
return;
-- An interesting little kludge here. If the previous token is a
-- semicolon, then there is no way that we can legitimately need
-- another semicolon. This could only arise in an error situation
-- where an error has already been signalled. By simply ignoring
-- the request for a semicolon in this case, we avoid some spurious
-- missing semicolon messages.
-- semicolon, then there is no way that we can legitimately need another
-- semicolon. This could only arise in an error situation where an error
-- has already been signalled. By simply ignoring the request for a
-- semicolon in this case, we avoid some spurious missing semicolon
-- messages.
elsif Prev_Token = Tok_Semicolon then
return;
-- If the current token is | then this is a reasonable
-- place to suggest the possibility of a "C" confusion :-)
-- If the current token is | then this is a reasonable place to suggest
-- the possibility of a "C" confusion.
elsif Token = Tok_Vertical_Bar then
Error_Msg_SC ("unexpected occurrence of ""'|"", did you mean OR'?");
Resync_Past_Semicolon;
return;
-- Deal with pragma. If pragma is not at start of line, it is
-- considered misplaced otherwise we treat it as a normal
-- missing semicolong case.
-- Deal with pragma. If pragma is not at start of line, it is considered
-- misplaced otherwise we treat it as a normal missing semicolong case.
elsif Token = Tok_Pragma
and then not Token_Is_At_Start_Of_Line

4
gcc/ada/par.adb
View file

@ -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- --
@ -184,7 +184,7 @@ is
-- of such a nested region. Again, like case 2, this causes us to miss
-- some nested cases, but it doesn't seen worth the effort to stack and
-- unstack the SIS information. Maybe we will reconsider this if we ever
-- get a complaint about a missed case :-)
-- get a complaint about a missed case.
-- 4. We encounter a valid pragma INTERFACE or IMPORT that effectively
-- supplies the missing body. In this case we reset the entry.

4
gcc/ada/s-assert.adb
View file

@ -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- --
@ -32,6 +32,7 @@
------------------------------------------------------------------------------
with Ada.Exceptions;
with System.Exceptions;
package body System.Assertions is
@ -41,6 +42,7 @@ package body System.Assertions is
procedure Raise_Assert_Failure (Msg : String) is
begin
System.Exceptions.Debug_Raise_Assert_Failure;
Ada.Exceptions.Raise_Exception (Assert_Failure'Identity, Msg);
end Raise_Assert_Failure;

6
gcc/ada/s-exctab.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1996-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1996-2006, 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- --
@ -62,7 +62,7 @@ package System.Exception_Table is
-- does not exist yet, null is returned.
function Registered_Exceptions_Count return Natural;
-- Return the number of currently registered exceptions.
-- Return the number of currently registered exceptions
type Exception_Data_Array is array (Natural range <>)
of SSL.Exception_Data_Ptr;
@ -70,6 +70,6 @@ package System.Exception_Table is
procedure Get_Registered_Exceptions
(List : out Exception_Data_Array;
Last : out Integer);
-- Return the list of registered exceptions.
-- Return the list of registered exceptions
end System.Exception_Table;

5
gcc/ada/s-memory.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2001-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- --
@ -75,8 +75,7 @@ package System.Memory is
function Realloc
(Ptr : System.Address;
Size : size_t)
return System.Address;
Size : size_t) return System.Address;
-- This is the low level reallocation routine. It takes an existing
-- block address returned by a previous call to Alloc or Realloc,
-- and reallocates the block. The size can either be increased or

4
gcc/ada/s-osprim.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1998-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -47,7 +47,7 @@ package System.OS_Primitives is
Duration'Last);
-- Max of half a year delay, needed to prevent exceptions for large delay
-- values. It seems unlikely that any test will notice this restriction,
-- except in the case of applications setting the clock at at run time (see
-- except in the case of applications setting the clock at run time (see
-- s-tastim.adb). Also note that a larger value might cause problems (e.g
-- overflow, or more likely OS limitation in the primitives used). In the
-- case where half a year is too long (which occurs in high integrity mode

1
gcc/ada/s-restri.ads
View file

@ -44,6 +44,7 @@ with System.Rident;
package System.Restrictions is
pragma Preelaborate;
pragma Discard_Names;
package Rident is new System.Rident;

3
gcc/ada/s-soflin.ads
View file

@ -52,8 +52,7 @@ package System.Soft_Links is
function Current_Target_Exception return EO;
pragma Import
(Ada, Current_Target_Exception,
"__gnat_current_target_exception");
(Ada, Current_Target_Exception, "__gnat_current_target_exception");
-- Import this subprogram from the private part of Ada.Exceptions
-- First we have the access subprogram types used to establish the links.

101
gcc/ada/s-unstyp.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, 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,24 +63,24 @@ package System.Unsigned_Types is
-- for details.
type Packed_Bytes2 is new Packed_Bytes1;
for Packed_Bytes2'Alignment use 2;
for Packed_Bytes2'Alignment use Integer'Min (2, Standard'Maximum_Alignment);
-- This is the type used to implement packed arrays where an alignment
-- of 2 is helpful for maximum efficiency of the get and set routines
-- in the corresponding library unit. This is true of all component
-- sizes that are even but not divisible by 4 (other than 2 for which
-- we use direct masking operations). In such cases, the clusters can
-- be assumed to be 2-byte aligned if the array is aligned. See for
-- of 2 (is possible) is helpful for maximum efficiency of the get and
-- set routines in the corresponding library unit. This is true of all
-- component sizes that are even but not divisible by 4 (other than 2 for
-- which we use direct masking operations). In such cases, the clusters
-- can be assumed to be 2-byte aligned if the array is aligned. See for
-- example System.Pack_10 in file s-pack10).
type Packed_Bytes4 is new Packed_Bytes1;
for Packed_Bytes4'Alignment use Integer'Min (4, Standard'Maximum_Alignment);
-- This is the type used to implement packed arrays where an alignment
-- of 4 is helpful for maximum efficiency of the get and set routines
-- in the corresponding library unit. This is true of all component
-- sizes that are divisible by 4 (other than powers of 2, which are
-- either handled by direct masking or not packed at all). In such cases
-- the clusters can be assumed to be 4-byte aligned if the array is
-- aligned (see System.Pack_12 in file s-pack12 as an example).
-- of 4 (if possible) is helpful for maximum efficiency of the get and
-- set routines in the corresponding library unit. This is true of all
-- component sizes that are divisible by 4 (other than powers of 2, which
-- are either handled by direct masking or not packed at all). In such
-- cases the clusters can be assumed to be 4-byte aligned if the array
-- is aligned (see System.Pack_12 in file s-pack12 as an example).
type Bits_1 is mod 2**1;
type Bits_2 is mod 2**2;
@ -92,128 +92,103 @@ package System.Unsigned_Types is
function Shift_Left
(Value : Short_Short_Unsigned;
Amount : Natural)
return Short_Short_Unsigned;
Amount : Natural) return Short_Short_Unsigned;
function Shift_Right
(Value : Short_Short_Unsigned;
Amount : Natural)
return Short_Short_Unsigned;
Amount : Natural) return Short_Short_Unsigned;
function Shift_Right_Arithmetic
(Value : Short_Short_Unsigned;
Amount : Natural)
return Short_Short_Unsigned;
Amount : Natural) return Short_Short_Unsigned;
function Rotate_Left
(Value : Short_Short_Unsigned;
Amount : Natural)
return Short_Short_Unsigned;
Amount : Natural) return Short_Short_Unsigned;
function Rotate_Right
(Value : Short_Short_Unsigned;
Amount : Natural)
return Short_Short_Unsigned;
Amount : Natural) return Short_Short_Unsigned;
function Shift_Left
(Value : Short_Unsigned;
Amount : Natural)
return Short_Unsigned;
Amount : Natural) return Short_Unsigned;
function Shift_Right
(Value : Short_Unsigned;
Amount : Natural)
return Short_Unsigned;
Amount : Natural) return Short_Unsigned;
function Shift_Right_Arithmetic
(Value : Short_Unsigned;
Amount : Natural)
return Short_Unsigned;
Amount : Natural) return Short_Unsigned;
function Rotate_Left
(Value : Short_Unsigned;
Amount : Natural)
return Short_Unsigned;
Amount : Natural) return Short_Unsigned;
function Rotate_Right
(Value : Short_Unsigned;
Amount : Natural)
return Short_Unsigned;
Amount : Natural) return Short_Unsigned;
function Shift_Left
(Value : Unsigned;
Amount : Natural)
return Unsigned;
Amount : Natural) return Unsigned;
function Shift_Right
(Value : Unsigned;
Amount : Natural)
return Unsigned;
Amount : Natural) return Unsigned;
function Shift_Right_Arithmetic
(Value : Unsigned;
Amount : Natural)
return Unsigned;
Amount : Natural) return Unsigned;
function Rotate_Left
(Value : Unsigned;
Amount : Natural)
return Unsigned;
Amount : Natural) return Unsigned;
function Rotate_Right
(Value : Unsigned;
Amount : Natural)
return Unsigned;
Amount : Natural) return Unsigned;
function Shift_Left
(Value : Long_Unsigned;
Amount : Natural)
return Long_Unsigned;
Amount : Natural) return Long_Unsigned;
function Shift_Right
(Value : Long_Unsigned;
Amount : Natural)
return Long_Unsigned;
Amount : Natural) return Long_Unsigned;
function Shift_Right_Arithmetic
(Value : Long_Unsigned;
Amount : Natural)
return Long_Unsigned;
Amount : Natural) return Long_Unsigned;
function Rotate_Left
(Value : Long_Unsigned;
Amount : Natural)
return Long_Unsigned;
Amount : Natural) return Long_Unsigned;
function Rotate_Right
(Value : Long_Unsigned;
Amount : Natural)
return Long_Unsigned;
Amount : Natural) return Long_Unsigned;
function Shift_Left
(Value : Long_Long_Unsigned;
Amount : Natural)
return Long_Long_Unsigned;
Amount : Natural) return Long_Long_Unsigned;
function Shift_Right
(Value : Long_Long_Unsigned;
Amount : Natural)
return Long_Long_Unsigned;
Amount : Natural) return Long_Long_Unsigned;
function Shift_Right_Arithmetic
(Value : Long_Long_Unsigned;
Amount : Natural)
return Long_Long_Unsigned;
Amount : Natural) return Long_Long_Unsigned;
function Rotate_Left
(Value : Long_Long_Unsigned;
Amount : Natural)
return Long_Long_Unsigned;
Amount : Natural) return Long_Long_Unsigned;
function Rotate_Right
(Value : Long_Long_Unsigned;
Amount : Natural)
return Long_Long_Unsigned;
Amount : Natural) return Long_Long_Unsigned;
pragma Import (Intrinsic, Shift_Left);
pragma Import (Intrinsic, Shift_Right);

6
gcc/ada/s-wchjis.adb
View file

@ -31,8 +31,6 @@
-- --
------------------------------------------------------------------------------
with System.Pure_Exceptions; use System.Pure_Exceptions;
package body System.WCh_JIS is
type Byte is mod 256;
@ -86,7 +84,7 @@ package body System.WCh_JIS is
-- bit is set in both bytes.
if JIS2 < 16#80# then
Raise_Exception (CE, "invalid small Katakana character");
raise Constraint_Error;
end if;
EUC1 := Character'Val (EUC_Hankaku_Kana);
@ -96,7 +94,7 @@ package body System.WCh_JIS is
-- a valid character for representation in EUC form.
elsif JIS1 > 16#7F# or else JIS2 > 16#7F# then
Raise_Exception (CE, "wide character value out of EUC range");
raise Constraint_Error;
-- Result is just the two characters with upper bits set

4
gcc/ada/sem_ch8.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004 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- --
@ -122,7 +122,7 @@ package Sem_Ch8 is
-- S is the entity of a scope. This function determines if this scope
-- is currently open (i.e. it appears somewhere in the scope stack).
procedure New_Scope (S : Entity_Id);
procedure Push_Scope (S : Entity_Id);
-- Make new scope stack entry, pushing S, the entity for a scope
-- onto the top of the scope table. The current setting of the scope
-- suppress flags is saved for restoration on exit.

32
gcc/ada/tbuild.adb
View file

@ -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- --
@ -28,9 +28,9 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Sinfo; use Sinfo;
@ -209,10 +209,32 @@ package body Tbuild is
Exception_Choices : List_Id;
Statements : List_Id) return Node_Id
is
Handler : constant Node_Id :=
Make_Exception_Handler
(Sloc, Choice_Parameter, Exception_Choices, Statements);
Handler : Node_Id;
Loc : Source_Ptr;
begin
-- Set the source location only when debugging the expanded code
-- When debugging the source code directly, we do not want the compiler
-- to associate this implicit exception handler with any specific source
-- line, because it can potentially confuse the debugger. The most
-- damaging situation would arise when the debugger tries to insert a
-- breakpoint at a certain line. If the code of the associated implicit
-- exception handler is generated before the code of that line, then the
-- debugger will end up inserting the breakpoint inside the exception
-- handler, rather than the code the user intended to break on. As a
-- result, it is likely that the program will not hit the breakpoint
-- as expected.
if Debug_Generated_Code then
Loc := Sloc;
else
Loc := No_Location;
end if;
Handler :=
Make_Exception_Handler
(Loc, Choice_Parameter, Exception_Choices, Statements);
Set_Local_Raise_Statements (Handler, No_Elist);
return Handler;
end Make_Implicit_Exception_Handler;

3
gcc/ada/tbuild.ads
View file

@ -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- --
@ -27,6 +27,7 @@
-- This package contains various utility procedures to assist in
-- building specific types of tree nodes.
with Namet; use Namet;
with Types; use Types;
package Tbuild is

6
gcc/ada/tree_io.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002 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- --
@ -448,6 +448,10 @@ package body Tree_IO is
procedure Write_Non_Compressed_Sequence;
-- Output currently collected sequence of non-compressible data
-----------------------------------
-- Write_Non_Compressed_Sequence --
-----------------------------------
procedure Write_Non_Compressed_Sequence is
begin
if NC > 0 then

6
gcc/ada/treepr.adb
View file

@ -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- --
@ -1004,9 +1004,7 @@ package body Treepr is
-- Print Etype field if present (printing of this field for entities
-- is handled by the Print_Entity_Info procedure).
if Nkind (N) in N_Has_Etype
and then Present (Etype (N))
then
if Nkind (N) in N_Has_Etype and then Present (Etype (N)) then
Print_Str (Prefix_Str_Char);
Print_Str ("Etype = ");
Print_Node_Ref (Etype (N));