2006-10-31 Robert Dewar <dewar@adacore.com>

	    Jose Ruiz  <ruiz@adacore.com>

	* a-dispat.ads, a-diroro.ads, a-diroro.adb: New files.

	* ali.adb (Get_Name): Properly handle scanning of wide character names
	encoded with brackets notation.
	(Known_ALI_Lines): Add S lines to this list.
	(Scan_ALI): Acquire S (priority specific dispatching) lines.
	New flag Elaborate_All_Desirable in unit table

	* ali.ads (Priority_Specific_Dispatching): Add this range of
	identifiers to be used for Priority_Specific_Dispatching table entries.
	(ALIs_Record): Add First_Specific_Dispatching and
	Last_Specific_Dispatching that point to the first and last entries
	respectively in the priority specific dispatching table for this unit.
	(Specific_Dispatching): Add this table for storing each S (priority
	specific dispatching) line encountered in the input ALI file.
	New flag Elaborate_All_Desirable in unit table

	* bcheck.adb: (Check_Configuration_Consistency): Add call to
	Check_Consistent_Dispatching_Policy.
	(Check_Consistent_Dispatching_Policy): Add this procedure in charge of
	verifying that the use of Priority_Specific_Dispatching,
	Task_Dispatching_Policy, and Locking_Policy is consistent across the
	partition.

	* bindgen.adb: (Public_Version_Warning): function removed.
	(Set_PSD_Pragma_Table): Add this procedure in charge of getting the
	required information from ALI files in order to initialize the table
	containing the specific dispatching policy.
	(Gen_Adainit_Ada): Generate the variables required for priority specific
	dispatching entries (__gl_priority_specific_dispatching and
	__gl_num_specific_dispatching).
	(Gen_Adainit_C): Generate the variables required for priority specific
	dispatching entries (__gl_priority_specific_dispatching and
	__gl_num_specific_dispatching).
	(Gen_Output_File): Acquire settings for Priority_Specific_Dispatching
	pragma entries.
	(Gen_Restrictions_String_1, Gen_Restrictions_String_2): Removed.
	(Gen_Restrictions_Ada, Gen_Restrictions_C, Set_Boolean): New procedures.
	(Tab_To): Removed.
	(Gen_Output_File_Ada/_C): Set directly __gl_xxx variables instead of
	a call to gnat_set_globals.
	Generate a string containing settings from
	Priority_Specific_Dispatching pragma entries.
	(Gen_Object_Files_Options): Do not include the runtime libraries when
	pragma No_Run_Time is specified.

	* init.c (__gnat_install_handler, case FreeBSD): Use SA_SIGINFO, for
	consistency with s-intman-posix.adb.
	(__gnat_error_handler, case FreeBSD): Account for the fact that the
	handler is installed with SA_SIGINFO.
	(__gnat_adjust_context_for_raise, FreeBSD case): New function for
	FreeBSD ZCX support, copied from Linux version.
	Add MaRTE-specific definitions for the linux target. Redefine sigaction,
	sigfillset, and sigemptyset so the routines defined by MaRTE.
	(__gl_priority_specific_dispatching): Add this variable that stores the
	string containing priority specific dispatching policies in the
	partition.
	(__gl_num_specific_dispatching): Add this variable that indicates the
	highest priority for which a priority specific dispatching pragma
	applies.
	(__gnat_get_specific_dispatching): Add this routine that returns the
	priority specific dispatching policy, as set by a
	Priority_Specific_Dispatching pragma appearing anywhere in the current
	partition. The input argument is the priority number, and the result
	is the upper case first character of the policy name.
	(__gnat_set_globals): Now a dummy function.
	(__gnat_handle_vms_condition): Feed adjust_context_for_raise with
	mechargs instead of sigargs, as the latter can be retrieved from the
	former and sigargs is not what we want on ia64.
	(__gnat_adjust_context_for_raise, alpha-vms): Fetch sigargs from the
	mechargs argument.
	(__gnat_adjust_context_for_raise, ia64-vms): New function.
	(tasking_error): Remove unused symbol.
	(_abort_signal): Move this symbol to the IRIX specific part since this
	is the only target that uses this definition.
	(Check_Abort_Status): Move this symbol to the IRIX specific part since
	this is the only target that uses this definition.
	(Lock_Task): Remove unused symbol.
	(Unlock_Task): Remove unused symbol.

	* lib-writ.adb (Write_ALI): Output new S lines for
	Priority_Specific_Dispatching pragmas.
	Implement new flag BD for elaborate body desirable

	* lib-writ.ads: Document S lines for Priority Specific Dispatching.
	(Specific_Dispatching): Add this table for storing the entries
	corresponding to Priority_Specific_Dispatching pragmas.
	Document new BD flag for elaborate body desirable

	* par-prag.adb (Prag): Add Priority_Specific_Dispatching to the list
	of known pragmas.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@118243 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 146 insertions, 90 deletions

diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
index 2bafec0295d..81008c82174 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, 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- --
@@ -54,6 +54,7 @@ package body ALI is
       'E'    => True,   -- external
       'D'    => True,   -- dependency
       'X'    => True,   -- xref
+      'S'    => True,   -- specific dispatching
       others => False);
 
    --------------------
@@ -140,13 +141,6 @@ package body ALI is
       --  be ignored by Scan_ALI and skipped, and False if the lines
       --  are to be read and processed.
 
-      Restrictions_Initial : Rident.Restrictions_Info;
-      pragma Warnings (Off, Restrictions_Initial);
-      --  This variable, which should really be a constant (but that's not
-      --  allowed by the language) is used only for initialization, and the
-      --  reason we are declaring it is to get the default initialization
-      --  set for the object.
-
       Bad_ALI_Format : exception;
       --  Exception raised by Fatal_Error if Err is True
 
@@ -197,7 +191,7 @@ package body ALI is
       --  white space (when Ignore_Spaces is False) or a typeref bracket or
       --  an equal sign except for the special case of an operator name
       --  starting with a double quite which is terminated by another double
-      --  quote.
+      --  quote. This function handles wide characters properly.
 
       function Get_Nat return Nat;
       --  Skip blanks, then scan out an unsigned integer value in Nat range
@@ -267,21 +261,6 @@ package body ALI is
          end if;
       end Check_At_End_Of_Field;
 
-      ------------
-      -- Checkc --
-      ------------
-
-      procedure Checkc (C : Character) is
-      begin
-         if Nextc = C then
-            P := P + 1;
-         elsif Ignore_Errors then
-            P := P + 1;
-         else
-            Fatal_Error;
-         end if;
-      end Checkc;
-
       ------------------------
       -- Check_Unknown_Line --
       ------------------------
@@ -308,6 +287,21 @@ package body ALI is
          end loop;
       end Check_Unknown_Line;
 
+      ------------
+      -- Checkc --
+      ------------
+
+      procedure Checkc (C : Character) is
+      begin
+         if Nextc = C then
+            P := P + 1;
+         elsif Ignore_Errors then
+            P := P + 1;
+         else
+            Fatal_Error;
+         end if;
+      end Checkc;
+
       -----------------
       -- Fatal_Error --
       -----------------
@@ -445,12 +439,21 @@ package body ALI is
                exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
 
             else
-               exit when (At_End_Of_Field and not Ignore_Spaces)
-                 or else Nextc = '(' or else Nextc = ')'
+               --  Terminate on parens or angle brackets or equal sign
+
+               exit when Nextc = '(' or else Nextc = ')'
                  or else Nextc = '{' or else Nextc = '}'
                  or else Nextc = '<' or else Nextc = '>'
-                 or else Nextc = '[' or else Nextc = ']'
                  or else Nextc = '=';
+
+               --  Terminate if left bracket not part of wide char sequence
+               --  Note that we only recognize brackets notation so far ???
+
+               exit when Nextc = '[' and then T (P + 1) /= '"';
+
+               --  Terminate if right bracket not part of wide char sequence
+
+               exit when Nextc = ']' and then T (P - 1) /= '"';
             end if;
          end loop;
 
@@ -524,29 +527,6 @@ package body ALI is
          return T;
       end Get_Stamp;
 
-      ----------
-      -- Getc --
-      ----------
-
-      function Getc return Character is
-      begin
-         if P = T'Last then
-            return EOF;
-         else
-            P := P + 1;
-            return T (P - 1);
-         end if;
-      end Getc;
-
-      -----------
-      -- Nextc --
-      -----------
-
-      function Nextc return Character is
-      begin
-         return T (P);
-      end Nextc;
-
       -----------------
       -- Get_Typeref --
       -----------------
@@ -635,6 +615,29 @@ package body ALI is
          end if;
       end Get_Typeref;
 
+      ----------
+      -- Getc --
+      ----------
+
+      function Getc return Character is
+      begin
+         if P = T'Last then
+            return EOF;
+         else
+            P := P + 1;
+            return T (P - 1);
+         end if;
+      end Getc;
+
+      -----------
+      -- Nextc --
+      -----------
+
+      function Nextc return Character is
+      begin
+         return T (P);
+      end Nextc;
+
       --------------
       -- Skip_Eol --
       --------------
@@ -740,10 +743,12 @@ package body ALI is
         Compile_Errors             => False,
         First_Interrupt_State      => Interrupt_States.Last + 1,
         First_Sdep                 => No_Sdep_Id,
+        First_Specific_Dispatching => Specific_Dispatching.Last + 1,
         First_Unit                 => No_Unit_Id,
         Float_Format               => 'I',
         Last_Interrupt_State       => Interrupt_States.Last,
         Last_Sdep                  => No_Sdep_Id,
+        Last_Specific_Dispatching  => Specific_Dispatching.Last,
         Last_Unit                  => No_Unit_Id,
         Locking_Policy             => ' ',
         Main_Priority              => -1,
@@ -752,7 +757,7 @@ package body ALI is
         Normalize_Scalars          => False,
         Ofile_Full_Name            => Full_Object_File_Name,
         Queuing_Policy             => ' ',
-        Restrictions               => Restrictions_Initial,
+        Restrictions               => No_Restrictions,
         SAL_Interface              => False,
         Sfile                      => No_Name,
         Task_Dispatching_Policy    => ' ',
@@ -1194,7 +1199,7 @@ package body ALI is
 
                if Ignore_Errors then
                   Cumulative_Restrictions := Save_R;
-                  ALIs.Table (Id).Restrictions := Restrictions_Initial;
+                  ALIs.Table (Id).Restrictions := No_Restrictions;
                   Skip_Eol;
 
                --  In normal mode, this is a fatal error
@@ -1254,6 +1259,47 @@ package body ALI is
          C := Getc;
       end loop;
 
+      --  Acquire 'S' lines if present
+
+      Check_Unknown_Line;
+
+      while C = 'S' loop
+         if Ignore ('S') then
+            Skip_Line;
+
+         else
+            declare
+               Policy     : Character;
+               First_Prio : Nat;
+               Last_Prio  : Nat;
+               Line_No    : Nat;
+
+            begin
+               Checkc (' ');
+               Skip_Space;
+
+               Policy := Getc;
+               Skip_Space;
+               First_Prio := Get_Nat;
+               Last_Prio := Get_Nat;
+               Line_No := Get_Nat;
+
+               Specific_Dispatching.Append (
+                 (Dispatching_Policy => Policy,
+                  First_Priority     => First_Prio,
+                  Last_Priority      => Last_Prio,
+                  PSD_Pragma_Line    => Line_No));
+
+               ALIs.Table (Id).Last_Specific_Dispatching :=
+                 Specific_Dispatching.Last;
+
+               Skip_Eol;
+            end;
+         end if;
+
+         C := Getc;
+      end loop;
+
       --  Loop to acquire unit entries
 
       U_Loop : loop
@@ -1270,42 +1316,47 @@ package body ALI is
             ALIs.Table (Id).First_Unit := Units.Last;
          end if;
 
-         Units.Table (Units.Last).Uname           := Get_Name;
-         Units.Table (Units.Last).Predefined      := Is_Predefined_Unit;
-         Units.Table (Units.Last).Internal        := Is_Internal_Unit;
-         Units.Table (Units.Last).My_ALI          := Id;
-         Units.Table (Units.Last).Sfile           := Get_Name (Lower => True);
-         Units.Table (Units.Last).Pure            := False;
-         Units.Table (Units.Last).Preelab         := False;
-         Units.Table (Units.Last).No_Elab         := False;
-         Units.Table (Units.Last).Shared_Passive  := False;
-         Units.Table (Units.Last).RCI             := False;
-         Units.Table (Units.Last).Remote_Types    := False;
-         Units.Table (Units.Last).Has_RACW        := False;
-         Units.Table (Units.Last).Init_Scalars    := False;
-         Units.Table (Units.Last).Is_Generic      := False;
-         Units.Table (Units.Last).Icasing         := Mixed_Case;
-         Units.Table (Units.Last).Kcasing         := All_Lower_Case;
-         Units.Table (Units.Last).Dynamic_Elab    := False;
-         Units.Table (Units.Last).Elaborate_Body  := False;
-         Units.Table (Units.Last).Set_Elab_Entity := False;
-         Units.Table (Units.Last).Version         := "00000000";
-         Units.Table (Units.Last).First_With      := Withs.Last + 1;
-         Units.Table (Units.Last).First_Arg       := First_Arg;
-         Units.Table (Units.Last).Elab_Position   := 0;
-         Units.Table (Units.Last).SAL_Interface   := ALIs.Table (Id).
-                                                       SAL_Interface;
-         Units.Table (Units.Last).Body_Needed_For_SAL := False;
-
-         if Debug_Flag_U then
-            Write_Str (" ----> reading unit ");
-            Write_Int (Int (Units.Last));
-            Write_Str ("  ");
-            Write_Unit_Name (Units.Table (Units.Last).Uname);
-            Write_Str (" from file ");
-            Write_Name (Units.Table (Units.Last).Sfile);
-            Write_Eol;
-         end if;
+         declare
+            UL : Unit_Record renames Units.Table (Units.Last);
+
+         begin
+            UL.Uname                    := Get_Name;
+            UL.Predefined               := Is_Predefined_Unit;
+            UL.Internal                 := Is_Internal_Unit;
+            UL.My_ALI                   := Id;
+            UL.Sfile                    := Get_Name (Lower => True);
+            UL.Pure                     := False;
+            UL.Preelab                  := False;
+            UL.No_Elab                  := False;
+            UL.Shared_Passive           := False;
+            UL.RCI                      := False;
+            UL.Remote_Types             := False;
+            UL.Has_RACW                 := False;
+            UL.Init_Scalars             := False;
+            UL.Is_Generic               := False;
+            UL.Icasing                  := Mixed_Case;
+            UL.Kcasing                  := All_Lower_Case;
+            UL.Dynamic_Elab             := False;
+            UL.Elaborate_Body           := False;
+            UL.Set_Elab_Entity          := False;
+            UL.Version                  := "00000000";
+            UL.First_With               := Withs.Last + 1;
+            UL.First_Arg                := First_Arg;
+            UL.Elab_Position            := 0;
+            UL.SAL_Interface            := ALIs.Table (Id).SAL_Interface;
+            UL.Body_Needed_For_SAL      := False;
+            UL.Elaborate_Body_Desirable := False;
+
+            if Debug_Flag_U then
+               Write_Str (" ----> reading unit ");
+               Write_Int (Int (Units.Last));
+               Write_Str ("  ");
+               Write_Unit_Name (UL.Uname);
+               Write_Str (" from file ");
+               Write_Name (UL.Sfile);
+               Write_Eol;
+            end if;
+         end;
 
          --  Check for duplicated unit in different files
 
@@ -1378,14 +1429,19 @@ package body ALI is
                   Units.Table (Units.Last).Version (J) := C;
                end loop;
 
-            --  BN parameter (Body needed)
+            --  BD/BN parameters
 
             elsif C = 'B' then
                C := Getc;
 
-               if C = 'N' then
+               if C = 'D' then
+                  Check_At_End_Of_Field;
+                  Units.Table (Units.Last).Elaborate_Body_Desirable := True;
+
+               elsif C = 'N' then
                   Check_At_End_Of_Field;
                   Units.Table (Units.Last).Body_Needed_For_SAL := True;
+
                else
                   Fatal_Error_Ignore;
                end if;