diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2004-07-20 12:26:51 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2004-07-20 12:26:51 +0200 |
| commit | 35ae2ed81410448471c46f7757e6bc879d4de250 (patch) | |
| tree | 238119d8dcbfc65df92cc128baf647ad882d0617 | |
| parent | a6c0a76c5f9eb216b5f08ffc4624a6d039ca3977 (diff) | |
| download | gcc-35ae2ed81410448471c46f7757e6bc879d4de250.zip gcc-35ae2ed81410448471c46f7757e6bc879d4de250.tar.gz gcc-35ae2ed81410448471c46f7757e6bc879d4de250.tar.bz2 | |
[multiple changes]
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
| -rw-r--r-- | gcc/ada/ChangeLog | 96 | ||||
| -rw-r--r-- | gcc/ada/Makefile.rtl | 1 | ||||
| -rw-r--r-- | gcc/ada/a-elchha.adb | 100 | ||||
| -rw-r--r-- | gcc/ada/a-except.adb | 110 | ||||
| -rw-r--r-- | gcc/ada/a-exexda.adb | 577 | ||||
| -rw-r--r-- | gcc/ada/a-exextr.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/clean.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/makegpr.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/mlib-utl.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/osint.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/s-solita.adb | 164 | ||||
| -rw-r--r-- | gcc/ada/s-solita.ads | 46 | ||||
| -rw-r--r-- | gcc/ada/s-taprob.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/s-tarest.adb | 91 | ||||
| -rw-r--r-- | gcc/ada/s-tasini.adb | 106 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 318 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/trans.c | 4099 |
20 files changed, 3254 insertions, 2568 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5af5ee3..28445a8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 9e45d01..10031f8 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -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) \ diff --git a/gcc/ada/a-elchha.adb b/gcc/ada/a-elchha.adb index 6e2da23..e7eb65c 100644 --- a/gcc/ada/a-elchha.adb +++ b/gcc/ada/a-elchha.adb @@ -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. - - 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. 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. - -- 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; diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 6a0885f..2da9de2 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -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 -- --------- diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index 214d534..63085f6 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -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. + + -- 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: - 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. + -- + -- 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_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 : 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_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,116 +354,202 @@ 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 -- + ------------------------------------------- - ------------------------------- - -- Basic_Exception_Traceback -- - ------------------------------- + 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; - function Basic_Exception_Traceback - (X : Exception_Occurrence) return String + ------------------------------------------- + -- 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 - 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. + begin + if X.Num_Tracebacks <= 0 then + return; + end if; + + Append_Info_String (BETB_Header, Info, Ptr); + Append_Info_NL (Info, Ptr); - 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. + 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; - Ptr : Natural := 0; + 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 - if X.Num_Tracebacks > 0 then - Append_Info_String ("Call stack traceback locations:", Info, Ptr); - Append_Info_NL (Info, Ptr); + return BETB_Header'Length + 1 + X.Num_Tracebacks * 19 + 1; + -- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ") + end Basic_Exception_Tback_Maxlength; - 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_Exception_Information -- + --------------------------------------- - Append_Info_NL (Info, Ptr); - end if; + 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; - return Info (1 .. Ptr); - end Basic_Exception_Traceback; + ------------------------------ + -- Exception_Info_Maxlength -- + ------------------------------ - --------------------------- - -- Exception_Information -- - --------------------------- + 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; - -- The format of the string is: + ----------------------------------- + -- Append_Info_Exception_Message -- + ----------------------------------- - -- Exception_Name: nnnnn - -- Message: mmmmm - -- PID: ppp - -- Call stack traceback locations: - -- 0xhhhh 0xhhhh 0xhhhh ... 0xhhh + 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; - -- where + 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; - -- nnnn is the fully qualified name of the exception in all upper - -- case letters. This line is always present. + -------------------------------- + -- Append_Info_Exception_Name -- + -------------------------------- - -- mmmm is the message (this line present only if message is non-null) + 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; - -- 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. + 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; - -- 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. + 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; - -- 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#). + --------------------------- + -- Exception_Name_Length -- + --------------------------- - -- 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. + 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. - -- 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. + return Id.Name_Length - 1; + end Exception_Name_Length; - function Exception_Information (X : Exception_Occurrence) return String is + function Exception_Name_Length + (X : Exception_Occurrence) return Natural is + begin + return Exception_Name_Length (X.Id); + end Exception_Name_Length; - -- 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. + ------------------------------ + -- Exception_Message_Length -- + ------------------------------ - Basic_Info : constant String := Basic_Exception_Information (X); - Tback_Info : constant String := Basic_Exception_Traceback (X); + function Exception_Message_Length + (X : Exception_Occurrence) return Natural is + begin + return X.Msg_Length; + end Exception_Message_Length; - Basic_Len : constant Natural := Basic_Info'Length; - Tback_Len : constant Natural := Tback_Info'Length; + ------------------------------- + -- Basic_Exception_Traceback -- + ------------------------------- - Info : String (1 .. Basic_Len + Tback_Len); - Ptr : Natural := 0; + function Basic_Exception_Traceback + (X : Exception_Occurrence) return String + is + Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X)); + Ptr : Natural := Info'First - 1; begin - Append_Info_String (Basic_Info, Info, Ptr); - Append_Info_String (Tback_Info, Info, Ptr); + Append_Info_Basic_Exception_Traceback (X, Info, Ptr); + return Info (Info'First .. Ptr); + end Basic_Exception_Traceback; - return Info; - end Exception_Information; + --------------------------- + -- Exception_Information -- + --------------------------- + + function Exception_Information + (X : Exception_Occurrence) return String + is + Info : String (1 .. Exception_Info_Maxlength (X)); + Ptr : Natural := Info'First - 1; + begin + 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; diff --git a/gcc/ada/a-exextr.adb b/gcc/ada/a-exextr.adb index 938f04b..835c2cb 100644 --- a/gcc/ada/a-exextr.adb +++ b/gcc/ada/a-exextr.adb @@ -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 -- diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 0f06fd3..3f82937 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -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 diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 2438d3f..c017d6d 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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 diff --git a/gcc/ada/makegpr.adb b/gcc/ada/makegpr.adb index 5594bba..7f39b00 100644 --- a/gcc/ada/makegpr.adb +++ b/gcc/ada/makegpr.adb @@ -2938,7 +2938,7 @@ package body Makegpr is procedure Gprmake is begin - Initialize; + Makegpr.Initialize; if Verbose_Mode then Write_Eol; diff --git a/gcc/ada/mlib-utl.adb b/gcc/ada/mlib-utl.adb index 152d272..328d5a5 100644 --- a/gcc/ada/mlib-utl.adb +++ b/gcc/ada/mlib-utl.adb @@ -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; diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 48da307..0b6a238 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -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; diff --git a/gcc/ada/s-solita.adb b/gcc/ada/s-solita.adb new file mode 100644 index 0000000..4144acc --- /dev/null +++ b/gcc/ada/s-solita.adb @@ -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; diff --git a/gcc/ada/s-solita.ads b/gcc/ada/s-solita.ads new file mode 100644 index 0000000..1b9dae4 --- /dev/null +++ b/gcc/ada/s-solita.ads @@ -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; diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb index a5f6278..4a5b6af 100644 --- a/gcc/ada/s-taprob.adb +++ b/gcc/ada/s-taprob.adb @@ -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; diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index be0c661..17c3ba6 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -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.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); - - 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 + SSL.Lock_Task := Task_Lock'Access; + SSL.Unlock_Task := Task_Unlock'Access; + SSL.Adafinal := Finalize_Global_Tasks'Access; - Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT); + -- Initialize the tasking soft links (if not done yet) that are common + -- to the full and the restricted run times. - SSL.Timed_Delay := Timed_Delay_T'Access; - SSL.Adafinal := Finalize_Global_Tasks'Access; + SSL.Tasking.Init_Tasking_Soft_Links; end Init_RTS; begin diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index d05654a..871b2d0 100644 --- a/gcc/ada/s-tasini.adb +++ b/gcc/ada/s-tasini.adb @@ -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; - - -- 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_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); + 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; + + SSL.Set_Exc_Stack_Addr (Null_Address, SSL.Get_Exc_Stack_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 -- ----------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 11d4c01..73c6b33 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index f674ba6..3831b67 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 55806aa..eeff994 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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; diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index 903b314..6b7a174 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -297,6 +297,2036 @@ gnat_init_stmt_group () REAL_ARITHMETIC (dconstmp5, RDIV_EXPR, dconstm1, dconst2); } +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier, + to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to + where we should place the result type. */ + +static tree +Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) +{ + tree gnu_result_type; + tree gnu_result; + Node_Id gnat_temp, gnat_temp_type; + + /* If the Etype of this node does not equal the Etype of the Entity, + something is wrong with the entity map, probably in generic + instantiation. However, this does not apply to types. Since we sometime + have strange Ekind's, just do this test for objects. Also, if the Etype of + the Entity is private, the Etype of the N_Identifier is allowed to be the + full type and also we consider a packed array type to be the same as the + original type. Similarly, a class-wide type is equivalent to a subtype of + itself. Finally, if the types are Itypes, one may be a copy of the other, + which is also legal. */ + gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier + ? gnat_node : Entity (gnat_node)); + gnat_temp_type = Etype (gnat_temp); + + if (Etype (gnat_node) != gnat_temp_type + && ! (Is_Packed (gnat_temp_type) + && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type)) + && ! (Is_Class_Wide_Type (Etype (gnat_node))) + && ! (IN (Ekind (gnat_temp_type), Private_Kind) + && Present (Full_View (gnat_temp_type)) + && ((Etype (gnat_node) == Full_View (gnat_temp_type)) + || (Is_Packed (Full_View (gnat_temp_type)) + && (Etype (gnat_node) + == Packed_Array_Type (Full_View (gnat_temp_type)))))) + && (!Is_Itype (Etype (gnat_node)) || !Is_Itype (gnat_temp_type)) + && (Ekind (gnat_temp) == E_Variable + || Ekind (gnat_temp) == E_Component + || Ekind (gnat_temp) == E_Constant + || Ekind (gnat_temp) == E_Loop_Parameter + || IN (Ekind (gnat_temp), Formal_Kind))) + gigi_abort (304); + + /* If this is a reference to a deferred constant whose partial view is an + unconstrained private type, the proper type is on the full view of the + constant, not on the full view of the type, which may be unconstrained. + + This may be a reference to a type, for example in the prefix of the + attribute Position, generated for dispatching code (see Make_DT in + exp_disp,adb). In that case we need the type itself, not is parent, + in particular if it is a derived type */ + if (Is_Private_Type (gnat_temp_type) + && Has_Unknown_Discriminants (gnat_temp_type) + && Present (Full_View (gnat_temp)) + && ! Is_Type (gnat_temp)) + { + gnat_temp = Full_View (gnat_temp); + gnat_temp_type = Etype (gnat_temp); + gnu_result_type = get_unpadded_type (gnat_temp_type); + } + else + { + /* Expand the type of this identitier first, in case it is an enumeral + literal, which only get made when the type is expanded. There is no + order-of-elaboration issue here. We want to use the Actual_Subtype if + it has already been elaborated, otherwise the Etype. Avoid using + Actual_Subtype for packed arrays to simplify things. */ + if ((Ekind (gnat_temp) == E_Constant + || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp)) + && ! (Is_Array_Type (Etype (gnat_temp)) + && Present (Packed_Array_Type (Etype (gnat_temp)))) + && Present (Actual_Subtype (gnat_temp)) + && present_gnu_tree (Actual_Subtype (gnat_temp))) + gnat_temp_type = Actual_Subtype (gnat_temp); + else + gnat_temp_type = Etype (gnat_node); + + gnu_result_type = get_unpadded_type (gnat_temp_type); + } + + gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0); + + /* If we are in an exception handler, force this variable into memory to + ensure optimization does not remove stores that appear redundant but are + actually needed in case an exception occurs. + + ??? Note that we need not do this if the variable is declared within the + handler, only if it is referenced in the handler and declared in an + enclosing block, but we have no way of testing that right now. + + ??? Also, for now all we can do is make it volatile. But we only + do this for SJLJ. */ + if (TREE_VALUE (gnu_except_ptr_stack) != 0 + && TREE_CODE (gnu_result) == VAR_DECL) + TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1; + + /* Some objects (such as parameters passed by reference, globals of + variable size, and renamed objects) actually represent the address + of the object. In that case, we must do the dereference. Likewise, + deal with parameters to foreign convention subprograms. Call fold + here since GNU_RESULT may be a CONST_DECL. */ + if (DECL_P (gnu_result) + && (DECL_BY_REF_P (gnu_result) + || (TREE_CODE (gnu_result) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (gnu_result)))) + { + int ro = DECL_POINTS_TO_READONLY_P (gnu_result); + tree initial; + + if (TREE_CODE (gnu_result) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (gnu_result)) + gnu_result + = build_unary_op (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (gnu_result_type), + gnu_result)); + + /* If the object is constant, we try to do the dereference directly + through the DECL_INITIAL. This is actually required in order to get + correct aliasing information for renamed objects that are components + of non-aliased aggregates, because the type of the renamed object and + that of the aggregate don't alias. + + Note that we expect the initial value to have been stabilized. + If it contains e.g. a variable reference, we certainly don't want + to re-evaluate the variable each time the renaming is used. + + Stabilization is currently not performed at the global level but + create_var_decl avoids setting DECL_INITIAL if the value is not + constant then, and we get to the pointer dereference below. + + ??? Couldn't the aliasing issue show up again in this case ? + There is no obvious reason why not. */ + else if (TREE_READONLY (gnu_result) + && DECL_INITIAL (gnu_result) + /* Strip possible conversion to reference type. */ + && ((initial = TREE_CODE (DECL_INITIAL (gnu_result)) + == NOP_EXPR + ? TREE_OPERAND (DECL_INITIAL (gnu_result), 0) + : DECL_INITIAL (gnu_result), 1)) + && TREE_CODE (initial) == ADDR_EXPR + && (TREE_CODE (TREE_OPERAND (initial, 0)) == ARRAY_REF + || (TREE_CODE (TREE_OPERAND (initial, 0)) + == COMPONENT_REF))) + gnu_result = TREE_OPERAND (initial, 0); + else + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, + fold (gnu_result)); + + TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro; + } + + /* The GNAT tree has the type of a function as the type of its result. Also + use the type of the result if the Etype is a subtype which is nominally + unconstrained. But remove any padding from the resulting type. */ + if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE + || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)) + { + gnu_result_type = TREE_TYPE (gnu_result); + if (TREE_CODE (gnu_result_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_result_type)) + gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type)); + } + + /* We always want to return the underlying INTEGER_CST for an enumeration + literal to avoid the need to call fold in lots of places. But don't do + this is the parent will be taking the address of this object. */ + if (TREE_CODE (gnu_result) == CONST_DECL) + { + gnat_temp = Parent (gnat_node); + if (DECL_CONST_CORRESPONDING_VAR (gnu_result) == 0 + || (Nkind (gnat_temp) != N_Reference + && ! (Nkind (gnat_temp) == N_Attribute_Reference + && ((Get_Attribute_Id (Attribute_Name (gnat_temp)) + == Attr_Address) + || (Get_Attribute_Id (Attribute_Name (gnat_temp)) + == Attr_Access) + || (Get_Attribute_Id (Attribute_Name (gnat_temp)) + == Attr_Unchecked_Access) + || (Get_Attribute_Id (Attribute_Name (gnat_temp)) + == Attr_Unrestricted_Access))))) + gnu_result = DECL_INITIAL (gnu_result); + } + + *gnu_result_type_p = gnu_result_type; + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. We don't + return anything. */ + +static void +Pragma_to_gnu (Node_Id gnat_node) +{ + Node_Id gnat_temp; + + /* Check for (and ignore) unrecognized pragma and do nothing if we are just + annotating types. */ + if (type_annotate_only + || ! Is_Pragma_Name (Chars (gnat_node))) + return; + + switch (Get_Pragma_Id (Chars (gnat_node))) + { + case Pragma_Inspection_Point: + /* Do nothing at top level: all such variables are already viewable. */ + if (global_bindings_p ()) + break; + + for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); + Present (gnat_temp); + gnat_temp = Next (gnat_temp)) + { + tree gnu_expr = gnat_to_gnu (Expression (gnat_temp)); + + if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF) + gnu_expr = TREE_OPERAND (gnu_expr, 0); + + gnu_expr = build1 (USE_STMT, void_type_node, gnu_expr); + add_stmt (gnu_expr); + } + break; + + case Pragma_Optimize: + switch (Chars (Expression + (First (Pragma_Argument_Associations (gnat_node))))) + { + case Name_Time: case Name_Space: + if (optimize == 0) + post_error ("insufficient -O value?", gnat_node); + break; + + case Name_Off: + if (optimize != 0) + post_error ("must specify -O0?", gnat_node); + break; + + default: + gigi_abort (331); + break; + } + break; + + case Pragma_Reviewable: + if (write_symbols == NO_DEBUG) + post_error ("must specify -g?", gnat_node); + break; + } +} +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute, + to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to + where we should place the result type. ATTRIBUTE is the attribute ID. */ + +static tree +Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) +{ + tree gnu_result = error_mark_node; + tree gnu_result_type; + tree gnu_expr; + bool prefix_unused = false; + tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); + tree gnu_type = TREE_TYPE (gnu_prefix); + + /* If the input is a NULL_EXPR, make a new one. */ + if (TREE_CODE (gnu_prefix) == NULL_EXPR) + { + *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); + return build1 (NULL_EXPR, *gnu_result_type_p, + TREE_OPERAND (gnu_prefix, 0)); + } + + switch (attribute) + { + case Attr_Pos: + case Attr_Val: + /* These are just conversions until since representation clauses for + enumerations are handled in the front end. */ + { + int check_p = Do_Range_Check (First (Expressions (gnat_node))); + + gnu_result = gnat_to_gnu (First (Expressions (gnat_node))); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = convert_with_check (Etype (gnat_node), gnu_result, + check_p, check_p, 1); + } + break; + + case Attr_Pred: + case Attr_Succ: + /* These just add or subject the constant 1. Representation clauses for + enumerations are handled in the front-end. */ + gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (Do_Range_Check (First (Expressions (gnat_node)))) + { + gnu_expr = protect_multiple_eval (gnu_expr); + gnu_expr + = emit_check + (build_binary_op (EQ_EXPR, integer_type_node, + gnu_expr, + attribute == Attr_Pred + ? TYPE_MIN_VALUE (gnu_result_type) + : TYPE_MAX_VALUE (gnu_result_type)), + gnu_expr, CE_Range_Check_Failed); + } + + gnu_result + = build_binary_op (attribute == Attr_Pred + ? MINUS_EXPR : PLUS_EXPR, + gnu_result_type, gnu_expr, + convert (gnu_result_type, integer_one_node)); + break; + + case Attr_Address: + case Attr_Unrestricted_Access: + /* Conversions don't change something's address but can cause us to miss + the COMPONENT_REF case below, so strip them off. */ + gnu_prefix = remove_conversions (gnu_prefix, + ! Must_Be_Byte_Aligned (gnat_node)); + + /* If we are taking 'Address of an unconstrained object, this is the + pointer to the underlying array. */ + gnu_prefix = maybe_unconstrained_array (gnu_prefix); + + /* ... fall through ... */ + + case Attr_Access: + case Attr_Unchecked_Access: + case Attr_Code_Address: + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result + = build_unary_op (((attribute == Attr_Address + || attribute == Attr_Unrestricted_Access) + && ! Must_Be_Byte_Aligned (gnat_node)) + ? ATTR_ADDR_EXPR : ADDR_EXPR, + gnu_result_type, gnu_prefix); + + /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we + don't try to build a trampoline. */ + if (attribute == Attr_Code_Address) + { + for (gnu_expr = gnu_result; + TREE_CODE (gnu_expr) == NOP_EXPR + || TREE_CODE (gnu_expr) == CONVERT_EXPR; + gnu_expr = TREE_OPERAND (gnu_expr, 0)) + TREE_CONSTANT (gnu_expr) = 1; + + if (TREE_CODE (gnu_expr) == ADDR_EXPR) + TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1; + } + break; + + case Attr_Pool_Address: + { + tree gnu_obj_type; + tree gnu_ptr = gnu_prefix; + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If this is an unconstrained array, we know the object must have been + allocated with the template in front of the object. So compute the + template address.*/ + if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) + gnu_ptr + = convert (build_pointer_type + (TYPE_OBJECT_RECORD_TYPE + (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), + gnu_ptr); + + gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); + if (TREE_CODE (gnu_obj_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type)) + { + tree gnu_char_ptr_type = build_pointer_type (char_type_node); + tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type)); + tree gnu_byte_offset + = convert (gnu_char_ptr_type, + size_diffop (size_zero_node, gnu_pos)); + + gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr); + gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type, + gnu_ptr, gnu_byte_offset); + } + + gnu_result = convert (gnu_result_type, gnu_ptr); + } + break; + + case Attr_Size: + case Attr_Object_Size: + case Attr_Value_Size: + case Attr_Max_Size_In_Storage_Elements: + gnu_expr = gnu_prefix; + + /* Remove NOPS from gnu_expr and conversions from gnu_prefix. + We only use GNU_EXPR to see if a COMPONENT_REF was involved. */ + while (TREE_CODE (gnu_expr) == NOP_EXPR) + gnu_expr = TREE_OPERAND (gnu_expr, 0) + ; + + gnu_prefix = remove_conversions (gnu_prefix, 1); + prefix_unused = true; + gnu_type = TREE_TYPE (gnu_prefix); + + /* Replace an unconstrained array type with the type of the underlying + array. We can't do this with a call to maybe_unconstrained_array + since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements, + use the record type that will be used to allocate the object and its + template. */ + if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + { + gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type); + if (attribute != Attr_Max_Size_In_Storage_Elements) + gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); + } + + /* If we're looking for the size of a field, return the field size. + Otherwise, if the prefix is an object, or if 'Object_Size or + 'Max_Size_In_Storage_Elements has been specified, the result is the + GCC size of the type. Otherwise, the result is the RM_Size of the + type. */ + if (TREE_CODE (gnu_prefix) == COMPONENT_REF) + gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1)); + else if (TREE_CODE (gnu_prefix) != TYPE_DECL + || attribute == Attr_Object_Size + || attribute == Attr_Max_Size_In_Storage_Elements) + { + /* If this is a padded type, the GCC size isn't relevant to the + programmer. Normally, what we want is the RM_Size, which was set + from the specified size, but if it was not set, we want the size + of the relevant field. Using the MAX of those two produces the + right result in all case. Don't use the size of the field if it's + a self-referential type, since that's never what's wanted. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type) + && TREE_CODE (gnu_expr) == COMPONENT_REF) + { + gnu_result = rm_size (gnu_type); + if (! (CONTAINS_PLACEHOLDER_P + (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))) + gnu_result + = size_binop (MAX_EXPR, gnu_result, + DECL_SIZE (TREE_OPERAND (gnu_expr, 1))); + } + else + gnu_result = TYPE_SIZE (gnu_type); + } + else + gnu_result = rm_size (gnu_type); + + if (gnu_result == 0) + gigi_abort (325); + + /* Deal with a self-referential size by returning the maximum size for a + type and by qualifying the size with the object for 'Size of an + object. */ + if (CONTAINS_PLACEHOLDER_P (gnu_result)) + { + if (TREE_CODE (gnu_prefix) != TYPE_DECL) + gnu_result = substitute_placeholder_in_expr (gnu_result, + gnu_expr); + else + gnu_result = max_size (gnu_result, 1); + } + + /* If the type contains a template, subtract its size. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + gnu_result = size_binop (MINUS_EXPR, gnu_result, + DECL_SIZE (TYPE_FIELDS (gnu_type))); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* Always perform division using unsigned arithmetic as the size cannot + be negative, but may be an overflowed positive value. This provides + correct results for sizes up to 512 MB. + + ??? Size should be calculated in storage elements directly. */ + + if (attribute == Attr_Max_Size_In_Storage_Elements) + gnu_result = convert (sizetype, + fold (build (CEIL_DIV_EXPR, bitsizetype, + gnu_result, bitsize_unit_node))); + break; + + case Attr_Alignment: + if (TREE_CODE (gnu_prefix) == COMPONENT_REF + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) + gnu_prefix = TREE_OPERAND (gnu_prefix, 0); + + gnu_type = TREE_TYPE (gnu_prefix); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + prefix_unused = true; + + if (TREE_CODE (gnu_prefix) == COMPONENT_REF) + gnu_result = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1))); + else + gnu_result = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT); + break; + + case Attr_First: + case Attr_Last: + case Attr_Range_Length: + prefix_unused = true; + + if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE) + { + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (attribute == Attr_First) + gnu_result = TYPE_MIN_VALUE (gnu_type); + else if (attribute == Attr_Last) + gnu_result = TYPE_MAX_VALUE (gnu_type); + else + gnu_result + = build_binary_op + (MAX_EXPR, get_base_type (gnu_result_type), + build_binary_op + (PLUS_EXPR, get_base_type (gnu_result_type), + build_binary_op (MINUS_EXPR, + get_base_type (gnu_result_type), + convert (gnu_result_type, + TYPE_MAX_VALUE (gnu_type)), + convert (gnu_result_type, + TYPE_MIN_VALUE (gnu_type))), + convert (gnu_result_type, integer_one_node)), + convert (gnu_result_type, integer_zero_node)); + + break; + } + + /* ... fall through ... */ + + case Attr_Length: + { + int Dimension = (Present (Expressions (gnat_node)) + ? UI_To_Int (Intval (First (Expressions (gnat_node)))) + : 1); + + /* Make sure any implicit dereference gets done. */ + gnu_prefix = maybe_implicit_deref (gnu_prefix); + gnu_prefix = maybe_unconstrained_array (gnu_prefix); + gnu_type = TREE_TYPE (gnu_prefix); + prefix_unused = true; + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (TYPE_CONVENTION_FORTRAN_P (gnu_type)) + { + int ndim; + tree gnu_type_temp; + + for (ndim = 1, gnu_type_temp = gnu_type; + TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp)); + ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp)) + ; + + Dimension = ndim + 1 - Dimension; + } + + for (; Dimension > 1; Dimension--) + gnu_type = TREE_TYPE (gnu_type); + + if (TREE_CODE (gnu_type) != ARRAY_TYPE) + gigi_abort (309); + + if (attribute == Attr_First) + gnu_result + = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); + else if (attribute == Attr_Last) + gnu_result + = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); + else + /* 'Length or 'Range_Length. */ + { + tree gnu_compute_type + = gnat_signed_or_unsigned_type (0, + get_base_type (gnu_result_type)); + + gnu_result + = build_binary_op + (MAX_EXPR, gnu_compute_type, + build_binary_op + (PLUS_EXPR, gnu_compute_type, + build_binary_op + (MINUS_EXPR, gnu_compute_type, + convert (gnu_compute_type, + TYPE_MAX_VALUE + (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))), + convert (gnu_compute_type, + TYPE_MIN_VALUE + (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))), + convert (gnu_compute_type, integer_one_node)), + convert (gnu_compute_type, integer_zero_node)); + } + + /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are + handling. Note that these attributes could not have been used on + an unconstrained array type. */ + gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, + gnu_prefix); + break; + } + + case Attr_Bit_Position: + case Attr_Position: + case Attr_First_Bit: + case Attr_Last_Bit: + case Attr_Bit: + { + HOST_WIDE_INT bitsize; + HOST_WIDE_INT bitpos; + tree gnu_offset; + tree gnu_field_bitpos; + tree gnu_field_offset; + tree gnu_inner; + enum machine_mode mode; + int unsignedp, volatilep; + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_prefix = remove_conversions (gnu_prefix, 1); + prefix_unused = true; + + /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF, + the result is 0. Don't allow 'Bit on a bare component, though. */ + if (attribute == Attr_Bit + && TREE_CODE (gnu_prefix) != COMPONENT_REF + && TREE_CODE (gnu_prefix) != FIELD_DECL) + { + gnu_result = integer_zero_node; + break; + } + + else if (TREE_CODE (gnu_prefix) != COMPONENT_REF + && ! (attribute == Attr_Bit_Position + && TREE_CODE (gnu_prefix) == FIELD_DECL)) + gigi_abort (310); + + get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset, + &mode, &unsignedp, &volatilep); + + if (TREE_CODE (gnu_prefix) == COMPONENT_REF) + { + gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1)); + gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1)); + + for (gnu_inner = TREE_OPERAND (gnu_prefix, 0); + TREE_CODE (gnu_inner) == COMPONENT_REF + && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1)); + gnu_inner = TREE_OPERAND (gnu_inner, 0)) + { + gnu_field_bitpos + = size_binop (PLUS_EXPR, gnu_field_bitpos, + bit_position (TREE_OPERAND (gnu_inner, 1))); + gnu_field_offset + = size_binop (PLUS_EXPR, gnu_field_offset, + byte_position (TREE_OPERAND (gnu_inner, 1))); + } + } + else if (TREE_CODE (gnu_prefix) == FIELD_DECL) + { + gnu_field_bitpos = bit_position (gnu_prefix); + gnu_field_offset = byte_position (gnu_prefix); + } + else + { + gnu_field_bitpos = bitsize_zero_node; + gnu_field_offset = size_zero_node; + } + + switch (attribute) + { + case Attr_Position: + gnu_result = gnu_field_offset; + break; + + case Attr_First_Bit: + case Attr_Bit: + gnu_result = size_int (bitpos % BITS_PER_UNIT); + break; + + case Attr_Last_Bit: + gnu_result = bitsize_int (bitpos % BITS_PER_UNIT); + gnu_result = size_binop (PLUS_EXPR, gnu_result, + TYPE_SIZE (TREE_TYPE (gnu_prefix))); + gnu_result = size_binop (MINUS_EXPR, gnu_result, + bitsize_one_node); + break; + + case Attr_Bit_Position: + gnu_result = gnu_field_bitpos; + break; + } + + /* If this has a PLACEHOLDER_EXPR, qualify it by the object + we are handling. */ + gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); + break; + } + + case Attr_Min: + case Attr_Max: + { + tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node))); + tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node)))); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_binary_op (attribute == Attr_Min + ? MIN_EXPR : MAX_EXPR, + gnu_result_type, gnu_lhs, gnu_rhs); + } + break; + + case Attr_Passed_By_Reference: + gnu_result = size_int (default_pass_by_ref (gnu_type) + || must_pass_by_ref (gnu_type)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case Attr_Component_Size: + if (TREE_CODE (gnu_prefix) == COMPONENT_REF + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) + gnu_prefix = TREE_OPERAND (gnu_prefix, 0); + + gnu_prefix = maybe_implicit_deref (gnu_prefix); + gnu_type = TREE_TYPE (gnu_prefix); + + if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type)))); + + while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) + gnu_type = TREE_TYPE (gnu_type); + + if (TREE_CODE (gnu_type) != ARRAY_TYPE) + gigi_abort (330); + + /* Note this size cannot be self-referential. */ + gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + prefix_unused = true; + break; + + case Attr_Null_Parameter: + /* This is just a zero cast to the pointer type for + our prefix and dereferenced. */ + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result + = build_unary_op (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (gnu_result_type), + integer_zero_node)); + TREE_PRIVATE (gnu_result) = 1; + break; + + case Attr_Mechanism_Code: + { + int code; + Entity_Id gnat_obj = Entity (Prefix (gnat_node)); + + prefix_unused = true; + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + if (Present (Expressions (gnat_node))) + { + int i = UI_To_Int (Intval (First (Expressions (gnat_node)))); + + for (gnat_obj = First_Formal (gnat_obj); i > 1; + i--, gnat_obj = Next_Formal (gnat_obj)) + ; + } + + code = Mechanism (gnat_obj); + if (code == Default) + code = ((present_gnu_tree (gnat_obj) + && (DECL_BY_REF_P (get_gnu_tree (gnat_obj)) + || ((TREE_CODE (get_gnu_tree (gnat_obj)) + == PARM_DECL) + && (DECL_BY_COMPONENT_PTR_P + (get_gnu_tree (gnat_obj)))))) + ? By_Reference : By_Copy); + gnu_result = convert (gnu_result_type, size_int (- code)); + } + break; + + default: + /* Say we have an unimplemented attribute. Then set the value to be + returned to be a zero and hope that's something we can convert to the + type of this attribute. */ + post_error ("unimplemented attribute", gnat_node); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = integer_zero_node; + break; + } + + /* If this is an attribute where the prefix was unused, force a use of it if + it has a side-effect. But don't do it if the prefix is just an entity + name. However, if an access check is needed, we must do it. See second + example in AARM 11.6(5.e). */ + if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix) + && ! Is_Entity_Name (Prefix (gnat_node))) + gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result), + gnu_prefix, gnu_result)); + + *gnu_result_type_p = gnu_result_type; + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement, + to a GCC tree, which is returned. */ + +static tree +Case_Statement_to_gnu (Node_Id gnat_node) +{ + tree gnu_result; + tree gnu_expr; + Node_Id gnat_when; + + gnu_expr = gnat_to_gnu (Expression (gnat_node)); + gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); + + /* The range of values in a case statement is determined by the rules in + RM 5.4(7-9). In almost all cases, this range is represented by the Etype + of the expression. One exception arises in the case of a simple name that + is parenthesized. This still has the Etype of the name, but since it is + not a name, para 7 does not apply, and we need to go to the base type. + This is the only case where parenthesization affects the dynamic + semantics (i.e. the range of possible values at runtime that is covered + by the others alternative. + + Another exception is if the subtype of the expression is non-static. In + that case, we also have to use the base type. */ + if (Paren_Count (Expression (gnat_node)) != 0 + || !Is_OK_Static_Subtype (Underlying_Type + (Etype (Expression (gnat_node))))) + gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); + + /* We build a SWITCH_EXPR that contains the code with interspersed + CASE_LABEL_EXPRs for each label. */ + + push_stack (&gnu_switch_label_stack, NULL_TREE, create_artificial_label ()); + start_stmt_group (); + for (gnat_when = First_Non_Pragma (Alternatives (gnat_node)); + Present (gnat_when); + gnat_when = Next_Non_Pragma (gnat_when)) + { + Node_Id gnat_choice; + + /* First compile all the different case choices for the current WHEN + alternative. */ + for (gnat_choice = First (Discrete_Choices (gnat_when)); + Present (gnat_choice); gnat_choice = Next (gnat_choice)) + { + tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; + + switch (Nkind (gnat_choice)) + { + case N_Range: + gnu_low = gnat_to_gnu (Low_Bound (gnat_choice)); + gnu_high = gnat_to_gnu (High_Bound (gnat_choice)); + break; + + case N_Subtype_Indication: + gnu_low = gnat_to_gnu (Low_Bound (Range_Expression + (Constraint (gnat_choice)))); + gnu_high = gnat_to_gnu (High_Bound (Range_Expression + (Constraint (gnat_choice)))); + break; + + case N_Identifier: + case N_Expanded_Name: + /* This represents either a subtype range or a static value of + some kind; Ekind says which. If a static value, fall through + to the next case. */ + if (IN (Ekind (Entity (gnat_choice)), Type_Kind)) + { + tree gnu_type = get_unpadded_type (Entity (gnat_choice)); + + gnu_low = fold (TYPE_MIN_VALUE (gnu_type)); + gnu_high = fold (TYPE_MAX_VALUE (gnu_type)); + break; + } + + /* ... fall through ... */ + + case N_Character_Literal: + case N_Integer_Literal: + gnu_low = gnat_to_gnu (gnat_choice); + break; + + case N_Others_Choice: + break; + + default: + gigi_abort (316); + } + + add_stmt_with_node (build (CASE_LABEL_EXPR, void_type_node, + gnu_low, gnu_high, + create_artificial_label ()), + gnat_choice); + } + + /* Push a binding level here in case variables are declared since we want + them to be local to this set of statements instead of the block + containing the Case statement. */ + add_stmt (build_stmt_group (Statements (gnat_when), true)); + add_stmt (build1 (GOTO_EXPR, void_type_node, + TREE_VALUE (gnu_switch_label_stack))); + } + + /* Now emit a definition of the label all the cases branched to. */ + add_stmt (build1 (LABEL_EXPR, void_type_node, + TREE_VALUE (gnu_switch_label_stack))); + gnu_result = build (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, + end_stmt_group (), NULL_TREE); + pop_stack (&gnu_switch_label_stack); + + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, + to a GCC tree, which is returned. */ + +static tree +Loop_Statement_to_gnu (Node_Id gnat_node) +{ + /* ??? It would be nice to use "build" here, but there's no build5. */ + tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, NULL_TREE); + tree gnu_loop_var = NULL_TREE; + Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); + tree gnu_cond_expr = NULL_TREE; + tree gnu_result; + + TREE_TYPE (gnu_loop_stmt) = void_type_node; + TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1; + LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (); + annotate_with_node (gnu_loop_stmt, gnat_node); + + /* Save the end label of this LOOP_STMT in a stack so that the corresponding + N_Exit_Statement can find it. */ + push_stack (&gnu_loop_label_stack, NULL_TREE, + LOOP_STMT_LABEL (gnu_loop_stmt)); + + /* Set the condition that under which the loop should continue. + For "LOOP .... END LOOP;" the condition is always true. */ + if (No (gnat_iter_scheme)) + ; + /* The case "WHILE condition LOOP ..... END LOOP;" */ + else if (Present (Condition (gnat_iter_scheme))) + LOOP_STMT_TOP_COND (gnu_loop_stmt) + = gnat_to_gnu (Condition (gnat_iter_scheme)); + else + { + /* We have an iteration scheme. */ + Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme); + Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec); + Entity_Id gnat_type = Etype (gnat_loop_var); + tree gnu_type = get_unpadded_type (gnat_type); + tree gnu_low = TYPE_MIN_VALUE (gnu_type); + tree gnu_high = TYPE_MAX_VALUE (gnu_type); + bool reversep = Reverse_Present (gnat_loop_spec); + tree gnu_first = reversep ? gnu_high : gnu_low; + tree gnu_last = reversep ? gnu_low : gnu_high; + enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR; + tree gnu_base_type = get_base_type (gnu_type); + tree gnu_limit = (reversep ? TYPE_MIN_VALUE (gnu_base_type) + : TYPE_MAX_VALUE (gnu_base_type)); + + /* We know the loop variable will not overflow if GNU_LAST is a constant + and is not equal to GNU_LIMIT. If it might overflow, we have to move + the limit test to the end of the loop. In that case, we have to test + for an empty loop outside the loop. */ + if (TREE_CODE (gnu_last) != INTEGER_CST + || TREE_CODE (gnu_limit) != INTEGER_CST + || tree_int_cst_equal (gnu_last, gnu_limit)) + { + gnu_cond_expr + = build (COND_EXPR, void_type_node, + build_binary_op (LE_EXPR, integer_type_node, + gnu_low, gnu_high), + NULL_TREE, alloc_stmt_list ()); + annotate_with_node (gnu_cond_expr, gnat_loop_spec); + } + + /* Open a new nesting level that will surround the loop to declare the + loop index variable. */ + start_stmt_group (); + gnat_pushlevel (); + + /* Declare the loop index and set it to its initial value. */ + gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1); + if (DECL_BY_REF_P (gnu_loop_var)) + gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var); + + /* The loop variable might be a padded type, so use `convert' to get a + reference to the inner variable if so. */ + gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var); + + /* Set either the top or bottom exit condition as appropriate depending + on whether or not we know an overflow cannot occur. */ + if (gnu_cond_expr) + LOOP_STMT_BOT_COND (gnu_loop_stmt) + = build_binary_op (NE_EXPR, integer_type_node, + gnu_loop_var, gnu_last); + else + LOOP_STMT_TOP_COND (gnu_loop_stmt) + = build_binary_op (end_code, integer_type_node, + gnu_loop_var, gnu_last); + + LOOP_STMT_UPDATE (gnu_loop_stmt) + = build_binary_op (reversep ? PREDECREMENT_EXPR + : PREINCREMENT_EXPR, + TREE_TYPE (gnu_loop_var), + gnu_loop_var, + convert (TREE_TYPE (gnu_loop_var), + integer_one_node)); + annotate_with_node (LOOP_STMT_UPDATE (gnu_loop_stmt), + gnat_iter_scheme); + } + + /* If the loop was named, have the name point to this loop. In this case, + the association is not a ..._DECL node, but the end label from this + LOOP_STMT. */ + if (Present (Identifier (gnat_node))) + save_gnu_tree (Entity (Identifier (gnat_node)), + LOOP_STMT_LABEL (gnu_loop_stmt), 1); + + /* Make the loop body into its own block, so any allocated storage will be + released every iteration. This is needed for stack allocation. */ + LOOP_STMT_BODY (gnu_loop_stmt) + = build_stmt_group (Statements (gnat_node), true); + + /* If we declared a variable, then we are in a statement group for that + declaration. Add the LOOP_STMT to it and make that the "loop". */ + if (gnu_loop_var) + { + add_stmt (gnu_loop_stmt); + gnat_poplevel (); + gnu_loop_stmt = end_stmt_group (); + } + + /* If we have an outer COND_EXPR, that's our result and this loop is its + "true" statement. Otherwise, the result is the LOOP_STMT. */ + if (gnu_cond_expr) + { + COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt; + gnu_result = gnu_cond_expr; + recalculate_side_effects (gnu_cond_expr); + } + else + gnu_result = gnu_loop_stmt; + + pop_stack (&gnu_loop_label_stack); + + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We + don't return anything. */ + +static void +Subprogram_Body_to_gnu (Node_Id gnat_node) +{ + /* Save debug output mode in case it is reset. */ + enum debug_info_type save_write_symbols = write_symbols; + const struct gcc_debug_hooks *const save_debug_hooks = debug_hooks; + /* Definining identifier of a parameter to the subprogram. */ + Entity_Id gnat_param; + /* The defining identifier for the subprogram body. Note that if a + specification has appeared before for this body, then the identifier + occurring in that specification will also be a defining identifier and all + the calls to this subprogram will point to that specification. */ + Entity_Id gnat_subprog_id + = (Present (Corresponding_Spec (gnat_node)) + ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node)); + /* The FUNCTION_DECL node corresponding to the subprogram spec. */ + tree gnu_subprog_decl; + /* The FUNCTION_TYPE node corresponding to the subprogram spec. */ + tree gnu_subprog_type; + tree gnu_cico_list; + tree gnu_result; + + /* If this is a generic object or if it has been eliminated, + ignore it. */ + if (Ekind (gnat_subprog_id) == E_Generic_Procedure + || Ekind (gnat_subprog_id) == E_Generic_Function + || Is_Eliminated (gnat_subprog_id)) + return; + + /* If debug information is suppressed for the subprogram, turn debug + mode off for the duration of processing. */ + if (!Needs_Debug_Info (gnat_subprog_id)) + { + write_symbols = NO_DEBUG; + debug_hooks = &do_nothing_debug_hooks; + } + + /* If this subprogram acts as its own spec, define it. Otherwise, just get + the already-elaborated tree node. However, if this subprogram had its + elaboration deferred, we will already have made a tree node for it. So + treat it as not being defined in that case. Such a subprogram cannot + have an address clause or a freeze node, so this test is safe, though it + does disable some otherwise-useful error checking. */ + gnu_subprog_decl + = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, + Acts_As_Spec (gnat_node) + && ! present_gnu_tree (gnat_subprog_id)); + + gnu_subprog_type = TREE_TYPE (gnu_subprog_decl); + + /* Set the line number in the decl to correspond to that of the body so that + the line number notes are written + correctly. */ + Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl)); + + begin_subprog_body (gnu_subprog_decl); + gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); + + /* If there are OUT parameters, we need to ensure that the return statement + properly copies them out. We do this by making a new block and converting + any inner return into a goto to a label at the end of the block. */ + push_stack (&gnu_return_label_stack, NULL_TREE, + gnu_cico_list ? create_artificial_label () : NULL_TREE); + + /* Get a tree corresponding to the code for the subprogram. */ + start_stmt_group (); + gnat_pushlevel (); + + /* See if there are any parameters for which we don't yet have GCC entities. + These must be for OUT parameters for which we will be making VAR_DECL + nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty + entry as well. We can match up the entries because TYPE_CI_CO_LIST is in + the order of the parameters. */ + for (gnat_param = First_Formal (gnat_subprog_id); + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param)) + if (!present_gnu_tree (gnat_param)) + { + /* Skip any entries that have been already filled in; they must + correspond to IN OUT parameters. */ + for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0; + gnu_cico_list = TREE_CHAIN (gnu_cico_list)) + ; + + /* Do any needed references for padded types. */ + TREE_VALUE (gnu_cico_list) + = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)), + gnat_to_gnu_entity (gnat_param, NULL_TREE, 1)); + } + + process_decls (Declarations (gnat_node), Empty, Empty, 1, 1); + + /* Generate the code of the subprogram itself. A return statement will be + present and any OUT parameters will be handled there. */ + add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + gnat_poplevel (); + gnu_result = end_stmt_group (); + + /* If we made a special return label, we need to make a block that contains + the definition of that label and the copying to the return value. That + block first contains the function, then the label and copy statement. */ + if (TREE_VALUE (gnu_return_label_stack) != 0) + { + tree gnu_retval; + + start_stmt_group (); + gnat_pushlevel (); + add_stmt (gnu_result); + add_stmt (build1 (LABEL_EXPR, void_type_node, + TREE_VALUE (gnu_return_label_stack))); + + gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); + if (list_length (gnu_cico_list) == 1) + gnu_retval = TREE_VALUE (gnu_cico_list); + else + gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type), + gnu_cico_list); + + if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval)) + gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval); + + add_stmt_with_node + (build1 (RETURN_EXPR, void_type_node, + build (MODIFY_EXPR, TREE_TYPE (gnu_retval), + DECL_RESULT (current_function_decl), gnu_retval)), + gnat_node); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + + pop_stack (&gnu_return_label_stack); + + /* Initialize the information node for the function and set the + end location. */ + allocate_struct_function (current_function_decl); + Sloc_to_locus + ((Present (End_Label (Handled_Statement_Sequence (gnat_node))) + ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node))) + : Sloc (gnat_node)), + &cfun->function_end_locus); + + end_subprog_body (gnu_result); + + /* Disconnect the trees for parameters that we made variables for from the + GNAT entities since these are unusable after we end the function. */ + for (gnat_param = First_Formal (gnat_subprog_id); + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param)) + if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL) + save_gnu_tree (gnat_param, NULL_TREE, 0); + + mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node))); + write_symbols = save_write_symbols; + debug_hooks = save_debug_hooks; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call + or an N_Procedure_Call_Statement, to a GCC tree, which is returned. + GNU_RESULT_TYPE_P is a pointer to where we should place the result type. */ + +static tree +call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) +{ + tree gnu_result; + /* The GCC node corresponding to the GNAT subprogram name. This can either + be a FUNCTION_DECL node if we are dealing with a standard subprogram call, + or an indirect reference expression (an INDIRECT_REF node) pointing to a + subprogram. */ + tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node)); + /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ + tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node); + tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_subprog_node); + Entity_Id gnat_formal; + Node_Id gnat_actual; + tree gnu_actual_list = NULL_TREE; + tree gnu_name_list = NULL_TREE; + tree gnu_before_list = NULL_TREE; + tree gnu_after_list = NULL_TREE; + tree gnu_subprog_call; + + switch (Nkind (Name (gnat_node))) + { + case N_Identifier: + case N_Operator_Symbol: + case N_Expanded_Name: + case N_Attribute_Reference: + if (Is_Eliminated (Entity (Name (gnat_node)))) + Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node))); + } + + if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE) + gigi_abort (317); + + /* If we are calling a stubbed function, make this into a raise of + Program_Error. Elaborate all our args first. */ + if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL + && DECL_STUBBED_P (gnu_subprog_node)) + { + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_actual = Next_Actual (gnat_actual)) + add_stmt (gnat_to_gnu (gnat_actual)); + + if (Nkind (gnat_node) == N_Function_Call) + { + *gnu_result_type_p = TREE_TYPE (gnu_subprog_type); + return build1 (NULL_EXPR, *gnu_result_type_p, + build_call_raise (PE_Stubbed_Subprogram_Called)); + } + else + return build_call_raise (PE_Stubbed_Subprogram_Called); + } + + /* The only way we can be making a call via an access type is if Name is an + explicit dereference. In that case, get the list of formal args from the + type the access type is pointing to. Otherwise, get the formals from + entity being called. */ + if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) + gnat_formal = First_Formal (Etype (Name (gnat_node))); + else if (Nkind (Name (gnat_node)) == N_Attribute_Reference) + /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */ + gnat_formal = 0; + else + gnat_formal = First_Formal (Entity (Name (gnat_node))); + + /* Create the list of the actual parameters as GCC expects it, namely a chain + of TREE_LIST nodes in which the TREE_VALUE field of each node is a + parameter-expression and the TREE_PURPOSE field is null. Skip OUT + parameters not passed by reference and don't need to be copied in. */ + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_formal = Next_Formal_With_Extras (gnat_formal), + gnat_actual = Next_Actual (gnat_actual)) + { + tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal)); + /* We treat a conversion between aggregate types as if it is an + unchecked conversion. */ + bool unchecked_convert_p + = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion + || (Nkind (gnat_actual) == N_Type_Conversion + && Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))); + Node_Id gnat_name = (unchecked_convert_p + ? Expression (gnat_actual) : gnat_actual); + tree gnu_name = gnat_to_gnu (gnat_name); + tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)); + tree gnu_actual; + + /* If it's possible we may need to use this expression twice, make sure + than any side-effects are handled via SAVE_EXPRs. Likewise if we need + to force side-effects before the call. + + ??? This is more conservative than we need since we don't need to do + this for pass-by-ref with no conversion. If we are passing a + non-addressable Out or In Out parameter by reference, pass the address + of a copy and set up to copy back out after the call. */ + if (Ekind (gnat_formal) != E_In_Parameter) + { + gnu_name = gnat_stabilize_reference (gnu_name, 1); + if (! addressable_p (gnu_name) + && present_gnu_tree (gnat_formal) + && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) + || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && (DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)) + || (DECL_BY_DESCRIPTOR_P + (get_gnu_tree (gnat_formal))))))) + { + tree gnu_copy = gnu_name; + tree gnu_temp; + + /* Remove any unpadding on the actual and make a copy. But if + the actual is a left-justified modular type, first convert + to it. */ + if (TREE_CODE (gnu_name) == COMPONENT_REF + && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))))) + gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0); + else if (TREE_CODE (gnu_name_type) == RECORD_TYPE + && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_name_type))) + gnu_name = convert (gnu_name_type, gnu_name); + + gnu_actual = save_expr (gnu_name); + + /* Since we're going to take the address of the SAVE_EXPR, we + don't want it to be marked as unchanging. So set + TREE_ADDRESSABLE. */ + gnu_temp = skip_simple_arithmetic (gnu_actual); + if (TREE_CODE (gnu_temp) == SAVE_EXPR) + { + TREE_ADDRESSABLE (gnu_temp) = 1; + TREE_READONLY (gnu_temp) = 0; + } + + /* Set up to move the copy back to the original. */ + gnu_temp = build (MODIFY_EXPR, TREE_TYPE (gnu_copy), + gnu_copy, gnu_actual); + annotate_with_node (gnu_temp, gnat_actual); + append_to_statement_list (gnu_temp, &gnu_after_list); + } + } + + /* If this was a procedure call, we may not have removed any padding. + So do it here for the part we will use as an input, if any. */ + gnu_actual = gnu_name; + if (Ekind (gnat_formal) != E_Out_Parameter + && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))) + gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), + gnu_actual); + + /* Unless this is an In parameter, we must remove any LJM building + from GNU_NAME. */ + if (Ekind (gnat_formal) != E_In_Parameter + && TREE_CODE (gnu_name) == CONSTRUCTOR + && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE + && TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name))) + gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), + gnu_name); + + if (Ekind (gnat_formal) != E_Out_Parameter + && ! unchecked_convert_p + && Do_Range_Check (gnat_actual)) + gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal)); + + /* Do any needed conversions. We need only check for unchecked + conversion since normal conversions will be handled by just + converting to the formal type. */ + if (unchecked_convert_p) + { + gnu_actual + = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)), + gnu_actual, + (Nkind (gnat_actual) + == N_Unchecked_Type_Conversion) + && No_Truncation (gnat_actual)); + + /* One we've done the unchecked conversion, we still must ensure that + the object is in range of the formal's type. */ + if (Ekind (gnat_formal) != E_Out_Parameter + && Do_Range_Check (gnat_actual)) + gnu_actual = emit_range_check (gnu_actual, + Etype (gnat_formal)); + } + else if (TREE_CODE (gnu_actual) != SAVE_EXPR) + /* We may have suppressed a conversion to the Etype of the actual since + the parent is a procedure call. So add the conversion here. */ + gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), + gnu_actual); + + if (TREE_CODE (gnu_actual) != SAVE_EXPR) + gnu_actual = convert (gnu_formal_type, gnu_actual); + + /* If we have not saved a GCC object for the formal, it means it is an + OUT parameter not passed by reference and that does not need to be + copied in. Otherwise, look at the PARM_DECL to see if it is passed by + reference. */ + if (present_gnu_tree (gnat_formal) + && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && DECL_BY_REF_P (get_gnu_tree (gnat_formal))) + { + if (Ekind (gnat_formal) != E_In_Parameter) + { + gnu_actual = gnu_name; + + /* If we have a padded type, be sure we've removed padding. */ + if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)) + && TREE_CODE (gnu_actual) != SAVE_EXPR) + gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), + gnu_actual); + } + + /* Otherwise, if we have a non-addressable COMPONENT_REF of a + variable-size type see if it's doing a unpadding operation. If + so, remove that operation since we have no way of allocating the + required temporary. */ + if (TREE_CODE (gnu_actual) == COMPONENT_REF + && ! TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual))) + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0))) + == RECORD_TYPE) + && TYPE_IS_PADDING_P (TREE_TYPE + (TREE_OPERAND (gnu_actual, 0))) + && !addressable_p (gnu_actual)) + gnu_actual = TREE_OPERAND (gnu_actual, 0); + + /* The symmetry of the paths to the type of an entity is broken here + since arguments don't know that they will be passed by ref. */ + gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); + gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); + } + else if (present_gnu_tree (gnat_formal) + && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))) + { + gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); + gnu_actual = maybe_implicit_deref (gnu_actual); + gnu_actual = maybe_unconstrained_array (gnu_actual); + + if (TREE_CODE (gnu_formal_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_formal_type)) + { + gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type)); + gnu_actual = convert (gnu_formal_type, gnu_actual); + } + + /* Take the address of the object and convert to the proper pointer + type. We'd like to actually compute the address of the beginning + of the array using an ADDR_EXPR of an ARRAY_REF, but there's a + possibility that the ARRAY_REF might return a constant and we'd be + getting the wrong address. Neither approach is exactly correct, + but this is the most likely to work in all cases. */ + gnu_actual = convert (gnu_formal_type, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_actual)); + } + else if (present_gnu_tree (gnat_formal) + && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal))) + { + /* If arg is 'Null_Parameter, pass zero descriptor. */ + if ((TREE_CODE (gnu_actual) == INDIRECT_REF + || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF) + && TREE_PRIVATE (gnu_actual)) + gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)), + integer_zero_node); + else + gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE, + fill_vms_descriptor (gnu_actual, + gnat_formal)); + } + else + { + tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual)); + + if (Ekind (gnat_formal) != E_In_Parameter) + gnu_name_list = chainon (gnu_name_list, + build_tree_list (NULL_TREE, gnu_name)); + + if (! present_gnu_tree (gnat_formal) + || TREE_CODE (get_gnu_tree (gnat_formal)) != PARM_DECL) + continue; + + /* If this is 'Null_Parameter, pass a zero even though we are + dereferencing it. */ + else if (TREE_CODE (gnu_actual) == INDIRECT_REF + && TREE_PRIVATE (gnu_actual) + && host_integerp (gnu_actual_size, 1) + && 0 >= compare_tree_int (gnu_actual_size, + BITS_PER_WORD)) + gnu_actual + = unchecked_convert + (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)), + convert (gnat_type_for_size + (tree_low_cst (gnu_actual_size, 1), 1), + integer_zero_node), 0); + else + gnu_actual = convert (TYPE_MAIN_VARIANT + (DECL_ARG_TYPE (get_gnu_tree (gnat_formal))), + gnu_actual); + } + + gnu_actual_list = chainon (gnu_actual_list, + build_tree_list (NULL_TREE, gnu_actual)); + } + + gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type), + gnu_subprog_addr, gnu_actual_list, NULL_TREE); + TREE_SIDE_EFFECTS (gnu_subprog_call) = 1; + + /* If it is a function call, the result is the call expression. */ + if (Nkind (gnat_node) == N_Function_Call) + { + gnu_result = gnu_subprog_call; + + /* If the function returns an unconstrained array or by reference, + we have to de-dereference the pointer. */ + if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type) + || TYPE_RETURNS_BY_REF_P (gnu_subprog_type)) + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); + + *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); + return gnu_result; + } + + /* If this is the case where the GNAT tree contains a procedure call + but the Ada procedure has copy in copy out parameters, the special + parameter passing mechanism must be used. */ + else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE) + { + /* List of FIELD_DECLs associated with the PARM_DECLs of the copy + in copy out parameters. */ + tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type); + int length = list_length (scalar_return_list); + + if (length > 1) + { + tree gnu_name; + + gnu_subprog_call = protect_multiple_eval (gnu_subprog_call); + + /* If any of the names had side-effects, ensure they are all + evaluated before the call. */ + for (gnu_name = gnu_name_list; gnu_name; + gnu_name = TREE_CHAIN (gnu_name)) + if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name))) + add_stmt (TREE_VALUE (gnu_name)); + } + + if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) + gnat_formal = First_Formal (Etype (Name (gnat_node))); + else + gnat_formal = First_Formal (Entity (Name (gnat_node))); + + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_formal = Next_Formal_With_Extras (gnat_formal), + gnat_actual = Next_Actual (gnat_actual)) + /* If we are dealing with a copy in copy out parameter, we must + retrieve its value from the record returned in the call. */ + if (! (present_gnu_tree (gnat_formal) + && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) + || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && ((DECL_BY_COMPONENT_PTR_P + (get_gnu_tree (gnat_formal)) + || (DECL_BY_DESCRIPTOR_P + (get_gnu_tree (gnat_formal)))))))) + && Ekind (gnat_formal) != E_In_Parameter) + { + /* Get the value to assign to this OUT or IN OUT parameter. It is + either the result of the function if there is only a single such + parameter or the appropriate field from the record returned. */ + tree gnu_result + = length == 1 ? gnu_subprog_call + : build_component_ref (gnu_subprog_call, NULL_TREE, + TREE_PURPOSE (scalar_return_list), 0); + bool unchecked_conversion = (Nkind (gnat_actual) + == N_Unchecked_Type_Conversion); + /* If the actual is a conversion, get the inner expression, which + will be the real destination, and convert the result to the + type of the actual parameter. */ + tree gnu_actual + = maybe_unconstrained_array (TREE_VALUE (gnu_name_list)); + + /* If the result is a padded type, remove the padding. */ + if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) + gnu_result = convert (TREE_TYPE (TYPE_FIELDS + (TREE_TYPE (gnu_result))), + gnu_result); + + /* If the result is a type conversion, do it. */ + if (Nkind (gnat_actual) == N_Type_Conversion) + gnu_result + = convert_with_check + (Etype (Expression (gnat_actual)), gnu_result, + Do_Overflow_Check (gnat_actual), + Do_Range_Check (Expression (gnat_actual)), + Float_Truncate (gnat_actual)); + + else if (unchecked_conversion) + gnu_result = unchecked_convert (TREE_TYPE (gnu_actual), + gnu_result, + No_Truncation (gnat_actual)); + else + { + if (Do_Range_Check (gnat_actual)) + gnu_result = emit_range_check (gnu_result, + Etype (gnat_actual)); + + if (! (! TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual))) + && TREE_CONSTANT (TYPE_SIZE + (TREE_TYPE (gnu_result))))) + gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result); + } + + gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, + gnu_actual, gnu_result); + annotate_with_node (gnu_result, gnat_actual); + append_to_statement_list (gnu_result, &gnu_before_list); + scalar_return_list = TREE_CHAIN (scalar_return_list); + gnu_name_list = TREE_CHAIN (gnu_name_list); + } + } + else + { + annotate_with_node (gnu_subprog_call, gnat_node); + append_to_statement_list (gnu_subprog_call, &gnu_before_list); + } + + append_to_statement_list (gnu_after_list, &gnu_before_list); + return gnu_before_list; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an + N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */ + +static tree +Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) +{ + tree gnu_jmpsave_decl = NULL_TREE; + tree gnu_jmpbuf_decl = NULL_TREE; + /* If just annotating, ignore all EH and cleanups. */ + bool gcc_zcx = (!type_annotate_only + && Present (Exception_Handlers (gnat_node)) + && Exception_Mechanism == GCC_ZCX); + bool setjmp_longjmp + = (!type_annotate_only && Present (Exception_Handlers (gnat_node)) + && Exception_Mechanism == Setjmp_Longjmp); + bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node)); + bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp); + tree gnu_inner_block; /* The statement(s) for the block itself. */ + tree gnu_result; + tree gnu_expr; + Node_Id gnat_temp; + + /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes + and we have our own SJLJ mechanism. To call the GCC mechanism, we call + add_cleanup, and when we leave the binding, end_stmt_group will create + the TRY_FINALLY_EXPR. + + ??? The region level calls down there have been specifically put in place + for a ZCX context and currently the order in which things are emitted + (region/handlers) is different from the SJLJ case. Instead of putting + other calls with different conditions at other places for the SJLJ case, + it seems cleaner to reorder things for the SJLJ case and generalize the + condition to make it not ZCX specific. + + If there are any exceptions or cleanup processing involved, we need an + outer statement group (for Setjmp_Longjmp) and binding level. */ + if (binding_for_block) + { + start_stmt_group (); + gnat_pushlevel (); + } + + /* If we are to call a function when exiting this block add a cleanup + to the binding level we made above. */ + if (at_end) + add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node)))); + + /* If using setjmp_longjmp, make the variables for the setjmp buffer and save + area for address of previous buffer. Do this first since we need to have + the setjmp buf known for any decls in this block. */ + if (setjmp_longjmp) + { + gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"), + NULL_TREE, jmpbuf_ptr_type, + build_call_0_expr (get_jmpbuf_decl), + 0, 0, 0, 0, 0, gnat_node); + gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"), + NULL_TREE, jmpbuf_type, + NULL_TREE, 0, 0, 0, 0, 0, gnat_node); + + set_block_jmpbuf_decl (gnu_jmpbuf_decl); + + /* When we exit this block, restore the saved value. */ + add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl)); + } + + /* Now build the tree for the declarations and statements inside this block. + If this is SJLJ, set our jmp_buf as the current buffer. */ + start_stmt_group (); + + if (setjmp_longjmp) + add_stmt (build_call_1_expr (set_jmpbuf_decl, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_jmpbuf_decl))); + + + if (Present (First_Real_Statement (gnat_node))) + process_decls (Statements (gnat_node), Empty, + First_Real_Statement (gnat_node), 1, 1); + + /* Generate code for each statement in the block. */ + for (gnat_temp = (Present (First_Real_Statement (gnat_node)) + ? First_Real_Statement (gnat_node) + : First (Statements (gnat_node))); + Present (gnat_temp); gnat_temp = Next (gnat_temp)) + add_stmt (gnat_to_gnu (gnat_temp)); + gnu_inner_block = end_stmt_group (); + + /* Now generate code for the two exception models, if either is relevant for + this block. */ + if (setjmp_longjmp) + { + tree *gnu_else_ptr = 0; + tree gnu_handler; + + /* Make a binding level for the exception handling declarations and code + and set up gnu_except_ptr_stack for the handlers to use. */ + start_stmt_group (); + gnat_pushlevel (); + + push_stack (&gnu_except_ptr_stack, NULL_TREE, + create_var_decl (get_identifier ("EXCEPT_PTR"), + NULL_TREE, + build_pointer_type (except_type_node), + build_call_0_expr (get_excptr_decl), + 0, 0, 0, 0, 0, gnat_node)); + + /* Generate code for each handler. The N_Exception_Handler case does the + real work and returns a COND_EXPR for each handler, which we chain + together here. */ + for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); + Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp)) + { + gnu_expr = gnat_to_gnu (gnat_temp); + + /* If this is the first one, set it as the outer one. Otherwise, + point the "else" part of the previous handler to us. Then point + to our "else" part. */ + if (!gnu_else_ptr) + add_stmt (gnu_expr); + else + *gnu_else_ptr = gnu_expr; + + gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); + } + + /* If none of the exception handlers did anything, re-raise but do not + defer abortion. */ + gnu_expr = build_call_1_expr (raise_nodefer_decl, + TREE_VALUE (gnu_except_ptr_stack)); + annotate_with_node (gnu_expr, gnat_node); + + if (gnu_else_ptr) + *gnu_else_ptr = gnu_expr; + else + add_stmt (gnu_expr); + + /* End the binding level dedicated to the exception handlers and get the + whole statement group. */ + pop_stack (&gnu_except_ptr_stack); + gnat_poplevel (); + gnu_handler = end_stmt_group (); + + /* If the setjmp returns 1, we restore our incoming longjmp value and + then check the handlers. */ + start_stmt_group (); + add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl, + gnu_jmpsave_decl), + gnat_node); + add_stmt (gnu_handler); + gnu_handler = end_stmt_group (); + + /* This block is now "if (setjmp) ... <handlers> else <block>". */ + gnu_result = build (COND_EXPR, void_type_node, + (build_call_1_expr + (setjmp_decl, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_jmpbuf_decl))), + gnu_handler, gnu_inner_block); + } + else if (gcc_zcx) + { + tree gnu_handlers; + + /* First make a block containing the handlers. */ + start_stmt_group (); + for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); + Present (gnat_temp); + gnat_temp = Next_Non_Pragma (gnat_temp)) + add_stmt (gnat_to_gnu (gnat_temp)); + gnu_handlers = end_stmt_group (); + + /* Now make the TRY_CATCH_EXPR for the block. */ + gnu_result = build (TRY_CATCH_EXPR, void_type_node, + gnu_inner_block, gnu_handlers); + } + else + gnu_result = gnu_inner_block; + + /* Now close our outer block, if we had to make one. */ + if (binding_for_block) + { + add_stmt (gnu_result); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, + to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp + exception handling. */ + +static tree +Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) +{ + /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make + an "if" statement to select the proper exceptions. For "Others", exclude + exceptions where Handled_By_Others is nonzero unless the All_Others flag + is set. For "Non-ada", accept an exception if "Lang" is 'V'. */ + tree gnu_choice = integer_zero_node; + tree gnu_body = build_stmt_group (Statements (gnat_node), false); + Node_Id gnat_temp; + + for (gnat_temp = First (Exception_Choices (gnat_node)); + gnat_temp; gnat_temp = Next (gnat_temp)) + { + tree this_choice; + + if (Nkind (gnat_temp) == N_Others_Choice) + { + if (All_Others (gnat_temp)) + this_choice = integer_one_node; + else + this_choice + = build_binary_op + (EQ_EXPR, integer_type_node, + convert + (integer_type_node, + build_component_ref + (build_unary_op + (INDIRECT_REF, NULL_TREE, + TREE_VALUE (gnu_except_ptr_stack)), + get_identifier ("not_handled_by_others"), NULL_TREE, + 0)), + integer_zero_node); + } + + else if (Nkind (gnat_temp) == N_Identifier + || Nkind (gnat_temp) == N_Expanded_Name) + { + tree gnu_expr + = gnat_to_gnu_entity (Entity (gnat_temp), NULL_TREE, 0); + + this_choice + = build_binary_op + (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack), + convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)), + build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); + + /* If this is the distinguished exception "Non_Ada_Error" (and we are + in VMS mode), also allow a non-Ada exception (a VMS condition) t + match. */ + if (Is_Non_Ada_Error (Entity (gnat_temp))) + { + tree gnu_comp + = build_component_ref + (build_unary_op (INDIRECT_REF, NULL_TREE, + TREE_VALUE (gnu_except_ptr_stack)), + get_identifier ("lang"), NULL_TREE, 0); + + this_choice + = build_binary_op + (TRUTH_ORIF_EXPR, integer_type_node, + build_binary_op (EQ_EXPR, integer_type_node, gnu_comp, + convert (TREE_TYPE (gnu_comp), + build_int_2 ('V', 0))), + this_choice); + } + } + else + gigi_abort (318); + + gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, + gnu_choice, this_choice); + } + + return build (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE); +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, + to a GCC tree, which is returned. This is the variant for ZCX. */ + +static tree +Exception_Handler_to_gnu_zcx (Node_Id gnat_node) +{ + tree gnu_etypes_list = NULL_TREE; + tree gnu_expr; + tree gnu_etype; + tree gnu_current_exc_ptr; + tree gnu_incoming_exc_ptr; + Node_Id gnat_temp; + + /* We build a TREE_LIST of nodes representing what exception types this + handler can catch, with special cases for others and all others cases. + + Each exception type is actually identified by a pointer to the exception + id, with special value zero for "others" and one for "all others". Beware + that these special values are known and used by the personality routine to + identify the corresponding specific kinds of handlers. + + ??? For initial time frame reasons, the others and all_others cases have + been handled using specific type trees, but this somehow hides information + from the back-end, which expects NULL to be passed for catch all and + end_cleanup to be used for cleanups. + + Care should be taken to ensure that the control flow impact of such + clauses is rendered in some way. lang_eh_type_covers is doing the trick + currently. */ + for (gnat_temp = First (Exception_Choices (gnat_node)); + gnat_temp; gnat_temp = Next (gnat_temp)) + { + if (Nkind (gnat_temp) == N_Others_Choice) + gnu_etype = (All_Others (gnat_temp) ? integer_one_node + : integer_zero_node); + else if (Nkind (gnat_temp) == N_Identifier + || Nkind (gnat_temp) == N_Expanded_Name) + { + Entity_Id gnat_ex_id = Entity (gnat_temp); + + /* Exception may be a renaming. Recover original exception which is + the one elaborated and registered. */ + if (Present (Renamed_Object (gnat_ex_id))) + gnat_ex_id = Renamed_Object (gnat_ex_id); + + gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); + gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); + + /* The Non_Ada_Error case for VMS exceptions is handled + by the personality routine. */ + } + else + gigi_abort (337); + + /* The GCC interface expects NULL to be passed for catch all handlers, so + it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype + is integer_zero_node. It would not work, however, because GCC's + notion of "catch all" is stronger than our notion of "others". Until + we correctly use the cleanup interface as well, doing that would + prevent the "all others" handlers from beeing seen, because nothing + can be caught beyond a catch all from GCC's point of view. */ + gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list); + } + + start_stmt_group (); + gnat_pushlevel (); + + /* Expand a call to the begin_handler hook at the beginning of the handler, + and arrange for a call to the end_handler hook to occur on every possible + exit path. + + The hooks expect a pointer to the low level occurrence. This is required + for our stack management scheme because a raise inside the handler pushes + a new occurrence on top of the stack, which means that this top does not + necessarily match the occurrence this handler was dealing with. + + The EXC_PTR_EXPR object references the exception occurrence being + propagated. Upon handler entry, this is the exception for which the + handler is triggered. This might not be the case upon handler exit, + however, as we might have a new occurrence propagated by the handler's + body, and the end_handler hook called as a cleanup in this context. + + We use a local variable to retrieve the incoming value at handler entry + time, and reuse it to feed the end_handler hook's argument at exit. */ + gnu_current_exc_ptr = build (EXC_PTR_EXPR, ptr_type_node); + gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE, + ptr_type_node, gnu_current_exc_ptr, + 0, 0, 0, 0, 0, gnat_node); + + add_stmt_with_node (build_call_1_expr (begin_handler_decl, + gnu_incoming_exc_ptr), + gnat_node); + add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr)); + add_stmt_list (Statements (gnat_node)); + gnat_poplevel (); + + return build (CATCH_EXPR, void_type_node, gnu_etypes_list, + end_stmt_group ()); +} + /* This function is the driver of the GNAT to GCC tree transformation process. It is the entry point of the tree transformer. GNAT_NODE is the root of some GNAT tree. Return the root of the corresponding GCC tree. @@ -315,7 +2345,6 @@ gnat_to_gnu (Node_Id gnat_node) tree gnu_expr; tree gnu_lhs, gnu_rhs; Node_Id gnat_temp; - Entity_Id gnat_temp_type; /* Save node number for error message and set location information. */ error_gnat_node = gnat_node; @@ -354,7 +2383,6 @@ gnat_to_gnu (Node_Id gnat_node) went_into_elab_proc = true; } - switch (Nkind (gnat_node)) { /********************************/ @@ -365,182 +2393,7 @@ gnat_to_gnu (Node_Id gnat_node) case N_Expanded_Name: case N_Operator_Symbol: case N_Defining_Identifier: - - /* If the Etype of this node does not equal the Etype of the Entity, - something is wrong with the entity map, probably in generic - instantiation. However, this does not apply to types. Since we - sometime have strange Ekind's, just do this test for objects. Also, - if the Etype of the Entity is private, the Etype of the N_Identifier - is allowed to be the full type and also we consider a packed array - type to be the same as the original type. Similarly, a class-wide - type is equivalent to a subtype of itself. Finally, if the types are - Itypes, one may be a copy of the other, which is also legal. */ - gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier - ? gnat_node : Entity (gnat_node)); - gnat_temp_type = Etype (gnat_temp); - - if (Etype (gnat_node) != gnat_temp_type - && ! (Is_Packed (gnat_temp_type) - && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type)) - && ! (Is_Class_Wide_Type (Etype (gnat_node))) - && ! (IN (Ekind (gnat_temp_type), Private_Kind) - && Present (Full_View (gnat_temp_type)) - && ((Etype (gnat_node) == Full_View (gnat_temp_type)) - || (Is_Packed (Full_View (gnat_temp_type)) - && Etype (gnat_node) == - Packed_Array_Type (Full_View (gnat_temp_type))))) - && (!Is_Itype (Etype (gnat_node)) || !Is_Itype (gnat_temp_type)) - && (Ekind (gnat_temp) == E_Variable - || Ekind (gnat_temp) == E_Component - || Ekind (gnat_temp) == E_Constant - || Ekind (gnat_temp) == E_Loop_Parameter - || IN (Ekind (gnat_temp), Formal_Kind))) - gigi_abort (304); - - /* If this is a reference to a deferred constant whose partial view - is an unconstrained private type, the proper type is on the full - view of the constant, not on the full view of the type, which may - be unconstrained. - - This may be a reference to a type, for example in the prefix of the - attribute Position, generated for dispatching code (see Make_DT in - exp_disp,adb). In that case we need the type itself, not is parent, - in particular if it is a derived type */ - if (Is_Private_Type (gnat_temp_type) - && Has_Unknown_Discriminants (gnat_temp_type) - && Present (Full_View (gnat_temp)) - && ! Is_Type (gnat_temp)) - { - gnat_temp = Full_View (gnat_temp); - gnat_temp_type = Etype (gnat_temp); - gnu_result_type = get_unpadded_type (gnat_temp_type); - } - else - { - /* Expand the type of this identitier first, in case it is - an enumeral literal, which only get made when the type - is expanded. There is no order-of-elaboration issue here. - We want to use the Actual_Subtype if it has already been - elaborated, otherwise the Etype. Avoid using Actual_Subtype - for packed arrays to simplify things. */ - if ((Ekind (gnat_temp) == E_Constant - || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp)) - && ! (Is_Array_Type (Etype (gnat_temp)) - && Present (Packed_Array_Type (Etype (gnat_temp)))) - && Present (Actual_Subtype (gnat_temp)) - && present_gnu_tree (Actual_Subtype (gnat_temp))) - gnat_temp_type = Actual_Subtype (gnat_temp); - else - gnat_temp_type = Etype (gnat_node); - - gnu_result_type = get_unpadded_type (gnat_temp_type); - } - - gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0); - - /* If we are in an exception handler, force this variable into memory - to ensure optimization does not remove stores that appear - redundant but are actually needed in case an exception occurs. - - ??? Note that we need not do this if the variable is declared within - the handler, only if it is referenced in the handler and declared - in an enclosing block, but we have no way of testing that - right now. - - ??? Also, for now all we can do is make it volatile. But we only - do this for SJLJ. */ - if (TREE_VALUE (gnu_except_ptr_stack) != 0 - && TREE_CODE (gnu_result) == VAR_DECL) - TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1; - - /* Some objects (such as parameters passed by reference, globals of - variable size, and renamed objects) actually represent the address - of the object. In that case, we must do the dereference. Likewise, - deal with parameters to foreign convention subprograms. Call fold - here since GNU_RESULT may be a CONST_DECL. */ - if (DECL_P (gnu_result) - && (DECL_BY_REF_P (gnu_result) - || (TREE_CODE (gnu_result) == PARM_DECL - && DECL_BY_COMPONENT_PTR_P (gnu_result)))) - { - int ro = DECL_POINTS_TO_READONLY_P (gnu_result); - tree initial; - - if (TREE_CODE (gnu_result) == PARM_DECL - && DECL_BY_COMPONENT_PTR_P (gnu_result)) - gnu_result - = build_unary_op (INDIRECT_REF, NULL_TREE, - convert (build_pointer_type (gnu_result_type), - gnu_result)); - - /* If the object is constant, we try to do the dereference directly - through the DECL_INITIAL. This is actually required in order to - get correct aliasing information for renamed objects that are - components of non-aliased aggregates, because the type of the - renamed object and that of the aggregate don't alias. - - Note that we expect the initial value to have been stabilized. - If it contains e.g. a variable reference, we certainly don't want - to re-evaluate the variable each time the renaming is used. - - Stabilization is currently not performed at the global level but - create_var_decl avoids setting DECL_INITIAL if the value is not - constant then, and we get to the pointer dereference below. - - ??? Couldn't the aliasing issue show up again in this case ? - There is no obvious reason why not. */ - else if (TREE_READONLY (gnu_result) - && DECL_INITIAL (gnu_result) - /* Strip possible conversion to reference type. */ - && ((initial = TREE_CODE (DECL_INITIAL (gnu_result)) - == NOP_EXPR - ? TREE_OPERAND (DECL_INITIAL (gnu_result), 0) - : DECL_INITIAL (gnu_result), 1)) - && TREE_CODE (initial) == ADDR_EXPR - && (TREE_CODE (TREE_OPERAND (initial, 0)) == ARRAY_REF - || (TREE_CODE (TREE_OPERAND (initial, 0)) - == COMPONENT_REF))) - gnu_result = TREE_OPERAND (initial, 0); - else - gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, - fold (gnu_result)); - - TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro; - } - - /* The GNAT tree has the type of a function as the type of its result. - Also use the type of the result if the Etype is a subtype which - is nominally unconstrained. But remove any padding from the - resulting type. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE - || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)) - { - gnu_result_type = TREE_TYPE (gnu_result); - if (TREE_CODE (gnu_result_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_result_type)) - gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type)); - } - - /* We always want to return the underlying INTEGER_CST for an - enumeration literal to avoid the need to call fold in lots - of places. But don't do this is the parent will be taking - the address of this object. */ - if (TREE_CODE (gnu_result) == CONST_DECL) - { - gnat_temp = Parent (gnat_node); - if (DECL_CONST_CORRESPONDING_VAR (gnu_result) == 0 - || (Nkind (gnat_temp) != N_Reference - && ! (Nkind (gnat_temp) == N_Attribute_Reference - && ((Get_Attribute_Id (Attribute_Name (gnat_temp)) - == Attr_Address) - || (Get_Attribute_Id (Attribute_Name (gnat_temp)) - == Attr_Access) - || (Get_Attribute_Id (Attribute_Name (gnat_temp)) - == Attr_Unchecked_Access) - || (Get_Attribute_Id (Attribute_Name (gnat_temp)) - == Attr_Unrestricted_Access))))) - gnu_result = DECL_INITIAL (gnu_result); - } + gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type); break; case N_Integer_Literal: @@ -657,9 +2510,6 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result_type = get_unpadded_type (Etype (gnat_node)); if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR) { - /* We assume here that all strings are of type standard.string. - "Weird" types of string have been converted to an aggregate - by the expander. */ String_Id gnat_string = Strval (gnat_node); int length = String_Length (gnat_string); char *string = (char *) alloca (length + 1); @@ -711,58 +2561,7 @@ gnat_to_gnu (Node_Id gnat_node) case N_Pragma: gnu_result = alloc_stmt_list (); - /* Check for (and ignore) unrecognized pragma and do nothing if - we are just annotating types. */ - if (type_annotate_only - || ! Is_Pragma_Name (Chars (gnat_node))) - break; - - switch (Get_Pragma_Id (Chars (gnat_node))) - { - case Pragma_Inspection_Point: - /* Do nothing at top level: all such variables are already - viewable. */ - if (global_bindings_p ()) - break; - - for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); - Present (gnat_temp); - gnat_temp = Next (gnat_temp)) - { - gnu_expr = gnat_to_gnu (Expression (gnat_temp)); - if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF) - gnu_expr = TREE_OPERAND (gnu_expr, 0); - - gnu_expr = build1 (USE_STMT, void_type_node, gnu_expr); - add_stmt (gnu_expr); - } - break; - - case Pragma_Optimize: - switch (Chars (Expression - (First (Pragma_Argument_Associations (gnat_node))))) - { - case Name_Time: case Name_Space: - if (optimize == 0) - post_error ("insufficient -O value?", gnat_node); - break; - - case Name_Off: - if (optimize != 0) - post_error ("must specify -O0?", gnat_node); - break; - - default: - gigi_abort (331); - break; - } - break; - - case Pragma_Reviewable: - if (write_symbols == NO_DEBUG) - post_error ("must specify -g?", gnat_node); - break; - } + Pragma_to_gnu (gnat_node); break; /**************************************/ @@ -1073,9 +2872,6 @@ gnat_to_gnu (Node_Id gnat_node) { /* The attribute designator (like an enumeration value). */ int attribute = Get_Attribute_Id (Attribute_Name (gnat_node)); - int prefix_unused = 0; - tree gnu_prefix; - tree gnu_type; /* The Elab_Spec and Elab_Body attributes are special in that Prefix is a unit, not an object with a GCC equivalent. Similarly @@ -1087,575 +2883,7 @@ gnat_to_gnu (Node_Id gnat_node) ? "elabb" : "elabs"), NULL_TREE, void_ftype, NULL_TREE, 0, 1, 1, 0, gnat_node)); - gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); - gnu_type = TREE_TYPE (gnu_prefix); - - /* If the input is a NULL_EXPR, make a new one. */ - if (TREE_CODE (gnu_prefix) == NULL_EXPR) - { - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = build1 (NULL_EXPR, gnu_result_type, - TREE_OPERAND (gnu_prefix, 0)); - break; - } - - switch (attribute) - { - case Attr_Pos: - case Attr_Val: - /* These are just conversions until since representation - clauses for enumerations are handled in the front end. */ - { - int check_p = Do_Range_Check (First (Expressions (gnat_node))); - - gnu_result = gnat_to_gnu (First (Expressions (gnat_node))); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = convert_with_check (Etype (gnat_node), gnu_result, - check_p, check_p, 1); - } - break; - - case Attr_Pred: - case Attr_Succ: - /* These just add or subject the constant 1. Representation - clauses for enumerations are handled in the front-end. */ - gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - if (Do_Range_Check (First (Expressions (gnat_node)))) - { - gnu_expr = protect_multiple_eval (gnu_expr); - gnu_expr - = emit_check - (build_binary_op (EQ_EXPR, integer_type_node, - gnu_expr, - attribute == Attr_Pred - ? TYPE_MIN_VALUE (gnu_result_type) - : TYPE_MAX_VALUE (gnu_result_type)), - gnu_expr, CE_Range_Check_Failed); - } - - gnu_result - = build_binary_op (attribute == Attr_Pred - ? MINUS_EXPR : PLUS_EXPR, - gnu_result_type, gnu_expr, - convert (gnu_result_type, integer_one_node)); - break; - - case Attr_Address: - case Attr_Unrestricted_Access: - - /* Conversions don't change something's address but can cause - us to miss the COMPONENT_REF case below, so strip them off. */ - gnu_prefix - = remove_conversions (gnu_prefix, - ! Must_Be_Byte_Aligned (gnat_node)); - - /* If we are taking 'Address of an unconstrained object, - this is the pointer to the underlying array. */ - gnu_prefix = maybe_unconstrained_array (gnu_prefix); - - /* ... fall through ... */ - - case Attr_Access: - case Attr_Unchecked_Access: - case Attr_Code_Address: - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result - = build_unary_op (((attribute == Attr_Address - || attribute == Attr_Unrestricted_Access) - && ! Must_Be_Byte_Aligned (gnat_node)) - ? ATTR_ADDR_EXPR : ADDR_EXPR, - gnu_result_type, gnu_prefix); - - /* For 'Code_Address, find an inner ADDR_EXPR and mark it - so that we don't try to build a trampoline. */ - if (attribute == Attr_Code_Address) - { - for (gnu_expr = gnu_result; - TREE_CODE (gnu_expr) == NOP_EXPR - || TREE_CODE (gnu_expr) == CONVERT_EXPR; - gnu_expr = TREE_OPERAND (gnu_expr, 0)) - TREE_CONSTANT (gnu_expr) = 1; - ; - - if (TREE_CODE (gnu_expr) == ADDR_EXPR) - TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1; - } - - break; - - case Attr_Pool_Address: - { - tree gnu_obj_type; - tree gnu_ptr = gnu_prefix; - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - /* If this is an unconstrained array, we know the object must - have been allocated with the template in front of the object. - So compute the template address.*/ - - if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) - gnu_ptr - = convert (build_pointer_type - (TYPE_OBJECT_RECORD_TYPE - (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), - gnu_ptr); - - gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); - if (TREE_CODE (gnu_obj_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type)) - { - tree gnu_char_ptr_type = build_pointer_type (char_type_node); - tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type)); - tree gnu_byte_offset - = convert (gnu_char_ptr_type, - size_diffop (size_zero_node, gnu_pos)); - - gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr); - gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type, - gnu_ptr, gnu_byte_offset); - } - - gnu_result = convert (gnu_result_type, gnu_ptr); - } - break; - - case Attr_Size: - case Attr_Object_Size: - case Attr_Value_Size: - case Attr_Max_Size_In_Storage_Elements: - - gnu_expr = gnu_prefix; - - /* Remove NOPS from gnu_expr and conversions from gnu_prefix. - We only use GNU_EXPR to see if a COMPONENT_REF was involved. */ - while (TREE_CODE (gnu_expr) == NOP_EXPR) - gnu_expr = TREE_OPERAND (gnu_expr, 0); - - gnu_prefix = remove_conversions (gnu_prefix, 1); - prefix_unused = 1; - gnu_type = TREE_TYPE (gnu_prefix); - - /* Replace an unconstrained array type with the type of the - underlying array. We can't do this with a call to - maybe_unconstrained_array since we may have a TYPE_DECL. - For 'Max_Size_In_Storage_Elements, use the record type - that will be used to allocate the object and its template. */ - - if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) - { - gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type); - if (attribute != Attr_Max_Size_In_Storage_Elements) - gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); - } - - /* If we are looking for the size of a field, return the - field size. Otherwise, if the prefix is an object, - or if 'Object_Size or 'Max_Size_In_Storage_Elements has - been specified, the result is the GCC size of the type. - Otherwise, the result is the RM_Size of the type. */ - if (TREE_CODE (gnu_prefix) == COMPONENT_REF) - gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1)); - else if (TREE_CODE (gnu_prefix) != TYPE_DECL - || attribute == Attr_Object_Size - || attribute == Attr_Max_Size_In_Storage_Elements) - { - /* If this is a padded type, the GCC size isn't relevant - to the programmer. Normally, what we want is the RM_Size, - which was set from the specified size, but if it was not - set, we want the size of the relevant field. Using the MAX - of those two produces the right result in all case. Don't - use the size of the field if it's a self-referential type, - since that's never what's wanted. */ - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type) - && TREE_CODE (gnu_expr) == COMPONENT_REF) - { - gnu_result = rm_size (gnu_type); - if (! (CONTAINS_PLACEHOLDER_P - (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))) - gnu_result - = size_binop (MAX_EXPR, gnu_result, - DECL_SIZE (TREE_OPERAND (gnu_expr, 1))); - } - else - gnu_result = TYPE_SIZE (gnu_type); - } - else - gnu_result = rm_size (gnu_type); - - if (gnu_result == 0) - gigi_abort (325); - - /* Deal with a self-referential size by returning the maximum - size for a type and by qualifying the size with - the object for 'Size of an object. */ - - if (CONTAINS_PLACEHOLDER_P (gnu_result)) - { - if (TREE_CODE (gnu_prefix) != TYPE_DECL) - gnu_result = substitute_placeholder_in_expr (gnu_result, - gnu_expr); - else - gnu_result = max_size (gnu_result, 1); - } - - /* If the type contains a template, subtract the size of the - template. */ - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) - gnu_result = size_binop (MINUS_EXPR, gnu_result, - DECL_SIZE (TYPE_FIELDS (gnu_type))); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - /* Always perform division using unsigned arithmetic as the - size cannot be negative, but may be an overflowed positive - value. This provides correct results for sizes up to 512 MB. - ??? Size should be calculated in storage elements directly. */ - - if (attribute == Attr_Max_Size_In_Storage_Elements) - gnu_result = convert (sizetype, - fold (build (CEIL_DIV_EXPR, bitsizetype, - gnu_result, - bitsize_unit_node))); - break; - - case Attr_Alignment: - if (TREE_CODE (gnu_prefix) == COMPONENT_REF - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P - (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) - gnu_prefix = TREE_OPERAND (gnu_prefix, 0); - - gnu_type = TREE_TYPE (gnu_prefix); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - prefix_unused = 1; - - if (TREE_CODE (gnu_prefix) == COMPONENT_REF) - gnu_result - = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1))); - else - gnu_result = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT); - break; - - case Attr_First: - case Attr_Last: - case Attr_Range_Length: - prefix_unused = 1; - - if (INTEGRAL_TYPE_P (gnu_type) - || TREE_CODE (gnu_type) == REAL_TYPE) - { - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - if (attribute == Attr_First) - gnu_result = TYPE_MIN_VALUE (gnu_type); - else if (attribute == Attr_Last) - gnu_result = TYPE_MAX_VALUE (gnu_type); - else - gnu_result - = build_binary_op - (MAX_EXPR, get_base_type (gnu_result_type), - build_binary_op - (PLUS_EXPR, get_base_type (gnu_result_type), - build_binary_op (MINUS_EXPR, - get_base_type (gnu_result_type), - convert (gnu_result_type, - TYPE_MAX_VALUE (gnu_type)), - convert (gnu_result_type, - TYPE_MIN_VALUE (gnu_type))), - convert (gnu_result_type, integer_one_node)), - convert (gnu_result_type, integer_zero_node)); - - break; - } - /* ... fall through ... */ - case Attr_Length: - { - int Dimension - = (Present (Expressions (gnat_node)) - ? UI_To_Int (Intval (First (Expressions (gnat_node)))) - : 1); - - /* Make sure any implicit dereference gets done. */ - gnu_prefix = maybe_implicit_deref (gnu_prefix); - gnu_prefix = maybe_unconstrained_array (gnu_prefix); - gnu_type = TREE_TYPE (gnu_prefix); - prefix_unused = 1; - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - if (TYPE_CONVENTION_FORTRAN_P (gnu_type)) - { - int ndim; - tree gnu_type_temp; - - for (ndim = 1, gnu_type_temp = gnu_type; - TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp)); - ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp)) - ; - - Dimension = ndim + 1 - Dimension; - } - - for (; Dimension > 1; Dimension--) - gnu_type = TREE_TYPE (gnu_type); - - if (TREE_CODE (gnu_type) != ARRAY_TYPE) - gigi_abort (309); - - if (attribute == Attr_First) - gnu_result - = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); - else if (attribute == Attr_Last) - gnu_result - = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); - else - /* 'Length or 'Range_Length. */ - { - tree gnu_compute_type - = gnat_signed_or_unsigned_type - (0, get_base_type (gnu_result_type)); - - gnu_result - = build_binary_op - (MAX_EXPR, gnu_compute_type, - build_binary_op - (PLUS_EXPR, gnu_compute_type, - build_binary_op - (MINUS_EXPR, gnu_compute_type, - convert (gnu_compute_type, - TYPE_MAX_VALUE - (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))), - convert (gnu_compute_type, - TYPE_MIN_VALUE - (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))), - convert (gnu_compute_type, integer_one_node)), - convert (gnu_compute_type, integer_zero_node)); - } - - /* If this has a PLACEHOLDER_EXPR, qualify it by the object - we are handling. Note that these attributes could not - have been used on an unconstrained array type. */ - gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, - gnu_prefix); - - break; - } - - case Attr_Bit_Position: - case Attr_Position: - case Attr_First_Bit: - case Attr_Last_Bit: - case Attr_Bit: - { - HOST_WIDE_INT bitsize; - HOST_WIDE_INT bitpos; - tree gnu_offset; - tree gnu_field_bitpos; - tree gnu_field_offset; - tree gnu_inner; - enum machine_mode mode; - int unsignedp, volatilep; - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_prefix = remove_conversions (gnu_prefix, 1); - prefix_unused = 1; - - /* We can have 'Bit on any object, but if it isn't a - COMPONENT_REF, the result is zero. Do not allow - 'Bit on a bare component, though. */ - if (attribute == Attr_Bit - && TREE_CODE (gnu_prefix) != COMPONENT_REF - && TREE_CODE (gnu_prefix) != FIELD_DECL) - { - gnu_result = integer_zero_node; - break; - } - - else if (TREE_CODE (gnu_prefix) != COMPONENT_REF - && ! (attribute == Attr_Bit_Position - && TREE_CODE (gnu_prefix) == FIELD_DECL)) - gigi_abort (310); - - get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset, - &mode, &unsignedp, &volatilep); - - if (TREE_CODE (gnu_prefix) == COMPONENT_REF) - { - gnu_field_bitpos - = bit_position (TREE_OPERAND (gnu_prefix, 1)); - gnu_field_offset - = byte_position (TREE_OPERAND (gnu_prefix, 1)); - - for (gnu_inner = TREE_OPERAND (gnu_prefix, 0); - TREE_CODE (gnu_inner) == COMPONENT_REF - && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1)); - gnu_inner = TREE_OPERAND (gnu_inner, 0)) - { - gnu_field_bitpos - = size_binop (PLUS_EXPR, gnu_field_bitpos, - bit_position (TREE_OPERAND (gnu_inner, - 1))); - gnu_field_offset - = size_binop (PLUS_EXPR, gnu_field_offset, - byte_position (TREE_OPERAND (gnu_inner, - 1))); - } - } - else if (TREE_CODE (gnu_prefix) == FIELD_DECL) - { - gnu_field_bitpos = bit_position (gnu_prefix); - gnu_field_offset = byte_position (gnu_prefix); - } - else - { - gnu_field_bitpos = bitsize_zero_node; - gnu_field_offset = size_zero_node; - } - - switch (attribute) - { - case Attr_Position: - gnu_result = gnu_field_offset; - break; - - case Attr_First_Bit: - case Attr_Bit: - gnu_result = size_int (bitpos % BITS_PER_UNIT); - break; - - case Attr_Last_Bit: - gnu_result = bitsize_int (bitpos % BITS_PER_UNIT); - gnu_result - = size_binop (PLUS_EXPR, gnu_result, - TYPE_SIZE (TREE_TYPE (gnu_prefix))); - gnu_result = size_binop (MINUS_EXPR, gnu_result, - bitsize_one_node); - break; - - case Attr_Bit_Position: - gnu_result = gnu_field_bitpos; - break; - } - - /* If this has a PLACEHOLDER_EXPR, qualify it by the object - we are handling. */ - gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, - gnu_prefix); - - break; - } - - case Attr_Min: - case Attr_Max: - gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node))); - gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node)))); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = build_binary_op (attribute == Attr_Min - ? MIN_EXPR : MAX_EXPR, - gnu_result_type, gnu_lhs, gnu_rhs); - break; - - case Attr_Passed_By_Reference: - gnu_result = size_int (default_pass_by_ref (gnu_type) - || must_pass_by_ref (gnu_type)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - break; - - case Attr_Component_Size: - if (TREE_CODE (gnu_prefix) == COMPONENT_REF - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P - (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) - gnu_prefix = TREE_OPERAND (gnu_prefix, 0); - - gnu_prefix = maybe_implicit_deref (gnu_prefix); - gnu_type = TREE_TYPE (gnu_prefix); - - if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) - gnu_type - = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type)))); - - while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) - gnu_type = TREE_TYPE (gnu_type); - - if (TREE_CODE (gnu_type) != ARRAY_TYPE) - gigi_abort (330); - - /* Note this size cannot be self-referential. */ - gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - prefix_unused = 1; - break; - - case Attr_Null_Parameter: - /* This is just a zero cast to the pointer type for - our prefix and dereferenced. */ - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result - = build_unary_op (INDIRECT_REF, NULL_TREE, - convert (build_pointer_type (gnu_result_type), - integer_zero_node)); - TREE_PRIVATE (gnu_result) = 1; - break; - - case Attr_Mechanism_Code: - { - int code; - Entity_Id gnat_obj = Entity (Prefix (gnat_node)); - - prefix_unused = 1; - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - if (Present (Expressions (gnat_node))) - { - int i = UI_To_Int (Intval (First (Expressions (gnat_node)))); - - for (gnat_obj = First_Formal (gnat_obj); i > 1; - i--, gnat_obj = Next_Formal (gnat_obj)) - ; - } - - code = Mechanism (gnat_obj); - if (code == Default) - code = ((present_gnu_tree (gnat_obj) - && (DECL_BY_REF_P (get_gnu_tree (gnat_obj)) - || ((TREE_CODE (get_gnu_tree (gnat_obj)) - == PARM_DECL) - && (DECL_BY_COMPONENT_PTR_P - (get_gnu_tree (gnat_obj)))))) - ? By_Reference : By_Copy); - gnu_result = convert (gnu_result_type, size_int (- code)); - } - break; - - default: - /* Say we have an unimplemented attribute. Then set the - value to be returned to be a zero and hope that's something - we can convert to the type of this attribute. */ - - post_error ("unimplemented attribute", gnat_node); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = integer_zero_node; - break; - } - - /* If this is an attribute where the prefix was unused, - force a use of it if it has a side-effect. But don't do it if - the prefix is just an entity name. However, if an access check - is needed, we must do it. See second example in AARM 11.6(5.e). */ - if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix) - && ! Is_Entity_Name (Prefix (gnat_node))) - gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result), - gnu_prefix, gnu_result)); + gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute); } break; @@ -2114,253 +3342,11 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Case_Statement: - { - Node_Id gnat_when; - - gnu_expr = gnat_to_gnu (Expression (gnat_node)); - gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); - - /* The range of values in a case statement is determined by the - rules in RM 5.4(7-9). In almost all cases, this range is - represented by the Etype of the expression. One exception arises - in the case of a simple name that is parenthesized. This still - has the Etype of the name, but since it is not a name, para 7 - does not apply, and we need to go to the base type. This is the - only case where parenthesization affects the dynamic semantics - (i.e. the range of possible values at runtime that is covered by - the others alternative. - - Another exception is if the subtype of the expression is - non-static. In that case, we also have to use the base type. */ - if (Paren_Count (Expression (gnat_node)) != 0 - || !Is_OK_Static_Subtype (Underlying_Type - (Etype (Expression (gnat_node))))) - gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); - - /* We build a SWITCH_EXPR that contains the code with interspersed - CASE_LABEL_EXPRs for each label. */ - - push_stack (&gnu_switch_label_stack, NULL_TREE, - create_artificial_label ()); - start_stmt_group (); - for (gnat_when = First_Non_Pragma (Alternatives (gnat_node)); - Present (gnat_when); - gnat_when = Next_Non_Pragma (gnat_when)) - { - Node_Id gnat_choice; - - /* First compile all the different case choices for the current - WHEN alternative. */ - for (gnat_choice = First (Discrete_Choices (gnat_when)); - Present (gnat_choice); gnat_choice = Next (gnat_choice)) - { - tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; - - switch (Nkind (gnat_choice)) - { - case N_Range: - gnu_low = gnat_to_gnu (Low_Bound (gnat_choice)); - gnu_high = gnat_to_gnu (High_Bound (gnat_choice)); - break; - - case N_Subtype_Indication: - gnu_low = gnat_to_gnu (Low_Bound - (Range_Expression - (Constraint (gnat_choice)))); - gnu_high = gnat_to_gnu (High_Bound - (Range_Expression - (Constraint (gnat_choice)))); - break; - - case N_Identifier: - case N_Expanded_Name: - /* This represents either a subtype range or a static value - of some kind; Ekind says which. If a static value, - fall through to the next case. */ - if (IN (Ekind (Entity (gnat_choice)), Type_Kind)) - { - tree gnu_type - = get_unpadded_type (Entity (gnat_choice)); - - gnu_low = fold (TYPE_MIN_VALUE (gnu_type)); - gnu_high = fold (TYPE_MAX_VALUE (gnu_type)); - break; - } - - /* ... fall through ... */ - case N_Character_Literal: - case N_Integer_Literal: - gnu_low = gnat_to_gnu (gnat_choice); - break; - - case N_Others_Choice: - break; - - default: - gigi_abort (316); - } - - add_stmt_with_node (build (CASE_LABEL_EXPR, void_type_node, - gnu_low, gnu_high, - create_artificial_label ()), - gnat_choice); - } - - /* Push a binding level here in case variables are declared since - we want them to be local to this set of statements instead of - the block containing the Case statement. */ - add_stmt (build_stmt_group (Statements (gnat_when), true)); - add_stmt (build1 (GOTO_EXPR, void_type_node, - TREE_VALUE (gnu_switch_label_stack))); - - } - - /* Now emit a definition of the label all the cases branched to. */ - add_stmt (build1 (LABEL_EXPR, void_type_node, - TREE_VALUE (gnu_switch_label_stack))); - gnu_result = build (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, - end_stmt_group (), NULL_TREE); - pop_stack (&gnu_switch_label_stack); - break; - } + gnu_result = Case_Statement_to_gnu (gnat_node); + break; case N_Loop_Statement: - { - /* ??? It would be nice to use "build" here, but there's no build5. */ - tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, NULL_TREE); - tree gnu_loop_var = NULL_TREE; - Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); - tree gnu_cond_expr = NULL_TREE; - - TREE_TYPE (gnu_loop_stmt) = void_type_node; - TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1; - LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (); - annotate_with_node (gnu_loop_stmt, gnat_node); - - /* Save the end label of this LOOP_STMT in a stack so that the - corresponding N_Exit_Statement can find it. */ - push_stack (&gnu_loop_label_stack, NULL_TREE, - LOOP_STMT_LABEL (gnu_loop_stmt)); - - /* Set the condition that under which the loop should continue. - For "LOOP .... END LOOP;" the condition is always true. */ - if (No (gnat_iter_scheme)) - ; - /* The case "WHILE condition LOOP ..... END LOOP;" */ - else if (Present (Condition (gnat_iter_scheme))) - LOOP_STMT_TOP_COND (gnu_loop_stmt) - = gnat_to_gnu (Condition (gnat_iter_scheme)); - else - { - /* We have an iteration scheme. */ - Node_Id gnat_loop_spec - = Loop_Parameter_Specification (gnat_iter_scheme); - Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec); - Entity_Id gnat_type = Etype (gnat_loop_var); - tree gnu_type = get_unpadded_type (gnat_type); - tree gnu_low = TYPE_MIN_VALUE (gnu_type); - tree gnu_high = TYPE_MAX_VALUE (gnu_type); - int reversep = Reverse_Present (gnat_loop_spec); - tree gnu_first = reversep ? gnu_high : gnu_low; - tree gnu_last = reversep ? gnu_low : gnu_high; - enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR; - tree gnu_base_type = get_base_type (gnu_type); - tree gnu_limit - = (reversep ? TYPE_MIN_VALUE (gnu_base_type) - : TYPE_MAX_VALUE (gnu_base_type)); - - /* We know the loop variable will not overflow if GNU_LAST is - a constant and is not equal to GNU_LIMIT. If it might - overflow, we have to move the limit test to the end of - the loop. In that case, we have to test for an - empty loop outside the loop. */ - if (TREE_CODE (gnu_last) != INTEGER_CST - || TREE_CODE (gnu_limit) != INTEGER_CST - || tree_int_cst_equal (gnu_last, gnu_limit)) - { - gnu_cond_expr - = build (COND_EXPR, void_type_node, - build_binary_op (LE_EXPR, integer_type_node, - gnu_low, gnu_high), - NULL_TREE, alloc_stmt_list ()); - annotate_with_node (gnu_cond_expr, gnat_loop_spec); - } - - /* Open a new nesting level that will surround the loop to declare - the loop index variable. */ - start_stmt_group (); - gnat_pushlevel (); - - /* Declare the loop index and set it to its initial value. */ - gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1); - if (DECL_BY_REF_P (gnu_loop_var)) - gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, - gnu_loop_var); - - /* The loop variable might be a padded type, so use `convert' to - get a reference to the inner variable if so. */ - gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var); - - /* Set either the top or bottom exit condition as - appropriate depending on whether we know an overflow - cannot occur or not. */ - if (gnu_cond_expr) - LOOP_STMT_BOT_COND (gnu_loop_stmt) - = build_binary_op (NE_EXPR, integer_type_node, - gnu_loop_var, gnu_last); - else - LOOP_STMT_TOP_COND (gnu_loop_stmt) - = build_binary_op (end_code, integer_type_node, - gnu_loop_var, gnu_last); - - LOOP_STMT_UPDATE (gnu_loop_stmt) - = build_binary_op (reversep ? PREDECREMENT_EXPR - : PREINCREMENT_EXPR, - TREE_TYPE (gnu_loop_var), - gnu_loop_var, - convert (TREE_TYPE (gnu_loop_var), - integer_one_node)); - annotate_with_node (LOOP_STMT_UPDATE (gnu_loop_stmt), - gnat_iter_scheme); - } - - /* If the loop was named, have the name point to this loop. In this case, - the association is not a ..._DECL node, but the end label from this - LOOP_STMT. */ - if (Present (Identifier (gnat_node))) - save_gnu_tree (Entity (Identifier (gnat_node)), - LOOP_STMT_LABEL (gnu_loop_stmt), 1); - - /* Make the loop body into its own block, so any allocated storage - will be released every iteration. This is needed for stack - allocation. */ - LOOP_STMT_BODY (gnu_loop_stmt) - = build_stmt_group (Statements (gnat_node), true); - - /* If we declared a variable, then we are in a statement group for - that declaration. Add the LOOP_STMT to it and make that the - "loop". */ - if (gnu_loop_var) - { - add_stmt (gnu_loop_stmt); - gnat_poplevel (); - gnu_loop_stmt = end_stmt_group (); - } - - /* If we have an outer COND_EXPR, that's our result and this loop - is its "true" statement. Otherwise, the result is the LOOP_STMT. */ - if (gnu_cond_expr) - { - COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt; - gnu_result = gnu_cond_expr; - recalculate_side_effects (gnu_cond_expr); - } - else - gnu_result = gnu_loop_stmt; - - pop_stack (&gnu_loop_label_stack); - } + gnu_result = Loop_Statement_to_gnu (gnat_node); break; case N_Block_Statement: @@ -2522,643 +3508,13 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Subprogram_Body: - { - /* Save debug output mode in case it is reset. */ - enum debug_info_type save_write_symbols = write_symbols; - const struct gcc_debug_hooks *const save_debug_hooks = debug_hooks; - /* Definining identifier of a parameter to the subprogram. */ - Entity_Id gnat_param; - /* The defining identifier for the subprogram body. Note that if a - specification has appeared before for this body, then the identifier - occurring in that specification will also be a defining identifier - and all the calls to this subprogram will point to that - specification. */ - Entity_Id gnat_subprog_id - = (Present (Corresponding_Spec (gnat_node)) - ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node)); - - /* The FUNCTION_DECL node corresponding to the subprogram spec. */ - tree gnu_subprog_decl; - /* The FUNCTION_TYPE node corresponding to the subprogram spec. */ - tree gnu_subprog_type; - tree gnu_cico_list; - - /* If this is a generic object or if it has been eliminated, - ignore it. */ - if (Ekind (gnat_subprog_id) == E_Generic_Procedure - || Ekind (gnat_subprog_id) == E_Generic_Function - || Is_Eliminated (gnat_subprog_id)) - return alloc_stmt_list (); - - /* If debug information is suppressed for the subprogram, turn debug - mode off for the duration of processing. */ - if (!Needs_Debug_Info (gnat_subprog_id)) - { - write_symbols = NO_DEBUG; - debug_hooks = &do_nothing_debug_hooks; - } - - /* If this subprogram acts as its own spec, define it. Otherwise, - just get the already-elaborated tree node. However, if this - subprogram had its elaboration deferred, we will already have made - a tree node for it. So treat it as not being defined in that - case. Such a subprogram cannot have an address clause or a freeze - node, so this test is safe, though it does disable some - otherwise-useful error checking. */ - gnu_subprog_decl - = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, - Acts_As_Spec (gnat_node) - && ! present_gnu_tree (gnat_subprog_id)); - - gnu_subprog_type = TREE_TYPE (gnu_subprog_decl); - - /* Set the line number in the decl to correspond to that of - the body so that the line number notes are written - correctly. */ - Sloc_to_locus (Sloc (gnat_node), - &DECL_SOURCE_LOCATION (gnu_subprog_decl)); - - begin_subprog_body (gnu_subprog_decl); - - gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); - - /* If there are OUT parameters, we need to ensure that the return - statement properly copies them out. We do this by making a new - block and converting any inner return into a goto to a label at - the end of the block. */ - push_stack (&gnu_return_label_stack, NULL_TREE, - gnu_cico_list ? create_artificial_label () : NULL_TREE); - - /* Get a tree corresponding to the code for the subprogram. */ - start_stmt_group (); - gnat_pushlevel (); - - /* See if there are any parameters for which we don't yet have - GCC entities. These must be for OUT parameters for which we - will be making VAR_DECL nodes here. Fill them in to - TYPE_CI_CO_LIST, which must contain the empty entry as well. - We can match up the entries because TYPE_CI_CO_LIST is in the - order of the parameters. */ - for (gnat_param = First_Formal (gnat_subprog_id); - Present (gnat_param); - gnat_param = Next_Formal_With_Extras (gnat_param)) - if (!present_gnu_tree (gnat_param)) - { - /* Skip any entries that have been already filled in; they - must correspond to IN OUT parameters. */ - for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0; - gnu_cico_list = TREE_CHAIN (gnu_cico_list)) - ; - - /* Do any needed references for padded types. */ - TREE_VALUE (gnu_cico_list) - = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)), - gnat_to_gnu_entity (gnat_param, NULL_TREE, 1)); - } - - process_decls (Declarations (gnat_node), Empty, Empty, 1, 1); - - /* Generate the code of the subprogram itself. A return statement - will be present and any OUT parameters will be handled there. */ - add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); - gnat_poplevel (); - gnu_result = end_stmt_group (); - - /* If we made a special return label, we need to make a block that - contains the definition of that label and the copying to the - return value. That block first contains the function, then - the label and copy statement. */ - if (TREE_VALUE (gnu_return_label_stack) != 0) - { - tree gnu_retval; - - start_stmt_group (); - gnat_pushlevel (); - add_stmt (gnu_result); - add_stmt (build1 (LABEL_EXPR, void_type_node, - TREE_VALUE (gnu_return_label_stack))); - - gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); - if (list_length (gnu_cico_list) == 1) - gnu_retval = TREE_VALUE (gnu_cico_list); - else - gnu_retval - = gnat_build_constructor (TREE_TYPE (gnu_subprog_type), - gnu_cico_list); - - if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval)) - gnu_retval - = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval); - - add_stmt_with_node - (build1 (RETURN_EXPR, void_type_node, - build (MODIFY_EXPR, TREE_TYPE (gnu_retval), - DECL_RESULT (current_function_decl), - gnu_retval)), - gnat_node); - gnat_poplevel (); - gnu_result = end_stmt_group (); - } - - pop_stack (&gnu_return_label_stack); - - /* Initialize the information node for the function and set the - end location. */ - allocate_struct_function (current_function_decl); - Sloc_to_locus - ((Present (End_Label (Handled_Statement_Sequence (gnat_node))) - ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node))) - : Sloc (gnat_node)), - &cfun->function_end_locus); - - end_subprog_body (gnu_result); - - /* Disconnect the trees for parameters that we made variables for - from the GNAT entities since these will become unusable after - we end the function. */ - for (gnat_param = First_Formal (gnat_subprog_id); - Present (gnat_param); - gnat_param = Next_Formal_With_Extras (gnat_param)) - if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL) - save_gnu_tree (gnat_param, NULL_TREE, 0); - - mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node))); - write_symbols = save_write_symbols; - debug_hooks = save_debug_hooks; - gnu_result = alloc_stmt_list (); - } + Subprogram_Body_to_gnu (gnat_node); + gnu_result = alloc_stmt_list (); break; case N_Function_Call: case N_Procedure_Call_Statement: - { - /* The GCC node corresponding to the GNAT subprogram name. This can - either be a FUNCTION_DECL node if we are dealing with a standard - subprogram call, or an indirect reference expression (an - INDIRECT_REF node) pointing to a subprogram. */ - tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node)); - /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ - tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node); - tree gnu_subprog_addr - = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog_node); - Entity_Id gnat_formal; - Node_Id gnat_actual; - tree gnu_actual_list = NULL_TREE; - tree gnu_name_list = NULL_TREE; - tree gnu_before_list = NULL_TREE; - tree gnu_after_list = NULL_TREE; - tree gnu_subprog_call; - - switch (Nkind (Name (gnat_node))) - { - case N_Identifier: - case N_Operator_Symbol: - case N_Expanded_Name: - case N_Attribute_Reference: - if (Is_Eliminated (Entity (Name (gnat_node)))) - Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node))); - } - - if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE) - gigi_abort (317); - - /* If we are calling a stubbed function, make this into a - raise of Program_Error. Elaborate all our args first. */ - - if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL - && DECL_STUBBED_P (gnu_subprog_node)) - { - for (gnat_actual = First_Actual (gnat_node); - Present (gnat_actual); - gnat_actual = Next_Actual (gnat_actual)) - add_stmt (gnat_to_gnu (gnat_actual)); - - if (Nkind (gnat_node) == N_Function_Call) - { - gnu_result_type = TREE_TYPE (gnu_subprog_type); - gnu_result - = build1 (NULL_EXPR, gnu_result_type, - build_call_raise (PE_Stubbed_Subprogram_Called)); - } - else - gnu_result = build_call_raise (PE_Stubbed_Subprogram_Called); - break; - } - - /* The only way we can be making a call via an access type is - if Name is an explicit dereference. In that case, get the - list of formal args from the type the access type is pointing - to. Otherwise, get the formals from entity being called. */ - if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) - gnat_formal = First_Formal (Etype (Name (gnat_node))); - else if (Nkind (Name (gnat_node)) == N_Attribute_Reference) - /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */ - gnat_formal = 0; - else - gnat_formal = First_Formal (Entity (Name (gnat_node))); - - /* Create the list of the actual parameters as GCC expects it, namely - a chain of TREE_LIST nodes in which the TREE_VALUE field of each - node is a parameter-expression and the TREE_PURPOSE field is - null. Skip OUT parameters that are not passed by reference and - don't need to be copied in. */ - - for (gnat_actual = First_Actual (gnat_node); - Present (gnat_actual); - gnat_formal = Next_Formal_With_Extras (gnat_formal), - gnat_actual = Next_Actual (gnat_actual)) - { - tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal)); - /* We treat a conversion between aggregate types as if it - is an unchecked conversion. */ - int unchecked_convert_p - = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion - || (Nkind (gnat_actual) == N_Type_Conversion - && Is_Composite_Type (Underlying_Type - (Etype (gnat_formal))))); - Node_Id gnat_name - = unchecked_convert_p ? Expression (gnat_actual) : gnat_actual; - tree gnu_name = gnat_to_gnu (gnat_name); - tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)); - tree gnu_actual; - - /* If it's possible we may need to use this expression twice, - make sure than any side-effects are handled via SAVE_EXPRs. - Likewise if we need to force side-effects before the call. - ??? This is more conservative than we need since we don't - need to do this for pass-by-ref with no conversion. - If we are passing a non-addressable Out or In Out parameter by - reference, pass the address of a copy and set up to copy back - out after the call. */ - - if (Ekind (gnat_formal) != E_In_Parameter) - { - gnu_name = gnat_stabilize_reference (gnu_name, 1); - if (! addressable_p (gnu_name) - && present_gnu_tree (gnat_formal) - && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) - || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && (DECL_BY_COMPONENT_PTR_P - (get_gnu_tree (gnat_formal)) - || DECL_BY_DESCRIPTOR_P - (get_gnu_tree (gnat_formal)))))) - { - tree gnu_copy = gnu_name; - tree gnu_temp; - - /* Remove any unpadding on the actual and make a copy. - But if the actual is a left-justified modular type, - first convert to it. */ - if (TREE_CODE (gnu_name) == COMPONENT_REF - && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P - (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))))) - gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0); - else if (TREE_CODE (gnu_name_type) == RECORD_TYPE - && (TYPE_LEFT_JUSTIFIED_MODULAR_P - (gnu_name_type))) - gnu_name = convert (gnu_name_type, gnu_name); - - gnu_actual = save_expr (gnu_name); - - /* Since we're going to take the address of the SAVE_EXPR, - we don't want it to be marked as unchanging. - So set TREE_ADDRESSABLE. */ - gnu_temp = skip_simple_arithmetic (gnu_actual); - if (TREE_CODE (gnu_temp) == SAVE_EXPR) - { - TREE_ADDRESSABLE (gnu_temp) = 1; - TREE_READONLY (gnu_temp) = 0; - } - - /* Set up to move the copy back to the original. */ - gnu_temp = build (MODIFY_EXPR, TREE_TYPE (gnu_copy), - gnu_copy, gnu_actual); - annotate_with_node (gnu_temp, gnat_actual); - append_to_statement_list (gnu_temp, &gnu_after_list); - } - } - - /* If this was a procedure call, we may not have removed any - padding. So do it here for the part we will use as an - input, if any. */ - gnu_actual = gnu_name; - if (Ekind (gnat_formal) != E_Out_Parameter - && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))) - gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), - gnu_actual); - - /* Unless this is an In parameter, we must remove any LJM building - from GNU_NAME. */ - if (Ekind (gnat_formal) != E_In_Parameter - && TREE_CODE (gnu_name) == CONSTRUCTOR - && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE - && TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name))) - gnu_name - = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), - gnu_name); - - if (Ekind (gnat_formal) != E_Out_Parameter - && ! unchecked_convert_p - && Do_Range_Check (gnat_actual)) - gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal)); - - /* Do any needed conversions. We need only check for - unchecked conversion since normal conversions will be handled - by just converting to the formal type. */ - if (unchecked_convert_p) - { - gnu_actual - = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)), - gnu_actual, - (Nkind (gnat_actual) - == N_Unchecked_Type_Conversion) - && No_Truncation (gnat_actual)); - - /* One we've done the unchecked conversion, we still - must ensure that the object is in range of the formal's - type. */ - if (Ekind (gnat_formal) != E_Out_Parameter - && Do_Range_Check (gnat_actual)) - gnu_actual = emit_range_check (gnu_actual, - Etype (gnat_formal)); - } - else if (TREE_CODE (gnu_actual) != SAVE_EXPR) - /* We may have suppressed a conversion to the Etype of the - actual since the parent is a procedure call. So add the - conversion here. */ - gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), - gnu_actual); - - if (TREE_CODE (gnu_actual) != SAVE_EXPR) - gnu_actual = convert (gnu_formal_type, gnu_actual); - - /* If we have not saved a GCC object for the formal, it means it - is an OUT parameter not passed by reference and that does not - need to be copied in. Otherwise, look at the PARM_DECL to see - if it is passed by reference. */ - if (present_gnu_tree (gnat_formal) - && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && DECL_BY_REF_P (get_gnu_tree (gnat_formal))) - { - if (Ekind (gnat_formal) != E_In_Parameter) - { - gnu_actual = gnu_name; - - /* If we have a padded type, be sure we've removed the - padding. */ - if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)) - && TREE_CODE (gnu_actual) != SAVE_EXPR) - gnu_actual - = convert (get_unpadded_type (Etype (gnat_actual)), - gnu_actual); - } - - /* Otherwise, if we have a non-addressable COMPONENT_REF of a - variable-size type see if it's doing a unpadding operation. - If so, remove that operation since we have no way of - allocating the required temporary. */ - if (TREE_CODE (gnu_actual) == COMPONENT_REF - && ! TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual))) - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0))) - == RECORD_TYPE) - && TYPE_IS_PADDING_P (TREE_TYPE - (TREE_OPERAND (gnu_actual, 0))) - && !addressable_p (gnu_actual)) - gnu_actual = TREE_OPERAND (gnu_actual, 0); - - /* The symmetry of the paths to the type of an entity is - broken here since arguments don't know that they will - be passed by ref. */ - gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); - gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, - gnu_actual); - } - else if (present_gnu_tree (gnat_formal) - && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))) - { - gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); - gnu_actual = maybe_implicit_deref (gnu_actual); - gnu_actual = maybe_unconstrained_array (gnu_actual); - - if (TREE_CODE (gnu_formal_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_formal_type)) - { - gnu_formal_type - = TREE_TYPE (TYPE_FIELDS (gnu_formal_type)); - gnu_actual = convert (gnu_formal_type, gnu_actual); - } - - /* Take the address of the object and convert to the - proper pointer type. We'd like to actually compute - the address of the beginning of the array using - an ADDR_EXPR of an ARRAY_REF, but there's a possibility - that the ARRAY_REF might return a constant and we'd - be getting the wrong address. Neither approach is - exactly correct, but this is the most likely to work - in all cases. */ - gnu_actual = convert (gnu_formal_type, - build_unary_op (ADDR_EXPR, NULL_TREE, - gnu_actual)); - } - else if (present_gnu_tree (gnat_formal) - && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal))) - { - /* If arg is 'Null_Parameter, pass zero descriptor. */ - if ((TREE_CODE (gnu_actual) == INDIRECT_REF - || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF) - && TREE_PRIVATE (gnu_actual)) - gnu_actual - = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)), - integer_zero_node); - else - gnu_actual - = build_unary_op (ADDR_EXPR, NULL_TREE, - fill_vms_descriptor (gnu_actual, - gnat_formal)); - } - else - { - tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual)); - - if (Ekind (gnat_formal) != E_In_Parameter) - gnu_name_list - = chainon (gnu_name_list, - build_tree_list (NULL_TREE, gnu_name)); - - if (! present_gnu_tree (gnat_formal) - || TREE_CODE (get_gnu_tree (gnat_formal)) != PARM_DECL) - continue; - - /* If this is 'Null_Parameter, pass a zero even though we are - dereferencing it. */ - else if (TREE_CODE (gnu_actual) == INDIRECT_REF - && TREE_PRIVATE (gnu_actual) - && host_integerp (gnu_actual_size, 1) - && 0 >= compare_tree_int (gnu_actual_size, - BITS_PER_WORD)) - gnu_actual - = unchecked_convert - (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)), - convert (gnat_type_for_size - (tree_low_cst (gnu_actual_size, 1), 1), - integer_zero_node), 0); - else - gnu_actual - = convert (TYPE_MAIN_VARIANT - (DECL_ARG_TYPE (get_gnu_tree (gnat_formal))), - gnu_actual); - } - - gnu_actual_list - = chainon (gnu_actual_list, - build_tree_list (NULL_TREE, gnu_actual)); - } - - gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type), - gnu_subprog_addr, gnu_actual_list, - NULL_TREE); - TREE_SIDE_EFFECTS (gnu_subprog_call) = 1; - - /* If it is a function call, the result is the call expression. */ - if (Nkind (gnat_node) == N_Function_Call) - { - gnu_result = gnu_subprog_call; - - /* If the function returns an unconstrained array or by reference, - we have to de-dereference the pointer. */ - if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type) - || TYPE_RETURNS_BY_REF_P (gnu_subprog_type)) - gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, - gnu_result); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - break; - } - - /* If this is the case where the GNAT tree contains a procedure call - but the Ada procedure has copy in copy out parameters, the special - parameter passing mechanism must be used. */ - else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE) - { - /* List of FIELD_DECLs associated with the PARM_DECLs of the copy - in copy out parameters. */ - tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type); - int length = list_length (scalar_return_list); - - if (length > 1) - { - tree gnu_name; - - gnu_subprog_call = protect_multiple_eval (gnu_subprog_call); - - /* If any of the names had side-effects, ensure they are - all evaluated before the call. */ - for (gnu_name = gnu_name_list; gnu_name; - gnu_name = TREE_CHAIN (gnu_name)) - if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name))) - gnu_subprog_call - = build (COMPOUND_EXPR, TREE_TYPE (gnu_subprog_call), - TREE_VALUE (gnu_name), gnu_subprog_call); - } - - if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) - gnat_formal = First_Formal (Etype (Name (gnat_node))); - else - gnat_formal = First_Formal (Entity (Name (gnat_node))); - - for (gnat_actual = First_Actual (gnat_node); - Present (gnat_actual); - gnat_formal = Next_Formal_With_Extras (gnat_formal), - gnat_actual = Next_Actual (gnat_actual)) - /* If we are dealing with a copy in copy out parameter, we must - retrieve its value from the record returned in the function - call. */ - if (! (present_gnu_tree (gnat_formal) - && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) - || ((TREE_CODE (get_gnu_tree (gnat_formal)) - == PARM_DECL) - && ((DECL_BY_COMPONENT_PTR_P - (get_gnu_tree (gnat_formal)) - || (DECL_BY_DESCRIPTOR_P - (get_gnu_tree (gnat_formal)))))))) - && Ekind (gnat_formal) != E_In_Parameter) - { - /* Get the value to assign to this OUT or IN OUT - parameter. It is either the result of the function if - there is only a single such parameter or the appropriate - field from the record returned. */ - tree gnu_result - = length == 1 ? gnu_subprog_call - : build_component_ref - (gnu_subprog_call, NULL_TREE, - TREE_PURPOSE (scalar_return_list), 0); - int unchecked_conversion - = Nkind (gnat_actual) == N_Unchecked_Type_Conversion; - /* If the actual is a conversion, get the inner expression, - which will be the real destination, and convert the - result to the type of the actual parameter. */ - tree gnu_actual - = maybe_unconstrained_array (TREE_VALUE (gnu_name_list)); - - /* If the result is a padded type, remove the padding. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) - gnu_result - = convert (TREE_TYPE (TYPE_FIELDS - (TREE_TYPE (gnu_result))), - gnu_result); - - /* If the result is a type conversion, do it. */ - if (Nkind (gnat_actual) == N_Type_Conversion) - gnu_result - = convert_with_check - (Etype (Expression (gnat_actual)), gnu_result, - Do_Overflow_Check (gnat_actual), - Do_Range_Check (Expression (gnat_actual)), - Float_Truncate (gnat_actual)); - - else if (unchecked_conversion) - gnu_result - = unchecked_convert (TREE_TYPE (gnu_actual), gnu_result, - No_Truncation (gnat_actual)); - else - { - if (Do_Range_Check (gnat_actual)) - gnu_result = emit_range_check (gnu_result, - Etype (gnat_actual)); - - if (! (! TREE_CONSTANT (TYPE_SIZE - (TREE_TYPE (gnu_actual))) - && TREE_CONSTANT (TYPE_SIZE - (TREE_TYPE (gnu_result))))) - gnu_result = convert (TREE_TYPE (gnu_actual), - gnu_result); - } - - gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, - gnu_actual, gnu_result); - annotate_with_node (gnu_result, gnat_actual); - append_to_statement_list (gnu_result, &gnu_before_list); - scalar_return_list = TREE_CHAIN (scalar_return_list); - gnu_name_list = TREE_CHAIN (gnu_name_list); - } - } - else - { - annotate_with_node (gnu_subprog_call, gnat_node); - append_to_statement_list (gnu_subprog_call, &gnu_before_list); - } - - append_to_statement_list (gnu_after_list, &gnu_before_list); - gnu_result = gnu_before_list; - } + gnu_result = call_to_gnu (gnat_node, &gnu_result_type); break; /*************************/ @@ -3264,20 +3620,7 @@ gnat_to_gnu (Node_Id gnat_node) /***************************/ case N_Handled_Sequence_Of_Statements: - - /* The GCC exception handling mechanism can handle both ZCX and SJLJ - schemes and we have our own SJLJ mechanism. To call the GCC - mechanism, we call add_cleanup, and when we leave the binding, - end_stmt_group will create the TRY_FINALLY_EXPR. - - ??? The region level calls down there have been specifically put in - place for a ZCX context and currently the order in which things are - emitted (region/handlers) is different from the SJLJ case. Instead of - putting other calls with different conditions at other places for the - SJLJ case, it seems cleaner to reorder things for the SJLJ case and - generalize the condition to make it not ZCX specific. */ - - /* If there is an At_End procedure attached to this node, and the eh + /* If there is an At_End procedure attached to this node, and the EH mechanism is SJLJ, we must have at least a corresponding At_End handler, unless the No_Exception_Handlers restriction is set. */ if (! type_annotate_only @@ -3287,370 +3630,14 @@ gnat_to_gnu (Node_Id gnat_node) && ! No_Exception_Handlers_Set()) gigi_abort (335); - { - tree gnu_jmpsave_decl = NULL_TREE; - tree gnu_jmpbuf_decl = NULL_TREE; - /* If just annotating, ignore all EH and cleanups. */ - bool gcc_zcx - = (!type_annotate_only && Present (Exception_Handlers (gnat_node)) - && Exception_Mechanism == GCC_ZCX); - bool setjmp_longjmp - = (!type_annotate_only && Present (Exception_Handlers (gnat_node)) - && Exception_Mechanism == Setjmp_Longjmp); - bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node)); - bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp); - tree gnu_inner_block; /* The statement(s) for the block itself. */ - - /* If there are any exceptions or cleanup processing involved, we need - an outer statement group (for Setjmp_Longjmp) and binding level. */ - if (binding_for_block) - { - start_stmt_group (); - gnat_pushlevel (); - } - - /* If we are to call a function when exiting this block add a cleanup - to the binding level we made above. */ - if (at_end) - add_cleanup (build_call_0_expr - (gnat_to_gnu (At_End_Proc (gnat_node)))); - - /* If using setjmp_longjmp, make the variables for the setjmp - buffer and save area for address of previous buffer. Do this - first since we need to have the setjmp buf known for any decls - in this block. */ - if (setjmp_longjmp) - { - gnu_jmpsave_decl - = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE, - jmpbuf_ptr_type, - build_call_0_expr (get_jmpbuf_decl), - 0, 0, 0, 0, 0, gnat_node); - gnu_jmpbuf_decl - = create_var_decl (get_identifier ("JMP_BUF"), - NULL_TREE, jmpbuf_type, - NULL_TREE, 0, 0, 0, 0, 0, gnat_node); - - set_block_jmpbuf_decl (gnu_jmpbuf_decl); - - /* When we exit this block, restore the saved value. */ - add_cleanup (build_call_1_expr (set_jmpbuf_decl, - gnu_jmpsave_decl)); - } - - /* Now build the tree for the declarations and statements inside this - block. If this is SJLJ, set our jmp_buf as the current buffer. */ - start_stmt_group (); - - if (setjmp_longjmp) - add_stmt (build_call_1_expr - (set_jmpbuf_decl, - build_unary_op (ADDR_EXPR, NULL_TREE, gnu_jmpbuf_decl))); - - - if (Present (First_Real_Statement (gnat_node))) - process_decls (Statements (gnat_node), Empty, - First_Real_Statement (gnat_node), 1, 1); - - /* Generate code for each statement in the block. */ - for (gnat_temp = (Present (First_Real_Statement (gnat_node)) - ? First_Real_Statement (gnat_node) - : First (Statements (gnat_node))); - Present (gnat_temp); gnat_temp = Next (gnat_temp)) - add_stmt (gnat_to_gnu (gnat_temp)); - gnu_inner_block = end_stmt_group (); - - /* Now generate code for the two exception models, if either is - relevant for this block. */ - if (setjmp_longjmp) - { - tree *gnu_else_ptr = 0; - tree gnu_handler; - - /* Make a binding level for the exception handling declarations - and code and set up gnu_except_ptr_stack for the handlers - to use. */ - start_stmt_group (); - gnat_pushlevel (); - - push_stack (&gnu_except_ptr_stack, NULL_TREE, - create_var_decl (get_identifier ("EXCEPT_PTR"), - NULL_TREE, - build_pointer_type (except_type_node), - build_call_0_expr (get_excptr_decl), - 0, 0, 0, 0, 0, gnat_node)); - - /* Generate code for each handler. The N_Exception_Handler case - below does the real work and returns a COND_EXPR for each - handler, which we chain together here. */ - for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); - Present (gnat_temp); - gnat_temp = Next_Non_Pragma (gnat_temp)) - { - gnu_expr = gnat_to_gnu (gnat_temp); - - /* If this is the first one, set it as the outer one. - Otherwise, point the "else" part of the previous handler - to us. Then point to our "else" part. */ - if (!gnu_else_ptr) - add_stmt (gnu_expr); - else - *gnu_else_ptr = gnu_expr; - - gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); - } - - /* If none of the exception handlers did anything, re-raise but - do not defer abortion. */ - gnu_expr = build_call_1_expr (raise_nodefer_decl, - TREE_VALUE (gnu_except_ptr_stack)); - annotate_with_node (gnu_expr, gnat_node); - - if (gnu_else_ptr) - *gnu_else_ptr = gnu_expr; - else - add_stmt (gnu_expr); - - /* End the binding level dedicated to the exception handlers - and get the whole statement group. */ - pop_stack (&gnu_except_ptr_stack); - gnat_poplevel (); - gnu_handler = end_stmt_group (); - - /* If the setjmp returns 1, we restore our incoming longjmp value - and then check the handlers. */ - start_stmt_group (); - add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl, - gnu_jmpsave_decl), - gnat_node); - add_stmt (gnu_handler); - gnu_handler = end_stmt_group (); - - /* This block is now "if (setjmp) ... <handlers> else <block>". */ - gnu_result = build (COND_EXPR, void_type_node, - (build_call_1_expr - (setjmp_decl, - build_unary_op (ADDR_EXPR, NULL_TREE, - gnu_jmpbuf_decl))), - gnu_handler, gnu_inner_block); - } - else if (gcc_zcx) - { - tree gnu_handlers; - - /* First make a block containing the handlers. */ - start_stmt_group (); - for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); - Present (gnat_temp); - gnat_temp = Next_Non_Pragma (gnat_temp)) - add_stmt (gnat_to_gnu (gnat_temp)); - gnu_handlers = end_stmt_group (); - - /* Now make the TRY_CATCH_EXPR for the block. */ - gnu_result = build (TRY_CATCH_EXPR, void_type_node, - gnu_inner_block, gnu_handlers); - } - else - gnu_result = gnu_inner_block; - - /* Now close our outer block, if we had to make one. */ - if (binding_for_block) - { - add_stmt (gnu_result); - gnat_poplevel (); - gnu_result = end_stmt_group (); - } - } + gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node); break; case N_Exception_Handler: if (Exception_Mechanism == Setjmp_Longjmp) - { - /* Unless this is "Others" or the special "Non-Ada" exception - for Ada, make an "if" statement to select the proper - exceptions. For "Others", exclude exceptions where - Handled_By_Others is nonzero unless the All_Others flag is set. - For "Non-ada", accept an exception if "Lang" is 'V'. */ - tree gnu_choice = integer_zero_node; - tree gnu_body = build_stmt_group (Statements (gnat_node), false); - - for (gnat_temp = First (Exception_Choices (gnat_node)); - gnat_temp; gnat_temp = Next (gnat_temp)) - { - tree this_choice; - - if (Nkind (gnat_temp) == N_Others_Choice) - { - if (All_Others (gnat_temp)) - this_choice = integer_one_node; - else - this_choice - = build_binary_op - (EQ_EXPR, integer_type_node, - convert - (integer_type_node, - build_component_ref - (build_unary_op - (INDIRECT_REF, NULL_TREE, - TREE_VALUE (gnu_except_ptr_stack)), - get_identifier ("not_handled_by_others"), NULL_TREE, - 0)), - integer_zero_node); - } - - else if (Nkind (gnat_temp) == N_Identifier - || Nkind (gnat_temp) == N_Expanded_Name) - { - gnu_expr - = gnat_to_gnu_entity (Entity (gnat_temp), NULL_TREE, 0); - - this_choice - = build_binary_op - (EQ_EXPR, integer_type_node, - TREE_VALUE (gnu_except_ptr_stack), - convert - (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)), - build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); - - /* If this is the distinguished exception "Non_Ada_Error" - (and we are in VMS mode), also allow a non-Ada - exception (a VMS condition) to match. */ - if (Is_Non_Ada_Error (Entity (gnat_temp))) - { - tree gnu_comp - = build_component_ref - (build_unary_op - (INDIRECT_REF, NULL_TREE, - TREE_VALUE (gnu_except_ptr_stack)), - get_identifier ("lang"), NULL_TREE, 0); - - this_choice - = build_binary_op - (TRUTH_ORIF_EXPR, integer_type_node, - build_binary_op - (EQ_EXPR, integer_type_node, gnu_comp, - convert (TREE_TYPE (gnu_comp), - build_int_2 ('V', 0))), - this_choice); - } - } - else - gigi_abort (318); - - gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, - gnu_choice, this_choice); - } - - gnu_result = build (COND_EXPR, void_type_node, gnu_choice, gnu_body, - NULL_TREE); - } - - /* Tell the back end that we start an exception handler if necessary. */ + gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node); else if (Exception_Mechanism == GCC_ZCX) - { - /* We build a TREE_LIST of nodes representing what exception - types this handler is able to catch, with special cases - for others and all others cases. - - Each exception type is actually identified by a pointer to the - exception id, with special value zero for "others" and one for - "all others". Beware that these special values are known and used - by the personality routine to identify the corresponding specific - kinds of handlers. - - ??? For initial time frame reasons, the others and all_others - cases have been handled using specific type trees, but this - somehow hides information to the back-end, which expects NULL to - be passed for catch all and end_cleanup to be used for cleanups. - - Care should be taken to ensure that the control flow impact of - such clauses is rendered in some way. lang_eh_type_covers is - doing the trick currently. */ - - tree gnu_etypes_list = NULL_TREE; - tree gnu_etype; - tree gnu_current_exc_ptr; - tree gnu_incoming_exc_ptr; - - for (gnat_temp = First (Exception_Choices (gnat_node)); - gnat_temp; gnat_temp = Next (gnat_temp)) - { - if (Nkind (gnat_temp) == N_Others_Choice) - gnu_etype - = All_Others (gnat_temp) ? integer_one_node - : integer_zero_node; - else if (Nkind (gnat_temp) == N_Identifier - || Nkind (gnat_temp) == N_Expanded_Name) - { - Entity_Id gnat_ex_id = Entity (gnat_temp); - - /* Exception may be a renaming. Recover original exception - which is the one elaborated and registered. */ - if (Present (Renamed_Object (gnat_ex_id))) - gnat_ex_id = Renamed_Object (gnat_ex_id); - - gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); - - gnu_etype - = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); - - /* The Non_Ada_Error case for VMS exceptions is handled - by the personality routine. */ - } - else - gigi_abort (337); - - /* The GCC interface expects NULL to be passed for catch all - handlers, so it would be quite tempting to set gnu_etypes_list - to NULL if gnu_etype is integer_zero_node. It would not work, - however, because GCC's notion of "catch all" is stronger than - our notion of "others". Until we correctly use the cleanup - interface as well, the doing tht would prevent the "all - others" handlers from beeing seen, because nothing can be - caught beyond a catch all from GCC's point of view. */ - gnu_etypes_list - = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list); - } - - start_stmt_group (); - gnat_pushlevel (); - - /* Expand a call to the begin_handler hook at the beginning of the - handler, and arrange for a call to the end_handler hook to occur - on every possible exit path. - - The hooks expect a pointer to the low level occurrence. This is - required for our stack management scheme because a raise inside - the handler pushes a new occurrence on top of the stack, which - means that this top does not necessarily match the occurrence - this handler was dealing with. - - The EXC_PTR_EXPR object references the exception occurrence - beeing propagated. Upon handler entry, this is the exception for - which the handler is triggered. This might not be the case upon - handler exit, however, as we might have a new occurrence - propagated by the handler's body, and the end_handler hook - called as a cleanup in this context. - - We use a local variable to retrieve the incoming value at - handler entry time, and reuse it to feed the end_handler hook's - argument at exit time. */ - gnu_current_exc_ptr = build (EXC_PTR_EXPR, ptr_type_node); - gnu_incoming_exc_ptr - = create_var_decl (get_identifier ("EXPTR"), NULL_TREE, - ptr_type_node, gnu_current_exc_ptr, - 0, 0, 0, 0, 0, gnat_node); - - add_stmt_with_node (build_call_1_expr (begin_handler_decl, - gnu_incoming_exc_ptr), - gnat_node); - add_cleanup (build_call_1_expr (end_handler_decl, - gnu_incoming_exc_ptr)); - add_stmt_list (Statements (gnat_node)); - gnat_poplevel (); - gnu_result = build (CATCH_EXPR, void_type_node, - gnu_etypes_list, end_stmt_group ()); - } + gnu_result = Exception_Handler_to_gnu_zcx (gnat_node); else abort (); |