This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
committed: Ada updates
- From: Arnaud Charlet <charlet at ACT-Europe dot FR>
- To: gcc-patches at gcc dot gnu dot org
- Date: Thu, 11 Dec 2003 17:22:27 +0100
- Subject: committed: Ada updates
Tested on x86-linux
--
2003-12-11 Ed Falis <falis@gnat.com>
* 5zinit.adb: Clean up.
* 5zintman.adb (Notify_Exception): replaced case statement with a call
to __gnat_map_signal, imported from init.c to support
signal -> exception mappings that depend on the vxWorks version.
* init.c:
Created and exported __gnat_map_signal to support signal -> exception
mapping that is dependent on the VxWorks version.
Change mapping of SIGBUS from Program_Error to Storage_Error on VxWorks
2003-12-11 Vasiliy Fofanv <fofanov@act-europe.fr>
* 5wosinte.ads: Link with -mthreads switch.
2003-12-11 Arnaud Charlet <charlet@act-europe.fr>
* init.c (__gnat_install_handler [NetBSD]): Set
__gnat_handler_installed, as done on all other platforms.
Remove duplicated code.
2003-12-11 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in (rts-zfp, rts-ravenscar): Create libgnat.a.
2003-12-11 Thomas Quinot <quinot@act-europe.fr>
* sinfo.ads: Fix inconsistent example code in comment.
2003-12-11 Robert Dewar <dewar@gnat.com>
* a-tiinau.adb: Add a couple of comments
* sem_ch3.adb: Minor reformatting
* sem_prag.adb:
Fix bad prototype of Same_Base_Type in body (code reading cleanup)
Minor reformatting throughout
2003-12-11 Ed Schonberg <schonberg@gnat.com>
* exp_ch7.adb (Establish_Transient_Scope): If the call is within the
bounds of a loop, create a separate block in order to generate proper
cleanup actions to prevent memory leaks.
* sem_res.adb (Resolve_Call): After a call to
Establish_Transient_Scope, the call may be rewritten and relocated, in
which case no further processing is needed.
* sem_util.adb: (Wrong_Type): Refine previous fix.
Fixes ACATS regressions.
PR ada/13353
* sem_prag.adb (Back_End_Cannot_Inline): A renaming_as_body can always
be inlined.
--
Index: 5wosinte.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5wosinte.ads,v
retrieving revision 1.4
diff -u -p -r1.4 5wosinte.ads
--- 5wosinte.ads 24 Apr 2003 17:53:52 -0000 1.4
+++ 5wosinte.ads 11 Dec 2003 13:31:27 -0000
@@ -46,6 +46,8 @@ with Interfaces.C.Strings;
package System.OS_Interface is
pragma Preelaborate;
+ pragma Linker_Options ("-mthreads");
+
subtype int is Interfaces.C.int;
subtype long is Interfaces.C.long;
Index: 5zinit.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zinit.adb,v
retrieving revision 1.2
diff -u -p -r1.2 5zinit.adb
--- 5zinit.adb 10 Nov 2003 17:29:58 -0000 1.2
+++ 5zinit.adb 11 Dec 2003 13:31:27 -0000
@@ -33,9 +33,6 @@
-- This is the VxWorks version of this package
-with System.OS_Interface;
--- used for various Constants, Signal and types
-
with Interfaces.C;
-- used for int and other types
@@ -47,10 +44,58 @@ package body System.Init is
-- This unit contains initialization circuits that are system dependent.
use Ada.Exceptions;
- use System.OS_Interface;
- use type Interfaces.C.int;
+ use Interfaces.C;
+
+ --------------------------
+ -- Signal Definitions --
+ --------------------------
+
+ NSIG : constant := 32;
+ -- Number of signals on the target OS
+ type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
+
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGFPE : constant := 8; -- floating point exception
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+
+ type sigset_t is new long;
+
+ SIG_SETMASK : constant := 3;
+ SA_ONSTACK : constant := 16#0004#;
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ -------------------------------
+ -- Binder Generated Values --
+ -------------------------------
- -- Copies of global values computed by the binder
Gl_Main_Priority : Integer := -1;
pragma Export (C, Gl_Main_Priority, "__gl_main_priority");
Index: 5zintman.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zintman.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5zintman.adb
--- 5zintman.adb 24 Nov 2003 14:27:57 -0000 1.7
+++ 5zintman.adb 11 Dec 2003 13:31:27 -0000
@@ -53,12 +53,8 @@ with Interfaces.C;
with System.OS_Interface;
-- used for various Constants, Signal and types
-with Ada.Exceptions;
--- used for Raise_Exception
-
package body System.Interrupt_Management is
- use Ada.Exceptions;
use System.OS_Interface;
use type Interfaces.C.int;
@@ -71,6 +67,11 @@ package body System.Interrupt_Management
Exception_Action : aliased struct_sigaction;
+ procedure Map_And_Raise_Exception (signo : Signal);
+ pragma Import (C, Map_And_Raise_Exception, "__gnat_map_signal");
+ -- Map signal to Ada exception and raise it. Different versions
+ -- of VxWorks need different mappings.
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -103,20 +104,7 @@ package body System.Interrupt_Management
Result := taskResume (My_Id);
end if;
- case signo is
- when SIGFPE =>
- Raise_Exception (Constraint_Error'Identity, "SIGFPE");
- when SIGILL =>
- Raise_Exception (Constraint_Error'Identity, "SIGILL");
- when SIGSEGV =>
- Raise_Exception
- (Program_Error'Identity,
- "stack overflow or erroneous memory access");
- when SIGBUS =>
- Raise_Exception (Program_Error'Identity, "SIGBUS");
- when others =>
- Raise_Exception (Program_Error'Identity, "unhandled signal");
- end case;
+ Map_And_Raise_Exception (signo);
end Notify_Exception;
---------------------------
Index: a-tiinau.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-tiinau.adb,v
retrieving revision 1.6
diff -u -p -r1.6 a-tiinau.adb
--- a-tiinau.adb 21 Oct 2003 13:41:54 -0000 1.6
+++ a-tiinau.adb 11 Dec 2003 13:31:27 -0000
@@ -167,6 +167,9 @@ package body Ada.Text_IO.Integer_Aux is
Load_Digits (File, Buf, Ptr, Loaded);
if Loaded then
+
+ -- Deal with based literal (note : is ok replacement for #)
+
Load (File, Buf, Ptr, '#', ':', Loaded);
if Loaded then
@@ -174,6 +177,8 @@ package body Ada.Text_IO.Integer_Aux is
Load_Extended_Digits (File, Buf, Ptr);
Load (File, Buf, Ptr, Buf (Hash_Loc));
end if;
+
+ -- Deal with exponent
Load (File, Buf, Ptr, 'E', 'e', Loaded);
Index: exp_ch7.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch7.adb,v
retrieving revision 1.9
diff -u -p -r1.9 exp_ch7.adb
--- exp_ch7.adb 21 Oct 2003 13:41:59 -0000 1.9
+++ exp_ch7.adb 11 Dec 2003 13:31:27 -0000
@@ -1074,6 +1074,76 @@ package body Exp_Ch7 is
if No (Wrap_Node) then
null;
+ elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
+
+ -- Create a declaration followed by an assignment, so that
+ -- the assignment can have its own transient scope.
+ -- We generate the equivalent of:
+
+ -- type Ptr is access all expr_type;
+ -- Var : Ptr;
+ -- begin
+ -- Var := Expr'reference;
+ -- end;
+
+ -- This closely resembles what is done in Remove_Side_Effect,
+ -- but it has to be done here, before the analysis of the call
+ -- is completed.
+
+ declare
+ Ptr_Typ : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('A'));
+ Ptr : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+
+ Expr_Type : constant Entity_Id := Etype (N);
+ New_Expr : constant Node_Id := Relocate_Node (N);
+ Decl : Node_Id;
+ Ptr_Typ_Decl : Node_Id;
+ Stmt : Node_Id;
+
+ begin
+ Ptr_Typ_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Reference_To (Expr_Type, Loc)));
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ptr,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
+
+ Set_Etype (Ptr, Ptr_Typ);
+ Stmt :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Ptr, Loc),
+ Expression => Make_Reference (Loc, New_Expr));
+
+ Set_Analyzed (New_Expr, False);
+
+ Insert_List_Before_And_Analyze
+ (Parent (Wrap_Node),
+ New_List (
+ Ptr_Typ_Decl,
+ Decl,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Stmt)))));
+
+ Rewrite (N,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Reference_To (Ptr, Loc)));
+ Analyze_And_Resolve (N, Expr_Type);
+
+ end;
+
-- Transient scope is required
else
@@ -1815,14 +1885,12 @@ package body Exp_Ch7 is
return The_Parent;
end if;
- -- ??? No scheme yet for "for I in Expression'Range loop"
- -- ??? the current scheme for Expression wrapping doesn't apply
- -- ??? because a RANGE is NOT an expression. Tricky problem...
- -- ??? while this problem is not solved we have a potential for
- -- ??? leak and unfinalized intermediate objects here.
+ -- If the expression is within the iteration scheme of a loop,
+ -- we must create a declaration for it, followed by an assignment
+ -- in order to have a usable statement to wrap.
when N_Loop_Parameter_Specification =>
- return Empty;
+ return Parent (The_Parent);
-- The following nodes contains "dummy calls" which don't
-- need to be wrapped.
Index: init.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/init.c,v
retrieving revision 1.21
diff -u -p -r1.21 init.c
--- init.c 18 Nov 2003 10:00:43 -0000 1.21
+++ init.c 11 Dec 2003 13:31:27 -0000
@@ -1551,6 +1551,7 @@ __gnat_initialize ()
extern int __gnat_inum_to_ivec (int);
static void __gnat_error_handler (int, int, struct sigcontext *);
+void __gnat_map_signal (int);
#ifndef __alpha_vxworks
@@ -1573,27 +1574,14 @@ __gnat_inum_to_ivec (int num)
return INUM_TO_IVEC (num);
}
-static void
-__gnat_error_handler (int sig, int code, struct sigcontext *sc)
+/* Exported to 5zintman.adb in order to handle different signal
+ to exception mappings in different VxWorks versions */
+void
+__gnat_map_signal (int sig)
{
struct Exception_Data *exception;
- sigset_t mask;
- int result;
char *msg;
- /* VxWorks will always mask out the signal during the signal handler and
- will reenable it on a longjmp. GNAT does not generate a longjmp to
- return from a signal handler so the signal will still be masked unless
- we unmask it. */
- sigprocmask (SIG_SETMASK, NULL, &mask);
- sigdelset (&mask, sig);
- sigprocmask (SIG_SETMASK, &mask, NULL);
-
- /* VxWorks will suspend the task when it gets a hardware exception. We
- take the liberty of resuming the task for the application. */
- if (taskIsSuspended (taskIdSelf ()) != 0)
- taskResume (taskIdSelf ());
-
switch (sig)
{
case SIGFPE:
@@ -1609,8 +1597,13 @@ __gnat_error_handler (int sig, int code,
msg = "SIGSEGV";
break;
case SIGBUS:
+#ifdef VTHREADS
+ exception = &storage_error;
+ msg = "SIGBUS: possible stack overflow";
+#else
exception = &program_error;
msg = "SIGBUS";
+#endif
break;
default:
exception = &program_error;
@@ -1620,6 +1613,29 @@ __gnat_error_handler (int sig, int code,
Raise_From_Signal_Handler (exception, msg);
}
+static void
+__gnat_error_handler (int sig, int code, struct sigcontext *sc)
+{
+ sigset_t mask;
+ int result;
+
+ /* VxWorks will always mask out the signal during the signal handler and
+ will reenable it on a longjmp. GNAT does not generate a longjmp to
+ return from a signal handler so the signal will still be masked unless
+ we unmask it. */
+ sigprocmask (SIG_SETMASK, NULL, &mask);
+ sigdelset (&mask, sig);
+ sigprocmask (SIG_SETMASK, &mask, NULL);
+
+ /* VxWorks will suspend the task when it gets a hardware exception. We
+ take the liberty of resuming the task for the application. */
+ if (taskIsSuspended (taskIdSelf ()) != 0)
+ taskResume (taskIdSelf ());
+
+ __gnat_map_signal (sig);
+
+}
+
void
__gnat_install_handler (void)
{
@@ -1755,6 +1771,8 @@ __gnat_install_handler(void)
sigaction (SIGSEGV, &act, NULL);
if (__gnat_get_interrupt_state (SIGBUS) != 's')
sigaction (SIGBUS, &act, NULL);
+
+ __gnat_handler_installed = 1;
}
void
@@ -1762,22 +1780,6 @@ __gnat_initialize (void)
{
__gnat_install_handler ();
__gnat_init_float ();
-}
-
-/***************************************/
-/* __gnat_initialize (RTEMS version) */
-/***************************************/
-
-#elif defined(__rtems__)
-
-extern void __gnat_install_handler (void);
-
-/* For RTEMS, each bsp will provide a custom __gnat_install_handler (). */
-
-void
-__gnat_initialize (void)
-{
- __gnat_install_handler ();
}
/***************************************/
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.59
diff -u -p -r1.59 Makefile.in
--- Makefile.in 8 Dec 2003 10:33:16 -0000 1.59
+++ Makefile.in 11 Dec 2003 13:31:28 -0000
@@ -1841,9 +1841,9 @@ rts-zfp: force
RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \
COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)"
-$(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
+ cd rts-zfp/adalib/ ; $(AR) r libgnat.a *.o
$(RM) rts-zfp/adalib/*.o
$(CHMOD) a-wx rts-zfp/adalib/*.ali
- $(AR) r rts-zfp/adalib/libgnat.a
$(CHMOD) a-wx rts-zfp/adalib/libgnat.a
rts-none: force
@@ -1862,8 +1862,9 @@ rts-ravenscar: force
COMPILABLE_SOURCES="$(COMPILABLE_RAVEN_SOURCES)"
-$(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
--GCC="../../../xgcc -B../../../"
+ cd rts-ravenscar/adalib/ ; $(AR) r libgnat.a *.o
+ $(RM) rts-ravenscar/adalib/*.o
$(CHMOD) a-wx rts-ravenscar/adalib/*.ali
- $(AR) r rts-ravenscar/adalib/libgnat.a
$(CHMOD) a-wx rts-ravenscar/adalib/libgnat.a
# Warning: this target assumes that LIBRARY_VERSION has been set correctly.
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.25
diff -u -p -r1.25 sem_ch3.adb
--- sem_ch3.adb 8 Dec 2003 10:33:16 -0000 1.25
+++ sem_ch3.adb 11 Dec 2003 13:31:28 -0000
@@ -8492,7 +8492,6 @@ package body Sem_Ch3 is
Set_Small_Value (T, Delta_Val);
Set_Scale_Value (T, Scale_Val);
Set_Is_Constrained (T);
-
end Decimal_Fixed_Point_Type_Declaration;
-----------------------
Index: sem_prag.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_prag.adb,v
retrieving revision 1.14
diff -u -p -r1.14 sem_prag.adb
--- sem_prag.adb 5 Dec 2003 10:24:05 -0000 1.14
+++ sem_prag.adb 11 Dec 2003 13:31:28 -0000
@@ -432,8 +432,7 @@ package body Sem_Prag is
function Is_Before_First_Decl
(Pragma_Node : Node_Id;
- Decls : List_Id)
- return Boolean;
+ Decls : List_Id) return Boolean;
-- Return True if Pragma_Node is before the first declarative item in
-- Decls where Decls is the list of declarative items.
@@ -1122,7 +1121,6 @@ package body Sem_Prag is
when N_Index_Or_Discriminant_Constraint =>
declare
IDC : Entity_Id := First (Constraints (Constr));
-
begin
while Present (IDC) loop
Check_Static_Constraint (IDC);
@@ -1506,8 +1504,7 @@ package body Sem_Prag is
function Is_Before_First_Decl
(Pragma_Node : Node_Id;
- Decls : List_Id)
- return Boolean
+ Decls : List_Id) return Boolean
is
Item : Node_Id := First (Decls);
@@ -2185,8 +2182,7 @@ package body Sem_Prag is
function Same_Base_Type
(Ptype : Node_Id;
- Formal : Entity_Id)
- return Boolean;
+ Formal : Entity_Id) return Boolean;
-- Determines if Ptype references the type of Formal. Note that
-- only the base types need to match according to the spec. Ptype
-- here is the argument from the pragma, which is either a type
@@ -2196,7 +2192,10 @@ package body Sem_Prag is
-- Same_Base_Type --
--------------------
- function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean is
+ function Same_Base_Type
+ (Ptype : Node_Id;
+ Formal : Entity_Id) return Boolean
+ is
Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
Pref : Node_Id;
@@ -2823,9 +2822,8 @@ package body Sem_Prag is
if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
declare
Cunit : constant Node_Id := Parent (Parent (N));
-
begin
- Set_Body_Required (Cunit, False);
+ Set_Body_Required (Cunit, False);
end;
end if;
end Process_Import_Or_Interface;
@@ -2869,10 +2867,21 @@ package body Sem_Prag is
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
then
- return
- Present (Exception_Handlers
- (Handled_Statement_Sequence
- (Unit_Declaration_Node (Corresponding_Body (Decl)))));
+ -- If the subprogram is a renaming as body, the body is
+ -- just a call to the renamed subprogram, and inlining is
+ -- trivially possible.
+
+ if Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ return False;
+
+ else
+ return
+ Present (Exception_Handlers
+ (Handled_Statement_Sequence
+ (Unit_Declaration_Node (Corresponding_Body (Decl)))));
+ end if;
else
-- If body is not available, assume the best, the check is
-- performed again when compiling enclosing package bodies.
@@ -3701,11 +3710,9 @@ package body Sem_Prag is
declare
Arg_Node : Node_Id;
-
begin
Arg_Count := 0;
Arg_Node := Arg1;
-
while Present (Arg_Node) loop
Arg_Count := Arg_Count + 1;
Next (Arg_Node);
@@ -4480,7 +4487,6 @@ package body Sem_Prag is
when Pragma_Convention => Convention : declare
C : Convention_Id;
E : Entity_Id;
-
begin
Check_Ada_83_Warning;
Check_Arg_Count (2);
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.14
diff -u -p -r1.14 sem_res.adb
--- sem_res.adb 27 Nov 2003 11:40:45 -0000 1.14
+++ sem_res.adb 11 Dec 2003 13:31:29 -0000
@@ -3727,6 +3727,13 @@ package body Sem_Res is
Establish_Transient_Scope
(N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
+ -- If the call appears within the bounds of a loop, it will
+ -- be rewritten and reanalyzed, nothing left to do here.
+
+ if Nkind (N) /= N_Function_Call then
+ return;
+ end if;
+
elsif Is_Init_Proc (Nam)
and then not Within_Init_Proc
then
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.16
diff -u -p -r1.16 sem_util.adb
--- sem_util.adb 8 Dec 2003 10:33:16 -0000 1.16
+++ sem_util.adb 11 Dec 2003 13:31:29 -0000
@@ -6371,7 +6371,10 @@ package body Sem_Util is
Error_Msg_N (
"operator of the type is not directly visible!", Expr);
- elsif Ekind (Found_Type) = E_Void then
+ elsif Ekind (Found_Type) = E_Void
+ and then Present (Parent (Found_Type))
+ and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
+ then
Error_Msg_NE ("found premature usage of}!", Expr, Found_Type);
else
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.16
diff -u -p -r1.16 sinfo.ads
--- sinfo.ads 24 Nov 2003 14:27:57 -0000 1.16
+++ sinfo.ads 11 Dec 2003 13:31:29 -0000
@@ -244,7 +244,7 @@ package Sinfo is
-- Variant := First (Variants (N));
-- while Present (Variant) loop
-- ...
- -- Alt := Next (Alt);
+ -- Variant := Next (Variant);
-- end loop;
-- or
@@ -252,7 +252,7 @@ package Sinfo is
-- Variant := First_Non_Pragma (Variants (N));
-- while Present (Variant) loop
-- ...
- -- Alt := Next_Non_Pragma (Alt);
+ -- Variant := Next_Non_Pragma (Variant);
-- end loop;
-- In the first form of the loop, Variant can either be an N_Pragma or