* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@74541
138bc75d-0d04-0410-961f-
82ee72b054a4
package System.OS_Interface is
pragma Preelaborate;
+ pragma Linker_Options ("-mthreads");
+
subtype int is Interfaces.C.int;
subtype long is Interfaces.C.long;
-- 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
-- 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");
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;
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 --
-----------------------
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;
---------------------------
+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,
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
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.
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
Load (File, Buf, Ptr, Buf (Hash_Loc));
end if;
+ -- Deal with exponent
+
Load (File, Buf, Ptr, 'E', 'e', Loaded);
if Loaded then
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
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.
extern int __gnat_inum_to_ivec (int);
static void __gnat_error_handler (int, int, struct sigcontext *);
+void __gnat_map_signal (int);
#ifndef __alpha_vxworks
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:
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;
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)
{
sigaction (SIGSEGV, &act, NULL);
if (__gnat_get_interrupt_state (SIGBUS) != 's')
sigaction (SIGBUS, &act, NULL);
+
+ __gnat_handler_installed = 1;
}
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
Set_Small_Value (T, Delta_Val);
Set_Scale_Value (T, Scale_Val);
Set_Is_Constrained (T);
-
end Decimal_Fixed_Point_Type_Declaration;
-----------------------
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.
when N_Index_Or_Discriminant_Constraint =>
declare
IDC : Entity_Id := First (Constraints (Constr));
-
begin
while Present (IDC) loop
Check_Static_Constraint (IDC);
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);
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
-- 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;
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;
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.
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);
when Pragma_Convention => Convention : declare
C : Convention_Id;
E : Entity_Id;
-
begin
Check_Ada_83_Warning;
Check_Arg_Count (2);
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
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
-- Variant := First (Variants (N));
-- while Present (Variant) loop
-- ...
- -- Alt := Next (Alt);
+ -- Variant := Next (Variant);
-- end loop;
-- or
-- 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
OSDN Git Service
