[multiple changes]

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.

From-SVN: r74541

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;
 

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");
 

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;
 
    ---------------------------

gcc/ada/ChangeLog

+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,

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.

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

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.

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

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;
 
    -----------------------

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);

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

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

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