OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2005-03-17  Vasiliy Fofanov  <fofanov@adacore.com>

	* gnat_ugn.texi: Document gnatmem restriction

2005-03-17  Thomas Quinot  <quinot@adacore.com>

	* snames.adb: Document new TSS names introduced by exp_dist/exp_tss
	cleanup

2005-03-17  Robert Dewar  <dewar@adacore.com>

	* s-interr.ads, s-interr.adb, sem_ch3.adb, prj.ads, prj.adb,
	a-interr.adb, a-interr.ads, s-interr-sigaction.adb, s-interr-dummy.adb,
	s-interr-vms.adb, s-interr-vxworks.adb: Minor reformatting

	* casing.adb: Comment improvements

2005-03-17  Pascal Obry  <obry@adacore.com>

	* g-expect.adb: Minor reformatting.

From-SVN: r96678
This commit is contained in:
Arnaud Charlet 2005-03-18 12:55:47 +01:00
parent 8095d0fa91
commit fa7c4d231f
15 changed files with 224 additions and 219 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/ada/a-interr.adb
View File

@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2003, Ada Core Technologies --
-- Copyright (C) 1995-2005 AdaCore --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -73,8 +73,7 @@ package body Ada.Interrupts is
---------------------
function Current_Handler
(Interrupt : Interrupt_ID)
return Parameterless_Handler
(Interrupt : Interrupt_ID) return Parameterless_Handler
is
begin
return To_Ada (SI.Current_Handler (SI.Interrupt_ID (Interrupt)));
@ -84,7 +83,7 @@ package body Ada.Interrupts is
-- Detach_Handler --
--------------------
procedure Detach_Handler (Interrupt : in Interrupt_ID) is
procedure Detach_Handler (Interrupt : Interrupt_ID) is
begin
SI.Detach_Handler (SI.Interrupt_ID (Interrupt), False);
end Detach_Handler;

5
gcc/ada/a-interr.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -49,8 +49,7 @@ package Ada.Interrupts is
function Is_Attached (Interrupt : Interrupt_ID) return Boolean;
function Current_Handler
(Interrupt : Interrupt_ID)
return Parameterless_Handler;
(Interrupt : Interrupt_ID) return Parameterless_Handler;
procedure Attach_Handler
(New_Handler : Parameterless_Handler;

23
gcc/ada/casing.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -140,6 +140,17 @@ package body Casing is
Ptr := 1;
while Ptr <= Name_Len loop
-- Wide character. Note that we do nothing with casing in this case.
-- In Ada 2005 mode, required folding of lower case letters happened
-- as the identifier was scanned, and we do not attempt any further
-- messing with case (note that in any case we do not know how to
-- fold upper case to lower case in wide character mode). We also
-- do not bother with recognizing punctuation as equivalent to an
-- underscore. There is nothing functional at this stage in doing
-- the requested casing operation, beyond folding to upper case
-- when it is mandatory, which does not involve underscores.
if Name_Buffer (Ptr) = ASCII.ESC
or else Name_Buffer (Ptr) = '['
or else (Upper_Half_Encoding
@ -148,12 +159,16 @@ package body Casing is
Skip_Wide (Name_Buffer, Ptr);
After_Und := False;
-- Underscore, or non-identifer character (error case)
elsif Name_Buffer (Ptr) = '_'
or else not Identifier_Char (Name_Buffer (Ptr))
then
After_Und := True;
Ptr := Ptr + 1;
-- Lower case letter
elsif Is_Lower_Case_Letter (Name_Buffer (Ptr)) then
if Actual_Casing = All_Upper_Case
or else (After_Und and then Actual_Casing = Mixed_Case)
@ -164,6 +179,8 @@ package body Casing is
After_Und := False;
Ptr := Ptr + 1;
-- Upper case letter
elsif Is_Upper_Case_Letter (Name_Buffer (Ptr)) then
if Actual_Casing = All_Lower_Case
or else (not After_Und and then Actual_Casing = Mixed_Case)
@ -174,7 +191,9 @@ package body Casing is
After_Und := False;
Ptr := Ptr + 1;
else -- all other characters
-- Other identifier character (must be digit)
else
After_Und := False;
Ptr := Ptr + 1;
end if;

32
gcc/ada/g-expect.adb
View File

@ -31,12 +31,12 @@
-- --
------------------------------------------------------------------------------
with System; use System;
with Ada.Calendar; use Ada.Calendar;
with System; use System;
with Ada.Calendar; use Ada.Calendar;
with GNAT.IO;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Regpat; use GNAT.Regpat;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Regpat; use GNAT.Regpat;
with Unchecked_Deallocation;
@ -762,9 +762,7 @@ package body GNAT.Expect is
------------------
function Get_Error_Fd
(Descriptor : Process_Descriptor)
return GNAT.OS_Lib.File_Descriptor
is
(Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is
begin
return Descriptor.Error_Fd;
end Get_Error_Fd;
@ -774,9 +772,7 @@ package body GNAT.Expect is
------------------
function Get_Input_Fd
(Descriptor : Process_Descriptor)
return GNAT.OS_Lib.File_Descriptor
is
(Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is
begin
return Descriptor.Input_Fd;
end Get_Input_Fd;
@ -786,9 +782,7 @@ package body GNAT.Expect is
-------------------
function Get_Output_Fd
(Descriptor : Process_Descriptor)
return GNAT.OS_Lib.File_Descriptor
is
(Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is
begin
return Descriptor.Output_Fd;
end Get_Output_Fd;
@ -798,9 +792,7 @@ package body GNAT.Expect is
-------------
function Get_Pid
(Descriptor : Process_Descriptor)
return Process_Id
is
(Descriptor : Process_Descriptor) return Process_Id is
begin
return Descriptor.Pid;
end Get_Pid;
@ -847,7 +839,7 @@ package body GNAT.Expect is
Arg : String_Access;
Arg_List : String_List (1 .. Args'Length + 2);
C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
Command_With_Path : String_Access;
@ -1004,9 +996,9 @@ package body GNAT.Expect is
----------
procedure Send
(Descriptor : in out Process_Descriptor;
Str : String;
Add_LF : Boolean := True;
(Descriptor : in out Process_Descriptor;
Str : String;
Add_LF : Boolean := True;
Empty_Buffer : Boolean := False)
is
Full_Str : constant String := Str & ASCII.LF;

2
gcc/ada/gnat_ugn.texi
View File

@ -18140,7 +18140,7 @@ allocation and deallocation routines that record call information. This
allows to obtain accurate dynamic memory usage history at a minimal cost to
the execution speed. Note however, that @code{gnatmem} is not supported on
all platforms (currently, it is supported on AIX, HP-UX, GNU/Linux x86,
Solaris (sparc and x86) and Windows NT/2000/XP (x86).
32-bit Solaris (sparc and x86) and Windows NT/2000/XP (x86).
@noindent
The @code{gnatmem} command has the form

12
gcc/ada/prj.adb
View File

@ -650,7 +650,7 @@ package body Prj is
end Set;
procedure Set
(Language_Processing : in Language_Processing_Data;
(Language_Processing : Language_Processing_Data;
For_Language : Language_Index;
In_Project : in out Project_Data;
In_Tree : Project_Tree_Ref)
@ -672,8 +672,7 @@ package body Prj is
begin
while Supp_Index /= No_Supp_Language_Index loop
Supp := In_Tree.Supp_Languages.Table
(Supp_Index);
Supp := In_Tree.Supp_Languages.Table (Supp_Index);
if Supp.Index = For_Language then
In_Tree.Supp_Languages.Table
@ -755,8 +754,8 @@ package body Prj is
-- Standard_Naming_Data --
--------------------------
function Standard_Naming_Data (Tree : Project_Tree_Ref := No_Project_Tree)
return Naming_Data
function Standard_Naming_Data
(Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data
is
begin
if Tree = No_Project_Tree then
@ -793,8 +792,7 @@ package body Prj is
begin
while Supp_Index /= No_Supp_Language_Index loop
Supp := In_Tree.Supp_Suffixes.Table
(Supp_Index);
Supp := In_Tree.Supp_Suffixes.Table (Supp_Index);
if Supp.Index = Language then
return Supp.Suffix;

4
gcc/ada/prj.ads
View File

@ -513,8 +513,8 @@ package Prj is
end record;
function Standard_Naming_Data (Tree : Project_Tree_Ref := No_Project_Tree)
return Naming_Data;
function Standard_Naming_Data
(Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data;
pragma Inline (Standard_Naming_Data);
-- The standard GNAT naming scheme when Tree is No_Project_Tree.
-- Otherwise, return the default naming scheme for the project tree Tree,

12
gcc/ada/s-interr-dummy.adb
View File

@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2004, Ada Core Technologies --
-- Copyright (C) 1995-2005 AdaCore --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -32,10 +32,7 @@
-- --
------------------------------------------------------------------------------
-- This is an OS/2 version of this package.
-- This version is a stub, for systems that
-- do not support interrupts (or signals).
-- This version is for systems that do not support interrupts (or signals)
with Ada.Exceptions;
@ -93,8 +90,7 @@ package body System.Interrupts is
---------------------
function Current_Handler
(Interrupt : Interrupt_ID)
return Parameterless_Handler
(Interrupt : Interrupt_ID) return Parameterless_Handler
is
begin
Unimplemented;
@ -155,7 +151,6 @@ package body System.Interrupts is
return Boolean
is
pragma Warnings (Off, Object);
begin
Unimplemented;
return True;
@ -166,7 +161,6 @@ package body System.Interrupts is
return Boolean
is
pragma Warnings (Off, Object);
begin
Unimplemented;
return True;

37
gcc/ada/s-interr-sigaction.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2004 Free Software Fundation --
-- Copyright (C) 1998-2005 Free Software Fundation --
-- --
-- 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- --
@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-- This is the IRIX & NT version of this package.
-- This is the IRIX & NT version of this package
with Ada.Task_Identification;
-- used for Task_Id
@ -120,15 +120,15 @@ package body System.Interrupts is
-- that contain interrupt handlers.
procedure Signal_Handler (Sig : Interrupt_ID);
-- This procedure is used to handle all the signals.
-- This procedure is used to handle all the signals
-- Type and Head, Tail of the list containing Registered Interrupt
-- Handlers. These definitions are used to register the handlers
-- specified by the pragma Interrupt_Handler.
--
-- Handler Registration:
--
--------------------------
-- Handler Registration --
--------------------------
type Registered_Handler;
type R_Link is access all Registered_Handler;
@ -362,15 +362,14 @@ package body System.Interrupts is
if not Restoration and then not Static
-- Tries to overwrite a static Interrupt Handler with a
-- dynamic Handler
-- Tries to overwrite a static Interrupt Handler with dynamic handle
and then (Descriptors (Interrupt).Static
and then
(Descriptors (Interrupt).Static
-- The new handler is not specified as an
-- Interrupt Handler by a pragma.
-- New handler not specified as an Interrupt Handler by a pragma
or else not Is_Registered (New_Handler))
or else not Is_Registered (New_Handler))
then
Raise_Exception (Program_Error'Identity,
"Trying to overwrite a static Interrupt Handler with a " &
@ -569,10 +568,10 @@ package body System.Interrupts is
Descriptors (Interrupt).T := T;
Descriptors (Interrupt).E := E;
-- Indicate the attachment of Interrupt Entry in ATCB.
-- This is need so that when an Interrupt Entry task terminates
-- the binding can be cleaned. The call to unbinding must be
-- make by the task before it terminates.
-- Indicate the attachment of Interrupt Entry in ATCB. This is needed so
-- that when an Interrupt Entry task terminates the binding can be
-- cleaned up. The call to unbinding must be make by the task before it
-- terminates.
T.Interrupt_Entry := True;
end Bind_Interrupt_To_Entry;
@ -597,7 +596,7 @@ package body System.Interrupts is
end if;
end loop;
-- Indicate in ATCB that no Interrupt Entries are attached.
-- Indicate in ATCB that no Interrupt Entries are attached
T.Interrupt_Entry := True;
end Detach_Interrupt_Entries;
@ -674,8 +673,8 @@ package body System.Interrupts is
Initialization.Undefer_Abort (Self_Id);
-- Undefer abort here to allow a window for this task
-- to be aborted at the time of system shutdown.
-- Undefer abort here to allow a window for this task to be aborted
-- at the time of system shutdown.
end loop;
end Server_Task;

78
gcc/ada/s-interr-vms.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-- This is an OpenVMS/Alpha version of this package.
-- This is an OpenVMS/Alpha version of this package
-- Invariants:
@ -140,9 +140,8 @@ package body System.Interrupts is
-- Local Tasks --
-----------------
-- WARNING: System.Tasking.Stages performs calls to this task
-- with low-level constructs. Do not change this spec without synchro-
-- nizing it.
-- WARNING: System.Tasking.Stages performs calls to this task with
-- low-level constructs. Do not change this spec without synchronizing it.
task Interrupt_Manager is
entry Detach_Interrupt_Entries (T : Task_Id);
@ -183,10 +182,10 @@ package body System.Interrupts is
task type Server_Task (Interrupt : Interrupt_ID) is
pragma Priority (System.Interrupt_Priority'Last);
-- Note: the above pragma Priority is strictly speaking improper
-- since it is outside the range of allowed priorities, but the
-- compiler treats system units specially and does not apply
-- this range checking rule to system units.
-- Note: the above pragma Priority is strictly speaking improper since
-- it is outside the range of allowed priorities, but the compiler
-- treats system units specially and does not apply this range checking
-- rule to system units.
end Server_Task;
@ -210,9 +209,9 @@ package body System.Interrupts is
(others => (null, Static => False));
pragma Volatile_Components (User_Handler);
-- Holds the protected procedure handler (if any) and its Static
-- information for each interrupt. A handler is a Static one if
-- it is specified through the pragma Attach_Handler.
-- Attach_Handler. Otherwise, not static)
-- information for each interrupt. A handler is a Static one if it is
-- specified through the pragma Attach_Handler. Attach_Handler. Otherwise,
-- not static)
User_Entry : array (Interrupt_ID'Range) of Entry_Assoc :=
(others => (T => Null_Task, E => Null_Task_Entry));
@ -221,7 +220,7 @@ package body System.Interrupts is
Blocked : constant array (Interrupt_ID'Range) of Boolean :=
(others => False);
-- ??? pragma Volatile_Components (Blocked);
-- ??? pragma Volatile_Components (Blocked);
-- True iff the corresponding interrupt is blocked in the process level
Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);
@ -238,13 +237,13 @@ package body System.Interrupts is
Server_ID : array (Interrupt_ID'Range) of Task_Id :=
(others => Null_Task);
pragma Atomic_Components (Server_ID);
-- Holds the Task_Id of the Server_Task for each interrupt.
-- Task_Id is needed to accomplish locking per Interrupt base. Also
-- is needed to decide whether to create a new Server_Task.
-- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is
-- needed to accomplish locking per Interrupt base. Also is needed to
-- decide whether to create a new Server_Task.
-- Type and Head, Tail of the list containing Registered Interrupt
-- Handlers. These definitions are used to register the handlers
-- specified by the pragma Interrupt_Handler.
-- Handlers. These definitions are used to register the handlers specified
-- by the pragma Interrupt_Handler.
type Registered_Handler;
type R_Link is access all Registered_Handler;
@ -334,7 +333,6 @@ package body System.Interrupts is
end loop;
return False;
end Is_Registered;
-----------------
@ -415,9 +413,9 @@ package body System.Interrupts is
Interrupt_ID'Image (Interrupt) & " is reserved");
end if;
-- ??? Since Parameterless_Handler is not Atomic, the
-- current implementation is wrong. We need a new service in
-- Interrupt_Manager to ensure atomicity.
-- ??? Since Parameterless_Handler is not Atomic, the current
-- implementation is wrong. We need a new service in Interrupt_Manager
-- to ensure atomicity.
return User_Handler (Interrupt).H;
end Current_Handler;
@ -452,19 +450,20 @@ package body System.Interrupts is
-- Exchange_Handler --
----------------------
-- Calling this procedure with New_Handler = null and Static = True
-- means we want to detach the current handler regardless of the
-- previous handler's binding status (ie. do not care if it is a
-- dynamic or static handler).
-- Calling this procedure with New_Handler = null and Static = True means
-- we want to detach the current handler regardless of the previous
-- handler's binding status (ie. do not care if it is dynamic or static
-- handler).
-- This option is needed so that during the finalization of a PO, we
-- can detach handlers attached through pragma Attach_Handler.
-- This option is needed so that during the finalization of a PO, we can
-- detach handlers attached through pragma Attach_Handler.
procedure Exchange_Handler
(Old_Handler : out Parameterless_Handler;
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
Static : Boolean := False) is
Static : Boolean := False)
is
begin
if Is_Reserved (Interrupt) then
Raise_Exception (Program_Error'Identity, "Interrupt" &
@ -1152,25 +1151,24 @@ package body System.Interrupts is
end Install_Handlers;
-- Elaboration code for package System.Interrupts
begin
-- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
-- During the elaboration of this package body we want RTS to
-- inherit the interrupt mask from the Environment Task.
-- During the elaboration of this package body we want RTS to inherit the
-- interrupt mask from the Environment Task.
-- The Environment Task should have gotten its mask from
-- the enclosing process during the RTS start up. (See
-- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment
-- task to the Interrupt_Manager.
-- The Environment Task should have gotten its mask from the enclosing
-- process during the RTS start up. (See in s-inmaop.adb). Pass the
-- Interrupt_Mask of the Environment task to the Interrupt_Manager.
-- Note : At this point we know that all tasks (including
-- RTS internal servers) are masked for non-reserved signals
-- (see s-taprop.adb). Only the Interrupt_Manager will have
-- masks set up differently inheriting the original Environment
-- Task's mask.
-- Note : At this point we know that all tasks (including RTS internal
-- servers) are masked for non-reserved signals (see s-taprop.adb). Only
-- the Interrupt_Manager will have masks set up differently inheriting the
-- original Environment Task's mask.
Interrupt_Manager.Initialize (IMOP.Environment_Mask);
end System.Interrupts;

76
gcc/ada/s-interr-vxworks.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -33,27 +33,27 @@
-- Invariants:
-- All user-handleable signals are masked at all times in all
-- tasks/threads except possibly for the Interrupt_Manager task.
-- All user-handleable signals are masked at all times in all tasks/threads
-- except possibly for the Interrupt_Manager task.
-- When a user task wants to have the effect of masking/unmasking an
-- signal, it must call Block_Interrupt/Unblock_Interrupt, which
-- will have the effect of unmasking/masking the signal in the
-- Interrupt_Manager task. These comments do not apply to vectored
-- hardware interrupts, which may be masked or unmasked using routined
-- interfaced to the relevant VxWorks system calls.
-- When a user task wants to have the effect of masking/unmasking an signal,
-- it must call Block_Interrupt/Unblock_Interrupt, which will have the effect
-- of unmasking/masking the signal in the Interrupt_Manager task. These
-- comments do not apply to vectored hardware interrupts, which may be masked
-- or unmasked using routined interfaced to the relevant VxWorks system
-- calls.
-- Once we associate a Signal_Server_Task with an signal, the task never
-- goes away, and we never remove the association. On the other hand, it
-- is more convenient to terminate an associated Interrupt_Server_Task
-- for a vectored hardware interrupt (since we use a binary semaphore
-- for synchronization with the umbrella handler).
-- Once we associate a Signal_Server_Task with an signal, the task never goes
-- away, and we never remove the association. On the other hand, it is more
-- convenient to terminate an associated Interrupt_Server_Task for a vectored
-- hardware interrupt (since we use a binary semaphore for synchronization
-- with the umbrella handler).
-- There is no more than one signal per Signal_Server_Task and no more than
-- one Signal_Server_Task per signal. The same relation holds for hardware
-- interrupts and Interrupt_Server_Task's at any given time. That is,
-- only one non-terminated Interrupt_Server_Task exists for a give
-- interrupt at any time.
-- one Signal_Server_Task per signal. The same relation holds for hardware
-- interrupts and Interrupt_Server_Task's at any given time. That is, only
-- one non-terminated Interrupt_Server_Task exists for a give interrupt at
-- any time.
-- Within this package, the lock L is used to protect the various status
-- tables. If there is a Server_Task associated with a signal or interrupt,
@ -124,9 +124,8 @@ package body System.Interrupts is
-- Local Tasks --
-----------------
-- WARNING: System.Tasking.Stages performs calls to this task
-- with low-level constructs. Do not change this spec without synchro-
-- nizing it.
-- WARNING: System.Tasking.Stages performs calls to this task with
-- low-level constructs. Do not change this spec without synchronizing it.
task Interrupt_Manager is
entry Detach_Interrupt_Entries (T : Task_Id);
@ -331,7 +330,8 @@ package body System.Interrupts is
---------------------
function Current_Handler
(Interrupt : Interrupt_ID) return Parameterless_Handler is
(Interrupt : Interrupt_ID) return Parameterless_Handler
is
begin
Check_Reserved_Interrupt (Interrupt);
@ -386,7 +386,8 @@ package body System.Interrupts is
(Old_Handler : out Parameterless_Handler;
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
Static : Boolean := False) is
Static : Boolean := False)
is
begin
Check_Reserved_Interrupt (Interrupt);
Interrupt_Manager.Exchange_Handler
@ -421,7 +422,7 @@ package body System.Interrupts is
-- Finalize_Interrupt_Servers --
--------------------------------
-- Restore default handlers for interrupt servers.
-- Restore default handlers for interrupt servers
-- This is called by the Interrupt_Manager task when it receives the abort
-- signal during program finalization.
@ -456,7 +457,6 @@ package body System.Interrupts is
return Boolean
is
pragma Unreferenced (Object);
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@ -466,7 +466,6 @@ package body System.Interrupts is
return Boolean
is
pragma Unreferenced (Object);
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@ -500,9 +499,11 @@ package body System.Interrupts is
procedure Install_Handlers
(Object : access Static_Interrupt_Protection;
New_Handlers : New_Handler_Array) is
New_Handlers : New_Handler_Array)
is
begin
for N in New_Handlers'Range loop
-- We need a lock around this ???
Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
@ -687,6 +688,7 @@ package body System.Interrupts is
procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
New_Node_Ptr : R_Link;
begin
-- This routine registers a handler as usable for dynamic
-- interrupt handler association. Routines attaching and detaching
@ -727,7 +729,8 @@ package body System.Interrupts is
------------------
function Unblocked_By
(Interrupt : Interrupt_ID) return System.Tasking.Task_Id is
(Interrupt : Interrupt_ID) return System.Tasking.Task_Id
is
begin
Unimplemented ("Unblocked_By");
return Null_Task;
@ -836,8 +839,9 @@ package body System.Interrupts is
-- status of the Current_Handler.
if not Static and then User_Handler (Interrupt).Static then
-- Trying to detach a static Interrupt Handler.
-- raise Program_Error.
-- Trying to detach a static Interrupt Handler. raise
-- Program_Error.
Raise_Exception (Program_Error'Identity,
"Trying to detach a static Interrupt Handler");
@ -864,9 +868,11 @@ package body System.Interrupts is
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
Static : Boolean;
Restoration : Boolean := False) is
Restoration : Boolean := False)
is
begin
if User_Entry (Interrupt).T /= Null_Task then
-- If an interrupt entry is already installed, raise
-- Program_Error. (propagate it to the caller).
@ -909,7 +915,7 @@ package body System.Interrupts is
if New_Handler = null then
-- The null handler means we are detaching the handler.
-- The null handler means we are detaching the handler
User_Handler (Interrupt).Static := False;
@ -935,11 +941,13 @@ package body System.Interrupts is
end if;
if (New_Handler = null) and then Old_Handler /= null then
-- Restore default handler
Unbind_Handler (Interrupt);
elsif Old_Handler = null then
-- Save default handler
Bind_Handler (Interrupt);
@ -1046,7 +1054,7 @@ package body System.Interrupts is
end if;
end loop;
-- Indicate in ATCB that no interrupt entries are attached.
-- Indicate in ATCB that no interrupt entries are attached
T.Interrupt_Entry := False;
end Detach_Interrupt_Entries;
@ -1140,7 +1148,7 @@ package body System.Interrupts is
end Interrupt_Server_Task;
begin
-- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
-- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
end System.Interrupts;

68
gcc/ada/s-interr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -157,20 +157,20 @@ package body System.Interrupts is
entry Initialize (Mask : IMNG.Interrupt_Mask);
entry Attach_Handler
(New_Handler : in Parameterless_Handler;
Interrupt : in Interrupt_ID;
Static : in Boolean;
Restoration : in Boolean := False);
(New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
Static : Boolean;
Restoration : Boolean := False);
entry Exchange_Handler
(Old_Handler : out Parameterless_Handler;
New_Handler : in Parameterless_Handler;
Interrupt : in Interrupt_ID;
Static : in Boolean);
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
Static : Boolean);
entry Detach_Handler
(Interrupt : in Interrupt_ID;
Static : in Boolean);
(Interrupt : Interrupt_ID;
Static : Boolean);
entry Bind_Interrupt_To_Entry
(T : Task_Id;
@ -256,7 +256,7 @@ package body System.Interrupts is
type R_Link is access all Registered_Handler;
type Registered_Handler is record
H : System.Address := System.Null_Address;
H : System.Address := System.Null_Address;
Next : R_Link := null;
end record;
@ -287,9 +287,9 @@ package body System.Interrupts is
-- can detach handlers attached through pragma Attach_Handler.
procedure Attach_Handler
(New_Handler : in Parameterless_Handler;
Interrupt : in Interrupt_ID;
Static : in Boolean := False)
(New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
Static : Boolean := False)
is
begin
if Is_Reserved (Interrupt) then
@ -352,9 +352,9 @@ package body System.Interrupts is
Interrupt_ID'Image (Interrupt) & " is reserved");
end if;
-- ??? Since Parameterless_Handler is not Atomic, the
-- current implementation is wrong. We need a new service in
-- Interrupt_Manager to ensure atomicity.
-- ??? Since Parameterless_Handler is not Atomic, the current
-- implementation is wrong. We need a new service in Interrupt_Manager
-- to ensure atomicity.
return User_Handler (Interrupt).H;
end Current_Handler;
@ -632,15 +632,15 @@ package body System.Interrupts is
New_Node_Ptr : R_Link;
begin
-- This routine registers the Handler as usable for Dynamic
-- Interrupt Handler. Routines attaching and detaching Handler
-- dynamically should first consult if the Handler is rgistered.
-- A Program Error should be raised if it is not registered.
-- This routine registers the Handler as usable for Dynamic Interrupt
-- Handler. Routines attaching and detaching Handler dynamically should
-- first consult if the Handler is registered. A Program Error should
-- be raised if it is not registered.
-- The pragma Interrupt_Handler can only appear in the library
-- level PO definition and instantiation. Therefore, we do not need
-- to implement Unregistering operation. Neither we need to
-- protect the queue structure using a Lock.
-- The pragma Interrupt_Handler can only appear in the library level PO
-- definition and instantiation. Therefore, we do not need to implement
-- Unregistering operation. Neither we need to protect the queue
-- structure using a Lock.
pragma Assert (Handler_Addr /= System.Null_Address);
@ -1014,10 +1014,10 @@ package body System.Interrupts is
begin
select
accept Attach_Handler
(New_Handler : in Parameterless_Handler;
Interrupt : in Interrupt_ID;
Static : in Boolean;
Restoration : in Boolean := False)
(New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
Static : Boolean;
Restoration : Boolean := False)
do
Unprotected_Exchange_Handler
(Old_Handler, New_Handler, Interrupt, Static, Restoration);
@ -1026,9 +1026,9 @@ package body System.Interrupts is
or
accept Exchange_Handler
(Old_Handler : out Parameterless_Handler;
New_Handler : in Parameterless_Handler;
Interrupt : in Interrupt_ID;
Static : in Boolean)
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
Static : Boolean)
do
Unprotected_Exchange_Handler
(Old_Handler, New_Handler, Interrupt, Static);
@ -1036,8 +1036,8 @@ package body System.Interrupts is
or
accept Detach_Handler
(Interrupt : in Interrupt_ID;
Static : in Boolean)
(Interrupt : Interrupt_ID;
Static : Boolean)
do
Unprotected_Detach_Handler (Interrupt, Static);
end Detach_Handler;

76
gcc/ada/s-interr.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -39,7 +39,7 @@
-- It is made a child of System to allow visibility of various
-- runtime system internal data and operations.
-- See System.Interrupt_Management for core interrupt/signal interfaces.
-- See System.Interrupt_Management for core interrupt/signal interfaces
-- These two packages are separated in order to allow
-- System.Interrupt_Management to be used without requiring the whole
@ -95,8 +95,7 @@ package System.Interrupts is
function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean;
function Current_Handler
(Interrupt : Interrupt_ID)
return Parameterless_Handler;
(Interrupt : Interrupt_ID) return Parameterless_Handler;
-- Calling the following procedures with New_Handler = null
-- and Static = true means that we want to modify the current handler
@ -119,8 +118,7 @@ package System.Interrupts is
Static : Boolean := False);
function Reference
(Interrupt : Interrupt_ID)
return System.Address;
(Interrupt : Interrupt_ID) return System.Address;
--------------------------------
-- Interrupt Entries Services --
@ -150,8 +148,7 @@ package System.Interrupts is
procedure Unblock_Interrupt (Interrupt : Interrupt_ID);
function Unblocked_By
(Interrupt : Interrupt_ID)
return System.Tasking.Task_Id;
(Interrupt : Interrupt_ID) return System.Tasking.Task_Id;
-- It returns the ID of the last Task which Unblocked this Interrupt.
-- It returns Null_Task if no tasks have ever requested the
-- Unblocking operation or the Interrupt is currently Blocked.
@ -185,38 +182,36 @@ package System.Interrupts is
-- There are two kinds of protected objects that deal with interrupts:
-- (1) Only Interrupt_Handler pragmas are used. We need to be able to
-- tell if an Interrupt_Handler applies to a given procedure, so
-- (1) Only Interrupt_Handler pragmas are used. We need to be able to tell
-- if an Interrupt_Handler applies to a given procedure, so
-- Register_Interrupt_Handler has to be called for all the potential
-- handlers, it should be done by calling Register_Interrupt_Handler
-- with the handler code address. On finalization, which can happen only
-- has part of library level finalization since PO with
-- Interrupt_Handler pragmas can only be declared at library level,
-- nothing special needs to be done since the default handlers have been
-- restored as part of task completion which is done just before global
-- finalization. Dynamic_Interrupt_Protection should be used in this
-- case.
-- handlers, it should be done by calling Register_Interrupt_Handler with
-- the handler code address. On finalization, which can happen only has
-- part of library level finalization since PO with Interrupt_Handler
-- pragmas can only be declared at library level, nothing special needs to
-- be done since the default handlers have been restored as part of task
-- completion which is done just before global finalization.
-- Dynamic_Interrupt_Protection should be used in this case.
-- (2) Attach_Handler pragmas are used, and possibly Interrupt_Handler
-- pragma. We need to attach the handlers to the given interrupts when
-- the objet is elaborated. This should be done by constructing an array
-- of pairs (interrupt, handler) from the pragmas and calling
-- Install_Handlers with it (types to be used are New_Handler_Item and
-- New_Handler_Array). On finalization, we need to restore the handlers
-- that were installed before the elaboration of the PO, so we need to
-- store these previous handlers. This is also done by Install_Handlers,
-- the room for these informations is provided by adding a discriminant
-- which is the number of Attach_Handler pragmas and an array of this
-- size in the protection type, Static_Interrupt_Protection.
-- pragma. We need to attach the handlers to the given interrupts when the
-- objet is elaborated. This should be done by constructing an array of
-- pairs (interrupt, handler) from the pragmas and calling Install_Handlers
-- with it (types to be used are New_Handler_Item and New_Handler_Array).
-- On finalization, we need to restore the handlers that were installed
-- before the elaboration of the PO, so we need to store these previous
-- handlers. This is also done by Install_Handlers, the room for these
-- informations is provided by adding a discriminant which is the number
-- of Attach_Handler pragmas and an array of this size in the protection
-- type, Static_Interrupt_Protection.
procedure Register_Interrupt_Handler
(Handler_Addr : System.Address);
-- This routine should be called by the compiler to allow the
-- handler be used as an Interrupt Handler. That means call this
-- procedure for each pragma Interrup_Handler providing the
-- address of the handler (not including the pointer to the
-- actual PO, this way this routine is called only once for
-- each type definition of PO).
-- This routine should be called by the compiler to allow the handler be
-- used as an Interrupt Handler. That means call this procedure for each
-- pragma Interrup_Handler providing the address of the handler (not
-- including the pointer to the actual PO, this way this routine is called
-- only once for each type definition of PO).
type Static_Handler_Index is range 0 .. Integer'Last;
subtype Positive_Static_Handler_Index is
@ -228,7 +223,7 @@ package System.Interrupts is
Handler : Parameterless_Handler;
Static : Boolean;
end record;
-- Contains all the information needed to restore a previous handler.
-- Contains all the information needed to restore a previous handler
type Previous_Handler_Array is array
(Positive_Static_Handler_Index range <>) of Previous_Handler_Item;
@ -237,7 +232,7 @@ package System.Interrupts is
Interrupt : Interrupt_ID;
Handler : Parameterless_Handler;
end record;
-- Contains all the information from an Attach_Handler pragma.
-- Contains all the information from an Attach_Handler pragma
type New_Handler_Array is
array (Positive_Static_Handler_Index range <>) of New_Handler_Item;
@ -253,7 +248,7 @@ package System.Interrupts is
function Has_Interrupt_Or_Attach_Handler
(Object : access Dynamic_Interrupt_Protection) return Boolean;
-- Returns True.
-- Returns True
-- Case (2)
@ -267,9 +262,8 @@ package System.Interrupts is
end record;
function Has_Interrupt_Or_Attach_Handler
(Object : access Static_Interrupt_Protection)
return Boolean;
-- Returns True.
(Object : access Static_Interrupt_Protection) return Boolean;
-- Returns True
procedure Finalize (Object : in out Static_Interrupt_Protection);
-- Restore previous handlers as required by C.3.1(12) then call
@ -277,7 +271,7 @@ package System.Interrupts is
procedure Install_Handlers
(Object : access Static_Interrupt_Protection;
New_Handlers : in New_Handler_Array);
New_Handlers : New_Handler_Array);
-- Store the old handlers in Object.Previous_Handlers and install
-- the new static handlers.

4
gcc/ada/sem_ch3.adb
View File

@ -9603,13 +9603,15 @@ package body Sem_Ch3 is
end if;
end Comes_From_Generic;
-- Start of processing for Derived_Type_Declaration
begin
Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
if Parent_Type = Any_Type
or else Etype (Parent_Type) = Any_Type
or else (Is_Class_Wide_Type (Parent_Type)
and then Etype (Parent_Type) = T)
and then Etype (Parent_Type) = T)
then
-- If Parent_Type is undefined or illegal, make new type into a
-- subtype of Any_Type, and set a few attributes to prevent cascaded

7
gcc/ada/snames.adb
View File

@ -735,15 +735,18 @@ package body Snames is
-- xxxDF deep finalize routine for type xxx (Exp_TSS)
-- xxxDI deep initialize routine for type xxx (Exp_TSS)
-- xxxEQ composite equality routine for record type xxx (Exp_TSS)
-- xxxFA PolyORB/DSA From_Any converter for type xxx (Exp_TSS)
-- xxxIP initialization procedure for type xxx (Exp_TSS)
-- xxxRA RAs type access routine for type xxx (Exp_TSS)
-- xxxRD RAs type dereference routine for type xxx (Exp_TSS)
-- xxxRA RAS type access routine for type xxx (Exp_TSS)
-- xxxRD RAS type dereference routine for type xxx (Exp_TSS)
-- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS)
-- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS)
-- xxxSI stream input attribute subprogram for type xxx (Exp_TSS)
-- xxxSO stream output attribute subprogram for type xxx (Exp_TSS)
-- xxxSR stream read attribute subprogram for type xxx (Exp_TSS)
-- xxxSW stream write attribute subprogram for type xxx (Exp_TSS)
-- xxxTA PolyORB/DSA To_Any converter for type xxx (Exp_TSS)
-- xxxTC PolyORB/DSA Typecode for type xxx (Exp_TSS)
-- Implicit type names