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

[multiple changes]

Browse Source 
2004-07-20  Olivier Hainque  <hainque@act-europe.fr>

	* a-elchha.adb (Last_Chance_Handler): Remove the bogus buffer dynamic
	allocation and potentially overflowing update with
	Tailored_Exception_Information. Use the sec-stack free procedural
	interface to output Exception_Information instead.

	* a-except.adb (To_Stderr): New subprogram for character, and string
	version moved from a-exextr to be visible from other separate units.
	(Tailored_Exception_Information): Remove the procedural version,
	previously used by the default Last_Chance_Handler and not any more.
	Adjust various comments.

	* a-exexda.adb: Generalize the exception information procedural
	interface, to minimize the use of secondary stack and the need for
	local buffers when the info is to be output to stderr:
	(Address_Image): Removed.
	(Append_Info_Character): New subprogram, checking for overflows and
	outputing to stderr if buffer to fill is of length 0.
	(Append_Info_String): Output to stderr if buffer to fill is of length 0.
	(Append_Info_Address, Append_Info_Exception_Name,
	Append_Info_Exception_Message, Append_Info_Basic_Exception_Information,
	Append_Info_Basic_Exception_Traceback,
	Append_Info_Exception_Information): New subprograms.
	(Append_Info_Nat, Append_Info_NL): Use Append_Info_Character.
	(Basic_Exception_Info_Maxlength, Basic_Exception_Tback_Maxlength,
	Exception_Info_Maxlength, Exception_Name_Length,
	Exception_Message_Length): New subprograms.
	(Exception_Information): Use Append_Info_Exception_Information.
	(Tailored_Exception_Information): Use
	Append_Info_Basic_Exception_Information.
	Export services for the default Last_Chance_Handler.

	* a-exextr.adb (To_Stderr): Remove. Now in a-except to be usable by
	other separate units.

2004-07-20  Vincent Celier  <celier@gnat.com>

	* clean.adb, mlib-utl.adb, osint.adb, makegpr.adb: Minor reformatting.

2004-07-20  Ed Schonberg  <schonberg@gnat.com>

	* freeze.adb (Freeze_Entity): If entity is a discriminated record type,
	emit itype references for the designated types of component types that
	are declared outside of the full record declaration, and that may
	denote a partial view of that record type.

2004-07-20  Ed Schonberg  <schonberg@gnat.com>

	PR ada/15607
	* sem_ch3.adb (Build_Discriminated_Subtype): Do not attach a subtype
	which is the designated type in an access component declaration, to the
	list of incomplete dependents of the parent type, to avoid elaboration
	issues with out-of-scope subtypes.
	(Complete_Private_Subtype): Recompute Has_Unknown_Discriminants from the
	full view of the parent.

2004-07-20  Ed Schonberg  <schonberg@gnat.com>

	PR ada/15610
	* sem_ch8.adb (Find_Expanded_Name): If name is overloaded, reject
	entities that are hidden, such as references to generic actuals
	outside an instance.

2004-07-20  Javier Miranda  <miranda@gnat.com>

	* sem_ch4.adb (Try_Object_Operation): New subprogram that gives
	support to the new notation.
	(Analyze_Selected_Component): Add call to Try_Object_Operation.

2004-07-20  Jose Ruiz  <ruiz@act-europe.fr>

	* s-taprob.adb: Adding the elaboration code required for initializing
	the tasking soft links that are common to the full and the restricted
	run times.

	* s-tarest.adb (Init_RTS): Tasking soft links that are shared with the
	restricted run time has been moved to the package
	System.Soft_Links.Tasking.

	* s-tasini.adb (Init_RTS): Tasking soft links that are shared with the
	restricted run time has been moved to the package
	System.Soft_Links.Tasking.

	* Makefile.rtl: Add entry for s-solita.o in run-time library list.

	* s-solita.ads, s-solita.adb: New files.

2004-07-20  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* trans.c (Identifier_to_gnu, Pragma_to_gnu, Attribute_to_gnu,
	Case_Statement_to_gnu): Split off from gnat_to_gnu.
	(Loop_Statement_to_gnu, Subprogram_Body_to_gnu, call_to_gnu,
	Handled_Sequence_Of_Statements_to_gnu, Exception_Handler_to_gnu_sjlj,
	Exception_Handler_to_gnu_zcx): Likewise.

From-SVN: r84948
This commit is contained in:
Arnaud Charlet 2004-07-20 12:26:51 +02:00
parent a6c0a76c5f
commit 35ae2ed814
20 changed files with 3262 additions and 2576 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
gcc/ada/ChangeLog
View File

@ -1,3 +1,99 @@
2004-07-20 Olivier Hainque <hainque@act-europe.fr>
* a-elchha.adb (Last_Chance_Handler): Remove the bogus buffer dynamic
allocation and potentially overflowing update with
Tailored_Exception_Information. Use the sec-stack free procedural
interface to output Exception_Information instead.
* a-except.adb (To_Stderr): New subprogram for character, and string
version moved from a-exextr to be visible from other separate units.
(Tailored_Exception_Information): Remove the procedural version,
previously used by the default Last_Chance_Handler and not any more.
Adjust various comments.
* a-exexda.adb: Generalize the exception information procedural
interface, to minimize the use of secondary stack and the need for
local buffers when the info is to be output to stderr:
(Address_Image): Removed.
(Append_Info_Character): New subprogram, checking for overflows and
outputing to stderr if buffer to fill is of length 0.
(Append_Info_String): Output to stderr if buffer to fill is of length 0.
(Append_Info_Address, Append_Info_Exception_Name,
Append_Info_Exception_Message, Append_Info_Basic_Exception_Information,
Append_Info_Basic_Exception_Traceback,
Append_Info_Exception_Information): New subprograms.
(Append_Info_Nat, Append_Info_NL): Use Append_Info_Character.
(Basic_Exception_Info_Maxlength, Basic_Exception_Tback_Maxlength,
Exception_Info_Maxlength, Exception_Name_Length,
Exception_Message_Length): New subprograms.
(Exception_Information): Use Append_Info_Exception_Information.
(Tailored_Exception_Information): Use
Append_Info_Basic_Exception_Information.
Export services for the default Last_Chance_Handler.
* a-exextr.adb (To_Stderr): Remove. Now in a-except to be usable by
other separate units.
2004-07-20 Vincent Celier <celier@gnat.com>
* clean.adb, mlib-utl.adb, osint.adb, makegpr.adb: Minor reformatting.
2004-07-20 Ed Schonberg <schonberg@gnat.com>
* freeze.adb (Freeze_Entity): If entity is a discriminated record type,
emit itype references for the designated types of component types that
are declared outside of the full record declaration, and that may
denote a partial view of that record type.
2004-07-20 Ed Schonberg <schonberg@gnat.com>
PR ada/15607
* sem_ch3.adb (Build_Discriminated_Subtype): Do not attach a subtype
which is the designated type in an access component declaration, to the
list of incomplete dependents of the parent type, to avoid elaboration
issues with out-of-scope subtypes.
(Complete_Private_Subtype): Recompute Has_Unknown_Discriminants from the
full view of the parent.
2004-07-20 Ed Schonberg <schonberg@gnat.com>
PR ada/15610
* sem_ch8.adb (Find_Expanded_Name): If name is overloaded, reject
entities that are hidden, such as references to generic actuals
outside an instance.
2004-07-20 Javier Miranda <miranda@gnat.com>
* sem_ch4.adb (Try_Object_Operation): New subprogram that gives
support to the new notation.
(Analyze_Selected_Component): Add call to Try_Object_Operation.
2004-07-20 Jose Ruiz <ruiz@act-europe.fr>
* s-taprob.adb: Adding the elaboration code required for initializing
the tasking soft links that are common to the full and the restricted
run times.
* s-tarest.adb (Init_RTS): Tasking soft links that are shared with the
restricted run time has been moved to the package
System.Soft_Links.Tasking.
* s-tasini.adb (Init_RTS): Tasking soft links that are shared with the
restricted run time has been moved to the package
System.Soft_Links.Tasking.
* Makefile.rtl: Add entry for s-solita.o in run-time library list.
* s-solita.ads, s-solita.adb: New files.
2004-07-20 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (Identifier_to_gnu, Pragma_to_gnu, Attribute_to_gnu,
Case_Statement_to_gnu): Split off from gnat_to_gnu.
(Loop_Statement_to_gnu, Subprogram_Body_to_gnu, call_to_gnu,
Handled_Sequence_Of_Statements_to_gnu, Exception_Handler_to_gnu_sjlj,
Exception_Handler_to_gnu_zcx): Likewise.
2004-07-17 Joseph S. Myers <jsm@polyomino.org.uk>
* gigi.h (builtin_function): Declare.

1
gcc/ada/Makefile.rtl
View File

@ -46,6 +46,7 @@ GNATRTL_TASKING_OBJS= \
s-intman$(objext) \
s-osinte$(objext) \
s-proinf$(objext) \
s-solita$(objext) \
s-taenca$(objext) \
s-taprob$(objext) \
s-taprop$(objext) \

100
gcc/ada/a-elchha.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2003 Free Software Foundation, Inc. --
-- Copyright (C) 2003-2004 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 --
@ -45,83 +45,43 @@ is
pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
-- Perform system dependent shutdown code
function Tailored_Exception_Information
(X : Exception_Occurrence) return String;
-- Exception information to be output in the case of automatic tracing
-- requested through GNAT.Exception_Traces.
--
-- This is the same as Exception_Information if no backtrace decorator
-- is currently in place. Otherwise, this is Exception_Information with
-- the call chain raw addresses replaced by the result of a call to the
-- current decorator provided with the call chain addresses.
function Exception_Message_Length
(X : Exception_Occurrence) return Natural;
pragma Import (Ada, Exception_Message_Length, "__gnat_exception_msg_len");
procedure Append_Info_Exception_Message
(X : Exception_Occurrence; Info : in out String; Ptr : in out Natural);
pragma Import
(Ada, Tailored_Exception_Information,
"__gnat_tailored_exception_information");
(Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
procedure Tailored_Exception_Information
(X : Exception_Occurrence;
Buff : in out String;
Last : in out Integer);
-- Procedural version of the above function. Instead of returning the
-- result, this one is put in Buff (Buff'first .. Buff'first + Last)
procedure Append_Info_Exception_Information
(X : Exception_Occurrence; Info : in out String; Ptr : in out Natural);
pragma Import
(Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info");
procedure To_Stderr (S : String);
pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
-- Little routine to output string to stderr
Ptr : Natural := 0;
Nobuf : String (1 .. 0);
Nline : constant String := String'(1 => ASCII.LF);
-- Convenient shortcut
Msg : constant String := Except.Msg (1 .. Except.Msg_Length);
Max_Static_Exc_Info : constant := 1024;
-- This should be enough for most exception information cases
-- even though tailoring introduces some uncertainty. The
-- name+message should not exceed 320 chars, so that leaves at
-- least 35 backtrace slots (each slot needs 19 chars for
-- representing a 64 bit address).
subtype Exc_Info_Type is String (1 .. Max_Static_Exc_Info);
type Str_Ptr is access Exc_Info_Type;
Exc_Info : Str_Ptr;
Exc_Info_Last : Natural := 0;
-- Buffer that is allocated to store the tailored exception
-- information while Adafinal is run. This buffer is allocated
-- on the heap only when it is needed. It is better to allocate
-- on the heap than on the stack since stack overflows are more
-- common than heap overflows.
procedure Tailored_Exception_Information
(X : Exception_Occurrence;
Buff : in out String;
Last : in out Integer)
is
Info : constant String := Tailored_Exception_Information (X);
begin
Last := Info'Last;
Buff (1 .. Last) := Info;
end Tailored_Exception_Information;
begin
-- First allocate & store the exception info in a buffer when
-- we know it will be needed. This needs to be done before
-- Adafinal because it implicitly uses the secondary stack.
-- Let's shutdown the runtime now. The rest of the procedure needs to be
-- careful not to use anything that would require runtime support. In
-- particular, functions returning strings are banned since the sec stack
-- is no longer functional. This is particularly important to note for the
-- Exception_Information output. We used to allow the tailored version to
-- show up here, which turned out to be a bad idea as it might involve a
-- traceback decorator the length of which we don't control. Potentially
-- heavy primary/secondary stack use or dynamic allocations right before
-- this point are not welcome, moving the output before the finalization
-- raises order of outputs concerns, and decorators are intended to only
-- be used with exception traces, which should have been issued already.
if Except.Id.Full_Name.all (1) /= '_'
and then Except.Num_Tracebacks /= 0
then
Exc_Info := new Exc_Info_Type;
if Exc_Info /= null then
Tailored_Exception_Information
(Except, Exc_Info.all, Exc_Info_Last);
end if;
end if;
-- Let's shutdown the runtime now. The rest of the procedure
-- needs to be careful not to use anything that would require
-- runtime support. In particular, functions returning strings
-- are banned since the sec stack is no longer functional.
System.Standard_Library.Adafinal;
-- Check for special case of raising _ABORT_SIGNAL, which is not
@ -142,9 +102,9 @@ begin
To_Stderr ("raised ");
To_Stderr (Except.Id.Full_Name.all (1 .. Except.Id.Name_Length - 1));
if Msg'Length /= 0 then
if Exception_Message_Length (Except) /= 0 then
To_Stderr (" : ");
To_Stderr (Msg);
Append_Info_Exception_Message (Except, Nobuf, Ptr);
end if;
To_Stderr (Nline);
@ -152,13 +112,11 @@ begin
-- Traceback exists
else
-- Note we can have this whole information output twice if
-- this occurrence gets reraised up to here.
To_Stderr (Nline);
To_Stderr ("Execution terminated by unhandled exception");
To_Stderr (Nline);
To_Stderr (Exc_Info (1 .. Exc_Info_Last));
Append_Info_Exception_Information (Except, Nobuf, Ptr);
end if;
Unhandled_Terminate;

110
gcc/ada/a-except.adb
View File

@ -120,6 +120,17 @@ package body Ada.Exceptions is
-- Raise_From_Signal_Handler. The origin of the call is indicated by the
-- From_Signal_Handler argument.
procedure To_Stderr (S : String);
pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
-- Little routine to output string to stderr that is also used
-- in the tasking run time.
procedure To_Stderr (C : Character);
pragma Inline (To_Stderr);
pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char");
-- Little routine to output a character to stderr, used by some of
-- the separate units below.
package Exception_Data is
---------------------------------
@ -154,34 +165,40 @@ package body Ada.Exceptions is
function Exception_Information (X : Exception_Occurrence) return String;
-- The format of the exception information is as follows:
--
-- exception name (as in Exception_Name)
-- message (or a null line if no message)
-- PID=nnnn
-- 0xyyyyyyyy 0xyyyyyyyy ...
-- Exception_Name: <exception name> (as in Exception_Name)
-- Message: <message> (only if Exception_Message is empty)
-- PID=nnnn (only if != 0)
-- Call stack traceback locations: (only if at least one location)
-- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded)
--
-- The lines are separated by a ASCII.LF character
-- The lines are separated by a ASCII.LF character.
-- The nnnn is the partition Id given as decimal digits.
-- The 0x... line represents traceback program counter locations,
-- in order with the first one being the exception location.
-- The 0x... line represents traceback program counter locations, in
-- execution order with the first one being the exception location. It
-- is present only
--
-- The Exception_Name and Message lines are omitted in the abort
-- signal case, since this is not really an exception.
-- !! If the format of the generated string is changed, please note
-- !! that an equivalent modification to the routine String_To_EO must
-- !! be made to preserve proper functioning of the stream attributes.
---------------------------------------
-- Exception backtracing subprograms --
---------------------------------------
-- What is automatically output when exception tracing is on basically
-- corresponds to the usual exception information, but with the call
-- chain backtrace possibly tailored by a backtrace decorator. Modifying
-- Exception_Information itself is not a good idea because the decorated
-- output is completely out of control and would break all our code
-- related to the streaming of exceptions.
--
-- We then provide an alternative function to Exception_Information to
-- compute the possibly tailored output, which is equivalent if no
-- decorator is currently set.
-- What is automatically output when exception tracing is on is the
-- usual exception information with the call chain backtrace possibly
-- tailored by a backtrace decorator. Modifying Exception_Information
-- itself is not a good idea because the decorated output is completely
-- out of control and would break all our code related to the streaming
-- of exceptions. We then provide an alternative function to compute
-- the possibly tailored output, which is equivalent if no decorator is
-- currently set:
function Tailored_Exception_Information
(X : Exception_Occurrence)
return String;
(X : Exception_Occurrence) return String;
-- Exception information to be output in the case of automatic tracing
-- requested through GNAT.Exception_Traces.
--
@ -193,28 +210,7 @@ package body Ada.Exceptions is
pragma Export
(Ada, Tailored_Exception_Information,
"__gnat_tailored_exception_information");
-- This function is used within this package but also from within
-- System.Tasking.Stages.
--
-- The output of Exception_Information and
-- Tailored_Exception_Information share a common part which was
-- formerly built using local procedures within
-- Exception_Information. These procedures have been extracted
-- from their original place to be available to
-- Tailored_Exception_Information also.
--
-- Each of these procedures appends some input to an
-- information string currently being built. The Ptr argument
-- represents the last position in this string at which a
-- character has been written.
procedure Tailored_Exception_Information
(X : Exception_Occurrence;
Buff : in out String;
Last : in out Integer);
-- Procedural version of the above function. Instead of returning the
-- result, this one is put in Buff (Buff'first .. Buff'first + Last)
-- And what happens on overflow ???
-- This is currently used by System.Tasking.Stages.
end Exception_Data;
@ -234,14 +230,14 @@ package body Ada.Exceptions is
-- routine when the GCC 3 mechanism is used.
procedure Notify_Handled_Exception;
pragma Export (C, Notify_Handled_Exception,
"__gnat_notify_handled_exception");
pragma Export
(C, Notify_Handled_Exception, "__gnat_notify_handled_exception");
-- This routine is called for a handled occurrence is about to be
-- propagated.
procedure Notify_Unhandled_Exception;
pragma Export (C, Notify_Unhandled_Exception,
"__gnat_notify_unhandled_exception");
pragma Export
(C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception");
-- This routine is called when an unhandled occurrence is about to be
-- propagated.
@ -1309,6 +1305,30 @@ package body Ada.Exceptions is
Raise_Current_Excep (E);
end Raise_Exception_No_Defer;
---------------
-- To_Stderr --
---------------
procedure To_Stderr (C : Character) is
type int is new Integer;
procedure put_char_stderr (C : int);
pragma Import (C, put_char_stderr, "put_char_stderr");
begin
put_char_stderr (Character'Pos (C));
end To_Stderr;
procedure To_Stderr (S : String) is
begin
for J in S'Range loop
if S (J) /= ASCII.CR then
To_Stderr (S (J));
end if;
end loop;
end To_Stderr;
---------
-- ZZZ --
---------

597
gcc/ada/a-exexda.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -36,39 +36,153 @@ with System.Storage_Elements; use System.Storage_Elements;
separate (Ada.Exceptions)
package body Exception_Data is
-----------------------
-- Local Subprograms --
-----------------------
-- This unit implements the Exception_Information related services for
-- both the Ada standard requirements and the GNAT.Exception_Traces
-- facility.
function Address_Image (A : System.Address) return String;
-- Returns at string of the form 0xhhhhhhhhh for an address, with
-- leading zeros suppressed. Hex characters a-f are in lower case.
-- There are common parts between the contents of Exception_Information
-- (the regular Ada interface) and Tailored_Exception_Information (what
-- the automatic backtracing output includes). The overall structure is
-- sketched below:
--
-- Exception_Information
-- |
-- +-------+--------+
-- | |
-- Basic_Exc_Info & Basic_Exc_Tback
-- (B_E_I) (B_E_TB)
-- o--
-- (B_E_I) | Exception_Name: <exception name> (as in Exception_Name)
-- | Message: <message> (or a null line if no message)
-- | PID=nnnn (if != 0)
-- o--
-- (B_E_TB) | Call stack traceback locations:
-- | <0xyyyyyyyy 0xyyyyyyyy ...>
-- o--
-- Tailored_Exception_Information
-- |
-- +----------+----------+
-- | |
-- Basic_Exc_Info & Tailored_Exc_Tback
-- |
-- +-----------+------------+
-- | |
-- Basic_Exc_Tback Or Tback_Decorator
-- if no decorator set otherwise
-- Functions returning String imply secondary stack use, which is a heavy
-- mechanism requiring run-time support. Besides, some of the routines we
-- provide here are to be used by the default Last_Chance_Handler, at the
-- critical point where the runtime is about to be finalized. Since most
-- of the items we have at hand are of bounded length, we also provide a
-- procedural interface able to incrementally append the necessary bits to
-- a preallocated buffer or output them straight to stderr.
-- The procedural interface is composed of two major sections: a neutral
-- section for basic types like Address, Character, Natural or String, and
-- an exception oriented section for the e.g. Basic_Exception_Information.
-- This is the Append_Info family of procedures below.
-- Output to stderr is commanded by passing an empty buffer to update, and
-- care is taken not to overflow otherwise.
--------------------------------------------
-- Procedural Interface - Neutral section --
--------------------------------------------
procedure Append_Info_Address
(A : Address;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Character
(C : Character;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Nat
(N : Natural;
Info : in out String;
Ptr : in out Natural);
-- Append the image of N at the end of the provided information string
procedure Append_Info_NL
(Info : in out String;
Ptr : in out Natural);
-- Append a LF at the end of the provided information string
pragma Inline (Append_Info_NL);
procedure Append_Info_String
(S : String;
Info : in out String;
Ptr : in out Natural);
-- Append a string at the end of the provided information string
-- To build Exception_Information and Tailored_Exception_Information,
-- we then use three intermediate functions :
-------------------------------------------------------
-- Procedural Interface - Exception oriented section --
-------------------------------------------------------
function Basic_Exception_Information
(X : Exception_Occurrence) return String;
-- Returns the basic exception information string associated with a
-- given exception occurrence. This is the common part shared by both
-- Exception_Information and Tailored_Exception_Infomation.
procedure Append_Info_Exception_Name
(Id : Exception_Id;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Exception_Name
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Exception_Message
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Basic_Exception_Information
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Basic_Exception_Traceback
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
procedure Append_Info_Exception_Information
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
-- The "functional" interface to the exception information not involving
-- a traceback decorator uses preallocated intermediate buffers to avoid
-- the use of secondary stack. Preallocation requires preliminary length
-- computation, for which a series of functions are introduced:
---------------------------------
-- Length evaluation utilities --
---------------------------------
function Basic_Exception_Info_Maxlength
(X : Exception_Occurrence) return Natural;
function Basic_Exception_Tback_Maxlength
(X : Exception_Occurrence) return Natural;
function Exception_Info_Maxlength
(X : Exception_Occurrence) return Natural;
function Exception_Name_Length
(Id : Exception_Id) return Natural;
function Exception_Name_Length
(X : Exception_Occurrence) return Natural;
function Exception_Message_Length
(X : Exception_Occurrence) return Natural;
--------------------------
-- Functional Interface --
--------------------------
function Basic_Exception_Traceback
(X : Exception_Occurrence) return String;
@ -82,32 +196,28 @@ package body Exception_Data is
-- exception occurrence, either in its basic form if no decorator is
-- in place, or as formatted by the decorator otherwise.
-- The overall organization of the exception information related code
-- is summarized below :
--
-- Exception_Information
-- |
-- +-------+--------+
-- | |
-- Basic_Exc_Info & Basic_Exc_Tback
--
--
-- Tailored_Exception_Information
-- |
-- +----------+----------+
-- | |
-- Basic_Exc_Info & Tailored_Exc_Tback
-- |
-- +-----------+------------+
-- | |
-- Basic_Exc_Tback Or Tback_Decorator
-- if no decorator set otherwise
-----------------------------------------------------------------------
-- Services for the default Last_Chance_Handler and the task wrapper --
-----------------------------------------------------------------------
-------------------
-- Address_Image --
-------------------
pragma Export
(Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
function Address_Image (A : Address) return String is
pragma Export
(Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info");
pragma Export
(Ada, Exception_Message_Length, "__gnat_exception_msg_len");
-------------------------
-- Append_Info_Address --
-------------------------
procedure Append_Info_Address
(A : Address;
Info : in out String;
Ptr : in out Natural)
is
S : String (1 .. 18);
P : Natural;
N : Integer_Address;
@ -126,8 +236,27 @@ package body Exception_Data is
S (P - 1) := '0';
S (P) := 'x';
return S (P - 1 .. S'Last);
end Address_Image;
Append_Info_String (S (P - 1 .. S'Last), Info, Ptr);
end Append_Info_Address;
---------------------------
-- Append_Info_Character --
---------------------------
procedure Append_Info_Character
(C : Character;
Info : in out String;
Ptr : in out Natural)
is
begin
if Info'Length = 0 then
To_Stderr (C);
elsif Ptr < Info'Last then
Ptr := Ptr + 1;
Info (Ptr) := C;
end if;
end Append_Info_Character;
---------------------
-- Append_Info_Nat --
@ -143,8 +272,8 @@ package body Exception_Data is
Append_Info_Nat (N / 10, Info, Ptr);
end if;
Ptr := Ptr + 1;
Info (Ptr) := Character'Val (Character'Pos ('0') + N mod 10);
Append_Info_Character
(Character'Val (Character'Pos ('0') + N mod 10), Info, Ptr);
end Append_Info_Nat;
--------------------
@ -156,8 +285,7 @@ package body Exception_Data is
Ptr : in out Natural)
is
begin
Ptr := Ptr + 1;
Info (Ptr) := ASCII.LF;
Append_Info_Character (ASCII.LF, Info, Ptr);
end Append_Info_NL;
------------------------
@ -169,64 +297,56 @@ package body Exception_Data is
Info : in out String;
Ptr : in out Natural)
is
Last : constant Natural := Integer'Min (Ptr + S'Length, Info'Last);
begin
Info (Ptr + 1 .. Last) := S;
Ptr := Last;
if Info'Length = 0 then
To_Stderr (S);
else
declare
Last : constant Natural :=
Integer'Min (Ptr + S'Length, Info'Last);
begin
Info (Ptr + 1 .. Last) := S;
Ptr := Last;
end;
end if;
end Append_Info_String;
---------------------------------
-- Basic_Exception_Information --
---------------------------------
---------------------------------------------
-- Append_Info_Basic_Exception_Information --
---------------------------------------------
function Basic_Exception_Information
(X : Exception_Occurrence) return String
-- To ease the maximum length computation, we define and pull out a couple
-- of string constants:
BEI_Name_Header : constant String := "Exception name: ";
BEI_Msg_Header : constant String := "Message: ";
BEI_PID_Header : constant String := "PID: ";
procedure Append_Info_Basic_Exception_Information
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural)
is
Name : constant String := Exception_Name (X);
Msg : constant String := Exception_Message (X);
-- Exception name and message that are going to be included in the
-- information to return, if not empty.
Name : String (1 .. Exception_Name_Length (X));
-- Bufer in which to fetch the exception name, in order to check
-- whether this is an internal _ABORT_SIGNAL or a regular occurrence.
Name_Len : constant Natural := Name'Length;
Msg_Len : constant Natural := Msg'Length;
-- Length of these strings, useful to compute the size of the string
-- we have to allocate for the complete result as well as in the body
-- of this procedure.
Info_Maxlen : constant Natural := 50 + Name_Len + Msg_Len;
-- Maximum length of the information string we will build, with :
--
-- 50 = 16 + 2 for the text associated with the name
-- + 9 + 2 for the text associated with the message
-- + 5 + 2 for the text associated with the pid
-- + 14 for the text image of the pid itself and a margin.
--
-- This is indeed a maximum since some data may not appear at all if
-- not relevant. For example, nothing related to the exception message
-- will be there if this message is empty.
--
-- WARNING : Do not forget to update these numbers if anything
-- involved in the computation changes.
Info : String (1 .. Info_Maxlen);
-- Information string we are going to build, containing the common
-- part shared by Exc_Info and Tailored_Exc_Info.
Ptr : Natural := 0;
Name_Ptr : Natural := Name'First - 1;
begin
-- Output exception name and message except for _ABORT_SIGNAL, where
-- these two lines are omitted (see discussion above).
-- these two lines are omitted.
if Name (1) /= '_' then
Append_Info_String ("Exception name: ", Info, Ptr);
Append_Info_Exception_Name (X, Name, Name_Ptr);
if Name (Name'First) /= '_' then
Append_Info_String (BEI_Name_Header, Info, Ptr);
Append_Info_String (Name, Info, Ptr);
Append_Info_NL (Info, Ptr);
if Msg_Len /= 0 then
Append_Info_String ("Message: ", Info, Ptr);
Append_Info_String (Msg, Info, Ptr);
if Exception_Message_Length (X) /= 0 then
Append_Info_String (BEI_Msg_Header, Info, Ptr);
Append_Info_Exception_Message (X, Info, Ptr);
Append_Info_NL (Info, Ptr);
end if;
end if;
@ -234,13 +354,172 @@ package body Exception_Data is
-- Output PID line if non-zero
if X.Pid /= 0 then
Append_Info_String ("PID: ", Info, Ptr);
Append_Info_String (BEI_PID_Header, Info, Ptr);
Append_Info_Nat (X.Pid, Info, Ptr);
Append_Info_NL (Info, Ptr);
end if;
end Append_Info_Basic_Exception_Information;
return Info (1 .. Ptr);
end Basic_Exception_Information;
-------------------------------------------
-- Basic_Exception_Information_Maxlength --
-------------------------------------------
function Basic_Exception_Info_Maxlength
(X : Exception_Occurrence) return Natural is
begin
return
BEI_Name_Header'Length + Exception_Name_Length (X) + 1
+ BEI_Msg_Header'Length + Exception_Message_Length (X) + 1
+ BEI_PID_Header'Length + 15;
end Basic_Exception_Info_Maxlength;
-------------------------------------------
-- Append_Info_Basic_Exception_Traceback --
-------------------------------------------
-- As for Basic_Exception_Information:
BETB_Header : constant String := "Call stack traceback locations:";
procedure Append_Info_Basic_Exception_Traceback
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural)
is
begin
if X.Num_Tracebacks <= 0 then
return;
end if;
Append_Info_String (BETB_Header, Info, Ptr);
Append_Info_NL (Info, Ptr);
for J in 1 .. X.Num_Tracebacks loop
Append_Info_Address (TBE.PC_For (X.Tracebacks (J)), Info, Ptr);
exit when J = X.Num_Tracebacks;
Append_Info_Character (' ', Info, Ptr);
end loop;
Append_Info_NL (Info, Ptr);
end Append_Info_Basic_Exception_Traceback;
-----------------------------------------
-- Basic_Exception_Traceback_Maxlength --
-----------------------------------------
function Basic_Exception_Tback_Maxlength
(X : Exception_Occurrence) return Natural is
begin
return BETB_Header'Length + 1 + X.Num_Tracebacks * 19 + 1;
-- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ")
end Basic_Exception_Tback_Maxlength;
---------------------------------------
-- Append_Info_Exception_Information --
---------------------------------------
procedure Append_Info_Exception_Information
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural)
is
begin
Append_Info_Basic_Exception_Information (X, Info, Ptr);
Append_Info_Basic_Exception_Traceback (X, Info, Ptr);
end Append_Info_Exception_Information;
------------------------------
-- Exception_Info_Maxlength --
------------------------------
function Exception_Info_Maxlength
(X : Exception_Occurrence) return Natural is
begin
return
Basic_Exception_Info_Maxlength (X)
+ Basic_Exception_Tback_Maxlength (X);
end Exception_Info_Maxlength;
-----------------------------------
-- Append_Info_Exception_Message --
-----------------------------------
procedure Append_Info_Exception_Message
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural) is
begin
if X.Id = Null_Id then
raise Constraint_Error;
end if;
declare
Len : constant Natural := Exception_Message_Length (X);
Msg : constant String (1 .. Len) := X.Msg (1 .. Len);
begin
Append_Info_String (Msg, Info, Ptr);
end;
end Append_Info_Exception_Message;
--------------------------------
-- Append_Info_Exception_Name --
--------------------------------
procedure Append_Info_Exception_Name
(Id : Exception_Id;
Info : in out String;
Ptr : in out Natural)
is
begin
if Id = Null_Id then
raise Constraint_Error;
end if;
declare
Len : constant Natural := Exception_Name_Length (Id);
Name : constant String (1 .. Len) := Id.Full_Name (1 .. Len);
begin
Append_Info_String (Name, Info, Ptr);
end;
end Append_Info_Exception_Name;
procedure Append_Info_Exception_Name
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural)
is
begin
Append_Info_Exception_Name (X.Id, Info, Ptr);
end Append_Info_Exception_Name;
---------------------------
-- Exception_Name_Length --
---------------------------
function Exception_Name_Length
(Id : Exception_Id) return Natural is
begin
-- What is stored in the internal Name buffer includes a terminating
-- null character that we never care about.
return Id.Name_Length - 1;
end Exception_Name_Length;
function Exception_Name_Length
(X : Exception_Occurrence) return Natural is
begin
return Exception_Name_Length (X.Id);
end Exception_Name_Length;
------------------------------
-- Exception_Message_Length --
------------------------------
function Exception_Message_Length
(X : Exception_Occurrence) return Natural is
begin
return X.Msg_Length;
end Exception_Message_Length;
-------------------------------
-- Basic_Exception_Traceback --
@ -249,102 +528,29 @@ package body Exception_Data is
function Basic_Exception_Traceback
(X : Exception_Occurrence) return String
is
Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19;
-- Maximum length of the information string we are building, with :
-- 33 = 31 + 4 for the text before and after the traceback, and
-- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ")
--
-- WARNING : Do not forget to update these numbers if anything
-- involved in the computation changes.
Info : String (1 .. Info_Maxlen);
-- Information string we are going to build, containing an image
-- of the call chain associated with the exception occurrence in its
-- most basic form, that is as a sequence of binary addresses.
Ptr : Natural := 0;
Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X));
Ptr : Natural := Info'First - 1;
begin
if X.Num_Tracebacks > 0 then
Append_Info_String ("Call stack traceback locations:", Info, Ptr);
Append_Info_NL (Info, Ptr);
for J in 1 .. X.Num_Tracebacks loop
Append_Info_String
(Address_Image (TBE.PC_For (X.Tracebacks (J))), Info, Ptr);
exit when J = X.Num_Tracebacks;
Append_Info_String (" ", Info, Ptr);
end loop;
Append_Info_NL (Info, Ptr);
end if;
return Info (1 .. Ptr);
Append_Info_Basic_Exception_Traceback (X, Info, Ptr);
return Info (Info'First .. Ptr);
end Basic_Exception_Traceback;
---------------------------
-- Exception_Information --
---------------------------
-- The format of the string is:
-- Exception_Name: nnnnn
-- Message: mmmmm
-- PID: ppp
-- Call stack traceback locations:
-- 0xhhhh 0xhhhh 0xhhhh ... 0xhhh
-- where
-- nnnn is the fully qualified name of the exception in all upper
-- case letters. This line is always present.
-- mmmm is the message (this line present only if message is non-null)
-- ppp is the Process Id value as a decimal integer (this line is
-- present only if the Process Id is non-zero). Currently we are
-- not making use of this field.
-- The Call stack traceback locations line and the following values
-- are present only if at least one traceback location was recorded.
-- the values are given in C style format, with lower case letters
-- for a-f, and only as many digits present as are necessary.
-- The line terminator sequence at the end of each line, including the
-- last line is a CR-LF sequence (16#0D# followed by 16#0A#).
-- The Exception_Name and Message lines are omitted in the abort
-- signal case, since this is not really an exception, and the only
-- use of this routine is internal for printing termination output.
-- WARNING: if the format of the generated string is changed, please note
-- that an equivalent modification to the routine String_To_EO must be
-- made to preserve proper functioning of the stream attributes.
function Exception_Information (X : Exception_Occurrence) return String is
-- This information is now built using the circuitry introduced in
-- association with the support of traceback decorators, as the
-- catenation of the exception basic information and the call chain
-- backtrace in its basic form.
Basic_Info : constant String := Basic_Exception_Information (X);
Tback_Info : constant String := Basic_Exception_Traceback (X);
Basic_Len : constant Natural := Basic_Info'Length;
Tback_Len : constant Natural := Tback_Info'Length;
Info : String (1 .. Basic_Len + Tback_Len);
Ptr : Natural := 0;
function Exception_Information
(X : Exception_Occurrence) return String
is
Info : String (1 .. Exception_Info_Maxlength (X));
Ptr : Natural := Info'First - 1;
begin
Append_Info_String (Basic_Info, Info, Ptr);
Append_Info_String (Tback_Info, Info, Ptr);
return Info;
Append_Info_Exception_Information (X, Info, Ptr);
return Info (Info'First .. Ptr);
end Exception_Information;
-------------------------
-- Set_Exception_C_Msg --
-------------------------
@ -457,11 +663,10 @@ package body Exception_Data is
function Tailored_Exception_Traceback
(X : Exception_Occurrence) return String
is
-- We indeed reference the decorator *wrapper* from here and not the
-- decorator itself. The purpose of the local variable Wrapper is to
-- prevent a potential crash by race condition in the code below. The
-- atomicity of this assignment is enforced by pragma Atomic in
-- System.Soft_Links.
-- We reference the decorator *wrapper* here and not the decorator
-- itself. The purpose of the local variable Wrapper is to prevent a
-- potential race condition in the code below. The atomicity of this
-- assignment is enforced by pragma Atomic in System.Soft_Links.
-- The potential race condition here, if no local variable was used,
-- relates to the test upon the wrapper's value and the call, which
@ -487,33 +692,19 @@ package body Exception_Data is
function Tailored_Exception_Information
(X : Exception_Occurrence) return String
is
-- The tailored exception information is simply the basic information
-- The tailored exception information is the basic information
-- associated with the tailored call chain backtrace.
Basic_Info : constant String := Basic_Exception_Information (X);
Tback_Info : constant String := Tailored_Exception_Traceback (X);
Basic_Len : constant Natural := Basic_Info'Length;
Tback_Len : constant Natural := Tback_Info'Length;
Info : String (1 .. Basic_Len + Tback_Len);
Ptr : Natural := 0;
Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len);
Ptr : Natural := Info'First - 1;
begin
Append_Info_String (Basic_Info, Info, Ptr);
Append_Info_Basic_Exception_Information (X, Info, Ptr);
Append_Info_String (Tback_Info, Info, Ptr);
return Info;
end Tailored_Exception_Information;
procedure Tailored_Exception_Information
(X : Exception_Occurrence;
Buff : in out String;
Last : in out Integer)
is
begin
Append_Info_String (Basic_Exception_Information (X), Buff, Last);
Append_Info_String (Tailored_Exception_Traceback (X), Buff, Last);
return Info (Info'First .. Ptr);
end Tailored_Exception_Information;
end Exception_Data;

28
gcc/ada/a-exextr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -57,8 +57,7 @@ package body Exception_Traces is
procedure Last_Chance_Handler
(Except : Exception_Occurrence);
pragma Import
(C, Last_Chance_Handler, "__gnat_last_chance_handler");
pragma Import (C, Last_Chance_Handler, "__gnat_last_chance_handler");
pragma No_Return (Last_Chance_Handler);
-- Users can replace the default version of this routine,
-- Ada.Exceptions.Last_Chance_Handler.
@ -76,11 +75,6 @@ package body Exception_Traces is
-- latter case because Notify_Handled_Exception may be called for an
-- actually unhandled occurrence in the Front-End-SJLJ case.
procedure To_Stderr (S : String);
pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
-- Little routine to output string to stderr that is also used
-- in the tasking run time.
---------------------------------
-- Debugger Interface Routines --
---------------------------------
@ -185,8 +179,6 @@ package body Exception_Traces is
-- Unhandled_Exception_Terminate --
-----------------------------------
type int is new Integer;
procedure Unhandled_Exception_Terminate is
Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all);
-- This occurrence will be used to display a message after finalization.
@ -198,22 +190,6 @@ package body Exception_Traces is
Last_Chance_Handler (Excep.all);
end Unhandled_Exception_Terminate;
---------------
-- To_Stderr --
---------------
procedure To_Stderr (S : String) is
procedure put_char_stderr (C : int);
pragma Import (C, put_char_stderr, "put_char_stderr");
begin
for J in 1 .. S'Length loop
if S (J) /= ASCII.CR then
put_char_stderr (Character'Pos (S (J)));
end if;
end loop;
end To_Stderr;
------------------------------------
-- Handling GNAT.Exception_Traces --

2
gcc/ada/clean.adb
View File

@ -1065,7 +1065,7 @@ package body Clean is
begin
-- Do the necessary initializations
Initialize;
Clean.Initialize;
-- Parse the command line, getting the switches and the executable names

38
gcc/ada/freeze.adb
View File

@ -3088,6 +3088,44 @@ package body Freeze is
else
Append (F_Node, Result);
end if;
-- A final pass over record types with discriminants. If the type
-- has an incomplete declaration, there may be constrained access
-- subtypes declared elsewhere, which do not depend on the discrimi-
-- nants of the type, and which are used as component types (i.e.
-- the full view is a recursive type). The designated types of these
-- subtypes can only be elaborated after the type itself, and they
-- need an itype reference.
if Ekind (E) = E_Record_Type
and then Has_Discriminants (E)
then
declare
Comp : Entity_Id;
IR : Node_Id;
Typ : Entity_Id;
begin
Comp := First_Component (E);
while Present (Comp) loop
Typ := Etype (Comp);
if Ekind (Comp) = E_Component
and then Is_Access_Type (Typ)
and then Scope (Typ) /= E
and then Base_Type (Designated_Type (Typ)) = E
and then Is_Itype (Designated_Type (Typ))
then
IR := Make_Itype_Reference (Sloc (Comp));
Set_Itype (IR, Designated_Type (Typ));
Append (IR, Result);
end if;
Next_Component (Comp);
end loop;
end;
end if;
end if;
-- When a type is frozen, the first subtype of the type is frozen as

2
gcc/ada/makegpr.adb
View File

@ -2938,7 +2938,7 @@ package body Makegpr is
procedure Gprmake is
begin
Initialize;
Makegpr.Initialize;
if Verbose_Mode then
Write_Eol;

4
gcc/ada/mlib-utl.adb
View File

@ -66,7 +66,7 @@ package body MLib.Utl is
Line_Length : Natural := 0;
begin
Initialize;
Utl.Initialize;
Arguments :=
new String_List (1 .. 1 + Ar_Options'Length + Objects'Length);
@ -177,7 +177,7 @@ package body MLib.Utl is
Driver : String_Access;
begin
Initialize;
Utl.Initialize;
if Driver_Name = No_Name then
Driver := Gcc_Exec;

2
gcc/ada/osint.adb
View File

@ -2820,7 +2820,7 @@ begin
Lib_Search_Directories.Set_Last (Primary_Directory);
Lib_Search_Directories.Table (Primary_Directory) := new String'("");
Initialize;
Osint.Initialize;
end Initialization;
end Osint;

164
gcc/ada/s-solita.adb Normal file
View File

@ -0,0 +1,164 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . S O F T _ L I N K S . T A S K I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004, 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains the tasking versions soft links.
pragma Style_Checks (All_Checks);
-- Turn off subprogram alpha ordering check, since we group soft link
-- bodies and dummy soft link bodies together separately in this unit.
pragma Polling (Off);
-- Turn polling off for this package. We don't need polling during any
-- of the routines in this package, and more to the point, if we try
-- to poll it can cause infinite loops.
with System.Task_Primitives.Operations;
-- Used for Self
-- Timed_Delay
package body System.Soft_Links.Tasking is
package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
----------------
-- Local Data --
----------------
Initialized : Boolean := False;
-- Boolean flag that indicates whether the tasking soft links have
-- already been set.
----------------------------------------------------------------------
-- Tasking versions of some services needed by non-tasking programs --
----------------------------------------------------------------------
function Get_Jmpbuf_Address return Address;
procedure Set_Jmpbuf_Address (Addr : Address);
-- Get/Set Jmpbuf_Address for current task
function Get_Sec_Stack_Addr return Address;
procedure Set_Sec_Stack_Addr (Addr : Address);
-- Get/Set location of current task's secondary stack
function Get_Machine_State_Addr return Address;
procedure Set_Machine_State_Addr (Addr : Address);
-- Get/Set the address for storing the current task's machine state
function Get_Current_Excep return SSL.EOA;
-- Task-safe version of SSL.Get_Current_Excep
procedure Timed_Delay_T (Time : Duration; Mode : Integer);
-- Task-safe version of SSL.Timed_Delay
----------------------
-- Soft-Link Bodies --
----------------------
function Get_Current_Excep return SSL.EOA is
begin
return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
end Get_Current_Excep;
function Get_Jmpbuf_Address return Address is
begin
return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
end Get_Jmpbuf_Address;
function Get_Machine_State_Addr return Address is
begin
return STPO.Self.Common.Compiler_Data.Machine_State_Addr;
end Get_Machine_State_Addr;
function Get_Sec_Stack_Addr return Address is
begin
return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
end Get_Sec_Stack_Addr;
procedure Set_Jmpbuf_Address (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
end Set_Jmpbuf_Address;
procedure Set_Machine_State_Addr (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Machine_State_Addr := Addr;
end Set_Machine_State_Addr;
procedure Set_Sec_Stack_Addr (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
end Set_Sec_Stack_Addr;
procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
begin
STPO.Timed_Delay (STPO.Self, Time, Mode);
end Timed_Delay_T;
-----------------------------
-- Init_Tasking_Soft_Links --
-----------------------------
procedure Init_Tasking_Soft_Links is
begin
-- If the tasking soft links have already been initialized do not
-- repeat it.
if not Initialized then
-- Mark tasking soft links as initialized
Initialized := True;
-- The application being executed uses tasking so that the tasking
-- version of the following soft links need to be used.
SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
SSL.Get_Current_Excep := Get_Current_Excep'Access;
SSL.Timed_Delay := Timed_Delay_T'Access;
-- No need to create a new Secondary Stack, since we will use the
-- default one created in s-secsta.adb
SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
end if;
end Init_Tasking_Soft_Links;
end System.Soft_Links.Tasking;

46
gcc/ada/s-solita.ads Normal file
View File

@ -0,0 +1,46 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . S O F T _ L I N K S . T A S K I N G --
-- --
-- S p e c --
-- --
-- Copyright (C) 2004, 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains the tasking versions soft links that are common
-- to the full and the restricted run times. The rest of the required soft
-- links are set by System.Tasking.Initialization and System.Tasking.Stages
-- (full run time) or System.Tasking.Restricted.Stages (restricted run
-- time).
package System.Soft_Links.Tasking is
procedure Init_Tasking_Soft_Links;
-- Set the tasking soft links that are common to the full and the
-- restricted run times.
end System.Soft_Links.Tasking;

9
gcc/ada/s-taprob.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-2004, Ada Core Technologies --
-- --
-- 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- --
@ -46,6 +46,9 @@ with System.Parameters;
with System.Traces;
-- used for Send_Trace_Info
with System.Soft_Links.Tasking;
-- Used for Init_Tasking_Soft_Links
package body System.Tasking.Protected_Objects is
use System.Task_Primitives.Operations;
@ -137,4 +140,8 @@ package body System.Tasking.Protected_Objects is
end if;
end Unlock;
begin
-- Ensure that tasking soft links are set when using protected objects
System.Soft_Links.Tasking.Init_Tasking_Soft_Links;
end System.Tasking.Protected_Objects;

91
gcc/ada/s-tarest.adb
View File

@ -67,6 +67,9 @@ with System.Soft_Links;
-- The GNARL must call these to be sure that all non-tasking
-- Ada constructs will work.
with System.Soft_Links.Tasking;
-- Used for Init_Tasking_Soft_Links
with System.Secondary_Stack;
-- used for SS_Init;
@ -105,21 +108,6 @@ package body System.Tasking.Restricted.Stages is
-- all nested locks must be released before other tasks competing for the
-- tasking lock are released.
-- See s-tasini.adb for more information on the following functions.
function Get_Jmpbuf_Address return Address;
procedure Set_Jmpbuf_Address (Addr : Address);
function Get_Sec_Stack_Addr return Address;
procedure Set_Sec_Stack_Addr (Addr : Address);
function Get_Machine_State_Addr return Address;
procedure Set_Machine_State_Addr (Addr : Address);
function Get_Current_Excep return SSL.EOA;
procedure Timed_Delay_T (Time : Duration; Mode : Integer);
-----------------------
-- Local Subprograms --
-----------------------
@ -158,45 +146,6 @@ package body System.Tasking.Restricted.Stages is
STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
end Task_Unlock;
----------------------
-- Soft-Link Bodies --
----------------------
function Get_Current_Excep return SSL.EOA is
begin
return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
end Get_Current_Excep;
function Get_Jmpbuf_Address return Address is
begin
return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
end Get_Jmpbuf_Address;
function Get_Machine_State_Addr return Address is
begin
return STPO.Self.Common.Compiler_Data.Machine_State_Addr;
end Get_Machine_State_Addr;
function Get_Sec_Stack_Addr return Address is
begin
return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
end Get_Sec_Stack_Addr;
procedure Set_Jmpbuf_Address (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
end Set_Jmpbuf_Address;
procedure Set_Machine_State_Addr (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Machine_State_Addr := Addr;
end Set_Machine_State_Addr;
procedure Set_Sec_Stack_Addr (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
end Set_Sec_Stack_Addr;
------------------
-- Task_Wrapper --
------------------
@ -262,15 +211,6 @@ package body System.Tasking.Restricted.Stages is
end;
end Task_Wrapper;
-------------------
-- Timed_Delay_T --
-------------------
procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
begin
STPO.Timed_Delay (STPO.Self, Time, Mode);
end Timed_Delay_T;
-----------------------
-- Restricted GNARLI --
-----------------------
@ -566,27 +506,14 @@ package body System.Tasking.Restricted.Stages is
-- Notify that the tasking run time has been elaborated so that
-- the tasking version of the soft links can be used.
SSL.Lock_Task := Task_Lock'Access;
SSL.Unlock_Task := Task_Unlock'Access;
SSL.Lock_Task := Task_Lock'Access;
SSL.Unlock_Task := Task_Unlock'Access;
SSL.Adafinal := Finalize_Global_Tasks'Access;
SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
SSL.Get_Current_Excep := Get_Current_Excep'Access;
SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
-- Initialize the tasking soft links (if not done yet) that are common
-- to the full and the restricted run times.
SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
-- No need to create a new Secondary Stack, since we will use the
-- default one created in s-secsta.adb
Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
SSL.Timed_Delay := Timed_Delay_T'Access;
SSL.Adafinal := Finalize_Global_Tasks'Access;
SSL.Tasking.Init_Tasking_Soft_Links;
end Init_RTS;
begin

102
gcc/ada/s-tasini.adb
View File

@ -60,6 +60,9 @@ with System.Soft_Links;
-- used for the non-tasking routines (*_NT) that refer to global data.
-- They are needed here before the tasking run time has been elaborated.
with System.Soft_Links.Tasking;
-- Used for Init_Tasking_Soft_Links
with System.Tasking.Debug;
-- used for Trace
@ -87,9 +90,9 @@ package body System.Tasking.Initialization is
(Ada, Current_Target_Exception, "__gnat_current_target_exception");
-- Import this subprogram from the private part of Ada.Exceptions.
-----------------------------------------------------------------
-- Tasking versions of services needed by non-tasking programs --
-----------------------------------------------------------------
----------------------------------------------------------------------
-- Tasking versions of some services needed by non-tasking programs --
----------------------------------------------------------------------
procedure Task_Lock;
-- Locks out other tasks. Preceding a section of code by Task_Lock and
@ -104,14 +107,6 @@ package body System.Tasking.Initialization is
-- all nested locks must be released before other tasks competing for the
-- tasking lock are released.
function Get_Jmpbuf_Address return Address;
procedure Set_Jmpbuf_Address (Addr : Address);
-- Get/Set Jmpbuf_Address for current task
function Get_Sec_Stack_Addr return Address;
procedure Set_Sec_Stack_Addr (Addr : Address);
-- Get/Set location of current task's secondary stack
function Get_Exc_Stack_Addr return Address;
-- Get the exception stack for the current task
@ -119,16 +114,6 @@ package body System.Tasking.Initialization is
-- Self_ID is the Task_Id of the task that gets the exception stack.
-- For Self_ID = Null_Address, the current task gets the exception stack.
function Get_Machine_State_Addr return Address;
procedure Set_Machine_State_Addr (Addr : Address);
-- Get/Set the address for storing the current task's machine state
function Get_Current_Excep return SSL.EOA;
-- Task-safe version of SSL.Get_Current_Excep
procedure Timed_Delay_T (Time : Duration; Mode : Integer);
-- Task-safe version of SSL.Timed_Delay
function Get_Stack_Info return Stack_Checking.Stack_Access;
-- Get access to the current task's Stack_Info
@ -404,30 +389,21 @@ package body System.Tasking.Initialization is
SSL.Abort_Undefer := Undefer_Abortion'Access;
end if;
SSL.Update_Exception := Update_Exception'Access;
SSL.Lock_Task := Task_Lock'Access;
SSL.Unlock_Task := Task_Unlock'Access;
SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
SSL.Get_Exc_Stack_Addr := Get_Exc_Stack_Addr'Access;
SSL.Set_Exc_Stack_Addr := Set_Exc_Stack_Addr'Access;
SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
SSL.Get_Current_Excep := Get_Current_Excep'Access;
SSL.Timed_Delay := Timed_Delay_T'Access;
SSL.Check_Abort_Status := Check_Abort_Status'Access;
SSL.Get_Stack_Info := Get_Stack_Info'Access;
SSL.Task_Name := Task_Name'Access;
SSL.Update_Exception := Update_Exception'Access;
SSL.Lock_Task := Task_Lock'Access;
SSL.Unlock_Task := Task_Unlock'Access;
SSL.Get_Exc_Stack_Addr := Get_Exc_Stack_Addr'Access;
SSL.Set_Exc_Stack_Addr := Set_Exc_Stack_Addr'Access;
SSL.Check_Abort_Status := Check_Abort_Status'Access;
SSL.Get_Stack_Info := Get_Stack_Info'Access;
SSL.Task_Name := Task_Name'Access;
-- No need to create a new Secondary Stack, since we will use the
-- default one created in s-secsta.adb
SSL.Set_Exc_Stack_Addr (Null_Address, SSL.Get_Exc_Stack_Addr_NT);
SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
SSL.Set_Exc_Stack_Addr (Null_Address, SSL.Get_Exc_Stack_Addr_NT);
SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
-- Initialize the tasking soft links (if not done yet) that are common
-- to the full and the restricted run times.
SSL.Tasking.Init_Tasking_Soft_Links;
-- Install tasking locks in the GCC runtime.
@ -920,31 +896,11 @@ package body System.Tasking.Initialization is
-- Soft-Link Bodies --
----------------------
function Get_Current_Excep return SSL.EOA is
begin
return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
end Get_Current_Excep;
function Get_Exc_Stack_Addr return Address is
begin
return STPO.Self.Common.Compiler_Data.Exc_Stack_Addr;
end Get_Exc_Stack_Addr;
function Get_Jmpbuf_Address return Address is
begin
return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
end Get_Jmpbuf_Address;
function Get_Machine_State_Addr return Address is
begin
return STPO.Self.Common.Compiler_Data.Machine_State_Addr;
end Get_Machine_State_Addr;
function Get_Sec_Stack_Addr return Address is
begin
return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
end Get_Sec_Stack_Addr;
function Get_Stack_Info return Stack_Checking.Stack_Access is
begin
return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access;
@ -960,26 +916,6 @@ package body System.Tasking.Initialization is
Me.Common.Compiler_Data.Exc_Stack_Addr := Addr;
end Set_Exc_Stack_Addr;
procedure Set_Jmpbuf_Address (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
end Set_Jmpbuf_Address;
procedure Set_Machine_State_Addr (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Machine_State_Addr := Addr;
end Set_Machine_State_Addr;
procedure Set_Sec_Stack_Addr (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
end Set_Sec_Stack_Addr;
procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
begin
STPO.Timed_Delay (STPO.Self, Time, Mode);
end Timed_Delay_T;
-----------------------
-- Soft-Link Dummies --
-----------------------

23
gcc/ada/sem_ch3.adb
View File

@ -6075,11 +6075,22 @@ package body Sem_Ch3 is
Set_Ekind (Def_Id, E_Class_Wide_Subtype);
else
-- Incomplete type. Attach subtype to list of dependents, to be
-- completed with full view of parent type.
-- Incomplete type. attach subtype to list of dependents, to be
-- completed with full view of parent type, unless is it the
-- designated subtype of a record component within an init_proc.
-- This last case arises for a component of an access type whose
-- designated type is incomplete (e.g. a Taft Amendment type).
-- The designated subtype is within an inner scope, and needs no
-- elaboration, because only the access type is needed in the
-- initialization procedure.
Set_Ekind (Def_Id, Ekind (T));
Append_Elmt (Def_Id, Private_Dependents (T));
if For_Access and then Within_Init_Proc then
null;
else
Append_Elmt (Def_Id, Private_Dependents (T));
end if;
end if;
Set_Etype (Def_Id, T);
@ -6831,6 +6842,12 @@ package body Sem_Ch3 is
if Has_Discriminants (Full_Base) then
Set_Discriminant_Constraint
(Full, Discriminant_Constraint (Full_Base));
-- The partial view may have been indefinite, the full view
-- might not be.
Set_Has_Unknown_Discriminants
(Full, Has_Unknown_Discriminants (Full_Base));
end if;
end if;

318
gcc/ada/sem_ch4.adb
View File

@ -28,6 +28,7 @@ with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
@ -233,6 +234,9 @@ package body Sem_Ch4 is
-- to a subprogram, and the call F (X) interpreted as F.all (X). In
-- this case the call may be overloaded with both interpretations.
function Try_Object_Operation (N : Node_Id) return Boolean;
-- Ada 2005 (AI-252): Give support to the object operation notation
------------------------
-- Ambiguous_Operands --
------------------------
@ -2677,6 +2681,15 @@ package body Sem_Ch4 is
Next_Entity (Comp);
end loop;
-- Ada 2005 (AI-252)
if Ada_Version >= Ada_05
and then Is_Tagged_Type (Prefix_Type)
and then Try_Object_Operation (N)
then
return;
end if;
elsif Is_Private_Type (Prefix_Type) then
-- Allow access only to discriminants of the type. If the
@ -4635,4 +4648,309 @@ package body Sem_Ch4 is
end Try_Indexed_Call;
--------------------------
-- Try_Object_Operation --
--------------------------
function Try_Object_Operation (N : Node_Id) return Boolean is
Obj : constant Node_Id := Prefix (N);
Obj_Type : Entity_Id;
Actual : Node_Id;
Last_Node : Node_Id;
-- Last_Node is used to free all the nodes generated while trying the
-- alternatives. NOTE: This must be removed because it is considered
-- too low level
use Atree_Private_Part;
function Try_Replacement
(New_Prefix : Entity_Id;
New_Subprg : Node_Id;
New_Formal : Node_Id;
Nam_Ent : Entity_Id) return Boolean;
-- Replace the node with the Object.Operation notation by the
-- equivalent node with the Package.Operation (Object, ...) notation
--
-- Nam_Ent is the entity that provides the formals against which
-- the actuals are checked. If the actuals are compatible with
-- Ent_Nam, this function returns true.
function Try_Primitive_Operations
(New_Prefix : Entity_Id;
New_Subprg : Node_Id;
Obj : Node_Id;
Obj_Type : Entity_Id) return Boolean;
-- Traverse the list of primitive subprograms to look for the
-- subprogram.
function Try_Class_Wide_Operation
(New_Subprg : Node_Id;
Obj : Node_Id;
Obj_Type : Entity_Id) return Boolean;
-- Traverse all the ancestor types to look for a class-wide
-- subprogram
------------------------------
-- Try_Primitive_Operations --
------------------------------
function Try_Primitive_Operations
(New_Prefix : Entity_Id;
New_Subprg : Node_Id;
Obj : Node_Id;
Obj_Type : Entity_Id) return Boolean
is
Deref : Node_Id;
Elmt : Elmt_Id;
Prim_Op : Entity_Id;
begin
-- Look for the subprogram in the list of primitive operations.
-- This case is simple because all the primitive operations are
-- implicitly inherited and thus we have a candidate as soon as
-- we find a primitive subprogram with the same name. The latter
-- analysis after the node replacement will resolve it.
Elmt := First_Elmt (Primitive_Operations (Obj_Type));
while Present (Elmt) loop
Prim_Op := Node (Elmt);
if Chars (Prim_Op) = Chars (New_Subprg) then
if Try_Replacement (New_Prefix => New_Prefix,
New_Subprg => New_Subprg,
New_Formal => Obj,
Nam_Ent => Prim_Op)
then
return True;
-- Try the implicit dereference in case of access type
elsif Is_Access_Type (Etype (Obj)) then
Deref := Make_Explicit_Dereference (Sloc (Obj), Obj);
Set_Etype (Deref, Obj_Type);
if Try_Replacement (New_Prefix => New_Prefix,
New_Subprg => New_Subprg,
New_Formal => Deref,
Nam_Ent => Prim_Op)
then
return True;
end if;
end if;
end if;
Next_Elmt (Elmt);
end loop;
return False;
end Try_Primitive_Operations;
------------------------------
-- Try_Class_Wide_Operation --
------------------------------
function Try_Class_Wide_Operation
(New_Subprg : Node_Id;
Obj : Node_Id;
Obj_Type : Entity_Id) return Boolean
is
Deref : Node_Id;
Hom : Entity_Id;
Typ : Entity_Id;
begin
Typ := Obj_Type;
loop
-- For each parent subtype we traverse all the homonym chain
-- looking for a candidate class-wide subprogram
Hom := Current_Entity (New_Subprg);
while Present (Hom) loop
if (Ekind (Hom) = E_Procedure
or else Ekind (Hom) = E_Function)
and then Present (First_Entity (Hom))
and then Etype (First_Entity (Hom)) = Class_Wide_Type (Typ)
then
if Try_Replacement
(New_Prefix => Scope (Hom),
New_Subprg => Make_Identifier (Sloc (N), Chars (Hom)),
New_Formal => Obj,
Nam_Ent => Hom)
then
return True;
-- Try the implicit dereference in case of access type
elsif Is_Access_Type (Etype (Obj)) then
Deref := Make_Explicit_Dereference (Sloc (Obj), Obj);
Set_Etype (Deref, Obj_Type);
if Try_Replacement
(New_Prefix => Scope (Hom),
New_Subprg => Make_Identifier (Sloc (N), Chars (Hom)),
New_Formal => Deref,
Nam_Ent => Hom)
then
return True;
end if;
end if;
end if;
Hom := Homonym (Hom);
end loop;
exit when Etype (Typ) = Typ;
Typ := Etype (Typ); -- Climb to the ancestor type
end loop;
return False;
end Try_Class_Wide_Operation;
---------------------
-- Try_Replacement --
---------------------
function Try_Replacement
(New_Prefix : Entity_Id;
New_Subprg : Node_Id;
New_Formal : Node_Id;
Nam_Ent : Entity_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
Call_Node : Node_Id;
New_Name : Node_Id;
New_Actuals : List_Id;
Node_To_Replace : Node_Id;
Success : Boolean;
begin
-- Step 1. Build the replacement node: a subprogram call node
-- with the object as its first actual parameter
New_Name := Make_Selected_Component (Loc,
Prefix => New_Reference_To (New_Prefix, Loc),
Selector_Name => New_Copy_Tree (New_Subprg));
New_Actuals := New_List (New_Copy_Tree (New_Formal));
if (Nkind (Parent (N)) = N_Procedure_Call_Statement
or else Nkind (Parent (N)) = N_Function_Call)
and then N /= First (Parameter_Associations (Parent (N)))
-- Protect against recursive call; It occurs in "..:= F (O.P)"
then
Node_To_Replace := Parent (N);
Append_List_To
(New_Actuals,
New_Copy_List (Parameter_Associations (Node_To_Replace)));
if Nkind (Node_To_Replace) = N_Procedure_Call_Statement then
Call_Node :=
Make_Procedure_Call_Statement (Loc, New_Name, New_Actuals);
else pragma Assert (Nkind (Node_To_Replace) = N_Function_Call);
Call_Node :=
Make_Function_Call (Loc, New_Name, New_Actuals);
end if;
-- Case of a function without parameters
else
Node_To_Replace := N;
Call_Node :=
Make_Function_Call (Loc, New_Name, New_Actuals);
end if;
-- Step 2. Analyze the candidate replacement node. If it was
-- successfully analyzed then replace the original node and
-- carry out the full analysis to verify that there is no
-- conflict with overloaded subprograms.
-- To properly analyze the candidate we must initialize the type
-- of the result node of the call to the error type; it will be
-- reset if the type is successfully resolved.
Set_Etype (Call_Node, Any_Type);
Analyze_One_Call
(N => Call_Node,
Nam => Nam_Ent,
Report => False, -- do not post errors
Success => Success);
if Success then
-- Previous analysis transformed the node with the name
-- and we have to reset it to properly re-analyze it.
New_Name := Make_Selected_Component (Loc,
Prefix => New_Reference_To (New_Prefix, Loc),
Selector_Name => New_Copy_Tree (New_Subprg));
Set_Name (Call_Node, New_Name);
Set_Analyzed (Call_Node, False);
Set_Parent (Call_Node, Parent (Node_To_Replace));
Replace (Node_To_Replace, Call_Node);
Analyze (Node_To_Replace);
return True;
-- Free all the nodes used for this test and return
else
Nodes.Set_Last (Last_Node);
return False;
end if;
end Try_Replacement;
-- Start of processing for Try_Object_Operation
begin
-- Find the type of the object
Obj_Type := Etype (Obj);
if Is_Access_Type (Obj_Type) then
Obj_Type := Designated_Type (Obj_Type);
end if;
if Ekind (Obj_Type) = E_Private_Subtype then
Obj_Type := Base_Type (Obj_Type);
end if;
if Is_Class_Wide_Type (Obj_Type) then
Obj_Type := Etype (Class_Wide_Type (Obj_Type));
end if;
-- Analyze the actuals
if (Nkind (Parent (N)) = N_Procedure_Call_Statement
or else Nkind (Parent (N)) = N_Function_Call)
and then N /= First (Parameter_Associations (Parent (N)))
-- Protects against recursive call in case of "..:= F (O.Proc)"
then
Actual := First (Parameter_Associations (Parent (N)));
while Present (Actual) loop
Analyze (Actual);
Check_Parameterless_Call (Actual);
Next_Actual (Actual);
end loop;
end if;
Last_Node := Last_Node_Id;
return Try_Primitive_Operations
(New_Prefix => Scope (Obj_Type),
New_Subprg => Selector_Name (N),
Obj => Obj,
Obj_Type => Obj_Type)
or else
Try_Class_Wide_Operation
(New_Subprg => Selector_Name (N),
Obj => Obj,
Obj_Type => Obj_Type);
end Try_Object_Operation;
end Sem_Ch4;

6
gcc/ada/sem_ch8.adb
View File

@ -3592,7 +3592,11 @@ package body Sem_Ch8 is
begin
while Present (H) loop
if Scope (H) = Scope (Id) then
if Scope (H) = Scope (Id)
and then
(not Is_Hidden (H)
or else Is_Immediately_Visible (H))
then
Collect_Interps (N);
exit;
end if;

4099
gcc/ada/trans.c
View File

File diff suppressed because it is too large Load Diff