diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/5wosinte.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/5zinit.adb | 57 | ||||
| -rw-r--r-- | gcc/ada/5zintman.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/ChangeLog | 59 | ||||
| -rw-r--r-- | gcc/ada/Makefile.in | 5 | ||||
| -rw-r--r-- | gcc/ada/a-tiinau.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 80 | ||||
| -rw-r--r-- | gcc/ada/init.c | 68 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 40 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 4 |
13 files changed, 271 insertions, 86 deletions
diff --git a/gcc/ada/5wosinte.ads b/gcc/ada/5wosinte.ads index cf9aee5a35b..8a74f50d14b 100644 --- a/gcc/ada/5wosinte.ads +++ b/gcc/ada/5wosinte.ads @@ -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; diff --git a/gcc/ada/5zinit.adb b/gcc/ada/5zinit.adb index e384d3b5116..3fe64bd1aed 100644 --- a/gcc/ada/5zinit.adb +++ b/gcc/ada/5zinit.adb @@ -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"); diff --git a/gcc/ada/5zintman.adb b/gcc/ada/5zintman.adb index fd9b86f242b..d5e8afcf904 100644 --- a/gcc/ada/5zintman.adb +++ b/gcc/ada/5zintman.adb @@ -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 is 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 is 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; --------------------------- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b1fba1a3189..91b74c58da0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,62 @@ +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. + 2003-12-08 Jerome Guitton <guitton@act-europe.fr> * 5ytiitho.adb, 5zthrini.adb, 5ztiitho.adb, i-vthrea.adb, diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 4d5b44330fa..acabfec9844 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -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. diff --git a/gcc/ada/a-tiinau.adb b/gcc/ada/a-tiinau.adb index f9d7ce0052a..03977710a50 100644 --- a/gcc/ada/a-tiinau.adb +++ b/gcc/ada/a-tiinau.adb @@ -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 @@ -175,6 +178,8 @@ package body Ada.Text_IO.Integer_Aux is Load (File, Buf, Ptr, Buf (Hash_Loc)); end if; + -- Deal with exponent + Load (File, Buf, Ptr, 'E', 'e', Loaded); if Loaded then diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index f9844cd3b33..e9e80532048 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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. diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 4f50b8f902e..734a482bdcc 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -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, struct sigcontext *sc) 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, struct sigcontext *sc) 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 @@ -1780,22 +1798,6 @@ __gnat_initialize (void) __gnat_install_handler (); } -/***************************************/ -/* __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 (); -} - #else /* For all other versions of GNAT, the initialize routine and handler diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f14e049ec75..b1b556b9ece 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; ----------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 77235fd8502..f080512468b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3b95b97c29c..f6c4ef969c0 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6183c0cc1a1..57f93173b54 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index f1764943a84..de8b23eb7d0 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -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 |